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