summaryrefslogtreecommitdiffstats
path: root/qemu/roms/SLOF/slof/fs/base.fs
blob: 03e77e54fc7e9e0f434316c9d4ee381c1ffb7890 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ *     IBM Corporation - initial implementation
\ ****************************************************************************/

\ Hash for faster lookup
#include <find-hash.fs>

: >name ( xt -- nfa ) \ note: still has the "immediate" field!
   BEGIN char- dup c@ UNTIL ( @lastchar )
   dup dup aligned - cell+ char- ( @lastchar lenmodcell )
   dup >r -
   BEGIN dup c@ r@ <> WHILE
      cell- r> cell+ >r
   REPEAT
   r> drop char-
;

\ Words missing in *.in files
VARIABLE mask -1 mask !

VARIABLE huge-tftp-load 1 huge-tftp-load !
\ Default implementation for sms-get-tftp-blocksize that return 1432 (decimal)
: sms-get-tftp-blocksize 598 ;

: default-hw-exception s" Exception #" type . ;

' default-hw-exception to hw-exception-handler

: diagnostic-mode? false ;	\ 2B DOTICK'D later in envvar.fs

: memory-test-suite ( addr len -- fail? )
	diagnostic-mode? IF
		." Memory test mask value: " mask @ . cr
		." No memory test suite currently implemented! " cr
	THEN
	false
;

: 0.r  0 swap <# 0 ?DO # LOOP #> type ;

\ count the number of bits equal 1
\ the idea is to clear in each step the least significant bit
\ v&(v-1) does exactly this, so count the steps until v == 0
: cnt-bits  ( 64-bit-value -- #bits=1 )
	dup IF
		41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP
	THEN
;

: bcd-to-bin  ( bcd -- bin )
   dup f and swap 4 rshift a * +
;

\ calcs the exponent of the highest power of 2 not greater than n
: 2log ( n -- lb{n} )
   8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP
;

\ calcs the exponent of the lowest power of 2 not less than n
: log2  ( n -- log2-n )
   1- 2log 1+
;


CREATE $catpad 400 allot
: $cat ( str1 len1 str2 len2 -- str3 len3 )
   >r >r dup >r $catpad swap move
   r> dup $catpad + r> swap r@ move
   r> + $catpad swap ;

\ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense
\ that they add 1 or 2 characters to str1 before executing $cat
\ The ASSUMPTION is that str1 buffer provides that extra space and it is
\ responsibility of the code owner to ensure that
: $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 )
	2dup + s" , " rot swap move 2+ 2swap $cat
;

: $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
	2dup + bl swap c! 1+ 2swap $cat
;
: $cathex ( str len val -- str len' )
   (u.) $cat
;


: 2CONSTANT    CREATE , , DOES> [ here ] 2@ ;

\ Save XT of 2CONSTANT, put on the stack by "[ here ]" :
CONSTANT <2constant>

: $2CONSTANT  $CREATE , , DOES> 2@ ;

: 2VARIABLE    CREATE 0 , 0 ,  DOES> ;


: (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;

: zplace ( str len buf -- )  2dup + 0 swap c! swap move ;
: rzplace ( str len buf -- )  2dup + 0 swap rb! swap rmove ;

: strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;

: str= ( str1 len1 str2 len2 -- equal? )
  rot over <> IF 3drop false ELSE comp 0= THEN ;

: test-string ( param len -- true | false )
   0 ?DO
      dup i + c@                     \ Get character / byte at current index
      dup 20 <  swap 7e >  OR IF     \ Is it out of range 32 to 126 (=ASCII)
         drop FALSE UNLOOP EXIT      \ FALSE means: No ASCII string
      THEN
   LOOP
   drop TRUE    \ Only ASCII found --> it is a string
;

: #aligned ( adr alignment -- adr' ) negate swap negate and negate ;
: #join  ( lo hi #bits -- x )  lshift or ;
: #split ( x #bits -- lo hi )  2dup rshift dup >r swap lshift xor r> ;

: /string ( str len u -- str' len' )
  >r swap r@ chars + swap r> - ;
: skip ( str len c -- str' len' )
  >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ;
: scan ( str len c -- str' len' )
  >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ;
: split ( str len char -- left len right len )
  >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
\ reverse findchar -- search from the end of the string
: rfindchar ( str len char -- offs true | false )
   swap 1 - 0 swap do
      over i + c@
      over dup bl = if <= else = then if
         2drop i dup dup leave
      then
   -1 +loop =
;
\ reverse split -- split at the last occurrence of char
: rsplit ( str len char -- left len right len )
  >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;

: left-parse-string ( str len char -- R-str R-len L-str L-len )
  split 2swap ;
: replace-char ( str len chout chin -- )
  >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
  r> 2drop 2drop
;
\ Duplicate string and replace \ with /
: \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;

: isdigit ( char -- true | false )
   30 39 between
;

: ishexdigit ( char -- true | false )
   30 39 between 41 46 between OR 61 66 between OR
;

\ Variant of $number that defaults to decimal unless "0x" is
\ a prefix
: $dh-number ( addr len -- true | number false )
   base @ >r
   decimal
   dup 2 > IF
       over dup c@ [char] 0 =
       over 1 + c@ 20 or [char] x =
       AND IF hex 2 + swap 2 - rot THEN drop
   THEN
   $number
   r> base !
;

: //  dup >r 1- + r> / ; \ division, round up

: c@+ ( adr -- c adr' )  dup c@ swap char+ ;
: 2c@ ( adr -- c1 c2 )  c@+ c@ ;
: 4c@ ( adr -- c1 c2 c3 c4 )  c@+ c@+ c@+ c@ ;
: 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 )  c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;


: 4dup  ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 )  2over 2over ;
: 4drop  ( n1 n2 n3 n4 -- )  2drop 2drop ;

\ yes sometimes even something like this is needed
: 5dup  ( 1 2 3 4 5 -- 1 2 3 4 5 1 2 3 4 5 )
   4 pick 4 pick 4 pick 4 pick 4 pick ;
: 5drop 4drop drop ;
: 5nip
  nip nip nip nip nip ;

: 6dup  ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
   5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ;

\ convert a 32 bit signed into a 64 signed
\ ( propagate bit 31 to all bits 32:63 )
: signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;

: <l@ ( addr -- x ) l@ signed ;

: -leading  BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
: (parse-line)  skipws 0 parse ;


\ Append two character to hex byte, if possible

: hex-byte ( char0 char1 -- value true|false )
   10 digit IF
      swap 10 digit IF
	 4 lshift or true EXIT
      ELSE
	 2drop 0
      THEN
   ELSE
      drop
   THEN
   false EXIT
;

\ Parse hex string within brackets

: parse-hexstring ( dst-adr -- dst-adr' )
   [char] ) parse cr                 ( dst-adr str len )
   bounds ?DO                        ( dst-adr )
      i c@ i 1+ c@ hex-byte IF       ( dst-adr hex-byte )
	 >r dup r> swap c! 1+ 2      ( dst-adr+1 2 )
      ELSE
	 drop 1                      ( dst-adr 1 )
      THEN
   +LOOP
;

\ Add special character to string

: add-specialchar ( dst-adr special -- dst-adr' )
   over c! 1+                        ( dst-adr' )
   1 >in +!                          \ advance input-index
;

\ Parse up to next "

: parse-" ( dst-adr -- dst-adr' )
   [char] " parse dup 3 pick + >r    ( dst-adr str len R: dst-adr' )
   >r swap r> move r>                ( dst-adr' )
;

: (") ( dst-adr -- dst-adr' )
   begin                             ( dst-adr )
      parse-"                        ( dst-adr' )
      >in @ dup span @ >= IF         ( dst-adr' >in-@ )
         drop
         EXIT
      THEN

      ib + c@
      CASE
         [char] ( OF parse-hexstring ENDOF
         [char] " OF [char] " add-specialchar ENDOF
         dup      OF EXIT ENDOF
      ENDCASE
   again
;

CREATE "pad 100 allot

\ String with embedded hex strings
\ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62<

: " ( [text<">< >] -- text-str text-len )
   state @ IF                        \ compile sliteral, pstr into dict
      "pad dup (") over -            ( str len )
      ['] sliteral compile, dup c,   ( str len )
      bounds ?DO i c@ c, LOOP
      align ['] count compile,
   ELSE
      pocket dup (") over -          \ Interpretation, put string
   THEN                              \ in temp buffer
; immediate


\ Output the carriage-return character
: (cr carret emit ;


\ Remove command old-name and all subsequent definitions

: $forget ( str len -- )
   2dup last @            ( str len str len last-bc )
   BEGIN
      dup >r             ( str len str len last-bc R: last-bc )
      cell+ char+ count  ( str len str len found-str found-len R: last-bc )
      string=ci IF       ( str len R: last-bc )
         r> @ last ! 2drop clean-hash EXIT ( -- )
      THEN
      2dup r> @ dup 0=   ( str len str len next-bc next-bc )
   UNTIL
   drop 2drop 2drop            \ clean hash table
;

: forget ( "old-name<>" -- )
    parse-word $forget
;

#include <search.fs>

\ The following constants are required in some parts
\ of the code, mainly instance variables and see. Having to reverse
\ engineer our own CFAs seems somewhat weird, but we gained a bit speed.

\ Each colon definition is surrounded by colon and semicolon
\ constant below contain address of their xt

: (function) ;
defer (defer)
0 value (value)
0 constant (constant)
variable (variable)
create (create)
alias (alias) (function)
cell buffer: (buffer:)

' (function) @        \ ( <colon> )
' (function) cell + @ \ ( ... <semicolon> )
' (defer) @           \ ( ... <defer> )
' (value) @           \ ( ... <value> )
' (constant) @	      \ ( ... <constant> )
' (variable) @        \ ( ... <variable> )
' (create) @          \ ( ... <create> )
' (alias) @           \ ( ... <alias> )
' (buffer:) @         \ ( ... <buffer:> )

\ now clean up the test functions
forget (function)

\ and remember the constants
constant <buffer:>
constant <alias>
constant <create>
constant <variable>
constant <constant>
constant <value>
constant <defer>
constant <semicolon>
constant <colon>

' lit      constant <lit>
' sliteral constant <sliteral>
' 0branch  constant <0branch>
' branch   constant <branch>
' doloop   constant <doloop>
' dotick   constant <dotick>
' doto     constant <doto>
' do?do    constant <do?do>
' do+loop  constant <do+loop>
' do       constant <do>
' exit     constant <exit>
' doleave  constant <doleave>
' do?leave  constant <do?leave>


\ provide the memory management words
\ #include <claim.fs>
\ #include "memory.fs"
#include <alloc-mem.fs>

#include <node.fs>

: find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
  \ if substr-len == 0 ?
  dup 0 = IF
    \ return 0
    2drop 2drop 0 exit THEN
  \ if substr-len <= basestr-len ?
  dup 3 pick <= IF
    \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
    2 pick over - 1+ 0 DO dup 0 DO
      \ substr-ptr[i] == basestr-ptr[j+i] ?
      over i + c@ 4 pick j + i + c@ = IF
        \ (I+1) == substr-len ?
        dup i 1+ = IF
          \ return J
          2drop 2drop j unloop unloop exit THEN
      ELSE leave THEN
    LOOP LOOP
  THEN
  \ if there is no match then exit with basestr-len as return value
  2drop nip
;

: find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
  \ if substr-len == 0 ?
  dup 0 = IF
    \ return 0
    2drop 2drop 0 exit THEN
  \ if substr-len <= basestr-len ?
  dup 3 pick <= IF
    \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
    2 pick over - 1+ 0 DO dup 0 DO
      \ substr-ptr[i] == basestr-ptr[j+i] ?
      over i + c@ lcc 4 pick j + i + c@ lcc = IF
        \ (I+1) == substr-len ?
        dup i 1+ = IF
          \ return J
          2drop 2drop j unloop unloop exit THEN
      ELSE leave THEN
    LOOP LOOP
  THEN
  \ if there is no match then exit with basestr-len as return value
  2drop nip
;

: find-nextline ( str-ptr str-len -- pos )
  \ run I from 0 to "str-len"-1 and check str-ptr[i]
  dup 0 ?DO over i + c@ CASE
    \ 0x0a (=LF) found ?
    0a OF
      \ if current cursor is at end position (I == "str-len"-1) ?
      dup 1- i = IF
        \ return I+1
        2drop i 1+ unloop exit THEN
        \ if str-ptr[I+1] == 0x0d (=CR) ?
      over i 1+ + c@ 0d = IF
        \ return I+2
        2drop i 2+ ELSE
        \ else return I+1
        2drop i 1+ THEN
      unloop exit
    ENDOF
    \ 0x0d (=CR) found ?
    0d OF
      \ if current cursor is at end position (I == "str-len"-1) ?
      dup 1- i = IF
        \ return I+1
        2drop i 1+ unloop exit THEN
      \ str-ptr[I+1] == 0x0a (=LF) ?
      over i 1+ + c@ 0a = IF
        \ return I+2
        2drop i 2+ ELSE
        \ return I+1
        2drop i 1+ THEN
      unloop exit
    ENDOF
  ENDCASE LOOP nip
;

: string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
  -rot 2 pick - -rot swap chars + swap
;

\ appends the string beginning at addr2 to the end of the string
\ beginning at addr1
\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
\ !!!        BEGINNING AT ADDR1 (cp. 'strcat' in 'C' )        !!!

: string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
  \ len1 := len1+len2
  rot dup >r over + -rot
  ( addr1 len1+len2 dest-ptr src-ptr len2 )
  3 pick r> chars + -rot
  ( ... dest-ptr src-ptr )
  0 ?DO
    2dup c@ swap c!
    char+ swap char+ swap
  LOOP 2drop
;

\ appends a character to the end of the string beginning at addr
\ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
\ !!!        BEGINNING AT ADDR1 (cp. 'strcat' in 'C' )        !!!

: char-cat ( addr len character -- addr len+1 )
  -rot 2dup >r >r 1+ rot r> r> chars + c!
;

\ Returns true if source and destination overlap
: overlap ( src dest size -- true|false )
	3dup over + within IF 3drop true ELSE rot tuck + within THEN
;

: parse-2int ( str len -- val.lo val.hi )
\ ." parse-2int ( " 2dup swap . . ." -- "
	[char] , split ?dup IF eval ELSE drop 0 THEN
	-rot ?dup IF eval ELSE drop 0 THEN
\ 2dup swap . . ." )" cr
;

\ peek/poke minimal implementation, just to support FCode drivers
\ Any implmentation with full error detection will be platform specific
: cpeek ( addr -- false | byte true ) c@ true ;
: cpoke ( byte addr -- success? ) c! true ;
: wpeek ( addr -- false | word true ) w@ true ;
: wpoke ( word addr -- success? ) w! true ;
: lpeek ( addr -- false | lword true ) l@ true ;
: lpoke ( lword addr -- success? ) l! true ;

defer reboot ( -- )
defer halt ( -- )
defer disable-watchdog ( -- )
defer reset-watchdog ( -- )
defer set-watchdog ( +n -- )
defer set-led ( type instance state -- status )
defer get-flashside ( -- side )
defer set-flashside ( side -- status )
defer read-bootlist ( -- )
defer furnish-boot-file ( -- adr len )
defer set-boot-file ( adr len -- )
defer mfg-mode? ( -- flag )
defer of-prompt? ( -- flag )
defer debug-boot? ( -- flag )
defer bmc-version ( -- adr len )
defer cursor-on ( -- )
defer cursor-off ( -- )

: nop-reboot ( -- ) ." reboot not available" abort ;
: nop-halt ( -- ) ." halt not available" abort ;
: nop-disable-watchdog ( -- )  ;
: nop-reset-watchdog ( -- )  ;
: nop-set-watchdog ( +n -- ) drop ;
: nop-set-led ( type instance state -- status ) drop drop drop ;
: nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
: nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
: nop-read-bootlist ( -- ) ;
: nop-furnish-bootfile ( -- adr len ) s" net:" ;
: nop-set-boot-file ( adr len -- ) 2drop ;
: nop-mfg-mode? ( -- flag ) false ;
: nop-of-prompt? ( -- flag ) false ;
: nop-debug-boot? ( -- flag ) false ;
: nop-bmc-version ( -- adr len ) s" XXXXX" ;
: nop-cursor-on ( -- ) ;
: nop-cursor-off ( -- ) ;

' nop-reboot to reboot
' nop-halt to halt
' nop-disable-watchdog to disable-watchdog
' nop-reset-watchdog   to reset-watchdog
' nop-set-watchdog     to set-watchdog
' nop-set-led          to set-led
' nop-get-flashside    to get-flashside
' nop-set-flashside    to set-flashside
' nop-read-bootlist    to read-bootlist
' nop-furnish-bootfile to furnish-boot-file
' nop-set-boot-file    to set-boot-file
' nop-mfg-mode?        to mfg-mode?
' nop-of-prompt?       to of-prompt?
' nop-debug-boot?      to debug-boot?
' nop-bmc-version      to bmc-version
' nop-cursor-on        to cursor-on
' nop-cursor-off       to cursor-off

: reset-all reboot ;

\ load-base is an env. variable now, but it can
\ be overriden temporarily provided users use
\ get-load-base rather than load-base directly
\
\ default-load-base is set here and can be
\ overriden by the board code. It will be used
\ to set the default value of the envvar "load-base"
\ when booting without a valid nvram

10000000 VALUE default-load-base
2000000 VALUE flash-load-base
0 VALUE load-base-override

: get-load-base
  load-base-override 0<> IF load-base-override ELSE
    " load-base" evaluate 
  THEN
;

\ provide first level debug support
#include "debug.fs"
\ provide 7.5.3.1 Dictionary search
#include "dictionary.fs"
\ provide a simple run time preprocessor
#include <preprocessor.fs>

: $dnumber base @ >r decimal $number r> base ! ;
: (.d) base @ >r decimal (.) r> base ! ;

\ IP address conversion

: (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
   base @ >r decimal
   over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
   [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
   [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
   [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
   $number IF false r> base ! EXIT THEN
   true r> base !
;

: (ipformat)  ( n1 n2 n3 n4 -- str len )
   base @ >r decimal
   0 <# # # # [char] . hold drop # # # [char] . hold
   drop # # # [char] . hold drop # # #s #>
   r> base !
;

: ipformat  ( n1 n2 n3 n4 -- ) (ipformat) type ;