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