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