File:
[gforth] /
gforth /
Attic /
kernal.fs
Revision
1.41:
download - view:
text,
annotated -
select for diffs
Sat Oct 7 17:38:16 1995 UTC (27 years, 5 months ago) by
anton
Branches:
MAIN
CVS tags:
HEAD
added code.fs (code, ;code, end-code, assembler)
renamed dostruc to dofield
made index and doc-entries nicer
Only words containing 'e' or 'E' are converted to FP numbers.
added many wordset comments
added flush-icache primitive and FLUSH_ICACHE macro
added +DO, U+DO, -DO, U-DO and -LOOP
added code address labels (`docol:' etc.)
fixed sparc cache_flush
1: \ KERNAL.FS GNU FORTH 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: \ labels for some code addresses
35:
36: : docon: ( -- addr ) \ gforth
37: \ the code address of a @code{CONSTANT}
38: ['] bl >code-address ;
39:
40: : docol: ( -- addr ) \ gforth
41: \ the code address of a colon definition
42: ['] docon: >code-address ;
43:
44: : dovar: ( -- addr ) \ gforth
45: \ the code address of a @code{CREATE}d word
46: ['] udp >code-address ;
47:
48: : douser: ( -- addr ) \ gforth
49: \ the code address of a @code{USER} variable
50: ['] s0 >code-address ;
51:
52: : dodefer: ( -- addr ) \ gforth
53: \ the code address of a @code{defer}ed word
54: ['] source >code-address ;
55:
56: : dofield: ( -- addr ) \ gforth
57: \ the code address of a @code{field}
58: ['] reveal-method >code-address ;
59:
60: \ Bit string manipulation 06oct92py
61:
62: Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
63: DOES> ( n -- ) + c@ ;
64:
65: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
66: : +bit ( addr n -- ) >bit over c@ or swap c! ;
67:
68: : relinfo ( -- addr ) forthstart dup @ + ;
69: : >rel ( addr -- n ) forthstart - ;
70: : relon ( addr -- ) relinfo swap >rel cell / +bit ;
71:
72: \ here allot , c, A, 17dec92py
73:
74: : dp ( -- addr ) dpp @ ;
75: : here ( -- here ) dp @ ;
76: : allot ( n -- ) dp +! ;
77: : c, ( c -- ) here 1 chars allot c! ;
78: : , ( x -- ) here cell allot ! ;
79: : 2, ( w1 w2 -- ) \ general
80: here 2 cells allot 2! ;
81:
82: : aligned ( addr -- addr' )
83: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
84: : align ( -- ) here dup aligned swap ?DO bl c, LOOP ;
85:
86: : faligned ( addr -- f-addr )
87: [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
88:
89: : falign ( -- )
90: here dup faligned swap
91: ?DO
92: bl c,
93: LOOP ;
94:
95: \ !! this is machine-dependent, but works on all but the strangest machines
96: ' faligned Alias maxaligned
97: ' falign Alias maxalign
98:
99: \ the code field is aligned if its body is maxaligned
100: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
101: ' maxaligned Alias cfaligned
102: ' maxalign Alias cfalign
103:
104: : chars ; immediate
105:
106: : A! ( addr1 addr2 -- ) dup relon ! ;
107: : A, ( addr -- ) here cell allot A! ;
108:
109: \ on off 23feb93py
110:
111: : on ( addr -- ) true swap ! ;
112: : off ( addr -- ) false swap ! ;
113:
114: \ name> found 17dec92py
115:
116: : (name>) ( nfa -- cfa )
117: count $1F and + cfaligned ;
118: : name> ( nfa -- cfa )
119: cell+
120: dup (name>) swap c@ $80 and 0= IF @ THEN ;
121:
122: : found ( nfa -- cfa n ) cell+
123: dup c@ >r (name>) r@ $80 and 0= IF @ THEN
124: -1 r@ $40 and IF 1- THEN
125: r> $20 and IF negate THEN ;
126:
127: \ (find) 17dec92py
128:
129: \ : (find) ( addr count nfa1 -- nfa2 / false )
130: \ BEGIN dup WHILE dup >r
131: \ cell+ count $1F and dup >r 2over r> =
132: \ IF -text 0= IF 2drop r> EXIT THEN
133: \ ELSE 2drop drop THEN r> @
134: \ REPEAT nip nip ;
135:
136: \ place bounds 13feb93py
137:
138: : place ( addr len to -- ) over >r rot over 1+ r> move c! ;
139: : bounds ( beg count -- end beg ) over + swap ;
140:
141: \ input stream primitives 23feb93py
142:
143: : tib >tib @ ;
144: Defer source \ used by dodefer:, must be defer
145: : (source) ( -- addr count ) tib #tib @ ;
146: ' (source) IS source
147:
148: \ (word) 22feb93py
149:
150: : scan ( addr1 n1 char -- addr2 n2 )
151: \ skip all characters not equal to char
152: >r
153: BEGIN
154: dup
155: WHILE
156: over c@ r@ <>
157: WHILE
158: 1 /string
159: REPEAT THEN
160: rdrop ;
161: : skip ( addr1 n1 char -- addr2 n2 )
162: \ skip all characters equal to char
163: >r
164: BEGIN
165: dup
166: WHILE
167: over c@ r@ =
168: WHILE
169: 1 /string
170: REPEAT THEN
171: rdrop ;
172:
173: : (word) ( addr1 n1 char -- addr2 n2 )
174: dup >r skip 2dup r> scan nip - ;
175:
176: \ (word) should fold white spaces
177: \ this is what (parse-white) does
178:
179: \ word parse 23feb93py
180:
181: : parse-word ( char -- addr len )
182: source 2dup >r >r >in @ over min /string
183: rot dup bl = IF drop (parse-white) ELSE (word) THEN
184: 2dup + r> - 1+ r> min >in ! ;
185: : word ( char -- addr )
186: parse-word here place bl here count + c! here ;
187:
188: : parse ( char -- addr len )
189: >r source >in @ over min /string over swap r> scan >r
190: over - dup r> IF 1+ THEN >in +! ;
191:
192: \ name 13feb93py
193:
194: : capitalize ( addr len -- addr len )
195: 2dup chars chars bounds
196: ?DO I c@ toupper I c! 1 chars +LOOP ;
197: : (name) ( -- c-addr count )
198: source 2dup >r >r >in @ /string (parse-white)
199: 2dup + r> - 1+ r> min >in ! ;
200: \ name count ;
201:
202: : name-too-short? ( c-addr u -- c-addr u )
203: dup 0= -&16 and throw ;
204:
205: : name-too-long? ( c-addr u -- c-addr u )
206: dup $1F u> -&19 and throw ;
207:
208: \ Literal 17dec92py
209:
210: : Literal ( n -- ) state @ IF postpone lit , THEN ;
211: immediate
212: : ALiteral ( n -- ) state @ IF postpone lit A, THEN ;
213: immediate
214:
215: : char ( 'char' -- n ) bl word char+ c@ ;
216: : [char] ( 'char' -- n ) char postpone Literal ; immediate
217: ' [char] Alias Ascii immediate
218:
219: : (compile) ( -- ) r> dup cell+ >r @ compile, ;
220: : postpone ( "name" -- )
221: name sfind dup 0= abort" Can't compile "
222: 0> IF compile, ELSE postpone (compile) A, THEN ;
223: immediate restrict
224:
225: \ Use (compile) for the old behavior of compile!
226:
227: \ digit? 17dec92py
228:
229: : digit? ( char -- digit true/ false )
230: base @ $100 =
231: IF
232: true EXIT
233: THEN
234: toupper [char] 0 - dup 9 u> IF
235: [ 'A '9 1 + - ] literal -
236: dup 9 u<= IF
237: drop false EXIT
238: THEN
239: THEN
240: dup base @ u>= IF
241: drop false EXIT
242: THEN
243: true ;
244:
245: : accumulate ( +d0 addr digit - +d1 addr )
246: swap >r swap base @ um* drop rot base @ um* d+ r> ;
247: : >number ( d addr count -- d addr count )
248: 0 ?DO count digit? WHILE accumulate LOOP 0
249: ELSE 1- I' I - UNLOOP THEN ;
250:
251: \ number? number 23feb93py
252:
253: Create bases 10 , 2 , A , 100 ,
254: \ 16 2 10 Zeichen
255: \ !! this saving and restoring base is an abomination! - anton
256: : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u<
257: IF cells bases + @ base ! 1 /string ELSE drop THEN ;
258: : s>number ( addr len -- d ) base @ >r dpl on
259: over c@ '- = dup >r IF 1 /string THEN
260: getbase dpl on 0 0 2swap
261: BEGIN dup >r >number dup WHILE dup r> - WHILE
262: dup dpl ! over c@ [char] . = WHILE
263: 1 /string
264: REPEAT THEN 2drop rdrop dpl off ELSE
265: 2drop rdrop r> IF dnegate THEN
266: THEN r> base ! ;
267: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
268: s>number dpl @ 0=
269: IF
270: 2drop false EXIT
271: THEN
272: dpl @ dup 0> 0= IF
273: nip
274: THEN ;
275: : number? ( string -- string 0 / n -1 / d 0> )
276: dup >r count snumber? dup if
277: rdrop
278: else
279: r> swap
280: then ;
281: : s>d ( n -- d ) dup 0< ;
282: : number ( string -- d )
283: number? ?dup 0= abort" ?" 0< IF s>d THEN ;
284:
285: \ space spaces ud/mod 21mar93py
286: decimal
287: Create spaces bl 80 times \ times from target compiler! 11may93jaw
288: DOES> ( u -- ) swap
289: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
290: Create backspaces 08 80 times \ times from target compiler! 11may93jaw
291: DOES> ( u -- ) swap
292: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
293: hex
294: : space 1 spaces ;
295:
296: : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
297: um/mod r> ;
298:
299: : pad ( -- addr )
300: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
301:
302: \ hold <# #> sign # #s 25jan92py
303:
304: : hold ( char -- ) pad cell - -1 chars over +! @ c! ;
305:
306: : <# pad cell - dup ! ;
307:
308: : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ;
309:
310: : sign ( n -- ) 0< IF [char] - hold THEN ;
311:
312: : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over <
313: IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ;
314:
315: : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
316:
317: \ print numbers 07jun92py
318:
319: : d.r >r tuck dabs <# #s rot sign #>
320: r> over - spaces type ;
321:
322: : ud.r >r <# #s #> r> over - spaces type ;
323:
324: : .r >r s>d r> d.r ;
325: : u.r 0 swap ud.r ;
326:
327: : d. 0 d.r space ;
328: : ud. 0 ud.r space ;
329:
330: : . s>d d. ;
331: : u. 0 ud. ;
332:
333: \ catch throw 23feb93py
334: \ bounce 08jun93jaw
335:
336: \ !! allow the user to add rollback actions anton
337: \ !! use a separate exception stack? anton
338:
339: : lp@ ( -- addr )
340: laddr# [ 0 , ] ;
341:
342: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
343: >r sp@ r> swap >r \ don't count xt! jaw
344: fp@ >r
345: lp@ >r
346: handler @ >r
347: rp@ handler !
348: execute
349: r> handler ! rdrop rdrop rdrop 0 ;
350:
351: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
352: ?DUP IF
353: [ here 4 cells ! ]
354: handler @ rp!
355: r> handler !
356: r> lp!
357: r> fp!
358: r> swap >r sp! r>
359: THEN ;
360:
361: \ Bouncing is very fine,
362: \ programming without wasting time... jaw
363: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
364: \ a throw without data or fp stack restauration
365: ?DUP IF
366: handler @ rp!
367: r> handler !
368: r> lp!
369: rdrop
370: rdrop
371: THEN ;
372:
373: \ ?stack 23feb93py
374:
375: : ?stack ( ?? -- ?? )
376: sp@ s0 @ > IF -4 throw THEN
377: fp@ f0 @ > IF -&45 throw THEN ;
378: \ ?stack should be code -- it touches an empty stack!
379:
380: \ interpret 10mar92py
381:
382: Defer parser
383: Defer name ' (name) IS name
384: Defer notfound ( c-addr count -- )
385:
386: : no.extensions ( addr u -- ) 2drop -&13 bounce ;
387:
388: ' no.extensions IS notfound
389:
390: : interpret
391: BEGIN
392: ?stack name dup
393: WHILE
394: parser
395: REPEAT
396: 2drop ;
397:
398: \ interpreter compiler 30apr92py
399:
400: : interpreter ( c-addr u -- )
401: \ interpretation semantics for the name/number c-addr u
402: 2dup sfind dup
403: IF
404: 1 and
405: IF \ not restricted to compile state?
406: nip nip execute EXIT
407: THEN
408: -&14 throw
409: THEN
410: drop
411: 2dup 2>r snumber?
412: IF
413: 2rdrop
414: ELSE
415: 2r> notfound
416: THEN ;
417:
418: ' interpreter IS parser
419:
420: : compiler ( c-addr u -- )
421: \ compilation semantics for the name/number c-addr u
422: 2dup sfind dup
423: IF
424: 0>
425: IF
426: nip nip execute EXIT
427: THEN
428: compile, 2drop EXIT
429: THEN
430: drop
431: 2dup snumber? dup
432: IF
433: 0>
434: IF
435: swap postpone Literal
436: THEN
437: postpone Literal
438: 2drop
439: ELSE
440: drop notfound
441: THEN ;
442:
443: : [ ['] interpreter IS parser state off ; immediate
444: : ] ['] compiler IS parser state on ;
445:
446: \ locals stuff needed for control structures
447:
448: : compile-lp+! ( n -- )
449: dup negate locals-size +!
450: 0 over = if
451: else -1 cells over = if postpone lp-
452: else 1 floats over = if postpone lp+
453: else 2 floats over = if postpone lp+2
454: else postpone lp+!# dup ,
455: then then then then drop ;
456:
457: : adjust-locals-size ( n -- )
458: \ sets locals-size to n and generates an appropriate lp+!
459: locals-size @ swap - compile-lp+! ;
460:
461:
462: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
463: AConstant locals-list \ acts like a variable that contains
464: \ a linear list of locals names
465:
466:
467: variable dead-code \ true if normal code at "here" would be dead
468: variable backedge-locals
469: \ contains the locals list that BEGIN will assume to be live on
470: \ the back edge if the BEGIN is unreachable from above. Set by
471: \ ASSUME-LIVE, reset by UNREACHABLE.
472:
473: : UNREACHABLE ( -- )
474: \ declares the current point of execution as unreachable
475: dead-code on
476: 0 backedge-locals ! ; immediate
477:
478: : ASSUME-LIVE ( orig -- orig )
479: \ used immediateliy before a BEGIN that is not reachable from
480: \ above. causes the BEGIN to assume that the same locals are live
481: \ as at the orig point
482: dup orig?
483: 2 pick backedge-locals ! ; immediate
484:
485: \ locals list operations
486:
487: : common-list ( list1 list2 -- list3 )
488: \ list1 and list2 are lists, where the heads are at higher addresses than
489: \ the tail. list3 is the largest sublist of both lists.
490: begin
491: 2dup u<>
492: while
493: 2dup u>
494: if
495: swap
496: then
497: @
498: repeat
499: drop ;
500:
501: : sub-list? ( list1 list2 -- f )
502: \ true iff list1 is a sublist of list2
503: begin
504: 2dup u<
505: while
506: @
507: repeat
508: = ;
509:
510: : list-size ( list -- u )
511: \ size of the locals frame represented by list
512: 0 ( list n )
513: begin
514: over 0<>
515: while
516: over
517: name> >body @ max
518: swap @ swap ( get next )
519: repeat
520: faligned nip ;
521:
522: : set-locals-size-list ( list -- )
523: dup locals-list !
524: list-size locals-size ! ;
525:
526: : check-begin ( list -- )
527: \ warn if list is not a sublist of locals-list
528: locals-list @ sub-list? 0= if
529: \ !! print current position
530: ." compiler was overly optimistic about locals at a BEGIN" cr
531: \ !! print assumption and reality
532: then ;
533:
534: \ Control Flow Stack
535: \ orig, etc. have the following structure:
536: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
537: \ address (of the branch or the instruction to be branched to) (second)
538: \ locals-list (valid at address) (third)
539:
540: \ types
541: 0 constant defstart
542: 1 constant live-orig
543: 2 constant dead-orig
544: 3 constant dest \ the loopback branch is always assumed live
545: 4 constant do-dest
546: 5 constant scopestart
547:
548: : def? ( n -- )
549: defstart <> abort" unstructured " ;
550:
551: : orig? ( n -- )
552: dup live-orig <> swap dead-orig <> and abort" expected orig " ;
553:
554: : dest? ( n -- )
555: dest <> abort" expected dest " ;
556:
557: : do-dest? ( n -- )
558: do-dest <> abort" expected do-dest " ;
559:
560: : scope? ( n -- )
561: scopestart <> abort" expected scope " ;
562:
563: : non-orig? ( n -- )
564: dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
565:
566: : cs-item? ( n -- )
567: live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
568:
569: 3 constant cs-item-size
570:
571: : CS-PICK ( ... u -- ... destu )
572: 1+ cs-item-size * 1- >r
573: r@ pick r@ pick r@ pick
574: rdrop
575: dup non-orig? ;
576:
577: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )
578: 1+ cs-item-size * 1- >r
579: r@ roll r@ roll r@ roll
580: rdrop
581: dup cs-item? ;
582:
583: : cs-push-part ( -- list addr )
584: locals-list @ here ;
585:
586: : cs-push-orig ( -- orig )
587: cs-push-part dead-code @
588: if
589: dead-orig
590: else
591: live-orig
592: then ;
593:
594: \ Structural Conditionals 12dec92py
595:
596: : ?struc ( flag -- ) abort" unstructured " ;
597: : sys? ( sys -- ) dup 0= ?struc ;
598: : >mark ( -- orig )
599: cs-push-orig 0 , ;
600: : >resolve ( addr -- ) here over - swap ! ;
601: : <resolve ( addr -- ) here - , ;
602:
603: : BUT 1 cs-roll ; immediate restrict
604: : YET 0 cs-pick ; immediate restrict
605:
606: \ Structural Conditionals 12dec92py
607:
608: : AHEAD ( -- orig )
609: POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
610:
611: : IF ( -- orig )
612: POSTPONE ?branch >mark ; immediate restrict
613:
614: : ?DUP-IF \ general
615: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
616: \ better handled by tools like stack checkers
617: POSTPONE ?dup POSTPONE if ; immediate restrict
618: : ?DUP-0=-IF \ general
619: POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
620:
621: : THEN ( orig -- )
622: dup orig?
623: dead-orig =
624: if
625: >resolve drop
626: else
627: dead-code @
628: if
629: >resolve set-locals-size-list dead-code off
630: else \ both live
631: over list-size adjust-locals-size
632: >resolve
633: locals-list @ common-list dup list-size adjust-locals-size
634: locals-list !
635: then
636: then ; immediate restrict
637:
638: ' THEN alias ENDIF immediate restrict \ general
639: \ Same as "THEN". This is what you use if your program will be seen by
640: \ people who have not been brought up with Forth (or who have been
641: \ brought up with fig-Forth).
642:
643: : ELSE ( orig1 -- orig2 )
644: POSTPONE ahead
645: 1 cs-roll
646: POSTPONE then ; immediate restrict
647:
648:
649: : BEGIN ( -- dest )
650: dead-code @ if
651: \ set up an assumption of the locals visible here. if the
652: \ users want something to be visible, they have to declare
653: \ that using ASSUME-LIVE
654: backedge-locals @ set-locals-size-list
655: then
656: cs-push-part dest
657: dead-code off ; immediate restrict
658:
659: \ AGAIN (the current control flow joins another, earlier one):
660: \ If the dest-locals-list is not a subset of the current locals-list,
661: \ issue a warning (see below). The following code is generated:
662: \ lp+!# (current-local-size - dest-locals-size)
663: \ branch <begin>
664: : AGAIN ( dest -- )
665: dest?
666: over list-size adjust-locals-size
667: POSTPONE branch
668: <resolve
669: check-begin
670: POSTPONE unreachable ; immediate restrict
671:
672: \ UNTIL (the current control flow may join an earlier one or continue):
673: \ Similar to AGAIN. The new locals-list and locals-size are the current
674: \ ones. The following code is generated:
675: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
676: : until-like ( list addr xt1 xt2 -- )
677: \ list and addr are a fragment of a cs-item
678: \ xt1 is the conditional branch without lp adjustment, xt2 is with
679: >r >r
680: locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
681: r> drop r> compile,
682: swap <resolve ( list adjustment ) ,
683: else ( list dest-addr adjustment )
684: drop
685: r> compile, <resolve
686: r> drop
687: then ( list )
688: check-begin ;
689:
690: : UNTIL ( dest -- )
691: dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
692:
693: : WHILE ( dest -- orig dest )
694: POSTPONE if
695: 1 cs-roll ; immediate restrict
696:
697: : REPEAT ( orig dest -- )
698: POSTPONE again
699: POSTPONE then ; immediate restrict
700:
701:
702: \ counted loops
703:
704: \ leave poses a little problem here
705: \ we have to store more than just the address of the branch, so the
706: \ traditional linked list approach is no longer viable.
707: \ This is solved by storing the information about the leavings in a
708: \ special stack.
709:
710: \ !! remove the fixed size limit. 'Tis not hard.
711: 20 constant leave-stack-size
712: create leave-stack 60 cells allot
713: Avariable leave-sp leave-stack 3 cells + leave-sp !
714:
715: : clear-leave-stack ( -- )
716: leave-stack leave-sp ! ;
717:
718: \ : leave-empty? ( -- f )
719: \ leave-sp @ leave-stack = ;
720:
721: : >leave ( orig -- )
722: \ push on leave-stack
723: leave-sp @
724: dup [ leave-stack 60 cells + ] Aliteral
725: >= abort" leave-stack full"
726: tuck ! cell+
727: tuck ! cell+
728: tuck ! cell+
729: leave-sp ! ;
730:
731: : leave> ( -- orig )
732: \ pop from leave-stack
733: leave-sp @
734: dup leave-stack <= IF
735: drop 0 0 0 EXIT THEN
736: cell - dup @ swap
737: cell - dup @ swap
738: cell - dup @ swap
739: leave-sp ! ;
740:
741: : DONE ( orig -- )
742: \ !! the original done had ( addr -- )
743: drop >r drop
744: begin
745: leave>
746: over r@ u>=
747: while
748: POSTPONE then
749: repeat
750: >leave rdrop ; immediate restrict
751:
752: : LEAVE ( -- )
753: POSTPONE ahead
754: >leave ; immediate restrict
755:
756: : ?LEAVE ( -- )
757: POSTPONE 0= POSTPONE if
758: >leave ; immediate restrict
759:
760: : DO ( -- do-sys )
761: POSTPONE (do)
762: POSTPONE begin drop do-dest
763: ( 0 0 0 >leave ) ; immediate restrict
764:
765: : ?do-like ( -- do-sys )
766: ( 0 0 0 >leave )
767: >mark >leave
768: POSTPONE begin drop do-dest ;
769:
770: : ?DO ( -- do-sys ) \ core-ext question-do
771: POSTPONE (?do) ?do-like ; immediate restrict
772:
773: : +DO ( -- do-sys ) \ gforth plus-do
774: POSTPONE (+do) ?do-like ; immediate restrict
775:
776: : U+DO ( -- do-sys ) \ gforth u-plus-do
777: POSTPONE (u+do) ?do-like ; immediate restrict
778:
779: : -DO ( -- do-sys ) \ gforth minus-do
780: POSTPONE (-do) ?do-like ; immediate restrict
781:
782: : U-DO ( -- do-sys ) \ gforth u-minus-do
783: POSTPONE (u-do) ?do-like ; immediate restrict
784:
785: : FOR ( -- do-sys )
786: POSTPONE (for)
787: POSTPONE begin drop do-dest
788: ( 0 0 0 >leave ) ; immediate restrict
789:
790: \ LOOP etc. are just like UNTIL
791:
792: : loop-like ( do-sys xt1 xt2 -- )
793: >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
794: until-like POSTPONE done POSTPONE unloop ;
795:
796: : LOOP ( do-sys -- ) \ core
797: ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
798:
799: : +LOOP ( do-sys -- ) \ core plus-loop
800: ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
801:
802: \ !! should the compiler warn about +DO..-LOOP?
803: : -LOOP ( do-sys -- ) \ gforth minus-loop
804: ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
805:
806: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
807: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
808: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
809: \ negative increments.
810: : S+LOOP ( do-sys -- ) \ gforth s-plus-loop
811: ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
812:
813: : NEXT ( do-sys -- )
814: ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
815:
816: \ Structural Conditionals 12dec92py
817:
818: : EXIT ( -- )
819: 0 adjust-locals-size
820: POSTPONE ;s
821: POSTPONE unreachable ; immediate restrict
822:
823: : ?EXIT ( -- )
824: POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
825:
826: \ Strings 22feb93py
827:
828: : ," ( "string"<"> -- ) [char] " parse
829: here over char+ allot place align ;
830: : "lit ( -- addr )
831: r> r> dup count + aligned >r swap >r ; restrict
832: : (.") "lit count type ; restrict
833: : (S") "lit count ; restrict
834: : SLiteral postpone (S") here over char+ allot place align ;
835: immediate restrict
836: create s"-buffer /line chars allot
837: : S" ( run-time: -- c-addr u )
838: [char] " parse
839: state @
840: IF
841: postpone SLiteral
842: ELSE
843: /line min >r s"-buffer r@ cmove
844: s"-buffer r>
845: THEN ;
846: immediate
847: : ." state @ IF postpone (.") ," align
848: ELSE [char] " parse type THEN ; immediate
849: : ( [char] ) parse 2drop ; immediate
850: : \ ( -- ) \ core-ext backslash
851: blk @
852: IF
853: >in @ c/l / 1+ c/l * >in !
854: EXIT
855: THEN
856: source >in ! drop ; immediate
857:
858: : \G ( -- ) \ new backslash
859: POSTPONE \ ; immediate
860:
861: \ error handling 22feb93py
862: \ 'abort thrown out! 11may93jaw
863:
864: : (abort") "lit >r IF r> "error ! -2 throw THEN
865: rdrop ;
866: : abort" postpone (abort") ," ; immediate restrict
867:
868: \ Header states 23feb93py
869:
870: : flag! ( 8b -- )
871: last @ dup 0= abort" last word was headerless"
872: cell+ tuck c@ xor swap c! ;
873: : immediate $20 flag! ;
874: : restrict $40 flag! ;
875: \ ' noop alias restrict
876:
877: \ Header 23feb93py
878:
879: \ input-stream, nextname and noname are quite ugly (passing
880: \ information through global variables), but they are useful for dealing
881: \ with existing/independent defining words
882:
883: defer (header)
884: defer header ' (header) IS header
885:
886: : string, ( c-addr u -- )
887: \ puts down string as cstring
888: dup c, here swap chars dup allot move ;
889:
890: : name, ( "name" -- )
891: name name-too-short? name-too-long?
892: string, cfalign ;
893: : input-stream-header ( "name" -- )
894: \ !! this is f83-implementation-dependent
895: align here last ! -1 A,
896: name, $80 flag! ;
897:
898: : input-stream ( -- ) \ general
899: \ switches back to getting the name from the input stream ;
900: ['] input-stream-header IS (header) ;
901:
902: ' input-stream-header IS (header)
903:
904: \ !! make that a 2variable
905: create nextname-buffer 32 chars allot
906:
907: : nextname-header ( -- )
908: \ !! f83-implementation-dependent
909: nextname-buffer count
910: align here last ! -1 A,
911: string, cfalign
912: $80 flag!
913: input-stream ;
914:
915: \ the next name is given in the string
916: : nextname ( c-addr u -- ) \ general
917: name-too-long?
918: nextname-buffer c! ( c-addr )
919: nextname-buffer count move
920: ['] nextname-header IS (header) ;
921:
922: : noname-header ( -- )
923: 0 last ! cfalign
924: input-stream ;
925:
926: : noname ( -- ) \ general
927: \ the next defined word remains anonymous. The xt of that word is given by lastxt
928: ['] noname-header IS (header) ;
929:
930: : lastxt ( -- xt ) \ general
931: \ 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
932: lastcfa @ ;
933:
934: : Alias ( cfa "name" -- )
935: Header reveal , $80 flag! ;
936:
937: : name>string ( nfa -- addr count )
938: cell+ count $1F and ;
939:
940: Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
941: : >name ( cfa -- nfa )
942: $21 cell do
943: dup i - count $9F and + cfaligned over $80 + = if
944: i - cell - unloop exit
945: then
946: cell +loop
947: drop ??? ( wouldn't 0 be better? ) ;
948:
949: \ threading 17mar93py
950:
951: : cfa, ( code-address -- ) \ gforth
952: here
953: dup lastcfa !
954: 0 A, 0 , code-address! ;
955: : compile, ( xt -- ) \ core-ext
956: A, ;
957: : !does ( addr -- ) lastxt does-code! ;
958: : (does>) ( R: addr -- ) r> /does-handler + !does ;
959: : dodoes, ( -- )
960: here /does-handler allot does-handler! ;
961:
962: : Create Header reveal dovar: cfa, ;
963:
964: \ DOES> 17mar93py
965:
966: : DOES> ( compilation: -- ) \ core
967: state @
968: IF
969: ;-hook postpone (does>) ?struc dodoes,
970: ELSE
971: align dodoes, here !does ]
972: THEN
973: defstart :-hook ; immediate
974:
975: \ Create Variable User Constant 17mar93py
976:
977: : Variable Create 0 , ;
978: : AVariable Create 0 A, ;
979: : 2VARIABLE ( "name" -- ) \ double
980: create 0 , 0 , ;
981:
982: : User Variable ;
983: : AUser AVariable ;
984:
985: : (Constant) Header reveal docon: cfa, ;
986: : Constant (Constant) , ;
987: : AConstant (Constant) A, ;
988:
989: : 2Constant
990: Create ( w1 w2 "name" -- )
991: 2,
992: DOES> ( -- w1 w2 )
993: 2@ ;
994:
995: \ IS Defer What's Defers TO 24feb93py
996:
997: : Defer ( -- )
998: \ !! shouldn't it be initialized with abort or something similar?
999: Header Reveal dodefer: cfa,
1000: ['] noop A, ;
1001: \ Create ( -- )
1002: \ ['] noop A,
1003: \ DOES> ( ??? )
1004: \ @ execute ;
1005:
1006: : IS ( addr "name" -- )
1007: ' >body
1008: state @
1009: IF postpone ALiteral postpone !
1010: ELSE !
1011: THEN ; immediate
1012: ' IS Alias TO immediate
1013:
1014: : What's ( "name" -- addr ) ' >body
1015: state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
1016: immediate
1017: : Defers ( "name" -- ) ' >body @ compile, ;
1018: immediate
1019:
1020: \ : ; 24feb93py
1021:
1022: defer :-hook ( sys1 -- sys2 )
1023: defer ;-hook ( sys2 -- sys1 )
1024:
1025: : : ( -- colon-sys ) Header docol: cfa, defstart ] :-hook ;
1026: : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ;
1027: immediate restrict
1028:
1029: : :noname ( -- xt colon-sys )
1030: 0 last !
1031: here docol: cfa, 0 ] :-hook ;
1032:
1033: \ Search list handling 23feb93py
1034:
1035: AVariable current
1036:
1037: : last? ( -- false / nfa nfa ) last @ ?dup ;
1038: : (reveal) ( -- )
1039: last?
1040: IF
1041: dup @ 0<
1042: IF
1043: current @ @ over ! current @ !
1044: ELSE
1045: drop
1046: THEN
1047: THEN ;
1048:
1049: \ object oriented search list 17mar93py
1050:
1051: \ word list structure:
1052:
1053: struct
1054: 1 cells: field find-method \ xt: ( c_addr u wid -- name-id )
1055: 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
1056: 1 cells: field rehash-method \ xt: ( wid -- )
1057: \ \ !! what else
1058: end-struct wordlist-map-struct
1059:
1060: struct
1061: 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
1062: 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
1063: 1 cells: field wordlist-link \ link field to other wordlists
1064: 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
1065: end-struct wordlist-struct
1066:
1067: : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ;
1068:
1069: \ Search list table: find reveal
1070: Create f83search ' f83find A, ' (reveal) A, ' drop A,
1071:
1072: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
1073: AVariable lookup G forth-wordlist lookup T !
1074: G forth-wordlist current T !
1075:
1076: : (search-wordlist) ( addr count wid -- nfa / false )
1077: dup wordlist-map @ find-method @ execute ;
1078:
1079: : search-wordlist ( addr count wid -- 0 / xt +-1 )
1080: (search-wordlist) dup IF found THEN ;
1081:
1082: Variable warnings G -1 warnings T !
1083:
1084: : check-shadow ( addr count wid -- )
1085: \ prints a warning if the string is already present in the wordlist
1086: \ !! should be refined so the user can suppress the warnings
1087: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
1088: ." redefined " name>string 2dup type
1089: compare 0<> if
1090: ." with " type
1091: else
1092: 2drop
1093: then
1094: space space EXIT
1095: then
1096: 2drop 2drop ;
1097:
1098: : sfind ( c-addr u -- xt n / 0 )
1099: lookup @ search-wordlist ;
1100:
1101: : find ( addr -- cfa +-1 / string false )
1102: \ !! not ANS conformant: returns +-2 for restricted words
1103: dup count sfind dup if
1104: rot drop
1105: then ;
1106:
1107: : reveal ( -- )
1108: last? if
1109: name>string current @ check-shadow
1110: then
1111: current @ wordlist-map @ reveal-method @ execute ;
1112:
1113: : rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ;
1114:
1115: : ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ;
1116: : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
1117: \ Input 13feb93py
1118:
1119: 07 constant #bell
1120: 08 constant #bs
1121: 09 constant #tab
1122: 7F constant #del
1123: 0D constant #cr \ the newline key code
1124: 0C constant #ff
1125: 0A constant #lf
1126:
1127: : bell #bell emit ;
1128:
1129: \ : backspaces 0 ?DO #bs emit LOOP ;
1130: : >string ( span addr pos1 -- span addr pos1 addr2 len )
1131: over 3 pick 2 pick chars /string ;
1132: : type-rest ( span addr pos1 -- span addr pos1 back )
1133: >string tuck type ;
1134: : (del) ( max span addr pos1 -- max span addr pos2 )
1135: 1- >string over 1+ -rot move
1136: rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
1137: : (ins) ( max span addr pos1 char -- max span addr pos2 )
1138: >r >string over 1+ swap move 2dup chars + r> swap c!
1139: rot 1+ -rot type-rest 1- backspaces 1+ ;
1140: : ?del ( max span addr pos1 -- max span addr pos2 0 )
1141: dup IF (del) THEN 0 ;
1142: : (ret) type-rest drop true space ;
1143: : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
1144: : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
1145: : eof 2 pick 0= IF bye ELSE (ret) THEN ;
1146:
1147: Create ctrlkeys
1148: ] false false back false eof false forw false
1149: ?del false (ret) false false (ret) false false
1150: false false false false false false false false
1151: false false false false false false false false [
1152:
1153: defer everychar
1154: ' noop IS everychar
1155:
1156: : decode ( max span addr pos1 key -- max span addr pos2 flag )
1157: everychar
1158: dup #del = IF drop #bs THEN \ del is rubout
1159: dup bl < IF cells ctrlkeys + @ execute EXIT THEN
1160: >r 2over = IF rdrop bell 0 EXIT THEN
1161: r> (ins) 0 ;
1162:
1163: \ decode should better use a table for control key actions
1164: \ to define keyboard bindings later
1165:
1166: : accept ( addr len -- len )
1167: dup 0< IF abs over dup 1 chars - c@ tuck type
1168: \ this allows to edit given strings
1169: ELSE 0 THEN rot over
1170: BEGIN key decode UNTIL
1171: 2drop nip ;
1172:
1173: \ Output 13feb93py
1174:
1175: Defer type \ defer type for a output buffer or fast
1176: \ screen write
1177:
1178: \ : (type) ( addr len -- )
1179: \ bounds ?DO I c@ emit LOOP ;
1180:
1181: ' (type) IS Type
1182:
1183: Defer emit
1184:
1185: ' (Emit) IS Emit
1186:
1187: Defer key
1188: ' (key) IS key
1189:
1190: \ : form ( -- rows cols ) &24 &80 ;
1191: \ form should be implemented using TERMCAPS or CURSES
1192: \ : rows form drop ;
1193: \ : cols form nip ;
1194:
1195: \ Query 07apr93py
1196:
1197: : refill ( -- flag )
1198: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
1199: tib /line
1200: loadfile @ ?dup
1201: IF read-line throw
1202: ELSE loadline @ 0< IF 2drop false EXIT THEN
1203: accept true
1204: THEN
1205: 1 loadline +!
1206: swap #tib ! 0 >in ! ;
1207:
1208: : Query ( -- ) loadfile off blk off refill drop ;
1209:
1210: \ File specifiers 11jun93jaw
1211:
1212:
1213: \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c,
1214: \ 2 c, here char r c, char + c, 0 c,
1215: \ 2 c, here char w c, char + c, 0 c, align
1216: 4 Constant w/o
1217: 2 Constant r/w
1218: 0 Constant r/o
1219:
1220: \ BIN WRITE-LINE 11jun93jaw
1221:
1222: \ : bin dup 1 chars - c@
1223: \ r/o 4 chars + over - dup >r swap move r> ;
1224:
1225: : bin 1 or ;
1226:
1227: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
1228: \ or not unix environments if
1229: \ bin is not selected
1230:
1231: : write-line dup >r write-file ?dup IF r> drop EXIT THEN
1232: nl$ count r> write-file ;
1233:
1234: \ include-file 07apr93py
1235:
1236: : push-file ( -- ) r>
1237: loadline @ >r loadfile @ >r
1238: blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;
1239:
1240: : pop-file ( throw-code -- throw-code )
1241: dup IF
1242: source >in @ loadline @ loadfilename 2@
1243: error-stack dup @ dup 1+
1244: max-errors 1- min error-stack !
1245: 6 * cells + cell+
1246: 5 cells bounds swap DO
1247: I !
1248: -1 cells +LOOP
1249: THEN
1250: r>
1251: r> >in ! r> #tib ! r> >tib ! r> blk !
1252: r> loadfile ! r> loadline ! >r ;
1253:
1254: : read-loop ( i*x -- j*x )
1255: BEGIN refill WHILE interpret REPEAT ;
1256:
1257: : include-file ( i*x fid -- j*x )
1258: push-file loadfile !
1259: 0 loadline ! blk off ['] read-loop catch
1260: loadfile @ close-file swap 2dup or
1261: pop-file drop throw throw ;
1262:
1263: create pathfilenamebuf 256 chars allot \ !! make this grow on demand
1264:
1265: \ : check-file-prefix ( addr len -- addr' len' flag )
1266: \ dup 0= IF true EXIT THEN
1267: \ over c@ '/ = IF true EXIT THEN
1268: \ over 2 S" ./" compare 0= IF true EXIT THEN
1269: \ over 3 S" ../" compare 0= IF true EXIT THEN
1270: \ over 2 S" ~/" compare 0=
1271: \ IF 1 /string
1272: \ S" HOME" getenv tuck pathfilenamebuf swap move
1273: \ 2dup + >r pathfilenamebuf + swap move
1274: \ pathfilenamebuf r> true
1275: \ ELSE false
1276: \ THEN ;
1277:
1278: : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
1279: \ opens a file for reading, searching in the path for it (unless
1280: \ the filename contains a slash); c-addr2 u2 is the full filename
1281: \ (valid until the next call); if the file is not found (or in
1282: \ case of other errors for each try), -38 (non-existant file) is
1283: \ thrown. Opening for other access modes makes little sense, as
1284: \ the path will usually contain dirs that are only readable for
1285: \ the user
1286: \ !! use file-status to determine access mode?
1287: 2dup [char] / scan nip ( 0<> )
1288: if \ the filename contains a slash
1289: 2dup r/o open-file throw ( c-addr1 u1 file-id )
1290: -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
1291: pathfilenamebuf r> EXIT
1292: then
1293: pathdirs 2@ 0
1294: \ check-file-prefix 0=
1295: \ IF pathdirs 2@ 0
1296: ?DO ( c-addr1 u1 dirnamep )
1297: dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
1298: 2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
1299: pathfilenamebuf over r> + dup >r r/o open-file 0=
1300: IF ( addr u file-id )
1301: nip nip r> rdrop 0 LEAVE
1302: THEN
1303: rdrop drop r> cell+ cell+
1304: LOOP
1305: \ ELSE 2dup open-file throw -rot THEN
1306: 0<> -&38 and throw ( file-id u2 )
1307: pathfilenamebuf swap ;
1308:
1309: create included-files 0 , 0 , ( pointer to and count of included files )
1310:
1311: : included? ( c-addr u -- f )
1312: \ true, iff filename c-addr u is in included-files
1313: included-files 2@ 0
1314: ?do ( c-addr u addr )
1315: dup >r 2@ 2over compare 0=
1316: if
1317: 2drop rdrop unloop
1318: true EXIT
1319: then
1320: r> cell+ cell+
1321: loop
1322: 2drop drop false ;
1323:
1324: : add-included-file ( c-addr u -- )
1325: \ add name c-addr u to included-files
1326: included-files 2@ tuck 1+ 2* cells resize throw
1327: swap 2dup 1+ included-files 2!
1328: 2* cells + 2! ;
1329:
1330: : save-string ( addr1 u -- addr2 u )
1331: swap >r
1332: dup allocate throw
1333: swap 2dup r> -rot move ;
1334:
1335: : included1 ( i*x file-id c-addr u -- j*x )
1336: \ include the file file-id with the name given by c-addr u
1337: loadfilename 2@ >r >r
1338: save-string 2dup loadfilename 2! add-included-file ( file-id )
1339: ['] include-file catch
1340: r> r> loadfilename 2! throw ;
1341:
1342: : included ( i*x addr u -- j*x )
1343: open-path-file included1 ;
1344:
1345: : required ( i*x addr u -- j*x )
1346: \ include the file with the name given by addr u, if it is not
1347: \ included already. Currently this works by comparing the name of
1348: \ the file (with path) against the names of earlier included
1349: \ files; however, it would probably be better to fstat the file,
1350: \ and compare the device and inode. The advantages would be: no
1351: \ problems with several paths to the same file (e.g., due to
1352: \ links) and we would catch files included with include-file and
1353: \ write a require-file.
1354: open-path-file 2dup included?
1355: if
1356: 2drop close-file throw
1357: else
1358: included1
1359: then ;
1360:
1361: \ HEX DECIMAL 2may93jaw
1362:
1363: : decimal a base ! ;
1364: : hex 10 base ! ;
1365:
1366: \ DEPTH 9may93jaw
1367:
1368: : depth ( -- +n ) sp@ s0 @ swap - cell / ;
1369: : clearstack ( ... -- ) s0 @ sp! ;
1370:
1371: \ INCLUDE 9may93jaw
1372:
1373: : include ( "file" -- )
1374: name included ;
1375:
1376: : require ( "file" -- )
1377: name required ;
1378:
1379: \ RECURSE 17may93jaw
1380:
1381: : recurse ( -- )
1382: lastxt compile, ; immediate restrict
1383: : recursive ( -- )
1384: reveal last off ; immediate
1385:
1386: \ */MOD */ 17may93jaw
1387:
1388: \ !! I think */mod should have the same rounding behaviour as / - anton
1389: : */mod >r m* r> sm/rem ;
1390:
1391: : */ */mod nip ;
1392:
1393: \ EVALUATE 17may93jaw
1394:
1395: : evaluate ( c-addr len -- )
1396: push-file dup #tib ! >tib @ swap move
1397: >in off blk off loadfile off -1 loadline !
1398:
1399: \ BEGIN interpret >in @ #tib @ u>= UNTIL
1400: ['] interpret catch
1401: pop-file throw ;
1402:
1403:
1404: : abort -1 throw ;
1405:
1406: \+ environment? true ENV" CORE"
1407: \ core wordset is now complete!
1408:
1409: \ Quit 13feb93py
1410:
1411: Defer 'quit
1412: Defer .status
1413: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
1414: : (quit) BEGIN .status cr query interpret prompt AGAIN ;
1415: ' (quit) IS 'quit
1416:
1417: \ DOERROR (DOERROR) 13jun93jaw
1418:
1419: 8 Constant max-errors
1420: Variable error-stack 0 error-stack !
1421: max-errors 6 * cells allot
1422: \ format of one cell:
1423: \ source ( addr u )
1424: \ >in
1425: \ line-number
1426: \ Loadfilename ( addr u )
1427:
1428: : dec. ( n -- )
1429: \ print value in decimal representation
1430: base @ decimal swap . base ! ;
1431:
1432: : typewhite ( addr u -- )
1433: \ like type, but white space is printed instead of the characters
1434: bounds ?do
1435: i c@ 9 = if \ check for tab
1436: 9
1437: else
1438: bl
1439: then
1440: emit
1441: loop
1442: ;
1443:
1444: DEFER DOERROR
1445:
1446: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
1447: cr error-stack @
1448: IF
1449: ." in file included from "
1450: type ." :" dec. drop 2drop
1451: ELSE
1452: type ." :" dec.
1453: cr dup 2over type cr drop
1454: nip -trailing 1- ( line-start index2 )
1455: 0 >r BEGIN
1456: 2dup + c@ bl > WHILE
1457: r> 1+ >r 1- dup 0< UNTIL THEN 1+
1458: ( line-start index1 )
1459: typewhite
1460: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
1461: [char] ^ emit
1462: loop
1463: THEN
1464: ;
1465:
1466: : (DoError) ( throw-code -- )
1467: loadline @ IF
1468: source >in @ loadline @ 0 0 .error-frame
1469: THEN
1470: error-stack @ 0 ?DO
1471: -1 error-stack +!
1472: error-stack dup @ 6 * cells + cell+
1473: 6 cells bounds DO
1474: I @
1475: cell +LOOP
1476: .error-frame
1477: LOOP
1478: dup -2 =
1479: IF
1480: "error @ ?dup
1481: IF
1482: cr count type
1483: THEN
1484: drop
1485: ELSE
1486: .error
1487: THEN
1488: normal-dp dpp ! ;
1489:
1490: ' (DoError) IS DoError
1491:
1492: : quit r0 @ rp! handler off >tib @ >r
1493: BEGIN
1494: postpone [
1495: ['] 'quit CATCH dup
1496: WHILE
1497: DoError r@ >tib !
1498: REPEAT
1499: drop r> >tib ! ;
1500:
1501: \ Cold 13feb93py
1502:
1503: \ : .name ( name -- ) cell+ count $1F and type space ;
1504: \ : words listwords @
1505: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
1506:
1507: : cstring>sstring ( cstring -- addr n ) -1 0 scan 0 swap 1+ /string ;
1508: : arg ( n -- addr count ) cells argv @ + @ cstring>sstring ;
1509: : #! postpone \ ; immediate
1510:
1511: Create pathstring 2 cells allot \ string
1512: Create pathdirs 2 cells allot \ dir string array, pointer and count
1513: Variable argv
1514: Variable argc
1515:
1516: 0 Value script? ( -- flag )
1517:
1518: : process-path ( addr1 u1 -- addr2 u2 )
1519: \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
1520: here >r
1521: BEGIN
1522: over >r [char] : scan
1523: over r> tuck - ( rest-str this-str )
1524: dup
1525: IF
1526: 2dup 1- chars + c@ [char] / <>
1527: IF
1528: 2dup chars + [char] / swap c!
1529: 1+
1530: THEN
1531: 2,
1532: ELSE
1533: 2drop
1534: THEN
1535: dup
1536: WHILE
1537: 1 /string
1538: REPEAT
1539: 2drop
1540: here r> tuck - 2 cells / ;
1541:
1542: : do-option ( addr1 len1 addr2 len2 -- n )
1543: 2swap
1544: 2dup s" -e" compare 0= >r
1545: 2dup s" --evaluate" compare 0= r> or
1546: IF 2drop dup >r ['] evaluate catch
1547: ?dup IF dup >r DoError r> negate (bye) THEN
1548: r> >tib +! 2 EXIT THEN
1549: ." Unknown option: " type cr 2drop 1 ;
1550:
1551: : process-args ( -- )
1552: >tib @ >r
1553: argc @ 1
1554: ?DO
1555: I arg over c@ [char] - <>
1556: IF
1557: required 1
1558: ELSE
1559: I 1+ argc @ = IF s" " ELSE I 1+ arg THEN
1560: do-option
1561: THEN
1562: +LOOP
1563: r> >tib ! ;
1564:
1565: Defer 'cold ' noop IS 'cold
1566:
1567: : cold ( -- )
1568: pathstring 2@ process-path pathdirs 2!
1569: 0 0 included-files 2!
1570: 'cold
1571: argc @ 1 >
1572: IF
1573: true to script?
1574: ['] process-args catch ?dup
1575: IF
1576: dup >r DoError cr r> negate (bye)
1577: THEN
1578: cr
1579: THEN
1580: false to script?
1581: ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
1582: ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
1583: ." Type `bye' to exit"
1584: loadline off quit ;
1585:
1586: : license ( -- ) cr
1587: ." This program is free software; you can redistribute it and/or modify" cr
1588: ." it under the terms of the GNU General Public License as published by" cr
1589: ." the Free Software Foundation; either version 2 of the License, or" cr
1590: ." (at your option) any later version." cr cr
1591:
1592: ." This program is distributed in the hope that it will be useful," cr
1593: ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
1594: ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
1595: ." GNU General Public License for more details." cr cr
1596:
1597: ." You should have received a copy of the GNU General Public License" cr
1598: ." along with this program; if not, write to the Free Software" cr
1599: ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
1600:
1601: : boot ( path **argv argc -- )
1602: argc ! argv ! cstring>sstring pathstring 2! main-task up!
1603: sp@ dup s0 ! $10 + >tib ! #tib off >in off
1604: rp@ r0 ! fp@ f0 ! cold ;
1605:
1606: : bye script? 0= IF cr THEN 0 (bye) ;
1607:
1608: \ **argv may be scanned by the C starter to get some important
1609: \ information, as -display and -geometry for an X client FORTH
1610: \ or space and stackspace overrides
1611:
1612: \ 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