File:
[gforth] /
gforth /
Attic /
kernal.fs
Revision
1.14:
download - view:
text,
annotated -
select for diffs
Fri Aug 19 17:47:23 1994 UTC (28 years, 7 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
Added filling to gforth.el and defined some keys
Minor changes in gforth.texi
renamed ?DUP-NOT-IF to ?DUP-0=-IF
increased default sizes for kernal
renamed ansforth to gforth
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 ) cell+
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: 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: : s>number ( addr len -- d ) base @ >r dpl on
198: over c@ '- = 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 rdrop dpl off ELSE
204: 2drop rdrop r> IF dnegate THEN
205: THEN r> base ! ;
206: : number? ( string -- string 0 / n -1 / d 0> )
207: dup count s>number dpl @ 0= IF 2drop false EXIT THEN
208: rot drop dpl @ dup 0> 0= IF nip THEN ;
209: : s>d ( n -- d ) dup 0< ;
210: : number ( string -- d )
211: number? ?dup 0= abort" ?" 0< IF s>d THEN ;
212:
213: \ space spaces ud/mod 21mar93py
214: decimal
215: Create spaces bl 80 times \ times from target compiler! 11may93jaw
216: DOES> ( u -- ) swap
217: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
218: hex
219: : space 1 spaces ;
220:
221: : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
222: um/mod r> ;
223:
224: : pad ( -- addr )
225: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
226:
227: \ hold <# #> sign # #s 25jan92py
228:
229: : hold ( char -- ) pad cell - -1 chars over +! @ c! ;
230:
231: : <# pad cell - dup ! ;
232:
233: : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ;
234:
235: : sign ( n -- ) 0< IF [char] - hold THEN ;
236:
237: : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over <
238: IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ;
239:
240: : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
241:
242: \ print numbers 07jun92py
243:
244: : d.r >r tuck dabs <# #s rot sign #>
245: r> over - spaces type ;
246:
247: : ud.r >r <# #s #> r> over - spaces type ;
248:
249: : .r >r s>d r> d.r ;
250: : u.r 0 swap ud.r ;
251:
252: : d. 0 d.r space ;
253: : ud. 0 ud.r space ;
254:
255: : . s>d d. ;
256: : u. 0 ud. ;
257:
258: \ catch throw 23feb93py
259: \ bounce 08jun93jaw
260:
261: \ !! allow the user to add rollback actions anton
262: \ !! use a separate exception stack? anton
263:
264: : lp@ ( -- addr )
265: laddr# [ 0 , ] ;
266:
267: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
268: >r sp@ r> swap >r \ don't count xt! jaw
269: fp@ >r
270: lp@ >r
271: handler @ >r
272: rp@ handler !
273: execute
274: r> handler ! rdrop rdrop rdrop 0 ;
275:
276: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
277: ?DUP IF
278: [ here 4 cells ! ]
279: handler @ rp!
280: r> handler !
281: r> lp!
282: r> fp!
283: r> swap >r sp! r>
284: THEN ;
285:
286: \ Bouncing is very fine,
287: \ programming without wasting time... jaw
288: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
289: \ a throw without data or fp stack restauration
290: ?DUP IF
291: handler @ rp!
292: r> handler !
293: r> lp!
294: rdrop
295: rdrop
296: THEN ;
297:
298: \ ?stack 23feb93py
299:
300: : ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ;
301: \ ?stack should be code -- it touches an empty stack!
302:
303: \ interpret 10mar92py
304:
305: Defer parser
306: Defer name ' (name) IS name
307: Defer notfound
308:
309: : no.extensions ( string -- ) IF -&13 bounce THEN ;
310:
311: ' no.extensions IS notfound
312:
313: : interpret
314: BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;
315:
316: \ interpreter compiler 30apr92py
317:
318: : interpreter ( name -- ) find ?dup
319: IF 1 and IF execute EXIT THEN -&14 throw THEN
320: number? 0= IF notfound THEN ;
321:
322: ' interpreter IS parser
323:
324: : compiler ( name -- ) find ?dup
325: IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
326: IF 0> IF swap postpone Literal THEN postpone Literal
327: ELSE drop notfound THEN ;
328:
329: : [ ['] interpreter IS parser state off ; immediate
330: : ] ['] compiler IS parser state on ;
331:
332: \ locals stuff needed for control structures
333:
334: : compile-lp+! ( n -- )
335: dup negate locals-size +!
336: 0 over = if
337: else -4 over = if postpone -4lp+!
338: else 8 over = if postpone 8lp+!
339: else 16 over = if postpone 16lp+!
340: else postpone lp+!# dup ,
341: then then then then drop ;
342:
343: : adjust-locals-size ( n -- )
344: \ sets locals-size to n and generates an appropriate lp+!
345: locals-size @ swap - compile-lp+! ;
346:
347:
348: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
349: AConstant locals-list \ acts like a variable that contains
350: \ a linear list of locals names
351:
352:
353: variable dead-code \ true if normal code at "here" would be dead
354:
355: : unreachable ( -- )
356: \ declares the current point of execution as unreachable
357: dead-code on ;
358:
359: \ locals list operations
360:
361: : common-list ( list1 list2 -- list3 )
362: \ list1 and list2 are lists, where the heads are at higher addresses than
363: \ the tail. list3 is the largest sublist of both lists.
364: begin
365: 2dup u<>
366: while
367: 2dup u>
368: if
369: swap
370: then
371: @
372: repeat
373: drop ;
374:
375: : sub-list? ( list1 list2 -- f )
376: \ true iff list1 is a sublist of list2
377: begin
378: 2dup u<
379: while
380: @
381: repeat
382: = ;
383:
384: : list-size ( list -- u )
385: \ size of the locals frame represented by list
386: 0 ( list n )
387: begin
388: over 0<>
389: while
390: over
391: name> >body @ max
392: swap @ swap ( get next )
393: repeat
394: faligned nip ;
395:
396: : set-locals-size-list ( list -- )
397: dup locals-list !
398: list-size locals-size ! ;
399:
400: : check-begin ( list -- )
401: \ warn if list is not a sublist of locals-list
402: locals-list @ sub-list? 0= if
403: \ !! print current position
404: ." compiler was overly optimistic about locals at a BEGIN" cr
405: \ !! print assumption and reality
406: then ;
407:
408: \ Control Flow Stack
409: \ orig, etc. have the following structure:
410: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
411: \ address (of the branch or the instruction to be branched to) (second)
412: \ locals-list (valid at address) (third)
413:
414: \ types
415: 0 constant defstart
416: 1 constant live-orig
417: 2 constant dead-orig
418: 3 constant dest \ the loopback branch is always assumed live
419: 4 constant do-dest
420: 5 constant scopestart
421:
422: : def? ( n -- )
423: defstart <> abort" unstructured " ;
424:
425: : orig? ( n -- )
426: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
427:
428: : dest? ( n -- )
429: dest <> abort" expected dest " ;
430:
431: : do-dest? ( n -- )
432: do-dest <> abort" expected do-dest " ;
433:
434: : scope? ( n -- )
435: scopestart <> abort" expected scope " ;
436:
437: : non-orig? ( n -- )
438: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
439:
440: : cs-item? ( n -- )
441: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
442:
443: 3 constant cs-item-size
444:
445: : CS-PICK ( ... u -- ... destu )
446: 1+ cs-item-size * 1- >r
447: r@ pick r@ pick r@ pick
448: rdrop
449: dup non-orig? ;
450:
451: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )
452: 1+ cs-item-size * 1- >r
453: r@ roll r@ roll r@ roll
454: rdrop
455: dup cs-item? ;
456:
457: : cs-push-part ( -- list addr )
458: locals-list @ here ;
459:
460: : cs-push-orig ( -- orig )
461: cs-push-part dead-code @
462: if
463: dead-orig
464: else
465: live-orig
466: then ;
467:
468: \ Structural Conditionals 12dec92py
469:
470: : ?struc ( flag -- ) abort" unstructured " ;
471: : sys? ( sys -- ) dup 0= ?struc ;
472: : >mark ( -- orig )
473: cs-push-orig 0 , ;
474: : >resolve ( addr -- ) here over - swap ! ;
475: : <resolve ( addr -- ) here - , ;
476:
477: : BUT 1 cs-roll ; immediate restrict
478: : YET 0 cs-pick ; immediate restrict
479:
480: \ Structural Conditionals 12dec92py
481:
482: : AHEAD ( -- orig )
483: POSTPONE branch >mark unreachable ; immediate restrict
484:
485: : IF ( -- orig )
486: POSTPONE ?branch >mark ; immediate restrict
487:
488: : ?DUP-IF \ general
489: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
490: \ better handled by tools like stack checkers
491: POSTPONE ?dup POSTPONE if ; immediate restrict
492: : ?DUP-0=-IF \ general
493: POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
494:
495: : THEN ( orig -- )
496: dup orig?
497: dead-code @
498: if
499: dead-orig =
500: if
501: >resolve drop
502: else
503: >resolve set-locals-size-list dead-code off
504: then
505: else
506: dead-orig =
507: if
508: >resolve drop
509: else \ both live
510: over list-size adjust-locals-size
511: >resolve
512: locals-list @ common-list dup list-size adjust-locals-size
513: locals-list !
514: then
515: then ; immediate restrict
516:
517: ' THEN alias ENDIF immediate restrict \ general
518: \ Same as "THEN". This is what you use if your program will be seen by
519: \ people who have not been brought up with Forth (or who have been
520: \ brought up with fig-Forth).
521:
522: : ELSE ( orig1 -- orig2 )
523: POSTPONE ahead
524: 1 cs-roll
525: POSTPONE then ; immediate restrict
526:
527:
528: : BEGIN ( -- dest )
529: dead-code @ if
530: \ set up an assumption of the locals visible here
531: \ currently we just take the top cs-item
532: \ it would be more intelligent to take the top orig
533: \ but that can be arranged by the user
534: dup defstart <> if
535: dup cs-item?
536: 2 pick
537: else
538: 0
539: then
540: set-locals-size-list
541: then
542: cs-push-part dest
543: dead-code off ; immediate restrict
544:
545: \ AGAIN (the current control flow joins another, earlier one):
546: \ If the dest-locals-list is not a subset of the current locals-list,
547: \ issue a warning (see below). The following code is generated:
548: \ lp+!# (current-local-size - dest-locals-size)
549: \ branch <begin>
550: : AGAIN ( dest -- )
551: dest?
552: over list-size adjust-locals-size
553: POSTPONE branch
554: <resolve
555: check-begin
556: unreachable ; immediate restrict
557:
558: \ UNTIL (the current control flow may join an earlier one or continue):
559: \ Similar to AGAIN. The new locals-list and locals-size are the current
560: \ ones. The following code is generated:
561: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
562: : until-like ( list addr xt1 xt2 -- )
563: \ list and addr are a fragment of a cs-item
564: \ xt1 is the conditional branch without lp adjustment, xt2 is with
565: >r >r
566: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
567: r> drop r> compile,
568: swap <resolve ( list adjustment ) ,
569: else ( list dest-addr adjustment )
570: drop
571: r> compile, <resolve
572: r> drop
573: then ( list )
574: check-begin ;
575:
576: : UNTIL ( dest -- )
577: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
578:
579: : WHILE ( dest -- orig dest )
580: POSTPONE if
581: 1 cs-roll ; immediate restrict
582:
583: : REPEAT ( orig dest -- )
584: POSTPONE again
585: POSTPONE then ; immediate restrict
586:
587:
588: \ counted loops
589:
590: \ leave poses a little problem here
591: \ we have to store more than just the address of the branch, so the
592: \ traditional linked list approach is no longer viable.
593: \ This is solved by storing the information about the leavings in a
594: \ special stack.
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 3 cells + 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 <= IF
621: drop 0 0 0 EXIT THEN
622: cell - dup @ swap
623: cell - dup @ swap
624: cell - dup @ swap
625: leave-sp ! ;
626:
627: : DONE ( orig -- ) drop >r drop
628: \ !! the original done had ( addr -- )
629: begin
630: leave>
631: over r@ u>=
632: while
633: POSTPONE then
634: repeat
635: >leave rdrop ; immediate restrict
636:
637: : LEAVE ( -- )
638: POSTPONE ahead
639: >leave ; immediate restrict
640:
641: : ?LEAVE ( -- )
642: POSTPONE 0= POSTPONE if
643: >leave ; immediate restrict
644:
645: : DO ( -- do-sys )
646: POSTPONE (do)
647: POSTPONE begin drop do-dest
648: ( 0 0 0 >leave ) ; immediate restrict
649:
650: : ?DO ( -- do-sys )
651: ( 0 0 0 >leave )
652: POSTPONE (?do)
653: >mark >leave
654: POSTPONE begin drop do-dest ; immediate restrict
655:
656: : FOR ( -- do-sys )
657: POSTPONE (for)
658: POSTPONE begin drop do-dest
659: ( 0 0 0 >leave ) ; immediate restrict
660:
661: \ LOOP etc. are just like UNTIL
662:
663: : loop-like ( do-sys xt1 xt2 -- )
664: >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
665: until-like POSTPONE done POSTPONE unloop ;
666:
667: : LOOP ( do-sys -- )
668: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
669:
670: : +LOOP ( do-sys -- )
671: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
672:
673: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
674: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
675: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
676: \ negative increments.
677: : S+LOOP ( do-sys -- )
678: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
679:
680: : NEXT ( do-sys -- )
681: ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
682:
683: \ Structural Conditionals 12dec92py
684:
685: : EXIT ( -- )
686: 0 adjust-locals-size
687: POSTPONE ;s
688: unreachable ; immediate restrict
689:
690: : ?EXIT ( -- )
691: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
692:
693: \ Strings 22feb93py
694:
695: : ," ( "string"<"> -- ) [char] " parse
696: here over char+ allot place align ;
697: : "lit ( -- addr )
698: r> r> dup count + aligned >r swap >r ; restrict
699: : (.") "lit count type ; restrict
700: : (S") "lit count ; restrict
701: : SLiteral postpone (S") here over char+ allot place align ;
702: immediate restrict
703: : S" [char] " parse state @ IF postpone SLiteral THEN ;
704: immediate
705: : ." state @ IF postpone (.") ," align
706: ELSE [char] " parse type THEN ; immediate
707: : ( [char] ) parse 2drop ; immediate
708: : \ source >in ! drop ; immediate
709:
710: \ error handling 22feb93py
711: \ 'abort thrown out! 11may93jaw
712:
713: : (abort") "lit >r IF r> "error ! -2 throw THEN
714: rdrop ;
715: : abort" postpone (abort") ," ; immediate restrict
716:
717: \ Header states 23feb93py
718:
719: : flag! ( 8b -- )
720: last @ dup 0= abort" last word was headerless"
721: cell+ tuck c@ xor swap c! ;
722: : immediate $20 flag! ;
723: : restrict $40 flag! ;
724: \ ' noop alias restrict
725:
726: \ Header 23feb93py
727:
728: \ input-stream, nextname and noname are quite ugly (passing
729: \ information through global variables), but they are useful for dealing
730: \ with existing/independent defining words
731:
732: defer header
733:
734: : name, ( "name" -- )
735: name c@
736: dup $1F u> -&19 and throw ( is name too long? )
737: 1+ chars allot align ;
738: : input-stream-header ( "name" -- )
739: \ !! this is f83-implementation-dependent
740: align here last ! -1 A,
741: name, $80 flag! ;
742:
743: : input-stream ( -- ) \ general
744: \ switches back to getting the name from the input stream ;
745: ['] input-stream-header IS header ;
746:
747: ' input-stream-header IS header
748:
749: \ !! make that a 2variable
750: create nextname-buffer 32 chars allot
751:
752: : nextname-header ( -- )
753: \ !! f83-implementation-dependent
754: nextname-buffer count
755: align here last ! -1 A,
756: dup c, here swap chars dup allot move align
757: $80 flag!
758: input-stream ;
759:
760: \ the next name is given in the string
761: : nextname ( c-addr u -- ) \ general
762: dup $1F u> -&19 and throw ( is name too long? )
763: nextname-buffer c! ( c-addr )
764: nextname-buffer count move
765: ['] nextname-header IS header ;
766:
767: : noname-header ( -- )
768: 0 last !
769: input-stream ;
770:
771: : noname ( -- ) \ general
772: \ the next defined word remains anonymous. The xt of that word is given by lastxt
773: ['] noname-header IS header ;
774:
775: : lastxt ( -- xt ) \ general
776: \ 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
777: lastcfa @ ;
778:
779: : Alias ( cfa "name" -- )
780: Header reveal , $80 flag! ;
781:
782: : name>string ( nfa -- addr count )
783: cell+ count $1F and ;
784:
785: Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
786: : >name ( cfa -- nfa )
787: $21 cell do
788: dup i - count $9F and + aligned over $80 + = if
789: i - cell - unloop exit
790: then
791: cell +loop
792: drop ??? ( wouldn't 0 be better? ) ;
793:
794: \ indirect threading 17mar93py
795:
796: : cfa, ( code-address -- )
797: here lastcfa !
798: here 0 A, 0 , code-address! ;
799: : compile, ( xt -- ) A, ;
800: : !does ( addr -- ) lastcfa @ does-code! ;
801: : (;code) ( R: addr -- ) r> /does-handler + !does ;
802: : dodoes, ( -- )
803: here /does-handler allot does-handler! ;
804:
805: \ direct threading is implementation dependent
806:
807: : Create Header reveal [ :dovar ] Literal cfa, ;
808:
809: \ DOES> 17mar93py
810:
811: : DOES> ( compilation: -- )
812: state @
813: IF
814: ;-hook postpone (;code) dodoes,
815: ELSE
816: dodoes, here !does 0 ]
817: THEN
818: :-hook ; immediate
819:
820: \ Create Variable User Constant 17mar93py
821:
822: : Variable Create 0 , ;
823: : AVariable Create 0 A, ;
824: : 2VARIABLE ( "name" -- ) \ double
825: create 0 , 0 , ;
826:
827: : User Variable ;
828: : AUser AVariable ;
829:
830: : (Constant) Header reveal [ :docon ] Literal cfa, ;
831: : Constant (Constant) , ;
832: : AConstant (Constant) A, ;
833:
834: : 2CONSTANT
835: create ( w1 w2 "name" -- )
836: 2,
837: does> ( -- w1 w2 )
838: 2@ ;
839:
840: \ IS Defer What's Defers TO 24feb93py
841:
842: : Defer
843: Create ( -- )
844: ['] noop A,
845: DOES> ( ??? )
846: @ execute ;
847:
848: : IS ( addr "name" -- )
849: ' >body
850: state @
851: IF postpone ALiteral postpone !
852: ELSE !
853: THEN ; immediate
854: ' IS Alias TO immediate
855:
856: : What's ( "name" -- addr ) ' >body
857: state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
858: immediate
859: : Defers ( "name" -- ) ' >body @ compile, ;
860: immediate
861:
862: \ : ; 24feb93py
863:
864: defer :-hook ( sys1 -- sys2 )
865: defer ;-hook ( sys2 -- sys1 )
866:
867: : : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ;
868: : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ;
869: immediate restrict
870:
871: : :noname ( -- xt colon-sys )
872: 0 last !
873: here [ :docol ] Literal cfa, 0 ] :-hook ;
874:
875: \ Search list handling 23feb93py
876:
877: AVariable current
878:
879: : last? ( -- false / nfa nfa ) last @ ?dup ;
880: : (reveal) ( -- )
881: last?
882: IF
883: dup @ 0<
884: IF
885: current @ @ over ! current @ !
886: ELSE
887: drop
888: THEN
889: THEN ;
890:
891: \ object oriented search list 17mar93py
892:
893: \ word list structure:
894: \ struct
895: \ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id )
896: \ 1 cells: field reveal-method \ xt: ( -- )
897: \ 1 cells: field rehash-method \ xt: ( wid -- )
898: \ \ !! what else
899: \ end-struct wordlist-map-struct
900:
901: \ struct
902: \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
903: \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
904: \ 1 cells: field wordlist-link \ link field to other wordlists
905: \ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
906: \ end-struct wordlist-struct
907:
908: : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
909:
910: \ Search list table: find reveal
911: Create f83search ' f83find A, ' (reveal) A, ' drop A,
912:
913: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
914: AVariable search G forth-wordlist search T !
915: G forth-wordlist current T !
916:
917: : (search-wordlist) ( addr count wid -- nfa / false )
918: dup ( @ swap ) cell+ @ @ execute ;
919:
920: : search-wordlist ( addr count wid -- 0 / xt +-1 )
921: (search-wordlist) dup IF found THEN ;
922:
923: Variable warnings G -1 warnings T !
924:
925: : check-shadow ( addr count wid -- )
926: \ prints a warning if the string is already present in the wordlist
927: \ !! should be refined so the user can suppress the warnings
928: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
929: ." redefined " name>string 2dup type
930: compare 0<> if
931: ." with " type
932: else
933: 2drop
934: then
935: space space EXIT
936: then
937: 2drop 2drop ;
938:
939: : find ( addr -- cfa +-1 / string false ) dup
940: count search @ search-wordlist dup IF rot drop THEN ;
941:
942: : reveal ( -- )
943: last? if
944: name>string current @ check-shadow
945: then
946: current @ cell+ @ cell+ @ execute ;
947:
948: : rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ;
949:
950: : ' ( "name" -- addr ) name find 0= no.extensions ;
951: : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
952: \ Input 13feb93py
953:
954: 07 constant #bell
955: 08 constant #bs
956: 7F constant #del
957: 0D constant #cr \ the newline key code
958: 0A constant #lf
959:
960: : bell #bell emit ;
961:
962: : backspaces 0 ?DO #bs emit LOOP ;
963: : >string ( span addr pos1 -- span addr pos1 addr2 len )
964: over 3 pick 2 pick chars /string ;
965: : type-rest ( span addr pos1 -- span addr pos1 back )
966: >string tuck type ;
967: : (del) ( max span addr pos1 -- max span addr pos2 )
968: 1- >string over 1+ -rot move
969: rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
970: : (ins) ( max span addr pos1 char -- max span addr pos2 )
971: >r >string over 1+ swap move 2dup chars + r> swap c!
972: rot 1+ -rot type-rest 1- backspaces 1+ ;
973: : ?del ( max span addr pos1 -- max span addr pos2 0 )
974: dup IF (del) THEN 0 ;
975: : (ret) type-rest drop true space ;
976: : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
977: : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
978:
979: Create crtlkeys
980: ] false false back false false false forw false
981: ?del false (ret) false false (ret) false false
982: false false false false false false false false
983: false false false false false false false false [
984:
985: : decode ( max span addr pos1 key -- max span addr pos2 flag )
986: dup #del = IF drop #bs THEN \ del is rubout
987: dup bl < IF cells crtlkeys + @ execute EXIT THEN
988: >r 2over = IF rdrop bell 0 EXIT THEN
989: r> (ins) 0 ;
990:
991: \ decode should better use a table for control key actions
992: \ to define keyboard bindings later
993:
994: : accept ( addr len -- len )
995: dup 0< IF abs over dup 1 chars - c@ tuck type
996: \ this allows to edit given strings
997: ELSE 0 THEN rot over
998: BEGIN key decode UNTIL
999: 2drop nip ;
1000:
1001: \ Output 13feb93py
1002:
1003: DEFER type \ defer type for a output buffer or fast
1004: \ screen write
1005:
1006: \ : (type) ( addr len -- )
1007: \ bounds ?DO I c@ emit LOOP ;
1008:
1009: ' (TYPE) IS Type
1010:
1011: DEFER Emit
1012:
1013: ' (Emit) IS Emit
1014:
1015: \ : form ( -- rows cols ) &24 &80 ;
1016: \ form should be implemented using TERMCAPS or CURSES
1017: \ : rows form drop ;
1018: \ : cols form nip ;
1019:
1020: \ Query 07apr93py
1021:
1022: : refill ( -- flag )
1023: tib /line
1024: loadfile @ ?dup
1025: IF \ dup file-position throw linestart 2!
1026: read-line throw
1027: ELSE loadline @ 0< IF 2drop false EXIT THEN
1028: accept true
1029: THEN
1030: 1 loadline +!
1031: swap #tib ! 0 >in ! ;
1032:
1033: : Query ( -- ) 0 loadfile ! refill drop ;
1034:
1035: \ File specifiers 11jun93jaw
1036:
1037:
1038: \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c,
1039: \ 2 c, here char r c, char + c, 0 c,
1040: \ 2 c, here char w c, char + c, 0 c, align
1041: 4 Constant w/o
1042: 2 Constant r/w
1043: 0 Constant r/o
1044:
1045: \ BIN WRITE-LINE 11jun93jaw
1046:
1047: \ : bin dup 1 chars - c@
1048: \ r/o 4 chars + over - dup >r swap move r> ;
1049:
1050: : bin 1+ ;
1051:
1052: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
1053: \ or not unix environments if
1054: \ bin is not selected
1055:
1056: : write-line dup >r write-file ?dup IF r> drop EXIT THEN
1057: nl$ count r> write-file ;
1058:
1059: \ include-file 07apr93py
1060:
1061: : push-file ( -- ) r>
1062: ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r
1063: blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;
1064:
1065: : pop-file ( -- ) r>
1066: r> >in ! r> #tib ! r> >tib ! r> blk !
1067: r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;
1068:
1069: : include-file ( i*x fid -- j*x )
1070: push-file loadfile !
1071: 0 loadline ! blk off
1072: BEGIN refill WHILE interpret REPEAT
1073: loadfile @ close-file throw
1074: pop-file ;
1075:
1076: : included ( i*x addr u -- j*x )
1077: loadfilename 2@ >r >r
1078: dup allocate throw over loadfilename 2!
1079: over loadfilename 2@ move
1080: r/o open-file throw include-file
1081: \ don't free filenames; they don't take much space
1082: \ and are used for debugging
1083: r> r> loadfilename 2! ;
1084:
1085: \ HEX DECIMAL 2may93jaw
1086:
1087: : decimal a base ! ;
1088: : hex 10 base ! ;
1089:
1090: \ DEPTH 9may93jaw
1091:
1092: : depth ( -- +n ) sp@ s0 @ swap - cell / ;
1093:
1094: \ INCLUDE 9may93jaw
1095:
1096: : include ( "file" -- )
1097: bl word count included ;
1098:
1099: \ RECURSE 17may93jaw
1100:
1101: : recurse ( -- )
1102: lastxt compile, ; immediate restrict
1103: : recursive ( -- )
1104: reveal ; immediate
1105:
1106: \ */MOD */ 17may93jaw
1107:
1108: \ !! I think */mod should have the same rounding behaviour as / - anton
1109: : */mod >r m* r> sm/rem ;
1110:
1111: : */ */mod nip ;
1112:
1113: \ EVALUATE 17may93jaw
1114:
1115: : evaluate ( c-addr len -- )
1116: push-file dup #tib ! >tib @ swap move
1117: >in off blk off loadfile off -1 loadline !
1118:
1119: BEGIN interpret >in @ #tib @ u>= UNTIL
1120:
1121: pop-file ;
1122:
1123:
1124: : abort -1 throw ;
1125:
1126: \+ environment? true ENV" CORE"
1127: \ core wordset is now complete!
1128:
1129: \ Quit 13feb93py
1130:
1131: Defer 'quit
1132: Defer .status
1133: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
1134: : (quit) BEGIN .status cr query interpret prompt AGAIN ;
1135: ' (quit) IS 'quit
1136:
1137: \ DOERROR (DOERROR) 13jun93jaw
1138:
1139: : dec. ( n -- )
1140: \ print value in decimal representation
1141: base @ decimal swap . base ! ;
1142:
1143: : typewhite ( addr u -- )
1144: \ like type, but white space is printed instead of the characters
1145: 0 ?do
1146: dup i + c@ 9 = if \ check for tab
1147: 9
1148: else
1149: bl
1150: then
1151: emit
1152: loop
1153: drop ;
1154:
1155: DEFER DOERROR
1156:
1157: : (DoError) ( throw-code -- )
1158: LoadFile @
1159: IF
1160: cr loadfilename 2@ type ." :" Loadline @ dec.
1161: THEN
1162: cr source type cr
1163: source drop >in @ -trailing ( throw-code line-start index2 )
1164: here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
1165: typewhite
1166: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
1167: ." ^"
1168: loop
1169: dup -2 =
1170: IF
1171: "error @ ?dup
1172: IF
1173: cr count type
1174: THEN
1175: drop
1176: ELSE
1177: .error
1178: THEN
1179: normal-dp dpp ! ;
1180:
1181: ' (DoError) IS DoError
1182:
1183: : quit r0 @ rp! handler off >tib @ >r
1184: BEGIN
1185: postpone [
1186: ['] 'quit CATCH dup
1187: WHILE
1188: DoError r@ >tib !
1189: REPEAT
1190: drop r> >tib ! ;
1191:
1192: \ Cold 13feb93py
1193:
1194: \ : .name ( name -- ) cell+ count $1F and type space ;
1195: \ : words listwords @
1196: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
1197:
1198: : >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ;
1199: : arg ( n -- addr count ) cells argv @ + @ >len ;
1200: : #! postpone \ ; immediate
1201:
1202: Variable env
1203: Variable argv
1204: Variable argc
1205:
1206: 0 Value script? ( -- flag )
1207:
1208: : ">tib ( addr len -- ) dup #tib ! >in off tib swap move ;
1209:
1210: : do-option ( addr1 len1 addr2 len2 -- n ) 2swap
1211: 2dup s" -e" compare 0= >r
1212: 2dup s" -evaluate" compare 0= r> or
1213: IF 2drop ">tib interpret 2 EXIT THEN
1214: ." Unknown option: " type cr 2drop 1 ;
1215:
1216: : process-args ( -- ) argc @ 1
1217: ?DO I arg over c@ [char] - <>
1218: IF true to script? included false to script? 1
1219: ELSE I 1+ arg do-option
1220: THEN
1221: +LOOP ;
1222:
1223: : cold ( -- )
1224: argc @ 1 >
1225: IF
1226: ['] process-args catch ?dup
1227: IF
1228: dup >r DoError cr r> negate (bye)
1229: THEN
1230: THEN
1231: cr
1232: ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr
1233: ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
1234: ." Type `bye' to exit"
1235: quit ;
1236:
1237: : license ( -- ) cr
1238: ." This program is free software; you can redistribute it and/or modify" cr
1239: ." it under the terms of the GNU General Public License as published by" cr
1240: ." the Free Software Foundation; either version 2 of the License, or" cr
1241: ." (at your option) any later version." cr cr
1242:
1243: ." This program is distributed in the hope that it will be useful," cr
1244: ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
1245: ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
1246: ." GNU General Public License for more details." cr cr
1247:
1248: ." You should have received a copy of the GNU General Public License" cr
1249: ." along with this program; if not, write to the Free Software" cr
1250: ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
1251:
1252: : boot ( **env **argv argc -- )
1253: argc ! argv ! env ! main-task up!
1254: sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
1255:
1256: : bye script? 0= IF cr THEN 0 (bye) ;
1257:
1258: \ **argv may be scanned by the C starter to get some important
1259: \ information, as -display and -geometry for an X client FORTH
1260: \ or space and stackspace overrides
1261:
1262: \ 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