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