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