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