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: \ !! 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
148: [ has? file [IF] ]
149: blk @
150: IF
151: >in @ c/l / 1+ c/l * >in !
152: EXIT
153: THEN
154: [ [THEN] ]
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
173: cell% field wordlist-map \ pointer to a wordlist-map-struct
174: cell% field wordlist-id \ linked list of words (for WORDS etc.)
175: cell% field wordlist-link \ link field to other wordlists
176: cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
177: end-struct wordlist-struct
178:
179: : f83find ( addr len wordlist -- nt / false )
180: wordlist-id @ (f83find) ;
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:
189: here G f83search T A, NIL A, NIL A, NIL A,
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:
277: const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
278: \ ??? is used by dovar:, must be created/:dovar
279:
280: : >head ( cfa -- nt ) \ gforth to-name
281: $21 cell do
282: dup i - count $9F and + cfaligned over alias-mask + = if
283: i - cell - unloop exit
284: then
285: cell +loop
286: drop ??? ( wouldn't 0 be better? ) ;
287:
288: ' >head ALIAS >name
289:
290: : body> 0 >body - ;
291:
292: : (search-wordlist) ( addr count wid -- nt / false )
293: dup wordlist-map @ find-method perform ;
294:
295: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
296: \ xt is the interpretation semantics
297: (search-wordlist) dup if
298: (name>intn)
299: then ;
300:
301: : find-name ( c-addr u -- nt/0 ) \ gforth
302: \g Find the name @var{c-addr u} in the current search
303: \g order. Return its nt, if found, otherwise 0.
304: lookup @ (search-wordlist) ;
305:
306: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
307: find-name dup
308: if ( nt )
309: state @
310: if
311: (name>comp)
312: else
313: (name>intn)
314: then
315: then ;
316:
317: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
318: dup count sfind dup
319: if
320: rot drop
321: then ;
322:
323: \ ticks
324:
325: : (') ( "name" -- nt ) \ gforth
326: name find-name dup 0=
327: IF
328: drop -&13 bounce
329: THEN ;
330:
331: : ' ( "name" -- xt ) \ core tick
332: \g @var{xt} represents @var{name}'s interpretation
333: \g semantics. Performs @code{-14 throw} if the word has no
334: \g interpretation semantics.
335: (') name?int ;
336:
337: \ \ the interpreter loop mar92py
338:
339: \ interpret 10mar92py
340:
341: Defer parser
342: Defer name ( -- c-addr count ) \ gforth
343: \ get the next word from the input buffer
344: ' (name) IS name
345: Defer compiler-notfound ( c-addr count -- )
346: Defer interpreter-notfound ( c-addr count -- )
347:
348: : no.extensions ( addr u -- )
349: 2drop -&13 bounce ;
350: ' no.extensions IS compiler-notfound
351: ' no.extensions IS interpreter-notfound
352:
353: : interpret ( ?? -- ?? ) \ gforth
354: \ interpret/compile the (rest of the) input buffer
355: BEGIN
356: ?stack name dup
357: WHILE
358: parser
359: REPEAT
360: 2drop ;
361:
362: \ interpreter 30apr92py
363:
364: \ not the most efficient implementations of interpreter and compiler
365: | : interpreter ( c-addr u -- )
366: 2dup find-name dup
367: if
368: nip nip name>int execute
369: else
370: drop
371: 2dup 2>r snumber?
372: IF
373: 2rdrop
374: ELSE
375: 2r> interpreter-notfound
376: THEN
377: then ;
378:
379: ' interpreter IS parser
380:
381: \ \ Query Evaluate 07apr93py
382:
383: has? file 0= [IF]
384: : sourceline# ( -- n ) 1 ;
385: [THEN]
386:
387: : refill ( -- flag ) \ core-ext,block-ext,file-ext
388: [ has? file [IF] ]
389: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
390: [ [THEN] ]
391: tib /line
392: [ has? file [IF] ]
393: loadfile @ ?dup
394: IF read-line throw
395: ELSE
396: [ [THEN] ]
397: sourceline# 0< IF 2drop false EXIT THEN
398: accept true
399: [ has? file [IF] ]
400: THEN
401: 1 loadline +!
402: [ [THEN] ]
403: swap #tib ! 0 >in ! ;
404:
405: : query ( -- ) \ core-ext
406: \G obsolescent
407: [ has? file [IF] ]
408: blk off loadfile off
409: [ [THEN] ]
410: tib /line accept #tib ! 0 >in ! ;
411:
412: \ save-mem extend-mem
413:
414: has? os [IF]
415: : save-mem ( addr1 u -- addr2 u ) \ gforth
416: \g copy a memory block into a newly allocated region in the heap
417: swap >r
418: dup allocate throw
419: swap 2dup r> -rot move ;
420:
421: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
422: \ extend memory block allocated from the heap by u aus
423: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
424: over >r + dup >r resize throw
425: r> over r> + -rot ;
426: [THEN]
427:
428: \ EVALUATE 17may93jaw
429:
430: has? file 0= [IF]
431: : push-file ( -- ) r>
432: tibstack @ >r >tib @ >r #tib @ >r
433: >tib @ tibstack @ = IF r@ tibstack +! THEN
434: tibstack @ >tib ! >in @ >r >r ;
435:
436: : pop-file ( throw-code -- throw-code )
437: r>
438: r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ;
439: [THEN]
440:
441: : evaluate ( c-addr len -- ) \ core,block
442: push-file #tib ! >tib !
443: >in off
444: [ has? file [IF] ]
445: blk off loadfile off -1 loadline !
446: [ [THEN] ]
447: ['] interpret catch
448: pop-file throw ;
449:
450: \ \ Quit 13feb93py
451:
452: Defer 'quit
453:
454: Defer .status
455:
456: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
457:
458: : (Query) ( -- )
459: [ has? file [IF] ]
460: loadfile off blk off loadline off
461: [ [THEN] ]
462: refill drop ;
463:
464: : (quit) BEGIN .status cr (query) interpret prompt AGAIN ;
465:
466: ' (quit) IS 'quit
467:
468: \ \ DOERROR (DOERROR) 13jun93jaw
469:
470: 8 Constant max-errors
471: Variable error-stack 0 error-stack !
472: max-errors 6 * cells allot
473: \ format of one cell:
474: \ source ( addr u )
475: \ >in
476: \ line-number
477: \ Loadfilename ( addr u )
478:
479: : dec. ( n -- ) \ gforth
480: \ print value in decimal representation
481: base @ decimal swap . base ! ;
482:
483: : hex. ( u -- ) \ gforth
484: \ print value as unsigned hex number
485: '$ emit base @ swap hex u. base ! ;
486:
487: : typewhite ( addr u -- ) \ gforth
488: \ like type, but white space is printed instead of the characters
489: bounds ?do
490: i c@ #tab = if \ check for tab
491: #tab
492: else
493: bl
494: then
495: emit
496: loop ;
497:
498: DEFER DOERROR
499:
500: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
501: cr error-stack @
502: IF
503: ." in file included from "
504: type ." :" dec. drop 2drop
505: ELSE
506: type ." :" dec.
507: cr dup 2over type cr drop
508: nip -trailing 1- ( line-start index2 )
509: 0 >r BEGIN
510: 2dup + c@ bl > WHILE
511: r> 1+ >r 1- dup 0< UNTIL THEN 1+
512: ( line-start index1 )
513: typewhite
514: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
515: [char] ^ emit
516: loop
517: THEN
518: ;
519:
520: : (DoError) ( throw-code -- )
521: [ has? os [IF] ]
522: >stderr
523: [ [THEN] ]
524: sourceline# IF
525: source >in @ sourceline# 0 0 .error-frame
526: THEN
527: error-stack @ 0 ?DO
528: -1 error-stack +!
529: error-stack dup @ 6 * cells + cell+
530: 6 cells bounds DO
531: I @
532: cell +LOOP
533: .error-frame
534: LOOP
535: dup -2 =
536: IF
537: "error @ ?dup
538: IF
539: cr count type
540: THEN
541: drop
542: ELSE
543: .error
544: THEN
545: normal-dp dpp ! ;
546:
547: ' (DoError) IS DoError
548:
549: : quit ( ?? -- ?? ) \ core
550: rp0 @ rp! handler off clear-tibstack >tib @ >r
551: BEGIN
552: [ has? compiler [IF] ]
553: postpone [
554: [ [THEN] ]
555: ['] 'quit CATCH dup
556: WHILE
557: DoError r@ >tib ! r@ tibstack !
558: REPEAT
559: drop r> >tib ! ;
560:
561: \ \ Cold Boot 13feb93py
562:
563: : (bootmessage)
564: ." GForth " version-string type
565: ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
566: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
567: [ has? os [IF] ]
568: cr ." Type `bye' to exit"
569: [ [THEN] ] ;
570:
571: defer bootmessage
572: defer process-args
573:
574: ' (bootmessage) IS bootmessage
575:
576: Defer 'cold ( -- ) \ gforth tick-cold
577: \ hook (deferred word) for things to do right before interpreting the
578: \ command-line arguments
579: ' noop IS 'cold
580:
581: include ../chains.fs
582:
583: Variable init8
584:
585: : cold ( -- ) \ gforth
586: [ has? file [IF] ]
587: pathstring 2@ fpath only-path
588: init-included-files
589: [ [THEN] ]
590: 'cold
591: init8 chainperform
592: [ has? file [IF] ]
593: process-args
594: loadline off
595: [ [THEN] ]
596: bootmessage
597: quit ;
598:
599: : clear-tibstack ( -- )
600: [ has? glocals [IF] ]
601: lp@ forthstart 7 cells + @ -
602: [ [ELSE] ]
603: [ has? os [IF] ]
604: r0 @ forthstart 6 cells + @ -
605: [ [ELSE] ]
606: sp@ $40 +
607: [ [THEN] ]
608: [ [THEN] ]
609: dup >tib ! tibstack ! #tib off >in off ;
610:
611: : boot ( path **argv argc -- )
612: main-task up!
613: [ has? os [IF] ]
614: stdout TO outfile-id
615: stdin TO infile-id
616: \ !! [ [THEN] ]
617: \ !! [ has? file [IF] ]
618: argc ! argv ! pathstring 2!
619: [ [THEN] ]
620: sp@ sp0 !
621: clear-tibstack
622: rp@ rp0 !
623: [ has? floating [IF] ]
624: fp@ fp0 !
625: [ [THEN] ]
626: ['] cold catch DoError cr
627: [ has? os [IF] ]
628: bye
629: [ [THEN] ]
630: ;
631:
632: has? os [IF]
633: : bye ( -- ) \ tools-ext
634: [ has? file [IF] ]
635: script? 0= IF cr THEN
636: [ [ELSE] ]
637: cr
638: [ [THEN] ]
639: 0 (bye) ;
640: [THEN]
641:
642: \ **argv may be scanned by the C starter to get some important
643: \ information, as -display and -geometry for an X client FORTH
644: \ or space and stackspace overrides
645:
646: \ 0 arg contains, however, the name of the program.
647:
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