![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to bootstrap.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 / openbios / forth / bootstrap|
Return to bootstrap.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / bootstrap |
1.1 root 1: \ tag: bootstrap of basic forth words
2: \
3: \ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
4: \
5: \ See the file "COPYING" for further information about
6: \ the copyright and warranty status of this work.
7: \
8:
9: \
10: \ this file contains almost all forth words described
11: \ by the open firmware user interface. Some more complex
12: \ parts are found in seperate files (memory management,
13: \ vocabulary support)
14: \
15:
16: \
17: \ often used constants (reduces dictionary size)
18: \
19:
20: 1 constant 1
21: 2 constant 2
22: 3 constant 3
23: -1 constant -1
24: 0 constant 0
25:
26: 0 value my-self
27:
28: \
29: \ 7.3.5.1 Numeric-base control
30: \
31:
32: : decimal 10 base ! ;
33: : hex 16 base ! ;
34: : octal 8 base ! ;
35: hex
36:
37: \
38: \ vocabulary words
39: \
40:
41: variable current forth-last current !
42:
43: : last
44: current @
45: ;
46:
47: variable #order 0 #order !
48:
49: defer context
50: 0 value vocabularies?
51:
52: \
53: \ 7.3.7 Flag constants
54: \
55:
56: 1 1 = constant true
57: 0 1 = constant false
58:
59: \
60: \ 7.3.9.2.2 Immediate words (part 1)
61: \
62:
63: : (immediate) ( xt -- )
64: 1 - dup c@ 1 or swap c!
65: ;
66:
67: : (compile-only)
68: 1 - dup c@ 2 or swap c!
69: ;
70:
71: : immediate
72: last @ (immediate)
73: ;
74:
75: : compile-only
76: last @ (compile-only)
77: ;
78:
79: : flags? ( xt -- flags )
80: /n /c + - c@ 7f and
81: ;
82:
83: : immediate? ( xt -- true|false )
84: flags? 1 and 1 =
85: ;
86:
87: : compile-only? ( xt -- true|false )
88: flags? 2 and 2 =
89: ;
90:
91: : [ 0 state ! ; compile-only
92: : ] -1 state ! ;
93:
94:
95:
96: \
97: \ 7.3.9.2.1 Data space allocation
98: \
99:
100: : allot here + here! ;
101: : , here /n allot ! ;
102: : c, here /c allot c! ;
103:
104: : align
105: /n here /n 1 - and - \ how many bytes to next alignment
106: /n 1 - and allot \ mask out everything that is bigger
107: ; \ than cellsize-1
108:
109: : null-align
110: here dup align here swap - 0 fill
111: ;
112:
113: : w,
114: here 1 and allot \ if here is not even, we have to align.
115: here /w allot w!
116: ;
117:
118: : l,
119: /l here /l 1 - and - \ same as in align, with /l
120: /l 1 - and \ if it's /l we are already aligned.
121: allot
122: here /l allot l!
123: ;
124:
125:
126: \
127: \ 7.3.6 comparison operators (part 1)
128: \
129:
130: : <> = invert ;
131:
132:
133: \
134: \ 7.3.9.2.4 Miscellaneous dictionary (part 1)
135: \
136:
137: : (to) ( xt-new xt-defer -- )
138: /n + !
139: ;
140:
141: : >body ( xt -- a-addr ) /n 1 lshift + ;
142: : body> ( a-addr -- xt ) /n 1 lshift - ;
143:
144: : reveal latest @ last ! ;
145: : recursive reveal ; immediate
146: : recurse latest @ /n + , ; immediate
147:
148: : noop ;
149:
150: defer environment?
151: : no-environment?
152: 2drop false
153: ;
154:
155: ['] no-environment? ['] environment? (to)
156:
157:
158: \
159: \ 7.3.8.1 Conditional branches
160: \
161:
162: \ A control stack entry is implemented using 2 data stack items
163: \ of the form ( addr type ). type can be one of the
164: \ following:
165: \ 0 - orig
166: \ 1 - dest
167: \ 2 - do-sys
168:
169: : resolve-orig here nip over /n + - swap ! ;
170: : (if) ['] do?branch , here 0 0 , ; compile-only
171: : (then) resolve-orig ; compile-only
172:
173: variable tmp-comp-depth -1 tmp-comp-depth !
174: variable tmp-comp-buf 0 tmp-comp-buf !
175:
176: : setup-tmp-comp ( -- )
177: state @ 0 = (if)
178: here tmp-comp-buf @ here! , \ save here and switch to tmp directory
179: 1 , \ DOCOL
180: depth tmp-comp-depth ! \ save control depth
181: ]
182: (then)
183: ;
184:
185: : execute-tmp-comp ( -- )
186: depth tmp-comp-depth @ =
187: (if)
188: -1 tmp-comp-depth !
189: ['] (semis) ,
190: tmp-comp-buf @
191: dup @ here!
192: 0 state !
193: /n + execute
194: (then)
195: ;
196:
197: : if setup-tmp-comp ['] do?branch , here 0 0 , ; immediate
198: : then resolve-orig execute-tmp-comp ; compile-only
199: : else ['] dobranch , here 0 0 , 2swap resolve-orig ; compile-only
200:
201: \
202: \ 7.3.8.3 Conditional loops
203: \
204:
205: \ some dummy words for see
206: : (begin) ;
207: : (again) ;
208: : (until) ;
209: : (while) ;
210: : (repeat) ;
211:
212: \ resolve-dest requires a loop...
213: : (resolve-dest) here /n + nip - , ;
214: : (resolve-begin) setup-tmp-comp ['] (begin) , here 1 ; immediate
215: : (resolve-until) ['] (until) , ['] do?branch , (resolve-dest) execute-tmp-comp ; compile-only
216:
217: : resolve-dest ( dest origN ... orig )
218: 2 >r
219: (resolve-begin)
220: \ Find topmost control stack entry with a type of 1 (dest)
221: r> dup dup pick 1 = if
222: \ Move it to the top
223: roll
224: swap 1 - roll
225: \ Resolve it
226: (resolve-dest)
227: 1 \ force exit
228: else
229: drop
230: 2 + >r
231: 0
232: then
233: (resolve-until)
234: ;
235:
236: : begin
237: setup-tmp-comp
238: ['] (begin) ,
239: here
240: 1
241: ; immediate
242:
243: : again
244: ['] (again) ,
245: ['] dobranch ,
246: resolve-dest
247: execute-tmp-comp
248: ; compile-only
249:
250: : until
251: ['] (until) ,
252: ['] do?branch ,
253: resolve-dest
254: execute-tmp-comp
255: ; compile-only
256:
257: : while
258: setup-tmp-comp
259: ['] (while) ,
260: ['] do?branch ,
261: here 0 0 , 2swap
262: ; immediate
263:
264: : repeat
265: ['] (repeat) ,
266: ['] dobranch ,
267: resolve-dest resolve-orig
268: execute-tmp-comp
269: ; compile-only
270:
271:
272: \
273: \ 7.3.8.4 Counted loops
274: \
275:
276: variable leaves 0 leaves !
277:
278: : resolve-loop
279: leaves @
280: begin
281: ?dup
282: while
283: dup @ \ leaves -- leaves *leaves )
284: swap \ -- *leaves leaves )
285: here over - \ -- *leaves leaves here-leaves
286: swap ! \ -- *leaves
287: repeat
288: here nip - ,
289: leaves !
290: ;
291:
292: : do
293: setup-tmp-comp
294: leaves @
295: here 2
296: ['] (do) ,
297: 0 leaves !
298: ; immediate
299:
300: : ?do
301: setup-tmp-comp
302: leaves @
303: ['] (?do) ,
304: here 2
305: here leaves !
306: 0 ,
307: ; immediate
308:
309: : loop
310: ['] (loop) ,
311: resolve-loop
312: execute-tmp-comp
313: ; immediate
314:
315: : +loop
316: ['] (+loop) ,
317: resolve-loop
318: execute-tmp-comp
319: ; immediate
320:
321:
322: \ Using primitive versions of i and j
323: \ speeds up loops by 300%
324: \ : i r> r@ swap >r ;
325: \ : j r> r> r> r@ -rot >r >r swap >r ;
326:
327: : unloop r> r> r> 2drop >r ;
328:
329: : leave
330: ['] unloop ,
331: ['] dobranch ,
332: leaves @
333: here leaves !
334: ,
335: ; immediate
336:
337: : ?leave if leave then ;
338:
339: \
340: \ 7.3.8.2 Case statement
341: \
342:
343: : case
344: setup-tmp-comp
345: 0
346: ; immediate
347:
348: : endcase
349: ['] drop ,
350: 0 ?do
351: ['] then execute
352: loop
353: execute-tmp-comp
354: ; immediate
355:
356: : of
357: 1 + >r
358: ['] over ,
359: ['] = ,
360: ['] if execute
361: ['] drop ,
362: r>
363: ; immediate
364:
365: : endof
366: >r
367: ['] else execute
368: r>
369: ; immediate
370:
371: \
372: \ 7.3.8.5 Other control flow commands
373: \
374:
375: : exit r> drop ;
376:
377:
378: \
379: \ 7.3.4.3 ASCII constants (part 1)
380: \
381:
382: 20 constant bl
383: 07 constant bell
384: 08 constant bs
385: 0d constant carret
386: 0a constant linefeed
387:
388:
389: \
390: \ 7.3.1.1 - stack duplication
391: \
392: : tuck swap over ;
393: : 3dup 2 pick 2 pick 2 pick ;
394:
395: \
396: \ 7.3.1.2 - stack removal
397: \
398: : clear 0 depth! ;
399: : 3drop 2drop drop ;
400:
401: \
402: \ 7.3.1.3 - stack rearrangement
403: \
404:
405: : 2rot >r >r 2swap r> r> 2swap ;
406:
407: \
408: \ 7.3.1.4 - return stack
409: \
410:
411: \ Note: these words are not part of the official OF specification, however
412: \ they are part of the ANSI DPANS94 core extensions (see section 6.2) and
413: \ so this seems an appropriate place for them.
414: : 2>r r> -rot swap >r >r >r ;
415: : 2r> r> r> r> rot >r swap ;
416: : 2r@ r> r> r> 2dup >r >r rot >r swap ;
417:
418: \
419: \ 7.3.2.1 - single precision integer arithmetic (part 1)
420: \
421:
422: : u/mod 0 swap mu/mod drop ;
423: : 1+ 1 + ;
424: : 1- 1 - ;
425: : 2+ 2 + ;
426: : 2- 2 - ;
427: : even 1+ -2 and ;
428: : bounds over + swap ;
429:
430: \
431: \ 7.3.2.2 bitwise logical operators
432: \
433: : << lshift ;
434: : >> rshift ;
435: : 2* 1 lshift ;
436: : u2/ 1 rshift ;
437: : 2/ 1 >>a ;
438: : not invert ;
439:
440: \
441: \ 7.3.2.3 double number arithmetic
442: \
443:
444: : s>d dup 0 < ;
445: : dnegate 0 0 2swap d- ;
446: : dabs dup 0 < if dnegate then ;
447: : um/mod mu/mod drop ;
448:
449: \ symmetric division
450: : sm/rem ( d n -- rem quot )
451: over >r >r dabs r@ abs um/mod r> 0 <
452: if
453: negate
454: then
455: r> 0 < if
456: negate swap negate swap
457: then
458: ;
459:
460: \ floored division
461: : fm/mod ( d n -- rem quot )
462: dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if
463: 1 - swap r> + swap exit
464: then
465: r> drop
466: ;
467:
468: \
469: \ 7.3.2.1 - single precision integer arithmetic (part 2)
470: \
471:
472: : */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod ;
473: : */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
474: : /mod >r s>d r> fm/mod ;
475: : mod /mod drop ;
476: : / /mod nip ;
477:
478:
479: \
480: \ 7.3.2.4 Data type conversion
481: \
482:
483: : lwsplit ( quad -- w.lo w.hi )
484: dup ffff and swap 10 rshift ffff and
485: ;
486:
487: : wbsplit ( word -- b.lo b.hi )
488: dup ff and swap 8 rshift ff and
489: ;
490:
491: : lbsplit ( quad -- b.lo b2 b3 b.hi )
492: lwsplit swap wbsplit rot wbsplit
493: ;
494:
495: : bwjoin ( b.lo b.hi -- word )
496: ff and 8 lshift swap ff and or
497: ;
498:
499: : wljoin ( w.lo w.hi -- quad )
500: ffff and 10 lshift swap ffff and or
501: ;
502:
503: : bljoin ( b.lo b2 b3 b.hi -- quad )
504: bwjoin -rot bwjoin swap wljoin
505: ;
506:
507: : wbflip ( word -- word ) \ flips bytes in a word
508: dup 8 rshift ff and swap ff and bwjoin
509: ;
510:
511: : lwflip ( q1 -- q2 )
512: dup 10 rshift ffff and swap ffff and wljoin
513: ;
514:
515: : lbflip ( q1 -- q2 )
516: dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
517: ;
518:
519: \
520: \ 7.3.2.5 address arithmetic
521: \
522:
523: : /c* /c * ;
524: : /w* /w * ;
525: : /l* /l * ;
526: : /n* /n * ;
527: : ca+ /c* + ;
528: : wa+ /w* + ;
529: : la+ /l* + ;
530: : na+ /n* + ;
531: : ca1+ /c + ;
532: : wa1+ /w + ;
533: : la1+ /l + ;
534: : na1+ /n + ;
535: : aligned /n 1- + /n negate and ;
536: : char+ ca1+ ;
537: : cell+ na1+ ;
538: : chars /c* ;
539: : cells /n* ;
540: /n constant cell
541:
542: \
543: \ 7.3.6 Comparison operators
544: \
545:
546: : <= > not ;
547: : >= < not ;
548: : 0= 0 = ;
549: : 0<= 0 <= ;
550: : 0< 0 < ;
551: : 0<> 0 <> ;
552: : 0> 0 > ;
553: : 0>= 0 >= ;
554: : u<= u> not ;
555: : u>= u< not ;
556: : within >r over > swap r> >= or not ;
557: : between 1 + within ;
558:
559: \
560: \ 7.3.3.1 Memory access
561: \
562:
563: : 2@ dup cell+ @ swap @ ;
564: : 2! dup >r ! r> cell+ ! ;
565:
566: : <w@ w@ dup 8000 >= if 10000 - then ;
567:
568: : comp ( str1 str2 len -- 0|1|-1 )
569: >r 0 -rot r>
570: bounds ?do
571: dup c@ i c@ - dup if
572: < if 1 else -1 then swap leave
573: then
574: drop ca1+
575: loop
576: drop
577: ;
578:
579: \ compare two string
580:
581: : $= ( str1 len1 str2 len2 -- true|false )
582: rot ( str1 str2 len2 len1 )
583: over ( str1 str2 len2 len1 len2 )
584: <> if ( str1 str2 len2 )
585: 3drop
586: false
587: else ( str1 str2 len2 )
588: comp
589: 0=
590: then
591: ;
592:
593: \ : +! tuck @ + swap ! ;
594: : off false swap ! ;
595: : on true swap ! ;
596: : blank bl fill ;
597: : erase 0 fill ;
598: : wbflips ( waddr len -- )
599: bounds do i w@ wbflip i w! /w +loop
600: ;
601:
602: : lwflips ( qaddr len -- )
603: bounds do i l@ lwflip i l! /l +loop
604: ;
605:
606: : lbflips ( qaddr len -- )
607: bounds do i l@ lbflip i l! /l +loop
608: ;
609:
610:
611: \
612: \ 7.3.8.6 Error handling (part 1)
613: \
614:
615: variable catchframe
616: 0 catchframe !
617:
618: : catch
619: my-self >r
620: depth >r
621: catchframe @ >r
622: rdepth catchframe !
623: execute
624: r> catchframe !
625: r> r> 2drop 0
626: ;
627:
628: : throw
629: ?dup if
630: catchframe @ rdepth!
631: r> catchframe !
632: r> swap >r depth!
633: drop r>
634: r> ['] my-self (to)
635: then
636: ;
637:
638: \
639: \ 7.3.3.2 memory allocation
640: \
641:
642: include memory.fs
643:
644:
645: \
646: \ 7.3.4.4 Console output (part 1)
647: \
648:
649: defer emit
650:
651: : type bounds ?do i c@ emit loop ;
652:
653: \ this one obviously only works when called
654: \ with a forth string as count fetches addr-1.
655: \ openfirmware has no such req. therefore it has to go:
656:
657: \ : type 0 do count emit loop drop ;
658:
659:
660: \
661: \ 7.3.4.1 Text Input
662: \
663:
664: 0 value source-id
665: 0 value ib
666: variable #ib 0 #ib !
667: variable >in 0 >in !
668:
669: : source ( -- addr len )
670: ib #ib @
671: ;
672:
673: : /string ( c-addr1 u1 n -- c-addr2 u2 )
674: tuck - -rot + swap
675: ;
676:
677:
678: \
679: \ pockets implementation for 7.3.4.1
680:
681: 100 constant pocketsize
682: 4 constant numpockets
683: variable pockets 0 pockets !
684: variable whichpocket 0 whichpocket !
685:
686: \ allocate 4 pockets to begin with
687: : init-pockets ( -- )
688: pocketsize numpockets * alloc-mem pockets !
689: ;
690:
691: : pocket ( ?? -- ?? )
692: pocketsize whichpocket @ *
693: pockets @ +
694: whichpocket @ 1 + numpockets mod
695: whichpocket !
696: ;
697:
698: \ span variable from 7.3.4.2
699: variable span 0 span !
700:
701: \ if char is bl then any control character is matched
702: : findchar ( str len char -- offs true | false )
703: swap 0 do
704: over i + c@
705: over dup bl = if <= else = then if
706: 2drop i dup dup leave
707: \ i nip nip true exit \ replaces above
708: then
709: loop
710: =
711: \ drop drop false
712: ;
713:
714: : parse ( delim text<delim> -- str len )
715: >r \ save delimiter
716: ib >in @ +
717: span @ >in @ - \ ib+offs len-offset.
718: dup 0 < if \ if we are already at the end of the string, return an empty string
719: + 0 \ move to end of input string
720: r> drop
721: exit
722: then
723: 2dup r> \ ib+offs len-offset ib+offs len-offset delim
724: findchar if \ look for the delimiter.
725: nip dup 1+
726: else
727: dup
728: then
729: >in +!
730: \ dup -1 = if drop 0 then \ workaround for negative length
731: ;
732:
733: : skipws ( -- )
734: ib span @ ( -- ib recvchars )
735: begin
736: dup >in @ > if ( -- recvchars>offs )
737: over >in @ +
738: c@ bl <=
739: else
740: false
741: then
742: while
743: 1 >in +!
744: repeat
745: 2drop
746: ;
747:
748: : parse-word ( < >text< > -- str len )
749: skipws bl parse
750: ;
751:
752: : word ( delim <delims>text<delim> -- pstr )
753: pocket >r parse dup r@ c! bounds r> dup 2swap
754: do
755: char+ i c@ over c!
756: loop
757: drop
758: ;
759:
760: : ( 29 parse 2drop ; immediate
761: : \ span @ >in ! ; immediate
762:
763:
764:
765: \
766: \ 7.3.4.7 String literals
767: \
768:
769: : ",
770: bounds ?do
771: i c@ c,
772: loop
773: ;
774:
775: : (") ( -- addr len )
776: r> dup
777: 2 cells + ( r-addr addr )
778: over cell+ @ ( r-addr addr len )
779: rot over + aligned cell+ >r ( addr len R: r-addr )
780: ;
781:
782: : handle-text ( temp-addr len -- addr len )
783: state @ if
784: ['] (") , dup , ", null-align
785: else
786: pocket swap
787: dup >r
788: 0 ?do
789: over i + c@ over i + c!
790: loop
791: nip r>
792: then
793: ;
794:
795: : s"
796: 22 parse handle-text
797: ; immediate
798:
799:
800:
801: \
802: \ 7.3.4.4 Console output (part 2)
803: \
804:
805: : ."
806: 22 parse handle-text
807: ['] type
808: state @ if
809: ,
810: else
811: execute
812: then
813: ; immediate
814:
815: : .(
816: 29 parse handle-text
817: ['] type
818: state @ if
819: ,
820: else
821: execute
822: then
823: ; immediate
824:
825:
826:
827: \
828: \ 7.3.4.8 String manipulation
829: \
830:
831: : count ( pstr -- str len ) 1+ dup 1- c@ ;
832:
833: : pack ( str len addr -- pstr )
834: 2dup c! \ store len
835: 1+ swap 0 ?do
836: over i + c@ over i + c!
837: loop nip 1-
838: ;
839:
840: : lcc ( char1 -- char2 ) dup 41 5a between if 20 + then ;
841: : upc ( char1 -- char2 ) dup 61 7a between if 20 - then ;
842:
843: : -trailing ( str len1 -- str len2 )
844: begin
845: dup 0<> if \ len != 0 ?
846: 2dup 1- +
847: c@ bl =
848: else
849: false
850: then
851: while
852: 1-
853: repeat
854: ;
855:
856:
857: \
858: \ 7.3.4.5 Output formatting
859: \
860:
861: : cr linefeed emit ;
862: : (cr carret emit ;
863: : space bl emit ;
864: : spaces 0 ?do space loop ;
865: variable #line 0 #line !
866: variable #out 0 #out !
867:
868:
869: \
870: \ 7.3.9.2.3 Dictionary search
871: \
872:
873: \ helper functions
874:
875: : lfa2name ( lfa -- name len )
876: 1- \ skip flag byte
877: begin \ skip 0 padding
878: 1- dup c@ ?dup
879: until
880: 7f and \ clear high bit in length
881:
882: tuck - swap ( ptr-to-len len - name len )
883: ;
884:
885: : comp-nocase ( str1 str2 len -- true|false )
886: 0 do
887: 2dup i + c@ upc ( str1 str2 byteX )
888: swap i + c@ upc ( str1 str2 byte1 byte2 )
889: <> if
890: 0 leave
891: then
892: loop
893: if -1 else drop 0 then
894: swap drop
895: ;
896:
897: : comp-word ( b-str len lfa -- true | false )
898: lfa2name ( str len str len -- )
899: >r swap r> ( str str len len )
900: over = if ( str str len )
901: comp-nocase
902: else
903: drop drop drop false \ if len does not match, string does not match
904: then
905: ;
906:
907: \ $find is an fcode word, but we place it here since we use it for find.
908:
909: : find-wordlist ( name-str name-len last -- xt true | name-str name-len false )
910:
911: @ >r
912:
913: begin
914: 2dup r@ dup if comp-word dup false = then
915: while
916: r> @ >r drop
917: repeat
918:
919: r@ if \ successful?
920: -rot 2drop r> cell+ swap
921: else
922: r> drop drop drop false
923: then
924:
925: ;
926:
927: : $find ( name-str name-len -- xt true | name-str name-len false )
928: vocabularies? if
929: #order @ 0 ?do
930: i cells context + @
931: find-wordlist
932: ?dup if
933: unloop exit
934: then
935: loop
936: false
937: else
938: forth-last find-wordlist
939: then
940: ;
941:
942: \ look up a word in the current wordlist
943: : $find1 ( name-str name-len -- xt true | name-str name-len false )
944: vocabularies? if
945: current @
946: else
947: forth-last
948: then
949: find-wordlist
950: ;
951:
952:
953: : '
954: parse-word $find 0= if
955: type 3a emit -13 throw
956: then
957: ;
958:
959: : [']
960: parse-word $find 0= if
961: type 3a emit -13 throw
962: then
963: state @ if
964: ['] (lit) , ,
965: then
966: ; immediate
967:
968: : find ( pstr -- xt n | pstr false )
969: dup count $find \ pstr xt true | pstr name-str name-len false
970: if
971: nip true
972: over immediate? if
973: negate \ immediate returns 1
974: then
975: else
976: 2drop false
977: then
978: ;
979:
980:
981: \
982: \ 7.3.9.2.2 Immediate words (part 2)
983: \
984:
985: : literal ['] (lit) , , ; immediate
986: : compile, , ; immediate
987: : compile r> cell+ dup @ , >r ;
988: : [compile] ['] ' execute , ; immediate
989:
990: : postpone
991: parse-word $find if
992: dup immediate? not if
993: ['] (lit) , , ['] ,
994: then
995: ,
996: else
997: s" undefined word " type type cr
998: then
999: ; immediate
1000:
1001:
1002: \
1003: \ 7.3.9.2.4 Miscellaneous dictionary (part 2)
1004: \
1005:
1006: variable #instance
1007:
1008: : instance ( -- )
1009: true #instance !
1010: ;
1011:
1012: : #instance-base
1013: my-self dup if @ then
1014: ;
1015:
1016: : #instance-offs
1017: my-self dup if na1+ then
1018: ;
1019:
1020: \ the following instance words are used internally
1021: \ to implement variable instantiation.
1022:
1023: : instance-cfa? ( cfa -- true | false )
1024: b e within \ b,c and d are instance defining words
1025: ;
1026:
1027: : behavior ( xt-defer -- xt )
1028: dup @ instance-cfa? if
1029: #instance-base ?dup if
1030: swap na1+ @ + @
1031: else
1032: 3 /n* + @
1033: then
1034: else
1035: na1+ @
1036: then
1037: ;
1038:
1039: : (ito) ( xt-new xt-defer -- )
1040: #instance-base ?dup if
1041: swap na1+ @ + !
1042: else
1043: 3 /n* + !
1044: then
1045: ;
1046:
1047: : to
1048: ['] ' execute
1049: dup @ instance-cfa?
1050: state @ if
1051: swap ['] (lit) , , if ['] (ito) else ['] (to) then ,
1052: else
1053: if (ito) else /n + ! then
1054: then
1055: ; immediate
1056:
1057: : is ( xt "wordname<>" -- )
1058: parse-word $find if
1059: (to)
1060: else
1061: s" could not find " type type
1062: then
1063: ;
1064:
1065: \
1066: \ 7.3.4.2 Console Input
1067: \
1068:
1069: defer key?
1070: defer key
1071:
1072: : accept ( addr len -- len2 )
1073: tuck 0 do
1074: key
1075: dup linefeed = if
1076: space drop drop drop i 0 leave
1077: then
1078: dup emit over c! 1 +
1079: loop
1080: drop ( cr )
1081: ;
1082:
1083: : expect ( addr len -- )
1084: accept span !
1085: ;
1086:
1087:
1088: \
1089: \ 7.3.4.3 ASCII constants (part 2)
1090: \
1091:
1092: : handle-lit
1093: state @ if
1094: 2 = if
1095: ['] (lit) , ,
1096: then
1097: ['] (lit) , ,
1098: else
1099: drop
1100: then
1101: ;
1102:
1103: : char
1104: parse-word 0<> if c@ else s" Unexpected EOL." type cr then ;
1105: ;
1106:
1107: : ascii char 1 handle-lit ; immediate
1108: : [char] char 1 handle-lit ; immediate
1109:
1110: : control
1111: char bl 1- and 1 handle-lit
1112: ; immediate
1113:
1114:
1115:
1116: \
1117: \ 7.3.8.6 Error handling (part 2)
1118: \
1119:
1120: : abort
1121: -1 throw
1122: ;
1123:
1124: : abort"
1125: ['] if execute
1126: 22 parse handle-text
1127: ['] type ,
1128: ['] (lit) ,
1129: -2 ,
1130: ['] throw ,
1131: ['] then execute
1132: ; compile-only
1133:
1134: \
1135: \ 7.5.3.1 Dictionary search
1136: \
1137:
1138: \ this does not belong here, but its nice for testing
1139:
1140: : words ( -- )
1141: last
1142: begin @
1143: ?dup while
1144: dup lfa2name
1145:
1146: \ Don't print spaces for headerless words
1147: dup if
1148: type space
1149: else
1150: type
1151: then
1152:
1153: repeat
1154: cr
1155: ;
1156:
1157: \
1158: \ 7.3.5.4 Numeric output primitives
1159: \
1160:
1161: false value capital-hex?
1162:
1163: : pad ( -- addr ) here 100 + aligned ;
1164:
1165: : todigit ( num -- ascii )
1166: dup 9 > if
1167: capital-hex? not if
1168: 20 +
1169: then
1170: 7 +
1171: then
1172: 30 +
1173: ;
1174:
1175: : <# pad dup ! ;
1176: : hold pad dup @ 1- tuck swap ! c! ;
1177: : sign
1178: 0< if
1179: 2d hold
1180: then
1181: ;
1182:
1183: : # base @ mu/mod rot todigit hold ;
1184: : #s begin # 2dup or 0= until ;
1185: : #> 2drop pad dup @ tuck - ;
1186: : (.) <# dup >r abs 0 #s r> sign #> ;
1187:
1188: : u# base @ u/mod swap todigit hold ;
1189: : u#s begin u# dup 0= until ;
1190: : u#> 0 #> ;
1191: : (u.) <# u#s u#> ;
1192:
1193: \
1194: \ 7.3.5.3 Numeric output
1195: \
1196:
1197: : . (.) type space ;
1198: : s. . ;
1199: : u. (u.) type space ;
1200: : .r swap (.) rot 2dup < if over - spaces else drop then type ;
1201: : u.r swap (u.) rot 2dup < if over - spaces else drop then type ;
1202: : .d base @ swap decimal . base ! ;
1203: : .h base @ swap hex . base ! ;
1204:
1205: : .s
1206: 3c emit depth dup (.) type 3e emit space
1207: 0
1208: ?do
1209: depth i - 1- pick .
1210: loop
1211: cr
1212: ;
1213:
1214: \
1215: \ 7.3.5.2 Numeric input
1216: \
1217:
1218: : digit ( char base -- n true | char false )
1219: swap dup upc dup
1220: 41 5a ( A - Z ) between if
1221: 7 -
1222: else
1223: dup 39 > if \ protect from : and ;
1224: -rot 2drop false exit
1225: then
1226: then
1227:
1228: 30 ( number 0 ) - rot over swap 0 swap within if
1229: nip true
1230: else
1231: drop false
1232: then
1233: ;
1234:
1235: : >number
1236: begin
1237: dup
1238: while
1239: over c@ base @ digit 0= if
1240: drop exit
1241: then >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap
1242: 1 /string
1243: repeat
1244: ;
1245:
1246: : numdelim?
1247: dup 2e = swap 2c = or
1248: ;
1249:
1250:
1251: : $dnumber?
1252: 0 0 2swap dup 0= if
1253: 2drop 2drop 0 exit
1254: then over c@ 2d = dup >r negate /string begin
1255: >number dup 1 >
1256: while
1257: over c@ numdelim? 0= if
1258: 2drop 2drop r> drop 0 exit
1259: then 1 /string
1260: repeat if
1261: c@ 2e = if
1262: true
1263: else
1264: 2drop r> drop 0 exit
1265: then
1266: else
1267: drop false
1268: then over or if
1269: r> if
1270: dnegate
1271: then 2
1272: else
1273: drop r> if
1274: negate
1275: then 1
1276: then
1277: ;
1278:
1279:
1280: : $number ( )
1281: $dnumber?
1282: case
1283: 0 of true endof
1284: 1 of false endof
1285: 2 of drop false endof
1286: endcase
1287: ;
1288:
1289: : d#
1290: parse-word
1291: base @ >r
1292:
1293: decimal
1294:
1295: $number if
1296: s" illegal number" type cr 0
1297: then
1298: r> base !
1299: 1 handle-lit
1300: ; immediate
1301:
1302: : h#
1303: parse-word
1304: base @ >r
1305:
1306: hex
1307:
1308: $number if
1309: s" illegal number" type cr 0
1310: then
1311: r> base !
1312: 1 handle-lit
1313: ; immediate
1314:
1315: : o#
1316: parse-word
1317: base @ >r
1318:
1319: octal
1320:
1321: $number if
1322: s" illegal number" type cr 0
1323: then
1324: r> base !
1325: 1 handle-lit
1326: ; immediate
1327:
1328:
1329: \
1330: \ 7.3.4.7 String Literals (part 2)
1331: \
1332:
1333: : "
1334: pocket dup
1335: begin
1336: span @ >in @ > if
1337: 22 parse >r ( pocket pocket str R: len )
1338: over r@ move \ copy string
1339: r> + ( pocket nextdest )
1340: ib >in @ + c@ ( pocket nextdest nexchar )
1341: 1 >in +!
1342: 28 = \ is nextchar a parenthesis?
1343: span @ >in @ > \ more input?
1344: and
1345: else
1346: false
1347: then
1348: while
1349: 29 parse \ parse everything up to the next ')'
1350: bounds ?do
1351: i c@ 10 digit if
1352: i 1+ c@ 10 digit if
1353: swap 4 lshift or
1354: else
1355: drop
1356: then
1357: over c! 1+
1358: 2
1359: else
1360: drop 1
1361: then
1362: +loop
1363: repeat
1364: over -
1365: handle-text
1366: ; immediate
1367:
1368:
1369: \
1370: \ 7.3.3.1 Memory Access (part 2)
1371: \
1372:
1373: : dump ( addr len -- )
1374: over + swap
1375: cr
1376: do i u. space
1377: 10 0 do
1378: j i + c@
1379: dup 10 / todigit emit
1380: 10 mod todigit emit
1381: space
1382: i 7 = if space then
1383: loop
1384: 3 spaces
1385: 10 0 do
1386: j i + c@
1387: dup 20 < if drop 2e then \ non-printables as dots?
1388: emit
1389: loop
1390: cr
1391: 10 +loop
1392: ;
1393:
1394:
1395:
1396: \
1397: \ 7.3.9.1 Defining words
1398: \
1399:
1400: : header ( name len -- )
1401: dup if \ might be a noname...
1402: 2dup $find1 if
1403: drop 2dup type s" isn't unique." type cr
1404: else
1405: 2drop
1406: then
1407: then
1408: null-align
1409: dup -rot ", 80 or c, \ write name and len
1410: here /n 1- and 0= if 0 c, then \ pad and space for flags
1411: null-align
1412: 80 here 1- c! \ write flags byte
1413: here last @ , latest ! \ write backlink and set latest
1414: ;
1415:
1416:
1417: : :
1418: parse-word header
1419: 1 , ]
1420: ;
1421:
1422: : :noname
1423: 0 0 header
1424: here
1425: 1 , ]
1426: ;
1427:
1428: : ;
1429: ['] (semis) , reveal ['] [ execute
1430: ; immediate
1431:
1432: : constant
1433: parse-word header
1434: 3 , , \ compile DOCON and value
1435: reveal
1436: ;
1437:
1438: 0 value active-package
1439: : instance, ( size -- )
1440: \ first word of the device node holds the instance size
1441: dup active-package @ dup rot + active-package !
1442: , , \ offset size
1443: ;
1444:
1445: : instance? ( -- flag )
1446: #instance @ dup if
1447: false #instance !
1448: then
1449: ;
1450:
1451: : value
1452: parse-word header
1453: instance? if
1454: /n b , instance, , \ DOIVAL
1455: else
1456: 3 , ,
1457: then
1458: reveal
1459: ;
1460:
1461: : variable
1462: parse-word header
1463: instance? if
1464: /n c , instance, 0 ,
1465: else
1466: 4 , 0 ,
1467: then
1468: reveal
1469: ;
1470:
1471: : $buffer: ( size str len -- where )
1472: header
1473: instance? if
1474: /n over /n 1- and - /n 1- and + \ align buffer size
1475: dup c , instance, \ DOIVAR
1476: else
1477: 4 ,
1478: then
1479: here swap
1480: 2dup 0 fill \ zerofill
1481: allot
1482: reveal
1483: ;
1484:
1485: : buffer: ( size -- )
1486: parse-word $buffer: drop
1487: ;
1488:
1489: : (undefined-defer) ( -- )
1490: \ XXX: this does not work with behavior ... execute
1491: r@ 2 cells - lfa2name
1492: s" undefined defer word " type type cr ;
1493:
1494: : (undefined-idefer) ( -- )
1495: s" undefined idefer word " type cr ;
1496:
1497: : defer ( new-name< > -- )
1498: parse-word header
1499: instance? if
1500: 2 /n* d , instance, \ DOIDEFER
1501: ['] (undefined-idefer)
1502: else
1503: 5 ,
1504: ['] (undefined-defer)
1505: then
1506: ,
1507: ['] (semis) ,
1508: reveal
1509: ;
1510:
1511: : alias ( new-name< >old-name< > -- )
1512: parse-word
1513: parse-word $find if
1514: -rot \ move xt behind.
1515: header
1516: 1 , \ fixme we want our own cfa here.
1517: , \ compile old name xt
1518: ['] (semis) ,
1519: reveal
1520: else
1521: s" undefined word " type type space
1522: 2drop
1523: then
1524: ;
1525:
1526: : $create
1527: header 6 ,
1528: ['] noop ,
1529: reveal
1530: ;
1531:
1532: : create
1533: parse-word $create
1534: ;
1535:
1536: : (does>)
1537: r> cell+ \ get address of code to execute
1538: latest @ \ backlink of just "create"d word
1539: cell+ cell+ ! \ write code to execute after the
1540: \ new word's CFA
1541: ;
1542:
1543: : does>
1544: ['] (does>) , \ compile does handling
1545: 1 , \ compile docol
1546: ; immediate
1547:
1548: 0 constant struct
1549:
1550: : field
1551: create
1552: over ,
1553: +
1554: does>
1555: @ +
1556: ;
1557:
1558: : 2constant
1559: create , ,
1560: does> 2@ reveal
1561: ;
1562:
1563: \
1564: \ initializer for the temporary compile buffer
1565: \
1566:
1567: : init-tmp-comp
1568: here 200 allot tmp-comp-buf !
1569: ;
1570:
1571: \ the end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.