![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to base.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs|
Return to base.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs |
1.1 root 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
8: \ *
9: \ * Contributors:
10: \ * IBM Corporation - initial implementation
11: \ ****************************************************************************/
12:
13: \ Hash for faster lookup
14: #include <find-hash.fs>
15:
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 )
19: dup >r -
20: BEGIN dup c@ r@ <> WHILE
21: cell- r> cell+ >r
22: REPEAT
23: r> drop char-
24: ;
25:
26: \ Words missing in *.in files
27: VARIABLE mask -1 mask !
28:
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 ;
32:
33: : default-hw-exception s" Exception #" type . ;
34:
35: ' default-hw-exception to hw-exception-handler
36:
37: : diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs
38:
39: : memory-test-suite ( addr len -- fail? )
40: diagnostic-mode? IF
41: ." Memory test mask value: " mask @ . cr
42: ." No memory test suite currently implemented! " cr
43: THEN
44: false
45: ;
46:
47: : 0.r 0 swap <# 0 ?DO # LOOP #> type ;
48:
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 )
53: dup IF
54: 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP
55: THEN
56: ;
57:
58: : bcd-to-bin ( bcd -- bin )
59: dup f and swap 4 rshift a * +
60: ;
61:
62: \ calcs the exponent of the highest power of 2 not greater than n
63: : 2log ( n -- lb{n} )
64: 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP
65: ;
66:
67: \ calcs the exponent of the lowest power of 2 not less than n
68: : log2 ( n -- log2-n )
69: 1- 2log 1+
70: ;
71:
72:
73: CREATE $catpad 100 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
77: r> + $catpad swap ;
78:
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
85: ;
86:
87: : $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
88: 2dup + bl swap c! 1+ 2swap $cat
89: ;
90: : $cathex ( str len val -- str len' )
91: (u.) $cat
92: ;
93:
94:
1.1.1.2 root 95: : 2CONSTANT CREATE , , DOES> [ here ] 2@ ;
96:
97: \ Save XT of 2CONSTANT, put on the stack by "[ here ]" :
98: CONSTANT <2constant>
1.1 root 99:
100: : $2CONSTANT $CREATE , , DOES> 2@ ;
1.1.1.2 root 101:
1.1 root 102: : 2VARIABLE CREATE 0 , 0 , DOES> ;
103:
1.1.1.2 root 104:
1.1 root 105: : (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;
106:
107: : zplace ( str len buf -- ) 2dup + 0 swap c! swap move ;
108: : rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ;
109:
110: : strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;
111:
112: : str= ( str1 len1 str2 len2 -- equal? )
113: rot over <> IF 3drop false ELSE comp 0= THEN ;
114:
1.1.1.3 ! root 115: : test-string ( param len -- true | false )
! 116: 0 ?DO
! 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
! 120: THEN
! 121: LOOP
! 122: drop TRUE \ Only ASCII found --> it is a string
! 123: ;
! 124:
1.1 root 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> ;
128:
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 )
139: swap 1 - 0 swap do
140: over i + c@
141: over dup bl = if <= else = then if
142: 2drop i dup dup leave
143: then
144: -1 +loop =
145: ;
146: \ reverse split -- split at the last occurence 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 ;
149:
150: : left-parse-string ( str len char -- R-str R-len L-str L-len )
151: split 2swap ;
152: : replace-char ( str len chout chin -- )
153: >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
154: r> 2drop 2drop
155: ;
156: \ Duplicate string and replace \ with /
157: : \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;
158:
1.1.1.3 ! root 159: : isdigit ( char -- true | false )
! 160: 30 39 between
! 161: ;
! 162:
1.1 root 163: : // dup >r 1- + r> / ; \ division, round up
164:
165: : c@+ ( adr -- c adr' ) dup c@ swap char+ ;
166: : 2c@ ( adr -- c1 c2 ) c@+ c@ ;
167: : 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ;
168: : 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;
169:
170:
171: : 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ;
172: : 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ;
173:
174: \ yes sometimes even something like this is needed
175: : 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
176: 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick
177: ;
178:
179: \ convert a 32 bit signed into a 64 signed
180: \ ( propagate bit 31 to all bits 32:63 )
181: : signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;
182:
183: : <l@ ( addr -- x ) l@ signed ;
184:
185: : -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
186: : (parse-line) skipws 0 parse ;
187:
188:
189: \ Append two character to hex byte, if possible
190:
191: : hex-byte ( char0 char1 -- value true|false )
192: 10 digit IF
193: swap 10 digit IF
194: 4 lshift or true EXIT
195: ELSE
196: 2drop 0
197: THEN
198: ELSE
199: drop
200: THEN
201: false EXIT
202: ;
203:
204: \ Parse hex string within brackets
205:
206: : parse-hexstring ( dst-adr -- dst-adr' )
207: [char] ) parse cr ( dst-adr str len )
208: bounds ?DO ( dst-adr )
209: i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte )
210: >r dup r> swap c! 1+ 2 ( dst-adr+1 2 )
211: ELSE
212: drop 1 ( dst-adr 1 )
213: THEN
214: +LOOP
215: ;
216:
217: \ Add special character to string
218:
219: : add-specialchar ( dst-adr special -- dst-adr' )
220: over c! 1+ ( dst-adr' )
221: 1 >in +! \ advance input-index
222: ;
223:
224: \ Parse upto next "
225:
226: : parse-" ( dst-adr -- dst-adr' )
227: [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' )
228: >r swap r> move r> ( dst-adr' )
229: ;
230:
231: : (") ( dst-adr -- dst-adr' )
232: begin ( dst-adr )
233: parse-" ( dst-adr' )
234: >in @ dup span @ >= IF ( dst-adr' >in-@ )
235: drop
236: EXIT
237: THEN
238:
239: ib + c@
240: CASE
241: [char] ( OF parse-hexstring ENDOF
242: [char] " OF [char] " add-specialchar ENDOF
243: dup OF EXIT ENDOF
244: ENDCASE
245: again
246: ;
247:
248: CREATE "pad 100 allot
249:
250: \ String with embedded hex strings
251: \ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62<
252:
253: : " ( [text<">< >] -- text-str text-len )
254: state @ IF \ compile sliteral, pstr into dict
255: "pad dup (") over - ( str len )
256: ['] sliteral compile, dup c, ( str len )
257: bounds ?DO i c@ c, LOOP
258: align ['] count compile,
259: ELSE
260: pocket dup (") over - \ Interpretation, put string
261: THEN \ in temp buffer
262: ; immediate
263:
1.1.1.3 ! root 264:
! 265: \ Output the carriage-return character
! 266: : (cr carret emit ;
! 267:
! 268:
1.1 root 269: \ Remove command old-name and all subsequent definitions
270:
271: : $forget ( str len -- )
272: 2dup last @ ( str len str len last-bc )
273: BEGIN
274: dup >r ( str len str len last-bc R: last-bc )
275: cell+ char+ count ( str len str len found-str found-len R: last-bc )
276: string=ci IF ( str len R: last-bc )
277: r> @ last ! 2drop clean-hash EXIT ( -- )
278: THEN
279: 2dup r> @ dup 0= ( str len str len next-bc next-bc )
280: UNTIL
281: drop 2drop 2drop \ clean hash table
282: ;
283:
284: : forget ( "old-name<>" -- )
285: parse-word $forget
286: ;
287:
288: #include <search.fs>
289:
290: \ The following constants are required in some parts
291: \ of the code, mainly instance variables and see. Having to reverse
292: \ engineer our own CFAs seems somewhat weird, but we gained a bit speed.
293:
294: \ Each colon definition is surrounded by colon and semicolon
295: \ constant below contain address of their xt
296:
297: : (function) ;
298: defer (defer)
299: 0 value (value)
300: 0 constant (constant)
301: variable (variable)
302: create (create)
303: alias (alias) (function)
304: cell buffer: (buffer:)
305:
306: ' (function) @ \ ( <colon> )
307: ' (function) cell + @ \ ( ... <semicolon> )
308: ' (defer) @ \ ( ... <defer> )
309: ' (value) @ \ ( ... <value> )
310: ' (constant) @ \ ( ... <constant> )
311: ' (variable) @ \ ( ... <variable> )
312: ' (create) @ \ ( ... <create> )
313: ' (alias) @ \ ( ... <alias> )
314: ' (buffer:) @ \ ( ... <buffer:> )
315:
316: \ now clean up the test functions
317: forget (function)
318:
319: \ and remember the constants
320: constant <buffer:>
321: constant <alias>
322: constant <create>
323: constant <variable>
324: constant <constant>
325: constant <value>
326: constant <defer>
327: constant <semicolon>
328: constant <colon>
329:
330: ' lit constant <lit>
331: ' sliteral constant <sliteral>
332: ' 0branch constant <0branch>
333: ' branch constant <branch>
334: ' doloop constant <doloop>
335: ' dotick constant <dotick>
336: ' doto constant <doto>
337: ' do?do constant <do?do>
338: ' do+loop constant <do+loop>
339: ' do constant <do>
340: ' exit constant <exit>
341: ' doleave constant <doleave>
342: ' do?leave constant <do?leave>
343:
344:
345: \ provide the memory management words
346: \ #include <claim.fs>
347: \ #include "memory.fs"
348: #include <alloc-mem.fs>
349:
350: #include <node.fs>
351:
352: : find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
353: \ if substr-len == 0 ?
354: dup 0 = IF
355: \ return 0
356: 2drop 2drop 0 exit THEN
357: \ if substr-len <= basestr-len ?
358: dup 3 pick <= IF
359: \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
360: 2 pick over - 1+ 0 DO dup 0 DO
361: \ substr-ptr[i] == basestr-ptr[j+i] ?
362: over i + c@ 4 pick j + i + c@ = IF
363: \ (I+1) == substr-len ?
364: dup i 1+ = IF
365: \ return J
366: 2drop 2drop j unloop unloop exit THEN
367: ELSE leave THEN
368: LOOP LOOP
369: THEN
370: \ if there is no match then exit with basestr-len as return value
371: 2drop nip
372: ;
373:
374: : find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
375: \ if substr-len == 0 ?
376: dup 0 = IF
377: \ return 0
378: 2drop 2drop 0 exit THEN
379: \ if substr-len <= basestr-len ?
380: dup 3 pick <= IF
381: \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
382: 2 pick over - 1+ 0 DO dup 0 DO
383: \ substr-ptr[i] == basestr-ptr[j+i] ?
384: over i + c@ lcc 4 pick j + i + c@ lcc = IF
385: \ (I+1) == substr-len ?
386: dup i 1+ = IF
387: \ return J
388: 2drop 2drop j unloop unloop exit THEN
389: ELSE leave THEN
390: LOOP LOOP
391: THEN
392: \ if there is no match then exit with basestr-len as return value
393: 2drop nip
394: ;
395:
396: : find-nextline ( str-ptr str-len -- pos )
397: \ run I from 0 to "str-len"-1 and check str-ptr[i]
398: dup 0 ?DO over i + c@ CASE
399: \ 0x0a (=LF) found ?
400: 0a OF
401: \ if current cursor is at end position (I == "str-len"-1) ?
402: dup 1- i = IF
403: \ return I+1
404: 2drop i 1+ unloop exit THEN
405: \ if str-ptr[I+1] == 0x0d (=CR) ?
406: over i 1+ + c@ 0d = IF
407: \ return I+2
408: 2drop i 2+ ELSE
409: \ else return I+1
410: 2drop i 1+ THEN
411: unloop exit
412: ENDOF
413: \ 0x0d (=CR) found ?
414: 0d OF
415: \ if current cursor is at end position (I == "str-len"-1) ?
416: dup 1- i = IF
417: \ return I+1
418: 2drop i 1+ unloop exit THEN
419: \ str-ptr[I+1] == 0x0a (=LF) ?
420: over i 1+ + c@ 0a = IF
421: \ return I+2
422: 2drop i 2+ ELSE
423: \ return I+1
424: 2drop i 1+ THEN
425: unloop exit
426: ENDOF
427: ENDCASE LOOP nip
428: ;
429:
430: : string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
431: -rot 2 pick - -rot swap chars + swap
432: ;
433:
434: \ appends the string beginning at addr2 to the end of the string
435: \ beginning at addr1
436: \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
437: \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
438:
439: : string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
440: \ len1 := len1+len2
441: rot dup >r over + -rot
442: ( addr1 len1+len2 dest-ptr src-ptr len2 )
443: 3 pick r> chars + -rot
444: ( ... dest-ptr src-ptr )
445: 0 ?DO
446: 2dup c@ swap c!
447: char+ swap char+ swap
448: LOOP 2drop
449: ;
450:
451: \ appends a character to the end of the string beginning at addr
452: \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
453: \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!!
454:
455: : char-cat ( addr len character -- addr len+1 )
456: -rot 2dup >r >r 1+ rot r> r> chars + c!
457: ;
458:
459: \ Returns true if source and destination overlap
460: : overlap ( src dest size -- true|false )
461: 3dup over + within IF 3drop true ELSE rot tuck + within THEN
462: ;
463:
464: : parse-2int ( str len -- val.lo val.hi )
465: \ ." parse-2int ( " 2dup swap . . ." -- "
466: [char] , split ?dup IF eval ELSE drop 0 THEN
467: -rot ?dup IF eval ELSE drop 0 THEN
468: \ 2dup swap . . ." )" cr
469: ;
470:
471: \ peek/poke minimal implementation, just to support FCode drivers
472: \ Any implmentation with full error detection will be platform specific
473: : cpeek ( addr -- false | byte true ) c@ true ;
474: : cpoke ( byte addr -- success? ) c! true ;
475: : wpeek ( addr -- false | word true ) w@ true ;
476: : wpoke ( word addr -- success? ) w! true ;
477: : lpeek ( addr -- false | lword true ) l@ true ;
478: : lpoke ( lword addr -- success? ) l! true ;
479:
480: defer reboot ( -- )
481: defer halt ( -- )
482: defer disable-watchdog ( -- )
483: defer reset-watchdog ( -- )
484: defer set-watchdog ( +n -- )
485: defer set-led ( type instance state -- status )
486: defer get-flashside ( -- side )
487: defer set-flashside ( side -- status )
488: defer read-bootlist ( -- )
489: defer furnish-boot-file ( -- adr len )
490: defer set-boot-file ( adr len -- )
491: defer mfg-mode? ( -- flag )
492: defer of-prompt? ( -- flag )
493: defer debug-boot? ( -- flag )
494: defer bmc-version ( -- adr len )
495: defer cursor-on ( -- )
496: defer cursor-off ( -- )
497:
498: : nop-reboot ( -- ) ." reboot not available" abort ;
499: : nop-halt ( -- ) ." halt not available" abort ;
500: : nop-disable-watchdog ( -- ) ;
501: : nop-reset-watchdog ( -- ) ;
502: : nop-set-watchdog ( +n -- ) drop ;
503: : nop-set-led ( type instance state -- status ) drop drop drop ;
504: : nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
505: : nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
506: : nop-read-bootlist ( -- ) ;
507: : nop-furnish-bootfile ( -- adr len ) s" net:" ;
508: : nop-set-boot-file ( adr len -- ) 2drop ;
509: : nop-mfg-mode? ( -- flag ) false ;
510: : nop-of-prompt? ( -- flag ) false ;
511: : nop-debug-boot? ( -- flag ) false ;
512: : nop-bmc-version ( -- adr len ) s" XXXXX" ;
513: : nop-cursor-on ( -- ) ;
514: : nop-cursor-off ( -- ) ;
515:
516: ' nop-reboot to reboot
517: ' nop-halt to halt
518: ' nop-disable-watchdog to disable-watchdog
519: ' nop-reset-watchdog to reset-watchdog
520: ' nop-set-watchdog to set-watchdog
521: ' nop-set-led to set-led
522: ' nop-get-flashside to get-flashside
523: ' nop-set-flashside to set-flashside
524: ' nop-read-bootlist to read-bootlist
525: ' nop-furnish-bootfile to furnish-boot-file
526: ' nop-set-boot-file to set-boot-file
527: ' nop-mfg-mode? to mfg-mode?
528: ' nop-of-prompt? to of-prompt?
529: ' nop-debug-boot? to debug-boot?
530: ' nop-bmc-version to bmc-version
531: ' nop-cursor-on to cursor-on
532: ' nop-cursor-off to cursor-off
533:
534: : reset-all reboot ;
535:
536: \ Load base
537: 10000000 value load-base
538: 2000000 value flash-load-base
539:
540: \ provide first level debug support
541: #include "debug.fs"
542: \ provide 7.5.3.1 Dictionary search
543: #include "dictionary.fs"
544: \ block data access for IO devices - ought to be implemented in engine
545: #include "rmove.fs"
546: \ provide a simple run time preprocessor
547: #include <preprocessor.fs>
548:
549: : $dnumber base @ >r decimal $number r> base ! ;
550: : (.d) base @ >r decimal (.) r> base ! ;
551:
552: \ IP address conversion
553:
554: : (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
555: base @ >r decimal
556: over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
557: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
558: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
559: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
560: $number IF false r> base ! EXIT THEN
561: true r> base !
562: ;
563:
564: : (ipformat) ( n1 n2 n3 n4 -- str len )
565: base @ >r decimal
566: 0 <# # # # [char] . hold drop # # # [char] . hold
567: drop # # # [char] . hold drop # # #s #>
568: r> base !
569: ;
570:
571: : ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ;
572:
573:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.