Annotation of gforth/kernel/int.fs, revision 1.14
1.1 pazsan 1: \ definitions needed for interpreter only
2:
1.11 anton 3: \ Copyright (C) 1995,1996,1997,1998 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:
1.1 pazsan 21: \ \ Revision-Log
22:
23: \ put in seperate file 14sep97jaw
24:
25: \ \ input stream primitives 23feb93py
26:
27: : tib ( -- c-addr ) \ core-ext
28: \ obsolescent
29: >tib @ ;
30:
31: Defer source ( -- addr count ) \ core
32: \ used by dodefer:, must be defer
33:
34: : (source) ( -- addr count )
35: tib #tib @ ;
36: ' (source) IS source
37:
38: : (word) ( addr1 n1 char -- addr2 n2 )
39: dup >r skip 2dup r> scan nip - ;
40:
41: \ (word) should fold white spaces
42: \ this is what (parse-white) does
43:
44: \ word parse 23feb93py
45:
1.3 anton 46: : sword ( char -- addr len ) \ gforth
47: \G parses like @code{word}, but the output is like @code{parse} output
48: \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
49: \ dpANS6 A.6.2.2008 have a word with that name that behaves
50: \ differently (like NAME).
1.1 pazsan 51: source 2dup >r >r >in @ over min /string
52: rot dup bl = IF drop (parse-white) ELSE (word) THEN
53: 2dup + r> - 1+ r> min >in ! ;
54:
55: : word ( char -- addr ) \ core
1.3 anton 56: sword here place bl here count + c! here ;
1.1 pazsan 57:
58: : parse ( char -- addr len ) \ core-ext
59: >r source >in @ over min /string over swap r> scan >r
60: over - dup r> IF 1+ THEN >in +! ;
61:
62: \ name 13feb93py
63:
64: [IFUNDEF] (name) \ name might be a primitive
65:
66: : (name) ( -- c-addr count )
67: source 2dup >r >r >in @ /string (parse-white)
68: 2dup + r> - 1+ r> min >in ! ;
69: \ name count ;
70: [THEN]
71:
72: : name-too-short? ( c-addr u -- c-addr u )
73: dup 0= -&16 and throw ;
74:
75: : name-too-long? ( c-addr u -- c-addr u )
76: dup $1F u> -&19 and throw ;
77:
78: \ \ Number parsing 23feb93py
79:
80: \ number? number 23feb93py
81:
82: hex
83: const Create bases 10 , 2 , A , 100 ,
84: \ 16 2 10 character
85: \ !! this saving and restoring base is an abomination! - anton
86:
87: : getbase ( addr u -- addr' u' )
88: over c@ [char] $ - dup 4 u<
89: IF
90: cells bases + @ base ! 1 /string
91: ELSE
92: drop
93: THEN ;
94:
95: : s>number ( addr len -- d )
96: base @ >r dpl on
97: over c@ '- = dup >r
98: IF
99: 1 /string
100: THEN
101: getbase dpl on 0 0 2swap
102: BEGIN
103: dup >r >number dup
104: WHILE
105: dup r> -
106: WHILE
107: dup dpl ! over c@ [char] . =
108: WHILE
109: 1 /string
110: REPEAT THEN
111: 2drop rdrop dpl off
112: ELSE
113: 2drop rdrop r>
114: IF
115: dnegate
116: THEN
117: THEN
118: r> base ! ;
119:
120: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
121: s>number dpl @ 0=
122: IF
123: 2drop false EXIT
124: THEN
125: dpl @ dup 0> 0= IF
126: nip
127: THEN ;
128:
129: : number? ( string -- string 0 / n -1 / d 0> )
130: dup >r count snumber? dup if
131: rdrop
132: else
133: r> swap
134: then ;
135:
136: : number ( string -- d )
137: number? ?dup 0= abort" ?" 0<
138: IF
139: s>d
140: THEN ;
141:
142: \ \ Comments ( \ \G
143:
144: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren
145: [char] ) parse 2drop ; immediate
146:
147: : \ ( -- ) \ core-ext backslash
1.12 pazsan 148: [ has? file [IF] ]
1.1 pazsan 149: blk @
150: IF
151: >in @ c/l / 1+ c/l * >in !
152: EXIT
153: THEN
1.12 pazsan 154: [ [THEN] ]
1.1 pazsan 155: source >in ! drop ; immediate
156:
157: : \G ( -- ) \ gforth backslash
158: POSTPONE \ ; immediate
159:
160: \ \ object oriented search list 17mar93py
161:
162: \ word list structure:
163:
164: struct
165: cell% field find-method \ xt: ( c_addr u wid -- nt )
166: cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
167: cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables)
168: cell% field hash-method \ xt: ( wid -- ) \ initializes ""
169: \ \ !! what else
170: end-struct wordlist-map-struct
171:
172: struct
1.6 pazsan 173: cell% field wordlist-map \ pointer to a wordlist-map-struct
1.13 anton 174: cell% field wordlist-id \ linked list of words (for WORDS etc.)
1.1 pazsan 175: cell% field wordlist-link \ link field to other wordlists
1.13 anton 176: cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
1.1 pazsan 177: end-struct wordlist-struct
178:
179: : f83find ( addr len wordlist -- nt / false )
1.6 pazsan 180: wordlist-id @ (f83find) ;
1.1 pazsan 181:
182: : initvoc ( wid -- )
183: dup wordlist-map @ hash-method perform ;
184:
185: \ Search list table: find reveal
186: Create f83search ( -- wordlist-map )
187: ' f83find A, ' drop A, ' drop A, ' drop A,
188:
1.6 pazsan 189: here G f83search T A, NIL A, NIL A, NIL A,
1.1 pazsan 190: AValue forth-wordlist \ variable, will be redefined by search.fs
191:
192: AVariable lookup forth-wordlist lookup !
193: \ !! last is user and lookup?! jaw
194: AVariable current ( -- addr ) \ gforth
195: AVariable voclink forth-wordlist wordlist-link voclink !
196: lookup AValue context
197:
198: forth-wordlist current !
199:
200: \ \ header, finding, ticks 17dec92py
201:
202: $80 constant alias-mask \ set when the word is not an alias!
203: $40 constant immediate-mask
204: $20 constant restrict-mask
205:
206: \ higher level parts of find
207:
208: : flag-sign ( f -- 1|-1 )
209: \ true becomes 1, false -1
210: 0= 2* 1+ ;
211:
212: : compile-only-error ( ... -- )
213: -&14 throw ;
214:
215: : (cfa>int) ( cfa -- xt )
216: [ has? compiler [IF] ]
217: dup interpret/compile?
218: if
219: interpret/compile-int @
220: then
221: [ [THEN] ] ;
222:
223: : (x>int) ( cfa b -- xt )
224: \ get interpretation semantics of name
225: restrict-mask and
226: if
227: drop ['] compile-only-error
228: else
229: (cfa>int)
230: then ;
231:
232: : name>string ( nt -- addr count ) \ gforth head-to-string
233: \g @var{addr count} is the name of the word represented by @var{nt}.
234: cell+ count $1F and ;
235:
236: : ((name>)) ( nfa -- cfa )
237: name>string + cfaligned ;
238:
239: : (name>x) ( nfa -- cfa b )
240: \ cfa is an intermediate cfa and b is the flags byte of nfa
241: dup ((name>))
242: swap cell+ c@ dup alias-mask and 0=
243: IF
244: swap @ swap
245: THEN ;
246:
247: : name>int ( nt -- xt ) \ gforth
248: \G @var{xt} represents the interpretation semantics of the word
249: \G @var{nt}. Produces @code{' compile-only-error} if
250: \G @var{nt} is compile-only.
251: (name>x) (x>int) ;
252:
253: : name?int ( nt -- xt ) \ gforth
254: \G Like name>int, but throws an error if compile-only.
255: (name>x) restrict-mask and
256: if
257: compile-only-error \ does not return
258: then
259: (cfa>int) ;
260:
261: : (name>comp) ( nt -- w +-1 ) \ gforth
262: \G @var{w xt} is the compilation token for the word @var{nt}.
263: (name>x) >r
264: [ has? compiler [IF] ]
265: dup interpret/compile?
266: if
267: interpret/compile-comp @
268: then
269: [ [THEN] ]
270: r> immediate-mask and flag-sign
271: ;
272:
273: : (name>intn) ( nfa -- xt +-1 )
274: (name>x) tuck (x>int) ( b xt )
275: swap immediate-mask and flag-sign ;
276:
1.14 ! anton 277: : head? ( addr -- f )
! 278: \G heuristic check whether addr is a name token; may deliver false
! 279: \G positives; addr must be a valid address
! 280: \ we follow the link fields and check for plausibility; two
! 281: \ iterations should catch most false addresses: on the first
! 282: \ iteration, we may get an xt, on the second a code address (or
! 283: \ some code), which is typically not in the dictionary.
! 284: 2 0 do
! 285: dup @ dup
! 286: if ( addr addr1 )
! 287: dup rot forthstart within
! 288: if \ addr1 is outside forthstart..addr, not a head
! 289: drop false unloop exit
! 290: then ( addr1 )
! 291: else \ 0 in the link field, no further checks
! 292: 2drop true unloop exit
! 293: then
! 294: loop
! 295: \ in dubio pro:
! 296: drop true ;
! 297:
1.1 pazsan 298: const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
299: \ ??? is used by dovar:, must be created/:dovar
300:
1.14 ! anton 301: : >head ( cfa -- nt ) \ gforth to-head
! 302: $21 cell do ( cfa )
! 303: dup i - count $9F and + cfaligned over alias-mask + =
! 304: if ( cfa )
! 305: dup i - cell - dup head?
! 306: if
! 307: nip unloop exit
! 308: then
! 309: drop
! 310: then
! 311: cell +loop
! 312: drop ??? ( wouldn't 0 be better? ) ;
1.1 pazsan 313:
314: ' >head ALIAS >name
315:
316: : body> 0 >body - ;
317:
318: : (search-wordlist) ( addr count wid -- nt / false )
319: dup wordlist-map @ find-method perform ;
320:
321: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
322: \ xt is the interpretation semantics
323: (search-wordlist) dup if
324: (name>intn)
325: then ;
326:
327: : find-name ( c-addr u -- nt/0 ) \ gforth
328: \g Find the name @var{c-addr u} in the current search
329: \g order. Return its nt, if found, otherwise 0.
330: lookup @ (search-wordlist) ;
331:
332: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
333: find-name dup
334: if ( nt )
335: state @
336: if
337: (name>comp)
338: else
339: (name>intn)
340: then
341: then ;
342:
343: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
344: dup count sfind dup
345: if
346: rot drop
347: then ;
348:
349: \ ticks
350:
351: : (') ( "name" -- nt ) \ gforth
352: name find-name dup 0=
353: IF
354: drop -&13 bounce
355: THEN ;
356:
357: : ' ( "name" -- xt ) \ core tick
358: \g @var{xt} represents @var{name}'s interpretation
359: \g semantics. Performs @code{-14 throw} if the word has no
360: \g interpretation semantics.
361: (') name?int ;
362:
363: \ \ the interpreter loop mar92py
364:
365: \ interpret 10mar92py
366:
367: Defer parser
368: Defer name ( -- c-addr count ) \ gforth
369: \ get the next word from the input buffer
370: ' (name) IS name
371: Defer compiler-notfound ( c-addr count -- )
372: Defer interpreter-notfound ( c-addr count -- )
373:
374: : no.extensions ( addr u -- )
375: 2drop -&13 bounce ;
376: ' no.extensions IS compiler-notfound
377: ' no.extensions IS interpreter-notfound
378:
379: : interpret ( ?? -- ?? ) \ gforth
380: \ interpret/compile the (rest of the) input buffer
381: BEGIN
382: ?stack name dup
383: WHILE
384: parser
385: REPEAT
386: 2drop ;
387:
388: \ interpreter 30apr92py
389:
390: \ not the most efficient implementations of interpreter and compiler
1.12 pazsan 391: | : interpreter ( c-addr u -- )
1.1 pazsan 392: 2dup find-name dup
393: if
394: nip nip name>int execute
395: else
396: drop
397: 2dup 2>r snumber?
398: IF
399: 2rdrop
400: ELSE
401: 2r> interpreter-notfound
402: THEN
403: then ;
404:
405: ' interpreter IS parser
406:
407: \ \ Query Evaluate 07apr93py
408:
409: has? file 0= [IF]
1.12 pazsan 410: : sourceline# ( -- n ) 1 ;
1.1 pazsan 411: [THEN]
412:
413: : refill ( -- flag ) \ core-ext,block-ext,file-ext
1.12 pazsan 414: [ has? file [IF] ]
415: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
416: [ [THEN] ]
417: tib /line
418: [ has? file [IF] ]
419: loadfile @ ?dup
420: IF read-line throw
421: ELSE
422: [ [THEN] ]
423: sourceline# 0< IF 2drop false EXIT THEN
424: accept true
425: [ has? file [IF] ]
426: THEN
427: 1 loadline +!
428: [ [THEN] ]
429: swap #tib ! 0 >in ! ;
1.1 pazsan 430:
431: : query ( -- ) \ core-ext
432: \G obsolescent
1.12 pazsan 433: [ has? file [IF] ]
434: blk off loadfile off
435: [ [THEN] ]
1.1 pazsan 436: tib /line accept #tib ! 0 >in ! ;
437:
438: \ save-mem extend-mem
439:
440: has? os [IF]
441: : save-mem ( addr1 u -- addr2 u ) \ gforth
442: \g copy a memory block into a newly allocated region in the heap
443: swap >r
444: dup allocate throw
445: swap 2dup r> -rot move ;
446:
447: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
448: \ extend memory block allocated from the heap by u aus
449: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
450: over >r + dup >r resize throw
451: r> over r> + -rot ;
452: [THEN]
453:
454: \ EVALUATE 17may93jaw
455:
456: has? file 0= [IF]
457: : push-file ( -- ) r>
1.12 pazsan 458: tibstack @ >r >tib @ >r #tib @ >r
1.1 pazsan 459: >tib @ tibstack @ = IF r@ tibstack +! THEN
460: tibstack @ >tib ! >in @ >r >r ;
461:
462: : pop-file ( throw-code -- throw-code )
463: r>
1.12 pazsan 464: r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ;
1.1 pazsan 465: [THEN]
466:
467: : evaluate ( c-addr len -- ) \ core,block
468: push-file #tib ! >tib !
1.12 pazsan 469: >in off
470: [ has? file [IF] ]
471: blk off loadfile off -1 loadline !
472: [ [THEN] ]
1.1 pazsan 473: ['] interpret catch
474: pop-file throw ;
475:
476: \ \ Quit 13feb93py
477:
478: Defer 'quit
479:
480: Defer .status
481:
482: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
483:
484: : (Query) ( -- )
1.12 pazsan 485: [ has? file [IF] ]
486: loadfile off blk off loadline off
487: [ [THEN] ]
488: refill drop ;
1.1 pazsan 489:
490: : (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
491:
492: ' (quit) IS 'quit
493:
494: \ \ DOERROR (DOERROR) 13jun93jaw
495:
496: 8 Constant max-errors
497: Variable error-stack 0 error-stack !
498: max-errors 6 * cells allot
499: \ format of one cell:
500: \ source ( addr u )
501: \ >in
502: \ line-number
503: \ Loadfilename ( addr u )
504:
505: : dec. ( n -- ) \ gforth
506: \ print value in decimal representation
507: base @ decimal swap . base ! ;
508:
509: : hex. ( u -- ) \ gforth
510: \ print value as unsigned hex number
511: '$ emit base @ swap hex u. base ! ;
512:
513: : typewhite ( addr u -- ) \ gforth
514: \ like type, but white space is printed instead of the characters
515: bounds ?do
516: i c@ #tab = if \ check for tab
517: #tab
518: else
519: bl
520: then
521: emit
522: loop ;
523:
524: DEFER DOERROR
525:
526: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
527: cr error-stack @
528: IF
529: ." in file included from "
530: type ." :" dec. drop 2drop
531: ELSE
532: type ." :" dec.
533: cr dup 2over type cr drop
534: nip -trailing 1- ( line-start index2 )
535: 0 >r BEGIN
536: 2dup + c@ bl > WHILE
537: r> 1+ >r 1- dup 0< UNTIL THEN 1+
538: ( line-start index1 )
539: typewhite
540: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
541: [char] ^ emit
542: loop
543: THEN
544: ;
545:
546: : (DoError) ( throw-code -- )
547: [ has? os [IF] ]
1.8 pazsan 548: >stderr
1.1 pazsan 549: [ [THEN] ]
550: sourceline# IF
1.8 pazsan 551: source >in @ sourceline# 0 0 .error-frame
1.1 pazsan 552: THEN
553: error-stack @ 0 ?DO
554: -1 error-stack +!
555: error-stack dup @ 6 * cells + cell+
556: 6 cells bounds DO
557: I @
558: cell +LOOP
559: .error-frame
560: LOOP
561: dup -2 =
562: IF
563: "error @ ?dup
564: IF
565: cr count type
566: THEN
567: drop
568: ELSE
569: .error
570: THEN
1.8 pazsan 571: normal-dp dpp ! ;
1.1 pazsan 572:
573: ' (DoError) IS DoError
574:
575: : quit ( ?? -- ?? ) \ core
1.5 anton 576: rp0 @ rp! handler off clear-tibstack >tib @ >r
1.1 pazsan 577: BEGIN
578: [ has? compiler [IF] ]
579: postpone [
580: [ [THEN] ]
581: ['] 'quit CATCH dup
582: WHILE
583: DoError r@ >tib ! r@ tibstack !
584: REPEAT
585: drop r> >tib ! ;
586:
587: \ \ Cold Boot 13feb93py
588:
589: : (bootmessage)
590: ." GForth " version-string type
1.11 anton 591: ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
1.1 pazsan 592: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
593: [ has? os [IF] ]
594: cr ." Type `bye' to exit"
595: [ [THEN] ] ;
596:
597: defer bootmessage
598: defer process-args
599:
600: ' (bootmessage) IS bootmessage
601:
1.10 anton 602: Defer 'cold ( -- ) \ gforth tick-cold
1.1 pazsan 603: \ hook (deferred word) for things to do right before interpreting the
604: \ command-line arguments
605: ' noop IS 'cold
606:
1.2 anton 607: include ../chains.fs
1.1 pazsan 608:
609: Variable init8
610:
611: : cold ( -- ) \ gforth
612: [ has? file [IF] ]
613: pathstring 2@ fpath only-path
614: init-included-files
615: [ [THEN] ]
616: 'cold
617: init8 chainperform
618: [ has? file [IF] ]
1.8 pazsan 619: process-args
1.12 pazsan 620: loadline off
1.1 pazsan 621: [ [THEN] ]
622: bootmessage
1.12 pazsan 623: quit ;
1.1 pazsan 624:
1.5 anton 625: : clear-tibstack ( -- )
626: [ has? glocals [IF] ]
627: lp@ forthstart 7 cells + @ -
628: [ [ELSE] ]
629: [ has? os [IF] ]
1.8 pazsan 630: r0 @ forthstart 6 cells + @ -
1.5 anton 631: [ [ELSE] ]
632: sp@ $40 +
633: [ [THEN] ]
634: [ [THEN] ]
635: dup >tib ! tibstack ! #tib off >in off ;
636:
1.1 pazsan 637: : boot ( path **argv argc -- )
638: main-task up!
639: [ has? os [IF] ]
640: stdout TO outfile-id
1.7 pazsan 641: stdin TO infile-id
1.1 pazsan 642: \ !! [ [THEN] ]
643: \ !! [ has? file [IF] ]
644: argc ! argv ! pathstring 2!
645: [ [THEN] ]
646: sp@ sp0 !
1.5 anton 647: clear-tibstack
1.1 pazsan 648: rp@ rp0 !
649: [ has? floating [IF] ]
650: fp@ fp0 !
651: [ [THEN] ]
1.8 pazsan 652: ['] cold catch DoError cr
1.1 pazsan 653: [ has? os [IF] ]
654: bye
655: [ [THEN] ]
656: ;
657:
658: has? os [IF]
659: : bye ( -- ) \ tools-ext
660: [ has? file [IF] ]
661: script? 0= IF cr THEN
662: [ [ELSE] ]
663: cr
664: [ [THEN] ]
665: 0 (bye) ;
666: [THEN]
667:
668: \ **argv may be scanned by the C starter to get some important
669: \ information, as -display and -geometry for an X client FORTH
670: \ or space and stackspace overrides
671:
672: \ 0 arg contains, however, the name of the program.
673:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>