File:
[gforth] /
gforth /
Attic /
kernal.fs
Revision
1.10:
download - view:
text,
annotated -
select for diffs
Fri Jul 8 15:00:51 1994 UTC (28 years, 8 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
signals are now translated into THROWs
A number of bug fixes (make a diff of BUGS for details)
added assert.fs and debugging.fs
made .s nicer
keep names of included files (in loadfilename) and print them upon error
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: cell+ 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