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