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