1: \ kernel.fs GForth kernel 17dec92py
2:
3: \ Copyright (C) 1995 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: \ Idea and implementation: Bernd Paysan (py)
22:
23: HEX
24:
25: \ labels for some code addresses
26:
27: : docon: ( -- addr ) \ gforth
28: \G the code address of a @code{CONSTANT}
29: ['] bl >code-address ;
30:
31: : docol: ( -- addr ) \ gforth
32: \G the code address of a colon definition
33: ['] docon: >code-address ;
34:
35: : dovar: ( -- addr ) \ gforth
36: \G the code address of a @code{CREATE}d word
37: ['] udp >code-address ;
38:
39: : douser: ( -- addr ) \ gforth
40: \G the code address of a @code{USER} variable
41: ['] s0 >code-address ;
42:
43: : dodefer: ( -- addr ) \ gforth
44: \G the code address of a @code{defer}ed word
45: ['] source >code-address ;
46:
47: : dofield: ( -- addr ) \ gforth
48: \G the code address of a @code{field}
49: ['] reveal-method >code-address ;
50:
51: NIL AConstant NIL \ gforth
52:
53: \ Aliases
54:
55: ' i Alias r@
56:
57: \ Bit string manipulation 06oct92py
58:
59: \ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
60: \ DOES> ( n -- ) + c@ ;
61:
62: \ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
63: \ : +bit ( addr n -- ) >bit over c@ or swap c! ;
64:
65: \ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ;
66: \ : >rel ( addr -- n ) forthstart - ;
67: \ : relon ( addr -- ) relinfo swap >rel cell / +bit ;
68:
69: \ here allot , c, A, 17dec92py
70:
71: : dp ( -- addr ) \ gforth
72: dpp @ ;
73: : here ( -- here ) \ core
74: dp @ ;
75: : allot ( n -- ) \ core
76: dp +! ;
77: : c, ( c -- ) \ core
78: here 1 chars allot c! ;
79: : , ( x -- ) \ core
80: here cell allot ! ;
81: : 2, ( w1 w2 -- ) \ gforth
82: here 2 cells allot 2! ;
83:
84: \ : aligned ( addr -- addr' ) \ core
85: \ [ cell 1- ] Literal + [ -1 cells ] Literal and ;
86: : align ( -- ) \ core
87: here dup aligned swap ?DO bl c, LOOP ;
88:
89: \ : faligned ( addr -- f-addr ) \ float
90: \ [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
91:
92: : falign ( -- ) \ float
93: here dup faligned swap
94: ?DO
95: bl c,
96: LOOP ;
97:
98: \ !! this is machine-dependent, but works on all but the strangest machines
99:
100: : maxaligned ( addr -- f-addr ) \ float
101: [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
102: : maxalign ( -- ) \ float
103: here dup maxaligned swap
104: ?DO
105: bl c,
106: LOOP ;
107:
108: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
109: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
110: \ the code field is aligned if its body is maxaligned
111: ' maxalign Alias cfalign ( -- ) \ gforth
112:
113: : chars ( n1 -- n2 ) \ core
114: ; immediate
115:
116:
117: \ : A! ( addr1 addr2 -- ) \ gforth
118: \ dup relon ! ;
119: \ : A, ( addr -- ) \ gforth
120: \ here cell allot A! ;
121: ' ! alias A! ( addr1 addr2 -- ) \ gforth
122: ' , alias A, ( addr -- ) \ gforth
123:
124:
125: \ on off 23feb93py
126:
127: : on ( addr -- ) \ gforth
128: true swap ! ;
129: : off ( addr -- ) \ gforth
130: false swap ! ;
131:
132: \ dabs roll 17may93jaw
133:
134: : dabs ( d1 -- d2 ) \ double
135: dup 0< IF dnegate THEN ;
136:
137: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
138: dup 1+ pick >r
139: cells sp@ cell+ dup cell+ rot move drop r> ;
140:
141: \ name> found 17dec92py
142:
143: $80 constant alias-mask \ set when the word is not an alias!
144: $40 constant immediate-mask
145: $20 constant restrict-mask
146:
147: : ((name>)) ( nfa -- cfa )
148: name>string + cfaligned ;
149:
150: : (name>x) ( nfa -- cfa b )
151: \ cfa is an intermediate cfa and b is the flags byte of nfa
152: dup ((name>))
153: swap cell+ c@ dup alias-mask and 0=
154: IF
155: swap @ swap
156: THEN ;
157:
158: \ place bounds 13feb93py
159:
160: : place ( addr len to -- ) \ gforth
161: over >r rot over 1+ r> move c! ;
162: : bounds ( beg count -- end beg ) \ gforth
163: over + swap ;
164:
165: \ input stream primitives 23feb93py
166:
167: : tib ( -- c-addr ) \ core-ext
168: \ obsolescent
169: >tib @ ;
170: Defer source ( -- addr count ) \ core
171: \ used by dodefer:, must be defer
172: : (source) ( -- addr count )
173: tib #tib @ ;
174: ' (source) IS source
175:
176: \ (word) 22feb93py
177:
178: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
179: \ skip all characters not equal to char
180: >r
181: BEGIN
182: dup
183: WHILE
184: over c@ r@ <>
185: WHILE
186: 1 /string
187: REPEAT THEN
188: rdrop ;
189: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
190: \ skip all characters equal to char
191: >r
192: BEGIN
193: dup
194: WHILE
195: over c@ r@ =
196: WHILE
197: 1 /string
198: REPEAT THEN
199: rdrop ;
200:
201: : (word) ( addr1 n1 char -- addr2 n2 )
202: dup >r skip 2dup r> scan nip - ;
203:
204: \ (word) should fold white spaces
205: \ this is what (parse-white) does
206:
207: \ word parse 23feb93py
208:
209: : parse-word ( char -- addr len ) \ gforth
210: source 2dup >r >r >in @ over min /string
211: rot dup bl = IF drop (parse-white) ELSE (word) THEN
212: 2dup + r> - 1+ r> min >in ! ;
213: : word ( char -- addr ) \ core
214: parse-word here place bl here count + c! here ;
215:
216: : parse ( char -- addr len ) \ core-ext
217: >r source >in @ over min /string over swap r> scan >r
218: over - dup r> IF 1+ THEN >in +! ;
219:
220: \ name 13feb93py
221:
222: : capitalize ( addr len -- addr len ) \ gforth
223: 2dup chars chars bounds
224: ?DO I c@ toupper I c! 1 chars +LOOP ;
225: : (name) ( -- c-addr count )
226: source 2dup >r >r >in @ /string (parse-white)
227: 2dup + r> - 1+ r> min >in ! ;
228: \ name count ;
229:
230: : name-too-short? ( c-addr u -- c-addr u )
231: dup 0= -&16 and throw ;
232:
233: : name-too-long? ( c-addr u -- c-addr u )
234: dup $1F u> -&19 and throw ;
235:
236: \ Literal 17dec92py
237:
238: : Literal ( compilation n -- ; run-time -- n ) \ core
239: postpone lit , ; immediate restrict
240: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
241: postpone lit A, ; immediate restrict
242:
243: : char ( 'char' -- n ) \ core
244: bl word char+ c@ ;
245: : [char] ( compilation 'char' -- ; run-time -- n )
246: char postpone Literal ; immediate restrict
247:
248: : (compile) ( -- ) \ gforth
249: r> dup cell+ >r @ compile, ;
250:
251: : postpone, ( w xt -- )
252: \g Compiles the compilation semantics represented by @var{w xt}.
253: dup ['] execute =
254: if
255: drop compile,
256: else
257: dup ['] compile, =
258: if
259: drop POSTPONE (compile) compile,
260: else
261: swap POSTPONE aliteral compile,
262: then
263: then ;
264:
265: : POSTPONE ( "name" -- ) \ core
266: \g Compiles the compilation semantics of @var{name}.
267: COMP' postpone, ; immediate restrict
268:
269: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
270: Create immediate swap A, A,
271: DOES>
272: abort" executed primary cfa of an interpret/compile: word" ;
273: \ state @ IF cell+ THEN perform ;
274:
275: \ Use (compile) for the old behavior of compile!
276:
277: \ digit? 17dec92py
278:
279: : digit? ( char -- digit true/ false ) \ gforth
280: base @ $100 =
281: IF
282: true EXIT
283: THEN
284: toupper [char] 0 - dup 9 u> IF
285: [ 'A '9 1 + - ] literal -
286: dup 9 u<= IF
287: drop false EXIT
288: THEN
289: THEN
290: dup base @ u>= IF
291: drop false EXIT
292: THEN
293: true ;
294:
295: : accumulate ( +d0 addr digit - +d1 addr )
296: swap >r swap base @ um* drop rot base @ um* d+ r> ;
297:
298: : >number ( d addr count -- d addr count ) \ core
299: 0
300: ?DO
301: count digit?
302: WHILE
303: accumulate
304: LOOP
305: 0
306: ELSE
307: 1- I' I -
308: UNLOOP
309: THEN ;
310:
311: \ number? number 23feb93py
312:
313: Create bases 10 , 2 , A , 100 ,
314: \ 16 2 10 character
315: \ !! this saving and restoring base is an abomination! - anton
316: : getbase ( addr u -- addr' u' )
317: over c@ [char] $ - dup 4 u<
318: IF
319: cells bases + @ base ! 1 /string
320: ELSE
321: drop
322: THEN ;
323: : s>number ( addr len -- d )
324: base @ >r dpl on
325: over c@ '- = dup >r
326: IF
327: 1 /string
328: THEN
329: getbase dpl on 0 0 2swap
330: BEGIN
331: dup >r >number dup
332: WHILE
333: dup r> -
334: WHILE
335: dup dpl ! over c@ [char] . =
336: WHILE
337: 1 /string
338: REPEAT THEN
339: 2drop rdrop dpl off
340: ELSE
341: 2drop rdrop r>
342: IF
343: dnegate
344: THEN
345: THEN
346: r> base ! ;
347:
348: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
349: s>number dpl @ 0=
350: IF
351: 2drop false EXIT
352: THEN
353: dpl @ dup 0> 0= IF
354: nip
355: THEN ;
356: : number? ( string -- string 0 / n -1 / d 0> )
357: dup >r count snumber? dup if
358: rdrop
359: else
360: r> swap
361: then ;
362: : s>d ( n -- d ) \ core s-to-d
363: dup 0< ;
364: : number ( string -- d )
365: number? ?dup 0= abort" ?" 0<
366: IF
367: s>d
368: THEN ;
369:
370: \ space spaces ud/mod 21mar93py
371: decimal
372: Create spaces ( u -- ) \ core
373: bl 80 times \ times from target compiler! 11may93jaw
374: DOES> ( u -- )
375: swap
376: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
377: Create backspaces
378: 08 80 times \ times from target compiler! 11may93jaw
379: DOES> ( u -- )
380: swap
381: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
382: hex
383: : space ( -- ) \ core
384: 1 spaces ;
385:
386: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
387: >r 0 r@ um/mod r> swap >r
388: um/mod r> ;
389:
390: : pad ( -- addr ) \ core-ext
391: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
392:
393: \ hold <# #> sign # #s 25jan92py
394:
395: : hold ( char -- ) \ core
396: pad cell - -1 chars over +! @ c! ;
397:
398: : <# ( -- ) \ core less-number-sign
399: pad cell - dup ! ;
400:
401: : #> ( xd -- addr u ) \ core number-sign-greater
402: 2drop pad cell - dup @ tuck - ;
403:
404: : sign ( n -- ) \ core
405: 0< IF [char] - hold THEN ;
406:
407: : # ( ud1 -- ud2 ) \ core number-sign
408: base @ 2 max ud/mod rot 9 over <
409: IF
410: [ char A char 9 - 1- ] Literal +
411: THEN
412: [char] 0 + hold ;
413:
414: : #s ( +d -- 0 0 ) \ core number-sign-s
415: BEGIN
416: # 2dup or 0=
417: UNTIL ;
418:
419: \ print numbers 07jun92py
420:
421: : d.r ( d n -- ) \ double d-dot-r
422: >r tuck dabs <# #s rot sign #>
423: r> over - spaces type ;
424:
425: : ud.r ( ud n -- ) \ gforth u-d-dot-r
426: >r <# #s #> r> over - spaces type ;
427:
428: : .r ( n1 n2 -- ) \ core-ext dot-r
429: >r s>d r> d.r ;
430: : u.r ( u n -- ) \ core-ext u-dot-r
431: 0 swap ud.r ;
432:
433: : d. ( d -- ) \ double d-dot
434: 0 d.r space ;
435: : ud. ( ud -- ) \ gforth u-d-dot
436: 0 ud.r space ;
437:
438: : . ( n -- ) \ core dot
439: s>d d. ;
440: : u. ( u -- ) \ core u-dot
441: 0 ud. ;
442:
443: \ catch throw 23feb93py
444: \ bounce 08jun93jaw
445:
446: \ !! allow the user to add rollback actions anton
447: \ !! use a separate exception stack? anton
448:
449: has-locals [IF]
450: : lp@ ( -- addr ) \ gforth l-p-fetch
451: laddr# [ 0 , ] ;
452: [THEN]
453:
454: Defer 'catch
455: Defer 'throw
456:
457: ' noop IS 'catch
458: ' noop IS 'throw
459:
460: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
461: 'catch
462: sp@ >r
463: [ has-floats [IF] ]
464: fp@ >r
465: [ [THEN] ]
466: [ has-locals [IF] ]
467: lp@ >r
468: [ [THEN] ]
469: handler @ >r
470: rp@ handler !
471: execute
472: r> handler ! rdrop rdrop rdrop 0 ;
473:
474: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
475: ?DUP IF
476: [ here 9 cells ! ] \ entry point for signal handler
477: handler @ dup 0= IF
478: [ has-os [IF] ]
479: 2 (bye)
480: [ [ELSE] ]
481: quit
482: [ [THEN] ]
483: THEN
484: rp!
485: r> handler !
486: [ has-locals [IF] ]
487: r> lp!
488: [ [THEN] ]
489: [ has-floats [IF] ]
490: r> fp!
491: [ [THEN] ]
492: r> swap >r sp! drop r>
493: 'throw
494: THEN ;
495:
496: \ Bouncing is very fine,
497: \ programming without wasting time... jaw
498: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
499: \ a throw without data or fp stack restauration
500: ?DUP IF
501: handler @ rp!
502: r> handler !
503: [ has-locals [IF] ]
504: r> lp!
505: [ [THEN] ]
506: [ has-floats [IF] ]
507: rdrop
508: [ [THEN] ]
509: rdrop
510: 'throw
511: THEN ;
512:
513: \ ?stack 23feb93py
514:
515: : ?stack ( ?? -- ?? ) \ gforth
516: sp@ s0 @ u> IF -4 throw THEN
517: [ has-floats [IF] ]
518: fp@ f0 @ u> IF -&45 throw THEN
519: [ [THEN] ]
520: ;
521: \ ?stack should be code -- it touches an empty stack!
522:
523: \ interpret 10mar92py
524:
525: Defer parser
526: Defer name ( -- c-addr count ) \ gforth
527: \ get the next word from the input buffer
528: ' (name) IS name
529: Defer compiler-notfound ( c-addr count -- )
530: Defer interpreter-notfound ( c-addr count -- )
531:
532: : no.extensions ( addr u -- )
533: 2drop -&13 bounce ;
534: ' no.extensions IS compiler-notfound
535: ' no.extensions IS interpreter-notfound
536:
537: : compile-only-error ( ... -- )
538: -&14 throw ;
539:
540: : interpret ( ?? -- ?? ) \ gforth
541: \ interpret/compile the (rest of the) input buffer
542: BEGIN
543: ?stack name dup
544: WHILE
545: parser
546: REPEAT
547: 2drop ;
548:
549: \ interpreter compiler 30apr92py
550:
551: \ not the most efficient implementations of interpreter and compiler
552: : interpreter ( c-addr u -- )
553: 2dup find-name dup
554: if
555: nip nip name>int execute
556: else
557: drop
558: 2dup 2>r snumber?
559: IF
560: 2rdrop
561: ELSE
562: 2r> interpreter-notfound
563: THEN
564: then ;
565:
566: : compiler ( c-addr u -- )
567: 2dup find-name dup
568: if ( c-addr u nt )
569: nip nip name>comp execute
570: else
571: drop
572: 2dup snumber? dup
573: IF
574: 0>
575: IF
576: swap postpone Literal
577: THEN
578: postpone Literal
579: 2drop
580: ELSE
581: drop compiler-notfound
582: THEN
583: then ;
584:
585: ' interpreter IS parser
586:
587: : [ ( -- ) \ core left-bracket
588: ['] interpreter IS parser state off ; immediate
589: : ] ( -- ) \ core right-bracket
590: ['] compiler IS parser state on ;
591:
592: \ Strings 22feb93py
593:
594: : ," ( "string"<"> -- ) [char] " parse
595: here over char+ allot place align ;
596: : "lit ( -- addr )
597: r> r> dup count + aligned >r swap >r ;
598: : (.") "lit count type ;
599: : (S") "lit count ;
600: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
601: postpone (S") here over char+ allot place align ;
602: immediate restrict
603: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
604: [char] ) parse 2drop ; immediate
605:
606: : \ ( -- ) \ core-ext backslash
607: blk @
608: IF
609: >in @ c/l / 1+ c/l * >in !
610: EXIT
611: THEN
612: source >in ! drop ; immediate
613:
614: : \G ( -- ) \ gforth backslash
615: POSTPONE \ ; immediate
616:
617: \ error handling 22feb93py
618: \ 'abort thrown out! 11may93jaw
619:
620: : (abort")
621: "lit >r
622: IF
623: r> "error ! -2 throw
624: THEN
625: rdrop ;
626: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
627: postpone (abort") ," ; immediate restrict
628:
629: \ Header states 23feb93py
630:
631: : cset ( bmask c-addr -- )
632: tuck c@ or swap c! ;
633: : creset ( bmask c-addr -- )
634: tuck c@ swap invert and swap c! ;
635: : ctoggle ( bmask c-addr -- )
636: tuck c@ xor swap c! ;
637:
638: : lastflags ( -- c-addr )
639: \ the address of the flags byte in the last header
640: \ aborts if the last defined word was headerless
641: last @ dup 0= abort" last word was headerless" cell+ ;
642:
643: : immediate ( -- ) \ core
644: immediate-mask lastflags cset ;
645: : restrict ( -- ) \ gforth
646: restrict-mask lastflags cset ;
647: ' restrict alias compile-only ( -- ) \ gforth
648:
649: \ Header 23feb93py
650:
651: \ input-stream, nextname and noname are quite ugly (passing
652: \ information through global variables), but they are useful for dealing
653: \ with existing/independent defining words
654:
655: defer (header)
656: defer header ( -- ) \ gforth
657: ' (header) IS header
658:
659: : string, ( c-addr u -- ) \ gforth
660: \G puts down string as cstring
661: dup c, here swap chars dup allot move ;
662:
663: : header, ( c-addr u -- ) \ gforth
664: name-too-long?
665: align here last !
666: current @ 1 or A, \ link field; before revealing, it contains the
667: \ tagged reveal-into wordlist
668: string, cfalign
669: alias-mask lastflags cset ;
670:
671: : input-stream-header ( "name" -- )
672: name name-too-short? header, ;
673: : input-stream ( -- ) \ general
674: \G switches back to getting the name from the input stream ;
675: ['] input-stream-header IS (header) ;
676:
677: ' input-stream-header IS (header)
678:
679: \ !! make that a 2variable
680: create nextname-buffer 32 chars allot
681:
682: : nextname-header ( -- )
683: nextname-buffer count header,
684: input-stream ;
685:
686: \ the next name is given in the string
687: : nextname ( c-addr u -- ) \ gforth
688: name-too-long?
689: nextname-buffer c! ( c-addr )
690: nextname-buffer count move
691: ['] nextname-header IS (header) ;
692:
693: : noname-header ( -- )
694: 0 last ! cfalign
695: input-stream ;
696:
697: : noname ( -- ) \ gforth
698: \ the next defined word remains anonymous. The xt of that word is given by lastxt
699: ['] noname-header IS (header) ;
700:
701: : lastxt ( -- xt ) \ gforth
702: \ 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
703: lastcfa @ ;
704:
705: : Alias ( cfa "name" -- ) \ gforth
706: Header reveal
707: alias-mask lastflags creset
708: dup A, lastcfa ! ;
709:
710: : name>string ( nt -- addr count ) \ gforth name-to-string
711: \g @var{addr count} is the name of the word represented by @var{nt}.
712: cell+ count $1F and ;
713:
714: Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
715: : >name ( cfa -- nt ) \ gforth to-name
716: $21 cell do
717: dup i - count $9F and + cfaligned over alias-mask + = if
718: i - cell - unloop exit
719: then
720: cell +loop
721: drop ??? ( wouldn't 0 be better? ) ;
722:
723: \ threading 17mar93py
724:
725: : cfa, ( code-address -- ) \ gforth cfa-comma
726: here
727: dup lastcfa !
728: 0 A, 0 , code-address! ;
729: : compile, ( xt -- ) \ core-ext compile-comma
730: A, ;
731: : !does ( addr -- ) \ gforth store-does
732: lastxt does-code! ;
733: : (does>) ( R: addr -- )
734: r> /does-handler + !does ;
735: : dodoes, ( -- )
736: here /does-handler allot does-handler! ;
737:
738: : Create ( "name" -- ) \ core
739: Header reveal dovar: cfa, ;
740:
741: \ Create Variable User Constant 17mar93py
742:
743: : Variable ( "name" -- ) \ core
744: Create 0 , ;
745: : AVariable ( "name" -- ) \ gforth
746: Create 0 A, ;
747: : 2VARIABLE ( "name" -- ) \ double
748: create 0 , 0 , ;
749:
750: : User ( "name" -- ) \ gforth
751: Variable ;
752: : AUser ( "name" -- ) \ gforth
753: AVariable ;
754:
755: : (Constant) Header reveal docon: cfa, ;
756: : Constant ( w "name" -- ) \ core
757: \G Defines constant @var{name}
758: \G
759: \G @var{name} execution: @var{-- w}
760: (Constant) , ;
761: : AConstant ( addr "name" -- ) \ gforth
762: (Constant) A, ;
763:
764: : 2Constant ( w1 w2 "name" -- ) \ double
765: Create ( w1 w2 "name" -- )
766: 2,
767: DOES> ( -- w1 w2 )
768: 2@ ;
769:
770: \ IS Defer What's Defers TO 24feb93py
771:
772: : Defer ( "name" -- ) \ gforth
773: \ !! shouldn't it be initialized with abort or something similar?
774: Header Reveal dodefer: cfa,
775: ['] noop A, ;
776: \ Create ( -- )
777: \ ['] noop A,
778: \ DOES> ( ??? )
779: \ perform ;
780:
781: : Defers ( "name" -- ) \ gforth
782: ' >body @ compile, ; immediate
783:
784: \ : ; 24feb93py
785:
786: defer :-hook ( sys1 -- sys2 )
787: defer ;-hook ( sys2 -- sys1 )
788:
789: : : ( "name" -- colon-sys ) \ core colon
790: Header docol: cfa, defstart ] :-hook ;
791: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon
792: ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
793:
794: : :noname ( -- xt colon-sys ) \ core-ext colon-no-name
795: 0 last !
796: cfalign here docol: cfa, 0 ] :-hook ;
797:
798: \ Search list handling 23feb93py
799:
800: AVariable current ( -- addr ) \ gforth
801:
802: : last? ( -- false / nfa nfa )
803: last @ ?dup ;
804: : (reveal) ( nt wid -- )
805: ( wid>wordlist-id ) dup >r
806: @ over ( name>link ) !
807: r> ! ;
808:
809: \ object oriented search list 17mar93py
810:
811: \ word list structure:
812:
813: struct
814: 1 cells: field find-method \ xt: ( c_addr u wid -- nt )
815: 1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
816: 1 cells: field rehash-method \ xt: ( wid -- )
817: \ \ !! what else
818: end-struct wordlist-map-struct
819:
820: struct
821: 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
822: 1 cells: field wordlist-map \ pointer to a wordlist-map-struct
823: 1 cells: field wordlist-link \ link field to other wordlists
824: 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
825: end-struct wordlist-struct
826:
827: : f83find ( addr len wordlist -- nt / false )
828: ( wid>wordlist-id ) @ (f83find) ;
829:
830: \ Search list table: find reveal
831: Create f83search ( -- wordlist-map )
832: ' f83find A, ' (reveal) A, ' drop A,
833:
834: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
835: AVariable lookup G forth-wordlist lookup T !
836: G forth-wordlist current T !
837:
838: \ higher level parts of find
839:
840: ( struct )
841: 0 >body cell
842: 1 cells: field interpret/compile-int
843: 1 cells: field interpret/compile-comp
844: end-struct interpret/compile-struct
845:
846: : interpret/compile? ( xt -- flag )
847: >does-code ['] S" >does-code = ;
848:
849: : (cfa>int) ( cfa -- xt )
850: dup interpret/compile?
851: if
852: interpret/compile-int @
853: then ;
854:
855: : (x>int) ( cfa b -- xt )
856: \ get interpretation semantics of name
857: restrict-mask and
858: if
859: drop ['] compile-only-error
860: else
861: (cfa>int)
862: then ;
863:
864: : name>int ( nt -- xt ) \ gforth
865: \G @var{xt} represents the interpretation semantics of the word
866: \G @var{nt}. Produces @code{' compile-only-error} if
867: \G @var{nt} is compile-only.
868: (name>x) (x>int) ;
869:
870: : name?int ( nt -- xt ) \ gforth
871: \G Like name>int, but throws an error if compile-only.
872: (name>x) restrict-mask and
873: if
874: compile-only-error \ does not return
875: then
876: (cfa>int) ;
877:
878: : name>comp ( nt -- w xt ) \ gforth
879: \G @var{w xt} is the compilation token for the word @var{nt}.
880: (name>x) >r dup interpret/compile?
881: if
882: interpret/compile-comp @
883: then
884: r> immediate-mask and if
885: ['] execute
886: else
887: ['] compile,
888: then ;
889:
890: : (search-wordlist) ( addr count wid -- nt / false )
891: dup wordlist-map @ find-method perform ;
892:
893: : flag-sign ( f -- 1|-1 )
894: \ true becomes 1, false -1
895: 0= 2* 1+ ;
896:
897: : (name>intn) ( nfa -- xt +-1 )
898: (name>x) tuck (x>int) ( b xt )
899: swap immediate-mask and flag-sign ;
900:
901: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
902: \ xt is the interpretation semantics
903: (search-wordlist) dup if
904: (name>intn)
905: then ;
906:
907: : find-name ( c-addr u -- nt/0 ) \ gforth
908: \g Find the name @var{c-addr u} in the current search
909: \g order. Return its nt, if found, otherwise 0.
910: lookup @ (search-wordlist) ;
911:
912: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
913: find-name dup
914: if ( nt )
915: state @
916: if
917: name>comp ['] execute = flag-sign
918: else
919: (name>intn)
920: then
921: then ;
922:
923: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
924: dup count sfind dup
925: if
926: rot drop
927: then ;
928:
929: : (') ( "name" -- nt ) \ gforth
930: name find-name dup 0=
931: IF
932: drop -&13 bounce
933: THEN ;
934:
935: : [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
936: (') postpone ALiteral ; immediate restrict
937:
938: : ' ( "name" -- xt ) \ core tick
939: \g @var{xt} represents @var{name}'s interpretation
940: \g semantics. Performs @code{-14 throw} if the word has no
941: \g interpretation semantics.
942: (') name?int ;
943: : ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick
944: \g @var{xt} represents @var{name}'s interpretation
945: \g semantics. Performs @code{-14 throw} if the word has no
946: \g interpretation semantics.
947: ' postpone ALiteral ; immediate restrict
948:
949: : COMP' ( "name" -- w xt ) \ gforth c-tick
950: \g @var{w xt} represents @var{name}'s compilation semantics.
951: (') name>comp ;
952: : [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
953: \g @var{w xt} represents @var{name}'s compilation semantics.
954: COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
955:
956: \ reveal words
957:
958: Variable warnings ( -- addr ) \ gforth
959: G -1 warnings T !
960:
961: : check-shadow ( addr count wid -- )
962: \G prints a warning if the string is already present in the wordlist
963: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
964: ." redefined " name>string 2dup type
965: compare 0<> if
966: ." with " type
967: else
968: 2drop
969: then
970: space space EXIT
971: then
972: 2drop 2drop ;
973:
974: : reveal ( -- ) \ gforth
975: last?
976: if \ the last word has a header
977: dup ( name>link ) @ 1 and
978: if \ it is still hidden
979: dup ( name>link ) @ 1 xor ( nt wid )
980: 2dup >r name>string r> check-shadow ( nt wid )
981: dup wordlist-map @ reveal-method perform
982: then
983: then ;
984:
985: : rehash ( wid -- )
986: dup wordlist-map @ rehash-method perform ;
987:
988: \ Input 13feb93py
989:
990: 07 constant #bell ( -- c ) \ gforth
991: 08 constant #bs ( -- c ) \ gforth
992: 09 constant #tab ( -- c ) \ gforth
993: 7F constant #del ( -- c ) \ gforth
994: 0D constant #cr ( -- c ) \ gforth
995: \ the newline key code
996: 0C constant #ff ( -- c ) \ gforth
997: 0A constant #lf ( -- c ) \ gforth
998:
999: : bell #bell emit ;
1000: : cr ( -- ) \ core
1001: \ emit a newline
1002: #lf ( sic! ) emit ;
1003:
1004: \ : backspaces 0 ?DO #bs emit LOOP ;
1005:
1006: : (ins) ( max span addr pos1 key -- max span addr pos2 )
1007: >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
1008: : (bs) ( max span addr pos1 -- max span addr pos2 flag )
1009: dup IF
1010: #bs emit bl emit #bs emit 1- rot 1- -rot
1011: THEN false ;
1012: : (ret) true bl emit ;
1013:
1014: Create ctrlkeys
1015: ] false false false false false false false false
1016: (bs) false (ret) false false (ret) false false
1017: false false false false false false false false
1018: false false false false false false false false [
1019:
1020: defer insert-char
1021: ' (ins) IS insert-char
1022: defer everychar
1023: ' noop IS everychar
1024:
1025: : decode ( max span addr pos1 key -- max span addr pos2 flag )
1026: everychar
1027: dup #del = IF drop #bs THEN \ del is rubout
1028: dup bl < IF cells ctrlkeys + perform EXIT THEN
1029: >r 2over = IF rdrop bell 0 EXIT THEN
1030: r> insert-char 0 ;
1031:
1032: : accept ( addr len -- len ) \ core
1033: dup 0< IF abs over dup 1 chars - c@ tuck type
1034: \ this allows to edit given strings
1035: ELSE 0 THEN rot over
1036: BEGIN key decode UNTIL
1037: 2drop nip ;
1038:
1039: \ Output 13feb93py
1040:
1041: has-os [IF]
1042: 0 Value outfile-id ( -- file-id ) \ gforth
1043:
1044: : (type) ( c-addr u -- ) \ gforth
1045: outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
1046: ;
1047:
1048: : (emit) ( c -- ) \ gforth
1049: outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
1050: ;
1051: [THEN]
1052:
1053: Defer type ( c-addr u -- ) \ core
1054: ' (type) IS Type
1055:
1056: Defer emit ( c -- ) \ core
1057: ' (Emit) IS Emit
1058:
1059: Defer key ( -- c ) \ core
1060: ' (key) IS key
1061:
1062: \ Query 07apr93py
1063:
1064: has-files 0= [IF]
1065: : sourceline# ( -- n ) loadline @ ;
1066: [THEN]
1067:
1068: : refill ( -- flag ) \ core-ext,block-ext,file-ext
1069: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
1070: tib /line
1071: [ has-files [IF] ]
1072: loadfile @ ?dup
1073: IF read-line throw
1074: ELSE
1075: [ [THEN] ]
1076: sourceline# 0< IF 2drop false EXIT THEN
1077: accept true
1078: [ has-files [IF] ]
1079: THEN
1080: [ [THEN] ]
1081: 1 loadline +!
1082: swap #tib ! 0 >in ! ;
1083:
1084: : query ( -- ) \ core-ext
1085: \G obsolescent
1086: blk off loadfile off
1087: tib /line accept #tib ! 0 >in ! ;
1088:
1089: \ save-mem extend-mem
1090:
1091: has-os [IF]
1092: : save-mem ( addr1 u -- addr2 u ) \ gforth
1093: \g copy a memory block into a newly allocated region in the heap
1094: swap >r
1095: dup allocate throw
1096: swap 2dup r> -rot move ;
1097:
1098: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
1099: \ extend memory block allocated from the heap by u aus
1100: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
1101: over >r + dup >r resize throw
1102: r> over r> + -rot ;
1103: [THEN]
1104:
1105: \ HEX DECIMAL 2may93jaw
1106:
1107: : decimal ( -- ) \ core
1108: a base ! ;
1109: : hex ( -- ) \ core-ext
1110: 10 base ! ;
1111:
1112: \ DEPTH 9may93jaw
1113:
1114: : depth ( -- +n ) \ core
1115: sp@ s0 @ swap - cell / ;
1116: : clearstack ( ... -- )
1117: s0 @ sp! ;
1118:
1119: \ RECURSE 17may93jaw
1120:
1121: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
1122: lastxt compile, ; immediate restrict
1123: ' reveal alias recursive ( -- ) \ gforth
1124: immediate
1125:
1126: \ */MOD */ 17may93jaw
1127:
1128: \ !! I think */mod should have the same rounding behaviour as / - anton
1129: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
1130: >r m* r> sm/rem ;
1131:
1132: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
1133: */mod nip ;
1134:
1135: \ EVALUATE 17may93jaw
1136:
1137: has-files 0= [IF]
1138: : push-file ( -- ) r>
1139: sourceline# >r tibstack @ >r >tib @ >r #tib @ >r
1140: >tib @ tibstack @ = IF r@ tibstack +! THEN
1141: tibstack @ >tib ! >in @ >r >r ;
1142:
1143: : pop-file ( throw-code -- throw-code )
1144: r>
1145: r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> loadline ! >r ;
1146: [THEN]
1147:
1148: : evaluate ( c-addr len -- ) \ core,block
1149: push-file #tib ! >tib !
1150: >in off blk off loadfile off -1 loadline !
1151: ['] interpret catch
1152: pop-file throw ;
1153:
1154: : abort ( ?? -- ?? ) \ core,exception-ext
1155: -1 throw ;
1156:
1157: \+ environment? true ENV" CORE"
1158: \ core wordset is now complete!
1159:
1160: \ Quit 13feb93py
1161:
1162: Defer 'quit
1163: Defer .status
1164: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
1165: : (Query) ( -- )
1166: loadfile off blk off refill drop ;
1167: : (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
1168: ' (quit) IS 'quit
1169:
1170: \ DOERROR (DOERROR) 13jun93jaw
1171:
1172: 8 Constant max-errors
1173: Variable error-stack 0 error-stack !
1174: max-errors 6 * cells allot
1175: \ format of one cell:
1176: \ source ( addr u )
1177: \ >in
1178: \ line-number
1179: \ Loadfilename ( addr u )
1180:
1181: : dec. ( n -- ) \ gforth
1182: \ print value in decimal representation
1183: base @ decimal swap . base ! ;
1184:
1185: : hex. ( u -- ) \ gforth
1186: \ print value as unsigned hex number
1187: '$ emit base @ swap hex u. base ! ;
1188:
1189: : typewhite ( addr u -- ) \ gforth
1190: \ like type, but white space is printed instead of the characters
1191: bounds ?do
1192: i c@ #tab = if \ check for tab
1193: #tab
1194: else
1195: bl
1196: then
1197: emit
1198: loop ;
1199:
1200: DEFER DOERROR
1201:
1202: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
1203: cr error-stack @
1204: IF
1205: ." in file included from "
1206: type ." :" dec. drop 2drop
1207: ELSE
1208: type ." :" dec.
1209: cr dup 2over type cr drop
1210: nip -trailing 1- ( line-start index2 )
1211: 0 >r BEGIN
1212: 2dup + c@ bl > WHILE
1213: r> 1+ >r 1- dup 0< UNTIL THEN 1+
1214: ( line-start index1 )
1215: typewhite
1216: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
1217: [char] ^ emit
1218: loop
1219: THEN
1220: ;
1221:
1222: : (DoError) ( throw-code -- )
1223: sourceline# IF
1224: source >in @ sourceline# 0 0 .error-frame
1225: THEN
1226: error-stack @ 0 ?DO
1227: -1 error-stack +!
1228: error-stack dup @ 6 * cells + cell+
1229: 6 cells bounds DO
1230: I @
1231: cell +LOOP
1232: .error-frame
1233: LOOP
1234: dup -2 =
1235: IF
1236: "error @ ?dup
1237: IF
1238: cr count type
1239: THEN
1240: drop
1241: ELSE
1242: .error
1243: THEN
1244: normal-dp dpp ! ;
1245:
1246: ' (DoError) IS DoError
1247:
1248: : quit ( ?? -- ?? ) \ core
1249: r0 @ rp! handler off >tib @ >r
1250: BEGIN
1251: postpone [
1252: ['] 'quit CATCH dup
1253: WHILE
1254: DoError r@ >tib ! r@ tibstack !
1255: REPEAT
1256: drop r> >tib ! ;
1257:
1258: \ Cold 13feb93py
1259:
1260: \ : .name ( name -- ) name>string type space ;
1261: \ : words listwords @
1262: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
1263: Defer 'cold ' noop IS 'cold
1264:
1265: : cold ( -- ) \ gforth
1266: [ has-os [IF] ]
1267: stdout TO outfile-id
1268: [ [THEN] ]
1269: [ has-files [IF] ]
1270: pathstring 2@ process-path pathdirs 2!
1271: init-included-files
1272: [ [THEN] ]
1273: 'cold
1274: [ has-files [IF] ]
1275: argc @ 1 >
1276: IF
1277: ['] process-args catch ?dup
1278: IF
1279: dup >r DoError cr r> negate (bye)
1280: THEN
1281: cr
1282: THEN
1283: [ [THEN] ]
1284: ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
1285: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
1286: [ has-os [IF] ]
1287: cr ." Type `bye' to exit"
1288: [ [THEN] ]
1289: loadline off quit ;
1290:
1291: : license ( -- ) \ gforth
1292: cr
1293: ." This program is free software; you can redistribute it and/or modify" cr
1294: ." it under the terms of the GNU General Public License as published by" cr
1295: ." the Free Software Foundation; either version 2 of the License, or" cr
1296: ." (at your option) any later version." cr cr
1297:
1298: ." This program is distributed in the hope that it will be useful," cr
1299: ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
1300: ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr
1301: ." GNU General Public License for more details." cr cr
1302:
1303: ." You should have received a copy of the GNU General Public License" cr
1304: ." along with this program; if not, write to the Free Software" cr
1305: ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
1306:
1307: : boot ( path **argv argc -- )
1308: [ has-files [IF] ]
1309: argc ! argv ! pathstring 2!
1310: [ [THEN] ]
1311: main-task up!
1312: sp@ s0 !
1313: [ has-locals [IF] ]
1314: lp@ forthstart 7 cells + @ -
1315: [ [ELSE] ]
1316: [ has-os [IF] ]
1317: sp@ $1040 +
1318: [ [ELSE] ]
1319: sp@ $40 +
1320: [ [THEN] ]
1321: [ [THEN] ]
1322: dup >tib ! tibstack ! #tib off >in off
1323: rp@ r0 !
1324: [ has-floats [IF] ]
1325: fp@ f0 !
1326: [ [THEN] ]
1327: ['] cold catch DoError
1328: [ has-os [IF] ]
1329: bye
1330: [ [THEN] ]
1331: ;
1332:
1333: has-os [IF]
1334: : bye ( -- ) \ tools-ext
1335: [ has-files [IF] ]
1336: script? 0= IF cr THEN
1337: [ [ELSE] ]
1338: cr
1339: [ [THEN] ]
1340: 0 (bye) ;
1341: [THEN]
1342:
1343: \ **argv may be scanned by the C starter to get some important
1344: \ information, as -display and -geometry for an X client FORTH
1345: \ or space and stackspace overrides
1346:
1347: \ 0 arg contains, however, the name of the program.
1348:
1349:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernel.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth