1: \ KERNAL.FS ANS figFORTH kernal 17dec92py
2: \ $ID:
3: \ Idea and implementation: Bernd Paysan (py)
4: \ Copyright 1992 by the ANSI figForth Development Group
5:
6: \ Log: ', '- usw. durch [char] ... ersetzt
7: \ man sollte die unterschiedlichen zahlensysteme
8: \ mit $ und & zumindest im interpreter weglassen
9: \ schon erledigt!
10: \ 11may93jaw
11: \ name> 0= nicht vorhanden 17may93jaw
12: \ nfa can be lfa or nfa!
13: \ find splited into find and (find)
14: \ (find) for later use 17may93jaw
15: \ search replaced by lookup because
16: \ it is a word of the string wordset
17: \ 20may93jaw
18: \ postpone added immediate 21may93jaw
19: \ to added immediate 07jun93jaw
20: \ cfa, header put "here lastcfa !" in
21: \ cfa, this is more logical
22: \ and noname: works wothout
23: \ extra "here lastcfa !" 08jun93jaw
24: \ (parse-white) thrown out
25: \ refill added outer trick
26: \ to show there is something
27: \ going on 09jun93jaw
28: \ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw
29: \ leave ?leave unloop thrown out
30: \ unloop after loop is used 10jun93jaw
31:
32: HEX
33:
34: \ Bit string manipulation 06oct92py
35:
36: Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
37: DOES> ( n -- ) + c@ ;
38:
39: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
40: : +bit ( addr n -- ) >bit over c@ or swap c! ;
41:
42: : relinfo ( -- addr ) forthstart dup @ + ;
43: : >rel ( addr -- n ) forthstart - ;
44: : relon ( addr -- ) relinfo swap >rel cell / +bit ;
45:
46: \ here allot , c, A, 17dec92py
47:
48: : dp ( -- addr ) dpp @ ;
49: : here ( -- here ) dp @ ;
50: : allot ( n -- ) dp +! ;
51: : c, ( c -- ) here 1 chars allot c! ;
52: : , ( x -- ) here cell allot ! ;
53: : 2, ( w1 w2 -- ) \ general
54: here 2 cells allot 2! ;
55:
56: : aligned ( addr -- addr' )
57: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
58: : align ( -- ) here dup aligned swap ?DO bl c, LOOP ;
59:
60: : faligned ( addr -- f-addr )
61: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
62:
63: : falign ( -- )
64: here dup faligned swap
65: ?DO
66: bl c,
67: LOOP ;
68:
69:
70:
71: : A! ( addr1 addr2 -- ) dup relon ! ;
72: : A, ( addr -- ) here cell allot A! ;
73:
74: \ on off 23feb93py
75:
76: : on ( addr -- ) true swap ! ;
77: : off ( addr -- ) false swap ! ;
78:
79: \ name> found 17dec92py
80:
81: : (name>) ( nfa -- cfa ) count $1F and + aligned ;
82: : name> ( nfa -- cfa )
83: dup (name>) swap c@ $80 and 0= IF @ THEN ;
84:
85: : found ( nfa -- cfa n ) cell+
86: dup c@ >r (name>) r@ $80 and 0= IF @ THEN
87: \ -1 r@ $40 and IF 1- THEN
88: -1 r> $20 and IF negate THEN ;
89:
90: \ (find) 17dec92py
91:
92: \ : (find) ( addr count nfa1 -- nfa2 / false )
93: \ BEGIN dup WHILE dup >r
94: \ cell+ count $1F and dup >r 2over r> =
95: \ IF -text 0= IF 2drop r> EXIT THEN
96: \ ELSE 2drop drop THEN r> @
97: \ REPEAT nip nip ;
98:
99: \ place bounds 13feb93py
100:
101: : place ( addr len to -- ) over >r rot over 1+ r> move c! ;
102: : bounds ( beg count -- end beg ) over + swap ;
103:
104: \ input stream primitives 23feb93py
105:
106: : tib >tib @ ;
107: Defer source
108: : (source) ( -- addr count ) tib #tib @ ;
109: ' (source) IS source
110:
111: \ (word) 22feb93py
112:
113: : scan ( addr1 n1 char -- addr2 n2 ) >r
114: BEGIN dup WHILE over c@ r@ <> WHILE 1 /string
115: REPEAT THEN rdrop ;
116: : skip ( addr1 n1 char -- addr2 n2 ) >r
117: BEGIN dup WHILE over c@ r@ = WHILE 1 /string
118: REPEAT THEN rdrop ;
119:
120: : (word) ( addr1 n1 char -- addr2 n2 )
121: dup >r skip 2dup r> scan nip - ;
122:
123: \ (word) should fold white spaces
124: \ this is what (parse-white) does
125:
126: \ word parse 23feb93py
127:
128: : parse-word ( char -- addr len )
129: source 2dup >r >r >in @ /string
130: rot dup bl = IF drop (parse-white) ELSE (word) THEN
131: 2dup + r> - 1+ r> min >in ! ;
132: : word ( char -- addr )
133: parse-word here place bl here count + c! here ;
134:
135: : parse ( char -- addr len )
136: >r source >in @ /string over swap r> scan >r
137: over - dup r> IF 1+ THEN >in +! ;
138:
139: \ name 13feb93py
140:
141: : capitalize ( addr -- addr )
142: dup count chars bounds
143: ?DO I c@ toupper I c! 1 chars +LOOP ;
144: : (name) ( -- addr ) bl word ;
145: : (cname) ( -- addr ) bl word capitalize ;
146:
147: \ Literal 17dec92py
148:
149: : Literal ( n -- ) state @ IF postpone lit , THEN ;
150: immediate
151: : ALiteral ( n -- ) state @ IF postpone lit A, THEN ;
152: immediate
153:
154: : char ( 'char' -- n ) bl word char+ c@ ;
155: : [char] ( 'char' -- n ) char postpone Literal ; immediate
156: ' [char] Alias Ascii immediate
157:
158: : (compile) ( -- ) r> dup cell+ >r @ A, ;
159: : postpone ( "name" -- )
160: name find dup 0= abort" Can't compile "
161: 0> IF A, ELSE postpone (compile) A, THEN ;
162: immediate restrict
163:
164: \ Use (compile) for the old behavior of compile!
165:
166: \ digit? 17dec92py
167:
168: : digit? ( char -- digit true/ false )
169: base @ $100 =
170: IF
171: true EXIT
172: THEN
173: toupper [char] 0 - dup 9 u> IF
174: [ 'A '9 1 + - ] literal -
175: dup 9 u<= IF
176: drop false EXIT
177: THEN
178: THEN
179: dup base @ u>= IF
180: drop false EXIT
181: THEN
182: true ;
183:
184: : accumulate ( +d0 addr digit - +d1 addr )
185: swap >r swap base @ um* drop rot base @ um* d+ r> ;
186: : >number ( d addr count -- d addr count )
187: 0 ?DO count digit? WHILE accumulate LOOP 0
188: ELSE 1- I' I - UNLOOP THEN ;
189:
190: \ number? number 23feb93py
191:
192: Create bases 10 , 2 , A , 100 ,
193: \ 16 2 10 Zeichen
194: \ !! this saving and restoring base is an abomination! - anton
195: : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u<
196: IF cells bases + @ base ! 1 /string ELSE drop THEN ;
197: : number? ( string -- string 0 / n -1 ) base @ >r
198: dup count over c@ [char] - = dup >r IF 1 /string THEN
199: getbase dpl on 0 0 2swap
200: BEGIN dup >r >number dup WHILE dup r> - WHILE
201: dup dpl ! over c@ [char] . = WHILE
202: 1 /string
203: REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN
204: 2drop rot drop rdrop r> IF dnegate THEN
205: dpl @ dup 0< IF nip THEN r> base ! ;
206: : s>d ( n -- d ) dup 0< ;
207: : number ( string -- d )
208: number? ?dup 0= abort" ?" 0< IF s>d THEN ;
209:
210: \ space spaces ud/mod 21mar93py
211: decimal
212: Create spaces bl 80 times \ times from target compiler! 11may93jaw
213: DOES> ( u -- ) swap
214: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
215: hex
216: : space 1 spaces ;
217:
218: : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
219: um/mod r> ;
220:
221: : pad ( -- addr )
222: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
223:
224: \ hold <# #> sign # #s 25jan92py
225:
226: : hold ( char -- ) pad cell - -1 chars over +! @ c! ;
227:
228: : <# pad cell - dup ! ;
229:
230: : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ;
231:
232: : sign ( n -- ) 0< IF [char] - hold THEN ;
233:
234: : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over <
235: IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ;
236:
237: : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
238:
239: \ print numbers 07jun92py
240:
241: : d.r >r tuck dabs <# #s rot sign #>
242: r> over - spaces type ;
243:
244: : ud.r >r <# #s #> r> over - spaces type ;
245:
246: : .r >r s>d r> d.r ;
247: : u.r 0 swap ud.r ;
248:
249: : d. 0 d.r space ;
250: : ud. 0 ud.r space ;
251:
252: : . s>d d. ;
253: : u. 0 ud. ;
254:
255: \ catch throw 23feb93py
256: \ bounce 08jun93jaw
257:
258: \ !! allow the user to add rollback actions anton
259: \ !! use a separate exception stack? anton
260:
261: : lp@ ( -- addr )
262: laddr# [ 0 , ] ;
263:
264: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
265: >r sp@ r> swap >r \ don't count xt! jaw
266: fp@ >r
267: lp@ >r
268: handler @ >r
269: rp@ handler !
270: execute
271: r> handler ! rdrop rdrop rdrop 0 ;
272:
273: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
274: ?DUP IF
275: handler @ rp!
276: r> handler !
277: r> lp!
278: r> fp!
279: r> swap >r sp! r>
280: THEN ;
281:
282: \ Bouncing is very fine,
283: \ programming without wasting time... jaw
284: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
285: \ a throw without data or fp stack restauration
286: ?DUP IF
287: handler @ rp!
288: r> handler !
289: r> lp!
290: rdrop
291: rdrop
292: THEN ;
293:
294: \ ?stack 23feb93py
295:
296: : ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ;
297: \ ?stack should be code -- it touches an empty stack!
298:
299: \ interpret 10mar92py
300:
301: Defer parser
302: Defer name ' (name) IS name
303: Defer notfound
304:
305: : no.extensions ( string -- ) IF &-13 bounce THEN ;
306:
307: ' no.extensions IS notfound
308:
309: : interpret
310: BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;
311:
312: \ interpreter compiler 30apr92py
313:
314: : interpreter ( name -- ) find ?dup
315: IF 1 and IF execute EXIT THEN -&14 throw THEN
316: number? 0= IF notfound THEN ;
317:
318: ' interpreter IS parser
319:
320: : compiler ( name -- ) find ?dup
321: IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
322: IF 0> IF swap postpone Literal THEN postpone Literal
323: ELSE drop notfound THEN ;
324:
325: : [ ['] interpreter IS parser state off ; immediate
326: : ] ['] compiler IS parser state on ;
327:
328: \ locals stuff needed for control structures
329:
330: variable locals-size \ this is the current size of the locals stack
331: \ frame of the current word
332:
333: : compile-lp+! ( n -- )
334: dup negate locals-size +!
335: 0 over = if
336: else -4 over = if postpone -4lp+!
337: else 8 over = if postpone 8lp+!
338: else 16 over = if postpone 16lp+!
339: else postpone lp+!# dup ,
340: then then then then drop ;
341:
342: : adjust-locals-size ( n -- )
343: \ sets locals-size to n and generates an appropriate lp+!
344: locals-size @ swap - compile-lp+! ;
345:
346:
347: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
348: AConstant locals-list \ acts like a variable that contains
349: \ a linear list of locals names
350:
351:
352: variable dead-code \ true if normal code at "here" would be dead
353:
354: : unreachable ( -- )
355: \ declares the current point of execution as unreachable
356: dead-code on ;
357:
358: \ locals list operations
359:
360: : common-list ( list1 list2 -- list3 )
361: \ list1 and list2 are lists, where the heads are at higher addresses than
362: \ the tail. list3 is the largest sublist of both lists.
363: begin
364: 2dup u<>
365: while
366: 2dup u>
367: if
368: swap
369: then
370: @
371: repeat
372: drop ;
373:
374: : sub-list? ( list1 list2 -- f )
375: \ true iff list1 is a sublist of list2
376: begin
377: 2dup u<
378: while
379: @
380: repeat
381: = ;
382:
383: : list-size ( list -- u )
384: \ size of the locals frame represented by list
385: 0 ( list n )
386: begin
387: over 0<>
388: while
389: over
390: cell+ name> >body @ max
391: swap @ swap ( get next )
392: repeat
393: faligned nip ;
394:
395: : set-locals-size-list ( list -- )
396: dup locals-list !
397: list-size locals-size ! ;
398:
399: : check-begin ( list -- )
400: \ warn if list is not a sublist of locals-list
401: locals-list @ sub-list? 0= if
402: \ !! print current position
403: ." compiler was overly optimistic about locals at a BEGIN" cr
404: \ !! print assumption and reality
405: then ;
406:
407: \ Control Flow Stack
408: \ orig, etc. have the following structure:
409: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
410: \ address (of the branch or the instruction to be branched to) (second)
411: \ locals-list (valid at address) (third)
412:
413: \ types
414: 0 constant defstart
415: 1 constant live-orig
416: 2 constant dead-orig
417: 3 constant dest \ the loopback branch is always assumed live
418: 4 constant do-dest
419: 5 constant scopestart
420:
421: : def? ( n -- )
422: defstart <> abort" unstructured " ;
423:
424: : orig? ( n -- )
425: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
426:
427: : dest? ( n -- )
428: dest <> abort" expected dest " ;
429:
430: : do-dest? ( n -- )
431: do-dest <> abort" expected do-dest " ;
432:
433: : scope? ( n -- )
434: scopestart <> abort" expected scope " ;
435:
436: : non-orig? ( n -- )
437: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
438:
439: : cs-item? ( n -- )
440: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
441:
442: 3 constant cs-item-size
443:
444: : CS-PICK ( ... u -- ... destu )
445: 1+ cs-item-size * 1- >r
446: r@ pick r@ pick r@ pick
447: rdrop
448: dup non-orig? ;
449:
450: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )
451: 1+ cs-item-size * 1- >r
452: r@ roll r@ roll r@ roll
453: rdrop
454: dup cs-item? ;
455:
456: : cs-push-part ( -- list addr )
457: locals-list @ here ;
458:
459: : cs-push-orig ( -- orig )
460: cs-push-part dead-code @
461: if
462: dead-orig
463: else
464: live-orig
465: then ;
466:
467: \ Structural Conditionals 12dec92py
468:
469: : ?struc ( flag -- ) abort" unstructured " ;
470: : sys? ( sys -- ) dup 0= ?struc ;
471: : >mark ( -- orig )
472: cs-push-orig 0 , ;
473: : >resolve ( addr -- ) here over - swap ! ;
474: : <resolve ( addr -- ) here - , ;
475:
476: : BUT 1 cs-roll ; immediate restrict
477: : YET 0 cs-pick ; immediate restrict
478:
479: \ Structural Conditionals 12dec92py
480:
481: : AHEAD ( -- orig )
482: POSTPONE branch >mark unreachable ; immediate restrict
483:
484: : IF ( -- orig )
485: POSTPONE ?branch >mark ; immediate restrict
486:
487: : ?DUP-IF \ general
488: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
489: \ better handled by tools like stack checkers
490: POSTPONE ?dup POSTPONE if ; immediate restrict
491: : ?DUP-NOT-IF \ general
492: POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
493:
494: : THEN ( orig -- )
495: dup orig?
496: dead-code @
497: if
498: dead-orig =
499: if
500: >resolve drop
501: else
502: >resolve set-locals-size-list dead-code off
503: then
504: else
505: dead-orig =
506: if
507: >resolve drop
508: else \ both live
509: over list-size adjust-locals-size
510: >resolve
511: locals-list @ common-list dup list-size adjust-locals-size
512: locals-list !
513: then
514: then ; immediate restrict
515:
516: ' THEN alias ENDIF immediate restrict \ general
517: \ Same as "THEN". This is what you use if your program will be seen by
518: \ people who have not been brought up with Forth (or who have been
519: \ brought up with fig-Forth).
520:
521: : ELSE ( orig1 -- orig2 )
522: POSTPONE ahead
523: 1 cs-roll
524: POSTPONE then ; immediate restrict
525:
526:
527: : BEGIN ( -- dest )
528: dead-code @ if
529: \ set up an assumption of the locals visible here
530: \ currently we just take the top cs-item
531: \ it would be more intelligent to take the top orig
532: \ but that can be arranged by the user
533: dup defstart <> if
534: dup cs-item?
535: 2 pick
536: else
537: 0
538: then
539: set-locals-size-list
540: then
541: cs-push-part dest
542: dead-code off ; immediate restrict
543:
544: \ AGAIN (the current control flow joins another, earlier one):
545: \ If the dest-locals-list is not a subset of the current locals-list,
546: \ issue a warning (see below). The following code is generated:
547: \ lp+!# (current-local-size - dest-locals-size)
548: \ branch <begin>
549: : AGAIN ( dest -- )
550: dest?
551: over list-size adjust-locals-size
552: POSTPONE branch
553: <resolve
554: check-begin
555: unreachable ; immediate restrict
556:
557: \ UNTIL (the current control flow may join an earlier one or continue):
558: \ Similar to AGAIN. The new locals-list and locals-size are the current
559: \ ones. The following code is generated:
560: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
561: : until-like ( list addr xt1 xt2 -- )
562: \ list and addr are a fragment of a cs-item
563: \ xt1 is the conditional branch without lp adjustment, xt2 is with
564: >r >r
565: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
566: r> drop r> compile,
567: swap <resolve ( list adjustment ) ,
568: else ( list dest-addr adjustment )
569: drop
570: r> compile, <resolve
571: r> drop
572: then ( list )
573: check-begin ;
574:
575: : UNTIL ( dest -- )
576: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
577:
578: : WHILE ( dest -- orig dest )
579: POSTPONE if
580: 1 cs-roll ; immediate restrict
581:
582: : REPEAT ( orig dest -- )
583: POSTPONE again
584: POSTPONE then ; immediate restrict
585:
586:
587: \ counted loops
588:
589: \ leave poses a little problem here
590: \ we have to store more than just the address of the branch, so the
591: \ traditional linked list approach is no longer viable.
592: \ This is solved by storing the information about the leavings in a
593: \ special stack. The leavings of different DO-LOOPs are separated
594: \ by a 0 entry
595:
596: \ !! remove the fixed size limit. 'Tis not hard.
597: 20 constant leave-stack-size
598: create leave-stack 60 cells allot
599: Avariable leave-sp leave-stack leave-sp !
600:
601: : clear-leave-stack ( -- )
602: leave-stack leave-sp ! ;
603:
604: \ : leave-empty? ( -- f )
605: \ leave-sp @ leave-stack = ;
606:
607: : >leave ( orig -- )
608: \ push on leave-stack
609: leave-sp @
610: dup [ leave-stack 60 cells + ] Aliteral
611: >= abort" leave-stack full"
612: tuck ! cell+
613: tuck ! cell+
614: tuck ! cell+
615: leave-sp ! ;
616:
617: : leave> ( -- orig )
618: \ pop from leave-stack
619: leave-sp @
620: dup leave-stack <= abort" leave-stack empty"
621: cell - dup @ swap
622: cell - dup @ swap
623: cell - dup @ swap
624: leave-sp ! ;
625:
626: : done ( -- )
627: \ !! the original done had ( addr -- )
628: begin
629: leave>
630: dup
631: while
632: POSTPONE then
633: repeat
634: 2drop drop ; immediate
635:
636: : LEAVE ( -- )
637: POSTPONE ahead
638: >leave ; immediate
639:
640: : ?LEAVE ( -- )
641: POSTPONE 0= POSTPONE if
642: >leave ; immediate
643:
644: : DO ( -- do-sys )
645: POSTPONE (do)
646: POSTPONE begin drop do-dest
647: 0 0 0 >leave ; immediate
648:
649: : ?DO ( -- do-sys )
650: 0 0 0 >leave
651: POSTPONE (?do)
652: >mark >leave
653: POSTPONE begin drop do-dest ; immediate
654:
655: : FOR ( -- do-sys )
656: POSTPONE (for)
657: POSTPONE begin drop do-dest
658: 0 0 0 >leave ; immediate
659:
660: \ LOOP etc. are just like UNTIL
661:
662: : loop-like ( do-sys xt1 xt2 -- )
663: rot do-dest?
664: until-like POSTPONE done POSTPONE unloop ;
665:
666: : LOOP ( do-sys -- )
667: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate
668:
669: : +LOOP ( do-sys -- )
670: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate
671:
672: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
673: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
674: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
675: \ negative increments.
676: : S+LOOP ( do-sys -- )
677: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate
678:
679: : NEXT ( do-sys -- )
680: ['] (next) ['] (next)-lp+!# loop-like ; immediate
681:
682: \ Structural Conditionals 12dec92py
683:
684: : EXIT ( -- )
685: 0 adjust-locals-size
686: POSTPONE ;s
687: unreachable ; immediate restrict
688:
689: : ?EXIT ( -- )
690: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
691:
692: \ Strings 22feb93py
693:
694: : ," ( "string"<"> -- ) [char] " parse
695: here over char+ allot place align ;
696: : "lit ( -- addr )
697: r> r> dup count + aligned >r swap >r ; restrict
698: : (.") "lit count type ; restrict
699: : (S") "lit count ; restrict
700: : SLiteral postpone (S") here over char+ allot place align ;
701: immediate restrict
702: : S" [char] " parse state @ IF postpone SLiteral THEN ;
703: immediate
704: : ." state @ IF postpone (.") ," align
705: ELSE [char] " parse type THEN ; immediate
706: : ( [char] ) parse 2drop ; immediate
707: : \ source >in ! drop ; immediate
708:
709: \ error handling 22feb93py
710: \ 'abort thrown out! 11may93jaw
711:
712: : (abort") "lit >r IF r> "error ! -2 throw THEN
713: rdrop ;
714: : abort" postpone (abort") ," ; immediate restrict
715:
716: \ Header states 23feb93py
717:
718: : flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ;
719: : immediate $20 flag! ;
720: \ : restrict $40 flag! ;
721: ' noop alias restrict
722:
723: \ Header 23feb93py
724:
725: \ input-stream, nextname and noname are quite ugly (passing
726: \ information through global variables), but they are useful for dealing
727: \ with existing/independent defining words
728:
729: defer header
730:
731: : name, ( "name" -- )
732: name c@ 1+ chars allot align ;
733: : input-stream-header ( "name" -- )
734: \ !! this is f83-implementation-dependent
735: align here last ! -1 A,
736: name, $80 flag! ;
737:
738: : input-stream ( -- ) \ general
739: \ switches back to getting the name from the input stream ;
740: ['] input-stream-header IS header ;
741:
742: ' input-stream-header IS header
743:
744: \ !! make that a 2variable
745: create nextname-buffer 32 chars allot
746:
747: : nextname-header ( -- )
748: \ !! f83-implementation-dependent
749: nextname-buffer count
750: align here last ! -1 A,
751: dup c, here swap chars dup allot move align
752: $80 flag!
753: input-stream ;
754:
755: \ the next name is given in the string
756: : nextname ( c-addr u -- ) \ general
757: dup 31 u> -19 and throw ( is name too long? )
758: nextname-buffer c! ( c-addr )
759: nextname-buffer count move
760: ['] nextname-header IS header ;
761:
762: : noname-header ( -- )
763: 0 last !
764: input-stream ;
765:
766: : noname ( -- ) \ general
767: \ the next defined word remains anonymous. The xt of that word is given by lastxt
768: ['] noname-header IS header ;
769:
770: : lastxt ( -- xt ) \ general
771: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
772: lastcfa @ ;
773:
774: : Alias ( cfa "name" -- )
775: Header reveal , $80 flag! ;
776:
777: : name>string ( nfa -- addr count )
778: cell+ count $1F and ;
779:
780: Create ??? ," ???"
781: : >name ( cfa -- nfa )
782: $21 cell do
783: dup i - count $9F and + aligned over $80 + = if
784: i - cell - unloop exit
785: then
786: cell +loop
787: drop ??? ( wouldn't 0 be better? ) ;
788:
789: \ indirect threading 17mar93py
790:
791: : cfa, ( code-address -- )
792: here lastcfa !
793: here 0 A, 0 , code-address! ;
794: : compile, ( xt -- ) A, ;
795: : !does ( addr -- ) lastcfa @ does-code! ;
796: : (;code) ( R: addr -- ) r> /does-handler + !does ;
797: : dodoes, ( -- )
798: here /does-handler allot does-handler! ;
799:
800: \ direct threading is implementation dependent
801:
802: : Create Header reveal [ :dovar ] Literal cfa, ;
803:
804: \ DOES> 17mar93py
805:
806: : DOES> ( compilation: -- )
807: state @
808: IF
809: ;-hook postpone (;code) dodoes,
810: ELSE
811: dodoes, here !does 0 ]
812: THEN
813: :-hook ; immediate
814:
815: \ Create Variable User Constant 17mar93py
816:
817: : Variable Create 0 , ;
818: : AVariable Create 0 A, ;
819: : 2VARIABLE ( "name" -- ) \ double
820: create 0 , 0 , ;
821:
822: : User Variable ;
823: : AUser AVariable ;
824:
825: : (Constant) Header reveal [ :docon ] Literal cfa, ;
826: : Constant (Constant) , ;
827: : AConstant (Constant) A, ;
828:
829: : 2CONSTANT
830: create ( w1 w2 "name" -- )
831: 2,
832: does> ( -- w1 w2 )
833: 2@ ;
834:
835: \ IS Defer What's Defers TO 24feb93py
836:
837: : Defer
838: Create ( -- )
839: ['] noop A,
840: DOES> ( ??? )
841: @ execute ;
842:
843: : IS ( addr "name" -- )
844: ' >body
845: state @
846: IF postpone ALiteral postpone !
847: ELSE !
848: THEN ; immediate
849: ' IS Alias TO immediate
850:
851: : What's ( "name" -- addr ) ' >body
852: state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
853: immediate
854: : Defers ( "name" -- ) ' >body @ compile, ;
855: immediate restrict
856:
857: \ : ; 24feb93py
858:
859: defer :-hook ( sys1 -- sys2 )
860: defer ;-hook ( sys2 -- sys1 )
861:
862: : : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ;
863: : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ;
864: immediate restrict
865:
866: : :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ;
867:
868: \ Search list handling 23feb93py
869:
870: AVariable current
871:
872: : last? ( -- false / nfa nfa ) last @ ?dup ;
873: : (reveal) ( -- )
874: last?
875: IF
876: dup @ 0<
877: IF
878: current @ @ over ! current @ !
879: ELSE
880: drop
881: THEN
882: THEN ;
883:
884: \ object oriented search list 17mar93py
885:
886: \ word list structure:
887: \ struct
888: \ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id )
889: \ 1 cells: field reveal-method \ xt: ( -- )
890: \ 1 cells: field rehash-method \ xt: ( wid -- )
891: \ \ !! what else
892: \ end-struct wordlist-map-struct
893:
894: \ struct
895: \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
896: \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
897: \ 1 cells: field wordlist-link \ link field to other wordlists
898: \ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
899: \ end-struct wordlist-struct
900:
901: : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
902: : f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ;
903:
904: \ Search list table: find reveal
905: Create f83search ' f83casefind A, ' (reveal) A, ' drop A,
906:
907: : caps-name ['] (cname) IS name ['] f83find f83search ! ;
908: : case-name ['] (name) IS name ['] f83casefind f83search ! ;
909: : case-sensitive ['] (name) IS name ['] f83find f83search ! ;
910:
911: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
912: AVariable search G forth-wordlist search T !
913: G forth-wordlist current T !
914:
915: : (search-wordlist) ( addr count wid -- nfa / false )
916: dup ( @ swap ) cell+ @ @ execute ;
917:
918: : search-wordlist ( addr count wid -- 0 / xt +-1 )
919: (search-wordlist) dup IF found THEN ;
920:
921: Variable warnings G -1 warnings T !
922:
923: : check-shadow ( addr count wid -- )
924: \ prints a warning if the string is already present in the wordlist
925: \ !! should be refined so the user can suppress the warnings
926: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
927: ." redefined " name>string 2dup type
928: compare 0<> if
929: ." with " type
930: else
931: 2drop
932: then
933: space space EXIT
934: then
935: 2drop 2drop ;
936:
937: : find ( addr -- cfa +-1 / string false ) dup
938: count search @ search-wordlist dup IF rot drop THEN ;
939:
940: : reveal ( -- )
941: last? if
942: name>string current @ check-shadow
943: then
944: current @ cell+ @ cell+ @ execute ;
945:
946: : rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;
947:
948: : ' ( "name" -- addr ) name find 0= no.extensions ;
949: : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
950: \ Input 13feb93py
951:
952: 07 constant #bell
953: 08 constant #bs
954: 7F constant #del
955: 0D constant #cr \ the newline key code
956: 0A constant #lf
957:
958: : bell #bell emit ;
959:
960: : backspaces 0 ?DO #bs emit LOOP ;
961: : >string ( span addr pos1 -- span addr pos1 addr2 len )
962: over 3 pick 2 pick chars /string ;
963: : type-rest ( span addr pos1 -- span addr pos1 back )
964: >string tuck type ;
965: : (del) ( max span addr pos1 -- max span addr pos2 )
966: 1- >string over 1+ -rot move
967: rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
968: : (ins) ( max span addr pos1 char -- max span addr pos2 )
969: >r >string over 1+ swap move 2dup chars + r> swap c!
970: rot 1+ -rot type-rest 1- backspaces 1+ ;
971: : ?del ( max span addr pos1 -- max span addr pos2 0 )
972: dup IF (del) THEN 0 ;
973: : (ret) type-rest drop true space ;
974: : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
975: : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
976:
977: Create crtlkeys
978: ] false false back false false false forw false
979: ?del false (ret) false false (ret) false false
980: false false false false false false false false
981: false false false false false false false false [
982:
983: : decode ( max span addr pos1 key -- max span addr pos2 flag )
984: dup #del = IF drop #bs THEN \ del is rubout
985: dup bl < IF cells crtlkeys + @ execute EXIT THEN
986: >r 2over = IF rdrop bell 0 EXIT THEN
987: r> (ins) 0 ;
988:
989: \ decode should better use a table for control key actions
990: \ to define keyboard bindings later
991:
992: : accept ( addr len -- len )
993: dup 0< IF abs over dup 1 chars - c@ tuck type
994: \ this allows to edit given strings
995: ELSE 0 THEN rot over
996: BEGIN key decode UNTIL
997: 2drop nip ;
998:
999: \ Output 13feb93py
1000:
1001: DEFER type \ defer type for a output buffer or fast
1002: \ screen write
1003:
1004: : (type) ( addr len -- )
1005: bounds ?DO I c@ emit LOOP ;
1006:
1007: ' (TYPE) IS Type
1008:
1009: \ DEFER Emit
1010:
1011: \ ' (Emit) IS Emit
1012:
1013: \ : form ( -- rows cols ) &24 &80 ;
1014: \ form should be implemented using TERMCAPS or CURSES
1015: \ : rows form drop ;
1016: \ : cols form nip ;
1017:
1018: \ Query 07apr93py
1019:
1020: : refill ( -- flag )
1021: tib /line
1022: loadfile @ ?dup
1023: IF dup file-position throw linestart 2!
1024: read-line throw
1025: ELSE linestart @ IF 2drop false EXIT THEN
1026: accept true
1027: THEN
1028: 1 loadline +!
1029: swap #tib ! >in off ;
1030:
1031: : Query ( -- ) loadfile off refill drop ;
1032:
1033: \ File specifiers 11jun93jaw
1034:
1035:
1036: \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c,
1037: \ 2 c, here char r c, char + c, 0 c,
1038: \ 2 c, here char w c, char + c, 0 c, align
1039: 4 Constant w/o
1040: 2 Constant r/w
1041: 0 Constant r/o
1042:
1043: \ BIN WRITE-LINE 11jun93jaw
1044:
1045: \ : bin dup 1 chars - c@
1046: \ r/o 4 chars + over - dup >r swap move r> ;
1047:
1048: : bin 1+ ;
1049:
1050: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
1051: \ or not unix environments if
1052: \ bin is not selected
1053:
1054: : write-line dup >r write-file ?dup IF r> drop EXIT THEN
1055: nl$ count r> write-file ;
1056:
1057: \ include-file 07apr93py
1058:
1059: : include-file ( i*x fid -- j*x )
1060: linestart @ >r loadline @ >r loadfile @ >r
1061: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
1062:
1063: >tib +! loadfile !
1064: 0 loadline ! blk off
1065: BEGIN refill WHILE interpret REPEAT
1066: loadfile @ close-file throw
1067:
1068: r> >in ! r> #tib ! r> >tib ! r> blk !
1069: r> loadfile ! r> loadline ! r> linestart ! ;
1070:
1071: : included ( i*x addr u -- j*x )
1072: r/o open-file throw include-file ;
1073:
1074: \ HEX DECIMAL 2may93jaw
1075:
1076: : decimal a base ! ;
1077: : hex 10 base ! ;
1078:
1079: \ DEPTH 9may93jaw
1080:
1081: : depth ( -- +n ) sp@ s0 @ swap - cell / ;
1082:
1083: \ INCLUDE 9may93jaw
1084:
1085: : include ( "file" -- )
1086: bl word count included ;
1087:
1088: \ RECURSE 17may93jaw
1089:
1090: : recurse last @ cell+ name> a, ; immediate restrict
1091: \ !! does not work with anonymous words; use lastxt compile,
1092:
1093: \ */MOD */ 17may93jaw
1094:
1095: : */mod >r m* r> sm/rem ;
1096:
1097: : */ */mod nip ;
1098:
1099: \ EVALUATE 17may93jaw
1100:
1101: : evaluate ( c-addr len -- )
1102: linestart @ >r loadline @ >r loadfile @ >r
1103: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
1104:
1105: >tib +! dup #tib ! >tib @ swap move
1106: >in off blk off loadfile off -1 linestart !
1107:
1108: BEGIN interpret >in @ #tib @ u>= UNTIL
1109:
1110: r> >in ! r> #tib ! r> >tib ! r> blk !
1111: r> loadfile ! r> loadline ! r> linestart ! ;
1112:
1113:
1114: : abort -1 throw ;
1115:
1116: \+ environment? true ENV" CORE"
1117: \ core wordset is now complete!
1118:
1119: \ Quit 13feb93py
1120:
1121: Defer 'quit
1122: Defer .status
1123: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
1124: : (quit) BEGIN .status cr query interpret prompt AGAIN ;
1125: ' (quit) IS 'quit
1126:
1127: \ DOERROR (DOERROR) 13jun93jaw
1128:
1129: DEFER DOERROR
1130:
1131: : (DoError) ( throw-code -- )
1132: LoadFile @
1133: IF
1134: ." Error in line: " Loadline @ . cr
1135: THEN
1136: cr source type cr
1137: source drop >in @ -trailing
1138: here c@ 1F min dup >r - 1- 0 max nip
1139: dup spaces
1140: IF
1141: ." ^"
1142: THEN
1143: r> 0 ?DO
1144: ." -"
1145: LOOP
1146: ." ^"
1147: dup -2 =
1148: IF
1149: "error @ ?dup
1150: IF
1151: cr count type
1152: THEN
1153: drop
1154: ELSE
1155: .error
1156: THEN
1157: normal-dp dpp ! ;
1158:
1159: ' (DoError) IS DoError
1160:
1161: : quit r0 @ rp! handler off >tib @ >r
1162: BEGIN
1163: postpone [
1164: ['] 'quit CATCH dup
1165: WHILE
1166: DoError r@ >tib !
1167: REPEAT
1168: drop r> >tib ! ;
1169:
1170: \ Cold 13feb93py
1171:
1172: \ : .name ( name -- ) cell+ count $1F and type space ;
1173: \ : words listwords @
1174: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
1175:
1176: : >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ;
1177: : arg ( n -- addr count ) cells argv @ + @ >len ;
1178: : #! postpone \ ; immediate
1179:
1180: Variable env
1181: Variable argv
1182: Variable argc
1183:
1184: : get-args ( -- ) #tib off
1185: argc @ 1 ?DO I arg 2dup source + swap move
1186: #tib +! drop bl source + c! 1 #tib +! LOOP
1187: >in off #tib @ 0<> #tib +! ;
1188:
1189: : script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ;
1190:
1191: : cold ( -- )
1192: argc @ 1 >
1193: IF script?
1194: IF 1 arg ['] included ELSE get-args ['] interpret THEN
1195: catch ?dup IF dup >r DoError cr r> (bye) THEN THEN
1196: ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
1197:
1198: : boot ( **env **argv argc -- )
1199: argc ! argv ! env ! main-task up!
1200: sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
1201:
1202: : bye cr 0 (bye) ;
1203:
1204: \ **argv may be scanned by the C starter to get some important
1205: \ information, as -display and -geometry for an X client FORTH
1206: \ or space and stackspace overrides
1207:
1208: \ 0 arg contains, however, the name of the program.
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernal.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth