1 \ *****************************************************************************
2 \ * Copyright (c) 2004, 2008 IBM Corporation
3 \ * All rights reserved.
4 \ * This program and the accompanying materials
5 \ * are made available under the terms of the BSD License
6 \ * which accompanies this distribution, and is available at
7 \ * http://www.opensource.org/licenses/bsd-license.php
10 \ * IBM Corporation - initial implementation
11 \ ****************************************************************************/
13 \ Hash for faster lookup
14 #include <find-hash.fs>
16 : >name ( xt -- nfa ) \ note: still has the "immediate" field!
17 BEGIN char- dup c@ UNTIL ( @lastchar )
18 dup dup aligned - cell+ char- ( @lastchar lenmodcell )
20 BEGIN dup c@ r@ <> WHILE
26 \ Words missing in *.in files
27 VARIABLE mask -1 mask !
29 VARIABLE huge-tftp-load 1 huge-tftp-load !
30 \ Default implementation for sms-get-tftp-blocksize that return 1432 (decimal)
31 : sms-get-tftp-blocksize 598 ;
33 : default-hw-exception s" Exception #" type . ;
35 ' default-hw-exception to hw-exception-handler
37 : diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs
39 : memory-test-suite ( addr len -- fail? )
41 ." Memory test mask value: " mask @ . cr
42 ." No memory test suite currently implemented! " cr
47 : 0.r 0 swap <# 0 ?DO # LOOP #> type ;
49 \ count the number of bits equal 1
50 \ the idea is to clear in each step the least significant bit
51 \ v&(v-1) does exactly this, so count the steps until v == 0
52 : cnt-bits ( 64-bit-value -- #bits=1 )
54 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP
58 : bcd-to-bin ( bcd -- bin )
59 dup f and swap 4 rshift a * +
62 \ calcs the exponent of the highest power of 2 not greater than n
64 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP
67 \ calcs the exponent of the lowest power of 2 not less than n
68 : log2 ( n -- log2-n )
73 CREATE $catpad 400 allot
74 : $cat ( str1 len1 str2 len2 -- str3 len3 )
75 >r >r dup >r $catpad swap move
76 r> dup $catpad + r> swap r@ move
79 \ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense
80 \ that they add 1 or 2 characters to str1 before executing $cat
81 \ The ASSUMPTION is that str1 buffer provides that extra space and it is
82 \ responsibility of the code owner to ensure that
83 : $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 )
84 2dup + s" , " rot swap move 2+ 2swap $cat
87 : $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
88 2dup + bl swap c! 1+ 2swap $cat
90 : $cathex ( str len val -- str len' )
95 : 2CONSTANT CREATE , , DOES> [ here ] 2@ ;
97 \ Save XT of 2CONSTANT, put on the stack by "[ here ]" :
100 : $2CONSTANT $CREATE , , DOES> 2@ ;
102 : 2VARIABLE CREATE 0 , 0 , DOES> ;
105 : (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;
107 : zplace ( str len buf -- ) 2dup + 0 swap c! swap move ;
108 : rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ;
110 : strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;
112 : str= ( str1 len1 str2 len2 -- equal? )
113 rot over <> IF 3drop false ELSE comp 0= THEN ;
115 : test-string ( param len -- true | false )
117 dup i + c@ \ Get character / byte at current index
118 dup 20 < swap 7e > OR IF \ Is it out of range 32 to 126 (=ASCII)
119 drop FALSE UNLOOP EXIT \ FALSE means: No ASCII string
122 drop TRUE \ Only ASCII found --> it is a string
125 : #aligned ( adr alignment -- adr' ) negate swap negate and negate ;
126 : #join ( lo hi #bits -- x ) lshift or ;
127 : #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ;
129 : /string ( str len u -- str' len' )
130 >r swap r@ chars + swap r> - ;
131 : skip ( str len c -- str' len' )
132 >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ;
133 : scan ( str len c -- str' len' )
134 >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ;
135 : split ( str len char -- left len right len )
136 >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
137 \ reverse findchar -- search from the end of the string
138 : rfindchar ( str len char -- offs true | false )
141 over dup bl = if <= else = then if
142 2drop i dup dup leave
146 \ reverse split -- split at the last occurrence of char
147 : rsplit ( str len char -- left len right len )
148 >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
150 : left-parse-string ( str len char -- R-str R-len L-str L-len )
152 : replace-char ( str len chout chin -- )
153 >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
156 \ Duplicate string and replace \ with /
157 : \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;
159 : isdigit ( char -- true | false )
163 : ishexdigit ( char -- true | false )
164 30 39 between 41 46 between OR 61 66 between OR
167 \ Variant of $number that defaults to decimal unless "0x" is
169 : $dh-number ( addr len -- true | number false )
173 over dup c@ [char] 0 =
174 over 1 + c@ 20 or [char] x =
175 AND IF hex 2 + swap 2 - rot THEN drop
181 : // dup >r 1- + r> / ; \ division, round up
183 : c@+ ( adr -- c adr' ) dup c@ swap char+ ;
184 : 2c@ ( adr -- c1 c2 ) c@+ c@ ;
185 : 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ;
186 : 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;
189 : 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ;
190 : 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ;
192 \ yes sometimes even something like this is needed
193 : 5dup ( 1 2 3 4 5 -- 1 2 3 4 5 1 2 3 4 5 )
194 4 pick 4 pick 4 pick 4 pick 4 pick ;
197 nip nip nip nip nip ;
199 : 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
200 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ;
202 \ convert a 32 bit signed into a 64 signed
203 \ ( propagate bit 31 to all bits 32:63 )
204 : signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;
206 : <l@ ( addr -- x ) l@ signed ;
208 : -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
209 : (parse-line) skipws 0 parse ;
212 \ Append two character to hex byte, if possible
214 : hex-byte ( char0 char1 -- value true|false )
217 4 lshift or true EXIT
227 \ Parse hex string within brackets
229 : parse-hexstring ( dst-adr -- dst-adr' )
230 [char] ) parse cr ( dst-adr str len )
231 bounds ?DO ( dst-adr )
232 i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte )
233 >r dup r> swap c! 1+ 2 ( dst-adr+1 2 )
240 \ Add special character to string
242 : add-specialchar ( dst-adr special -- dst-adr' )
243 over c! 1+ ( dst-adr' )
244 1 >in +! \ advance input-index
249 : parse-" ( dst-adr -- dst-adr' )
250 [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' )
251 >r swap r> move r> ( dst-adr' )
254 : (") ( dst-adr -- dst-adr' )
257 >in @ dup span @ >= IF ( dst-adr' >in-@ )
264 [char] ( OF parse-hexstring ENDOF
265 [char] " OF [char] " add-specialchar ENDOF
271 CREATE "pad 100 allot
273 \ String with embedded hex strings
274 \ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62<
276 : " ( [text<">< >] -- text-str text-len )
277 state @ IF \ compile sliteral, pstr into dict
278 "pad dup (") over - ( str len )
279 ['] sliteral compile, dup c, ( str len )
280 bounds ?DO i c@ c, LOOP
281 align ['] count compile,
283 pocket dup (") over - \ Interpretation, put string
284 THEN \ in temp buffer
288 \ Output the carriage-return character
292 \ Remove command old-name and all subsequent definitions
294 : $forget ( str len -- )
295 2dup last @ ( str len str len last-bc )
297 dup >r ( str len str len last-bc R: last-bc )
298 cell+ char+ count ( str len str len found-str found-len R: last-bc )
299 string=ci IF ( str len R: last-bc )
300 r> @ last ! 2drop clean-hash EXIT ( -- )
302 2dup r> @ dup 0= ( str len str len next-bc next-bc )
304 drop 2drop 2drop \ clean hash table
307 : forget ( "old-name<>" -- )
313 \ The following constants are required in some parts
314 \ of the code, mainly instance variables and see. Having to reverse
315 \ engineer our own CFAs seems somewhat weird, but we gained a bit speed.
317 \ Each colon definition is surrounded by colon and semicolon
318 \ constant below contain address of their xt
323 0 constant (constant)
326 alias (alias) (function)
327 cell buffer: (buffer:)
329 ' (function) @ \ ( <colon> )
330 ' (function) cell + @ \ ( ... <semicolon> )
331 ' (defer) @ \ ( ... <defer> )
332 ' (value) @ \ ( ... <value> )
333 ' (constant) @ \ ( ... <constant> )
334 ' (variable) @ \ ( ... <variable> )
335 ' (create) @ \ ( ... <create> )
336 ' (alias) @ \ ( ... <alias> )
337 ' (buffer:) @ \ ( ... <buffer:> )
339 \ now clean up the test functions
342 \ and remember the constants
354 ' sliteral constant <sliteral>
355 ' 0branch constant <0branch>
356 ' branch constant <branch>
357 ' doloop constant <doloop>
358 ' dotick constant <dotick>
359 ' doto constant <doto>
360 ' do?do constant <do?do>
361 ' do+loop constant <do+loop>
363 ' exit constant <exit>
364 ' doleave constant <doleave>
365 ' do?leave constant <do?leave>
368 \ provide the memory management words
369 \ #include <claim.fs>
370 \ #include "memory.fs"
371 #include <alloc-mem.fs>
375 : find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
376 \ if substr-len == 0 ?
379 2drop 2drop 0 exit THEN
380 \ if substr-len <= basestr-len ?
382 \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
383 2 pick over - 1+ 0 DO dup 0 DO
384 \ substr-ptr[i] == basestr-ptr[j+i] ?
385 over i + c@ 4 pick j + i + c@ = IF
386 \ (I+1) == substr-len ?
389 2drop 2drop j unloop unloop exit THEN
393 \ if there is no match then exit with basestr-len as return value
397 : find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
398 \ if substr-len == 0 ?
401 2drop 2drop 0 exit THEN
402 \ if substr-len <= basestr-len ?
404 \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
405 2 pick over - 1+ 0 DO dup 0 DO
406 \ substr-ptr[i] == basestr-ptr[j+i] ?
407 over i + c@ lcc 4 pick j + i + c@ lcc = IF
408 \ (I+1) == substr-len ?
411 2drop 2drop j unloop unloop exit THEN
415 \ if there is no match then exit with basestr-len as return value
419 : find-nextline ( str-ptr str-len -- pos )
420 \ run I from 0 to "str-len"-1 and check str-ptr[i]
421 dup 0 ?DO over i + c@ CASE
424 \ if current cursor is at end position (I == "str-len"-1) ?
427 2drop i 1+ unloop exit THEN
428 \ if str-ptr[I+1] == 0x0d (=CR) ?
429 over i 1+ + c@ 0d = IF
438 \ if current cursor is at end position (I == "str-len"-1) ?
441 2drop i 1+ unloop exit THEN
442 \ str-ptr[I+1] == 0x0a (=LF) ?
443 over i 1+ + c@ 0a = IF
453 : string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
454 -rot 2 pick - -rot swap chars + swap
457 \ appends the string beginning at addr2 to the end of the string
459 \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
460 \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
462 : string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
464 rot dup >r over + -rot
465 ( addr1 len1+len2 dest-ptr src-ptr len2 )
466 3 pick r> chars + -rot
467 ( ... dest-ptr src-ptr )
470 char+ swap char+ swap
474 \ appends a character to the end of the string beginning at addr
475 \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
476 \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
478 : char-cat ( addr len character -- addr len+1 )
479 -rot 2dup >r >r 1+ rot r> r> chars + c!
482 \ Returns true if source and destination overlap
483 : overlap ( src dest size -- true|false )
484 3dup over + within IF 3drop true ELSE rot tuck + within THEN
487 : parse-2int ( str len -- val.lo val.hi )
488 \ ." parse-2int ( " 2dup swap . . ." -- "
489 [char] , split ?dup IF eval ELSE drop 0 THEN
490 -rot ?dup IF eval ELSE drop 0 THEN
491 \ 2dup swap . . ." )" cr
494 \ peek/poke minimal implementation, just to support FCode drivers
495 \ Any implmentation with full error detection will be platform specific
496 : cpeek ( addr -- false | byte true ) c@ true ;
497 : cpoke ( byte addr -- success? ) c! true ;
498 : wpeek ( addr -- false | word true ) w@ true ;
499 : wpoke ( word addr -- success? ) w! true ;
500 : lpeek ( addr -- false | lword true ) l@ true ;
501 : lpoke ( lword addr -- success? ) l! true ;
505 defer disable-watchdog ( -- )
506 defer reset-watchdog ( -- )
507 defer set-watchdog ( +n -- )
508 defer set-led ( type instance state -- status )
509 defer get-flashside ( -- side )
510 defer set-flashside ( side -- status )
511 defer read-bootlist ( -- )
512 defer furnish-boot-file ( -- adr len )
513 defer set-boot-file ( adr len -- )
514 defer mfg-mode? ( -- flag )
515 defer of-prompt? ( -- flag )
516 defer debug-boot? ( -- flag )
517 defer bmc-version ( -- adr len )
518 defer cursor-on ( -- )
519 defer cursor-off ( -- )
521 : nop-reboot ( -- ) ." reboot not available" abort ;
522 : nop-halt ( -- ) ." halt not available" abort ;
523 : nop-disable-watchdog ( -- ) ;
524 : nop-reset-watchdog ( -- ) ;
525 : nop-set-watchdog ( +n -- ) drop ;
526 : nop-set-led ( type instance state -- status ) drop drop drop ;
527 : nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
528 : nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
529 : nop-read-bootlist ( -- ) ;
530 : nop-furnish-bootfile ( -- adr len ) s" net:" ;
531 : nop-set-boot-file ( adr len -- ) 2drop ;
532 : nop-mfg-mode? ( -- flag ) false ;
533 : nop-of-prompt? ( -- flag ) false ;
534 : nop-debug-boot? ( -- flag ) false ;
535 : nop-bmc-version ( -- adr len ) s" XXXXX" ;
536 : nop-cursor-on ( -- ) ;
537 : nop-cursor-off ( -- ) ;
539 ' nop-reboot to reboot
541 ' nop-disable-watchdog to disable-watchdog
542 ' nop-reset-watchdog to reset-watchdog
543 ' nop-set-watchdog to set-watchdog
544 ' nop-set-led to set-led
545 ' nop-get-flashside to get-flashside
546 ' nop-set-flashside to set-flashside
547 ' nop-read-bootlist to read-bootlist
548 ' nop-furnish-bootfile to furnish-boot-file
549 ' nop-set-boot-file to set-boot-file
550 ' nop-mfg-mode? to mfg-mode?
551 ' nop-of-prompt? to of-prompt?
552 ' nop-debug-boot? to debug-boot?
553 ' nop-bmc-version to bmc-version
554 ' nop-cursor-on to cursor-on
555 ' nop-cursor-off to cursor-off
559 \ load-base is an env. variable now, but it can
560 \ be overriden temporarily provided users use
561 \ get-load-base rather than load-base directly
563 \ default-load-base is set here and can be
564 \ overriden by the board code. It will be used
565 \ to set the default value of the envvar "load-base"
566 \ when booting without a valid nvram
568 10000000 VALUE default-load-base
569 2000000 VALUE flash-load-base
570 0 VALUE load-base-override
573 load-base-override 0<> IF load-base-override ELSE
574 " load-base" evaluate
578 \ provide first level debug support
580 \ provide 7.5.3.1 Dictionary search
581 #include "dictionary.fs"
582 \ provide a simple run time preprocessor
583 #include <preprocessor.fs>
585 : $dnumber base @ >r decimal $number r> base ! ;
586 : (.d) base @ >r decimal (.) r> base ! ;
588 \ IP address conversion
590 : (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
592 over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
593 [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
594 [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
595 [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
596 $number IF false r> base ! EXIT THEN
600 : (ipformat) ( n1 n2 n3 n4 -- str len )
602 0 <# # # # [char] . hold drop # # # [char] . hold
603 drop # # # [char] . hold drop # # #s #>
607 : ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ;