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