Annotation of gforth/kernel/int.fs, revision 1.36
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:
1.33 jwilke 27: require ./basics.fs \ bounds decimal hex ...
28: require ./io.fs \ type ...
29: require ./nio.fs \ . <# ...
30: require ./errore.fs \ .error ...
1.36 ! anton 31: require ~+/kernel/version.fs \ version-string
1.33 jwilke 32: require ./../chains.fs
33:
1.1 pazsan 34: : tib ( -- c-addr ) \ core-ext
1.29 crook 35: \G @var{c-addr} is the address of the Terminal Input Buffer.
36: \G OBSOLESCENT: @code{source} superceeds the function of this word.
1.1 pazsan 37: >tib @ ;
38:
1.29 crook 39: Defer source ( -- c-addr u ) \ core
1.1 pazsan 40: \ used by dodefer:, must be defer
1.29 crook 41: \G @var{c-addr} is the address of the input buffer and @var{u} is the
42: \G number of characters in it.
1.1 pazsan 43:
1.29 crook 44: : (source) ( -- c-addr u )
1.1 pazsan 45: tib #tib @ ;
46: ' (source) IS source
47:
48: : (word) ( addr1 n1 char -- addr2 n2 )
49: dup >r skip 2dup r> scan nip - ;
50:
51: \ (word) should fold white spaces
52: \ this is what (parse-white) does
53:
54: \ word parse 23feb93py
55:
1.29 crook 56: : sword ( char -- addr len ) \ gforth s-word
57: \G Parses like @code{word}, but the output is like @code{parse} output
1.3 anton 58: \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
59: \ dpANS6 A.6.2.2008 have a word with that name that behaves
60: \ differently (like NAME).
1.1 pazsan 61: source 2dup >r >r >in @ over min /string
62: rot dup bl = IF drop (parse-white) ELSE (word) THEN
63: 2dup + r> - 1+ r> min >in ! ;
64:
1.29 crook 65: : word ( char "<chars>ccc<char>-- c-addr ) \ core
66: \G Skip leading delimiters. Parse @var{ccc}, delimited by
67: \G @var{char}, in the parse area. @var{c-addr} is the addres of a
68: \G transient region containing the parsed string in
69: \G counted-strinng format. If the parse area was empty or
70: \G contained no characters other than delimiters, the resulting
71: \G string has zero length. A program may replace characters within
72: \G the counted string. OBSOLESCENT: the counted string has a
73: \G trailing space that is not included in its length.
74: sword here place bl here count + c! here ;
75:
76: : parse ( char "ccc<char>" -- c-addr u ) \ core-ext
77: \G Parse @var{ccc}, delimited by @var{char}, in the parse
78: \G area. @var{c-addr u} specifies the parsed string within the
79: \G parse area. If the parse area was empty, @var{u} is 0.
80: >r source >in @ over min /string over swap r> scan >r
1.1 pazsan 81: over - dup r> IF 1+ THEN >in +! ;
82:
83: \ name 13feb93py
84:
85: [IFUNDEF] (name) \ name might be a primitive
86:
87: : (name) ( -- c-addr count )
88: source 2dup >r >r >in @ /string (parse-white)
89: 2dup + r> - 1+ r> min >in ! ;
90: \ name count ;
91: [THEN]
92:
93: : name-too-short? ( c-addr u -- c-addr u )
94: dup 0= -&16 and throw ;
95:
96: : name-too-long? ( c-addr u -- c-addr u )
97: dup $1F u> -&19 and throw ;
98:
99: \ \ Number parsing 23feb93py
100:
101: \ number? number 23feb93py
102:
103: hex
104: const Create bases 10 , 2 , A , 100 ,
105: \ 16 2 10 character
106:
1.18 anton 107: \ !! protect BASE saving wrapper against exceptions
1.1 pazsan 108: : getbase ( addr u -- addr' u' )
109: over c@ [char] $ - dup 4 u<
110: IF
111: cells bases + @ base ! 1 /string
112: ELSE
113: drop
114: THEN ;
115:
1.20 pazsan 116: : sign? ( addr u -- addr u flag )
1.33 jwilke 117: over c@ [char] - = dup >r
1.1 pazsan 118: IF
119: 1 /string
120: THEN
1.20 pazsan 121: r> ;
122:
123: : s>unumber? ( addr u -- ud flag )
1.21 pazsan 124: base @ >r dpl on getbase
1.20 pazsan 125: 0. 2swap
1.18 anton 126: BEGIN ( d addr len )
1.1 pazsan 127: dup >r >number dup
1.18 anton 128: WHILE \ there are characters left
1.1 pazsan 129: dup r> -
1.18 anton 130: WHILE \ the last >number parsed something
131: dup 1- dpl ! over c@ [char] . =
132: WHILE \ the current char is '.'
1.1 pazsan 133: 1 /string
1.18 anton 134: REPEAT THEN \ there are unparseable characters left
1.21 pazsan 135: 2drop false
1.20 pazsan 136: ELSE
137: rdrop 2drop true
1.21 pazsan 138: THEN
139: r> base ! ;
1.20 pazsan 140:
141: \ ouch, this is complicated; there must be a simpler way - anton
142: : s>number? ( addr len -- d f )
143: \ converts string addr len into d, flag indicates success
1.21 pazsan 144: sign? >r
1.20 pazsan 145: s>unumber?
146: 0= IF
1.21 pazsan 147: rdrop false
1.18 anton 148: ELSE \ no characters left, all ok
1.20 pazsan 149: r>
1.1 pazsan 150: IF
151: dnegate
152: THEN
1.18 anton 153: true
1.21 pazsan 154: THEN ;
1.1 pazsan 155:
1.18 anton 156: : s>number ( addr len -- d )
157: \ don't use this, there is no way to tell success
158: s>number? drop ;
159:
1.1 pazsan 160: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
1.18 anton 161: s>number? 0=
1.1 pazsan 162: IF
163: 2drop false EXIT
164: THEN
1.18 anton 165: dpl @ dup 0< IF
1.1 pazsan 166: nip
1.18 anton 167: ELSE
168: 1+
1.1 pazsan 169: THEN ;
170:
171: : number? ( string -- string 0 / n -1 / d 0> )
172: dup >r count snumber? dup if
173: rdrop
174: else
175: r> swap
176: then ;
177:
178: : number ( string -- d )
179: number? ?dup 0= abort" ?" 0<
180: IF
181: s>d
182: THEN ;
183:
184: \ \ Comments ( \ \G
185:
1.29 crook 186: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ thisone- core,file paren
1.17 crook 187: \G ** this will not get annotated. The alias in glocals.fs will instead **
1.29 crook 188: \G It does not work to use "wordset-" prefix since this file is glossed
189: \G by cross.fs which doesn't have the same functionalty as makedoc.fs
1.1 pazsan 190: [char] ) parse 2drop ; immediate
191:
1.29 crook 192: : \ ( -- ) \ thisone- core-ext,block-ext backslash
193: \G ** this will not get annotated. The alias in glocals.fs will instead **
194: \G It does not work to use "wordset-" prefix since this file is glossed
195: \G by cross.fs which doesn't have the same functionalty as makedoc.fs
1.12 pazsan 196: [ has? file [IF] ]
1.1 pazsan 197: blk @
198: IF
199: >in @ c/l / 1+ c/l * >in !
200: EXIT
201: THEN
1.12 pazsan 202: [ [THEN] ]
1.1 pazsan 203: source >in ! drop ; immediate
204:
1.19 crook 205: : \G ( -- ) \ gforth backslash-gee
206: \G Equivalent to @code{\} but used as a tag to annotate definition
207: \G comments into documentation.
1.1 pazsan 208: POSTPONE \ ; immediate
209:
210: \ \ object oriented search list 17mar93py
211:
212: \ word list structure:
213:
214: struct
215: cell% field find-method \ xt: ( c_addr u wid -- nt )
216: cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
217: cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables)
218: cell% field hash-method \ xt: ( wid -- ) \ initializes ""
219: \ \ !! what else
220: end-struct wordlist-map-struct
221:
222: struct
1.6 pazsan 223: cell% field wordlist-map \ pointer to a wordlist-map-struct
1.13 anton 224: cell% field wordlist-id \ linked list of words (for WORDS etc.)
1.1 pazsan 225: cell% field wordlist-link \ link field to other wordlists
1.13 anton 226: cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
1.1 pazsan 227: end-struct wordlist-struct
228:
229: : f83find ( addr len wordlist -- nt / false )
1.6 pazsan 230: wordlist-id @ (f83find) ;
1.1 pazsan 231:
232: : initvoc ( wid -- )
233: dup wordlist-map @ hash-method perform ;
234:
235: \ Search list table: find reveal
236: Create f83search ( -- wordlist-map )
237: ' f83find A, ' drop A, ' drop A, ' drop A,
238:
1.6 pazsan 239: here G f83search T A, NIL A, NIL A, NIL A,
1.1 pazsan 240: AValue forth-wordlist \ variable, will be redefined by search.fs
241:
242: AVariable lookup forth-wordlist lookup !
243: \ !! last is user and lookup?! jaw
244: AVariable current ( -- addr ) \ gforth
1.17 crook 245: \G VARIABLE: holds the wid of the current compilation word list.
1.1 pazsan 246: AVariable voclink forth-wordlist wordlist-link voclink !
1.17 crook 247: lookup AValue context ( -- addr ) \ gforth
248: \G VALUE: @code{context} @code{@@} is the wid of the word list at the
249: \G top of the search order stack.
1.1 pazsan 250:
251: forth-wordlist current !
252:
253: \ \ header, finding, ticks 17dec92py
254:
1.33 jwilke 255: hex
256: 80 constant alias-mask \ set when the word is not an alias!
257: 40 constant immediate-mask
258: 20 constant restrict-mask
1.1 pazsan 259:
260: \ higher level parts of find
261:
262: : flag-sign ( f -- 1|-1 )
263: \ true becomes 1, false -1
264: 0= 2* 1+ ;
265:
266: : compile-only-error ( ... -- )
267: -&14 throw ;
268:
269: : (cfa>int) ( cfa -- xt )
270: [ has? compiler [IF] ]
271: dup interpret/compile?
272: if
273: interpret/compile-int @
274: then
275: [ [THEN] ] ;
276:
277: : (x>int) ( cfa b -- xt )
278: \ get interpretation semantics of name
279: restrict-mask and
280: if
281: drop ['] compile-only-error
282: else
283: (cfa>int)
284: then ;
285:
286: : name>string ( nt -- addr count ) \ gforth head-to-string
287: \g @var{addr count} is the name of the word represented by @var{nt}.
288: cell+ count $1F and ;
289:
290: : ((name>)) ( nfa -- cfa )
291: name>string + cfaligned ;
292:
293: : (name>x) ( nfa -- cfa b )
294: \ cfa is an intermediate cfa and b is the flags byte of nfa
295: dup ((name>))
296: swap cell+ c@ dup alias-mask and 0=
297: IF
298: swap @ swap
299: THEN ;
300:
301: : name>int ( nt -- xt ) \ gforth
1.31 crook 302: \G @i{xt} represents the interpretation semantics of the word
303: \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
304: \G @code{compile-only}), @i{xt} is the execution token for
305: \G @code{compile-only-error}, which performs @code{-14 throw}.
1.1 pazsan 306: (name>x) (x>int) ;
307:
308: : name?int ( nt -- xt ) \ gforth
1.31 crook 309: \G Like @code{name>int}, but perform @code{-14 throw} if @i{nt}
310: \G has no interpretation semantics.
1.1 pazsan 311: (name>x) restrict-mask and
312: if
313: compile-only-error \ does not return
314: then
315: (cfa>int) ;
316:
317: : (name>comp) ( nt -- w +-1 ) \ gforth
1.31 crook 318: \G @i{w xt} is the compilation token for the word @i{nt}.
1.1 pazsan 319: (name>x) >r
320: [ has? compiler [IF] ]
321: dup interpret/compile?
322: if
323: interpret/compile-comp @
324: then
325: [ [THEN] ]
326: r> immediate-mask and flag-sign
327: ;
328:
329: : (name>intn) ( nfa -- xt +-1 )
330: (name>x) tuck (x>int) ( b xt )
331: swap immediate-mask and flag-sign ;
332:
1.30 jwilke 333: const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
334: \ ??? is used by dovar:, must be created/:dovar
335:
336: [IFDEF] forthstart
337: \ if we have a forthstart we can define head? with it
338: \ otherwise leave out the head? check
339:
1.14 anton 340: : head? ( addr -- f )
341: \G heuristic check whether addr is a name token; may deliver false
342: \G positives; addr must be a valid address
343: \ we follow the link fields and check for plausibility; two
344: \ iterations should catch most false addresses: on the first
345: \ iteration, we may get an xt, on the second a code address (or
346: \ some code), which is typically not in the dictionary.
347: 2 0 do
348: dup @ dup
349: if ( addr addr1 )
350: dup rot forthstart within
351: if \ addr1 is outside forthstart..addr, not a head
352: drop false unloop exit
353: then ( addr1 )
354: else \ 0 in the link field, no further checks
355: 2drop true unloop exit
356: then
357: loop
358: \ in dubio pro:
359: drop true ;
360:
361: : >head ( cfa -- nt ) \ gforth to-head
362: $21 cell do ( cfa )
363: dup i - count $9F and + cfaligned over alias-mask + =
364: if ( cfa )
365: dup i - cell - dup head?
366: if
367: nip unloop exit
368: then
369: drop
370: then
371: cell +loop
372: drop ??? ( wouldn't 0 be better? ) ;
1.1 pazsan 373:
1.30 jwilke 374: [ELSE]
375:
376: : >head ( cfa -- nt ) \ gforth to-head
377: $21 cell do ( cfa )
378: dup i - count $9F and + cfaligned over alias-mask + =
379: if ( cfa ) i - cell - unloop exit
380: then
381: cell +loop
382: drop ??? ( wouldn't 0 be better? ) ;
383:
384: [THEN]
385:
1.1 pazsan 386: ' >head ALIAS >name
387:
388: : body> 0 >body - ;
389:
1.31 crook 390: : (search-wordlist) ( addr count wid -- nt | false )
1.1 pazsan 391: dup wordlist-map @ find-method perform ;
392:
1.31 crook 393: : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
394: \G Search the word list identified by @i{wid}
395: \G for the definition named by the string at @i{c-addr count}.
1.17 crook 396: \G If the definition is not found, return 0. If the definition
397: \G is found return 1 (if the definition is immediate) or -1
1.31 crook 398: \G (if the definition is not immediate) together with the @i{xt}.
399: \G The @i{xt} returned represents the interpretation semantics.
1.1 pazsan 400: (search-wordlist) dup if
401: (name>intn)
402: then ;
403:
1.31 crook 404: : find-name ( c-addr u -- nt | 0 ) \ gforth
405: \g Find the name @i{c-addr u} in the current search
406: \g order. Return its @i{nt}, if found, otherwise 0.
1.1 pazsan 407: lookup @ (search-wordlist) ;
408:
409: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete
410: find-name dup
411: if ( nt )
412: state @
413: if
414: (name>comp)
415: else
416: (name>intn)
417: then
418: then ;
419:
1.31 crook 420: : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search
1.17 crook 421: \G Search all word lists in the current search order
1.31 crook 422: \G for the definition named by the counted string at @i{c-addr}.
1.17 crook 423: \G If the definition is not found, return 0. If the definition
424: \G is found return 1 (if the definition is immediate) or -1
1.31 crook 425: \G (if the definition is not immediate) together with the @i{xt}.
1.1 pazsan 426: dup count sfind dup
427: if
428: rot drop
429: then ;
430:
1.34 jwilke 431: \ ticks in interpreter
1.1 pazsan 432:
433: : (') ( "name" -- nt ) \ gforth
1.32 anton 434: name name-too-short?
1.28 anton 435: find-name dup 0=
1.1 pazsan 436: IF
437: drop -&13 bounce
438: THEN ;
439:
440: : ' ( "name" -- xt ) \ core tick
1.31 crook 441: \g @i{xt} represents @i{name}'s interpretation
442: \g semantics. Perform @code{-14 throw} if the word has no
1.1 pazsan 443: \g interpretation semantics.
444: (') name?int ;
1.34 jwilke 445:
446: has? compiler 0= [IF] \ interpreter only version of IS and TO
447:
448: : IS ' >body ! ;
449: ' IS Alias TO
450:
451: [THEN]
1.1 pazsan 452:
453: \ \ the interpreter loop mar92py
454:
455: \ interpret 10mar92py
456:
457: Defer parser
458: Defer name ( -- c-addr count ) \ gforth
459: \ get the next word from the input buffer
460: ' (name) IS name
461: Defer compiler-notfound ( c-addr count -- )
462: Defer interpreter-notfound ( c-addr count -- )
463:
464: : no.extensions ( addr u -- )
465: 2drop -&13 bounce ;
466: ' no.extensions IS compiler-notfound
467: ' no.extensions IS interpreter-notfound
468:
469: : interpret ( ?? -- ?? ) \ gforth
470: \ interpret/compile the (rest of the) input buffer
1.33 jwilke 471: [ has? backtrace [IF] ]
1.24 anton 472: rp@ backtrace-rp0 !
1.33 jwilke 473: [ [THEN] ]
1.1 pazsan 474: BEGIN
475: ?stack name dup
476: WHILE
477: parser
478: REPEAT
479: 2drop ;
480:
481: \ interpreter 30apr92py
482:
483: \ not the most efficient implementations of interpreter and compiler
1.33 jwilke 484: : interpreter ( c-addr u -- )
1.1 pazsan 485: 2dup find-name dup
486: if
487: nip nip name>int execute
488: else
489: drop
490: 2dup 2>r snumber?
491: IF
492: 2rdrop
493: ELSE
494: 2r> interpreter-notfound
495: THEN
496: then ;
497:
498: ' interpreter IS parser
499:
500: \ \ Query Evaluate 07apr93py
501:
502: has? file 0= [IF]
1.12 pazsan 503: : sourceline# ( -- n ) 1 ;
1.1 pazsan 504: [THEN]
505:
506: : refill ( -- flag ) \ core-ext,block-ext,file-ext
1.29 crook 507: \G Attempt to fill the input buffer from the input source. When
508: \G the input source is the user input device, attempt to receive
509: \G input into the terminal input device. If successful, make the
510: \G result the input buffer, set @code{>IN} to 0 and return true;
511: \G otherwise return false. When the input source is a block, add 1
512: \G to the value of @code{BLK} to make the next block the input
513: \G source and current input buffer, and set @code{>IN} to 0;
514: \G return true if the new value of @code{BLK} is a valid block
515: \G number, false otherwise. When the input source is a text file,
516: \G attempt to read the next line from the file. If successful,
517: \G make the result the current input buffer, set @code{>IN} to 0
518: \G and return true; otherwise, return false. A successful result
519: \G includes receipt of a line containing 0 characters.
1.12 pazsan 520: [ has? file [IF] ]
521: blk @ IF 1 blk +! true 0 >in ! EXIT THEN
522: [ [THEN] ]
523: tib /line
524: [ has? file [IF] ]
525: loadfile @ ?dup
526: IF read-line throw
527: ELSE
528: [ [THEN] ]
529: sourceline# 0< IF 2drop false EXIT THEN
530: accept true
531: [ has? file [IF] ]
532: THEN
533: 1 loadline +!
534: [ [THEN] ]
535: swap #tib ! 0 >in ! ;
1.1 pazsan 536:
537: : query ( -- ) \ core-ext
1.29 crook 538: \G Make the user input device the input source. Receive input into
539: \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
540: \G superceeded by @code{accept}.
1.12 pazsan 541: [ has? file [IF] ]
542: blk off loadfile off
543: [ [THEN] ]
1.1 pazsan 544: tib /line accept #tib ! 0 >in ! ;
545:
546: \ save-mem extend-mem
547:
548: has? os [IF]
549: : save-mem ( addr1 u -- addr2 u ) \ gforth
550: \g copy a memory block into a newly allocated region in the heap
551: swap >r
552: dup allocate throw
553: swap 2dup r> -rot move ;
554:
555: : extend-mem ( addr1 u1 u -- addr addr2 u2 )
556: \ extend memory block allocated from the heap by u aus
557: \ the (possibly reallocated piece is addr2 u2, the extension is at addr
558: over >r + dup >r resize throw
559: r> over r> + -rot ;
560: [THEN]
561:
562: \ EVALUATE 17may93jaw
563:
564: has? file 0= [IF]
565: : push-file ( -- ) r>
1.12 pazsan 566: tibstack @ >r >tib @ >r #tib @ >r
1.1 pazsan 567: >tib @ tibstack @ = IF r@ tibstack +! THEN
568: tibstack @ >tib ! >in @ >r >r ;
569:
570: : pop-file ( throw-code -- throw-code )
571: r>
1.12 pazsan 572: r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ;
1.1 pazsan 573: [THEN]
574:
1.29 crook 575: : evaluate ( c-addr u -- ) \ core,block
576: \G Save the current input source specification. Store -1 in
577: \G @code{source-id} and 0 in @code{blk}. Set @code{>IN} to 0 and
578: \G make the string @var{c-addr u} the input source and input
579: \G buffer. Interpret. When the parse area is empty, restore the
580: \G input source specification.
581: push-file #tib ! >tib !
582: >in off
583: [ has? file [IF] ]
584: blk off loadfile off -1 loadline !
585: [ [THEN] ]
586: ['] interpret catch
587: pop-file throw ;
1.1 pazsan 588:
589: \ \ Quit 13feb93py
590:
591: Defer 'quit
592:
593: Defer .status
594:
595: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
596:
597: : (Query) ( -- )
1.12 pazsan 598: [ has? file [IF] ]
599: loadfile off blk off loadline off
600: [ [THEN] ]
601: refill drop ;
1.1 pazsan 602:
1.33 jwilke 603: : (quit)
604: BEGIN .status cr (query) interpret prompt AGAIN ;
1.1 pazsan 605:
606: ' (quit) IS 'quit
607:
608: \ \ DOERROR (DOERROR) 13jun93jaw
609:
610: 8 Constant max-errors
611: Variable error-stack 0 error-stack !
612: max-errors 6 * cells allot
613: \ format of one cell:
614: \ source ( addr u )
615: \ >in
616: \ line-number
617: \ Loadfilename ( addr u )
618:
619: : dec. ( n -- ) \ gforth
1.27 crook 620: \G Display @var{n} as a signed decimal number, followed by a space.
1.23 jwilke 621: \G !! not used...
1.1 pazsan 622: base @ decimal swap . base ! ;
623:
1.23 jwilke 624: : dec.r ( u -- ) \ gforth
1.27 crook 625: \G Display @var{u} as a unsigned decimal number
1.23 jwilke 626: base @ decimal swap 0 .r base ! ;
627:
1.1 pazsan 628: : hex. ( u -- ) \ gforth
1.27 crook 629: \G Display @var{u} as an unsigned hex number, prefixed with a "$" and
1.17 crook 630: \G followed by a space.
1.23 jwilke 631: \G !! not used...
1.33 jwilke 632: [char] $ emit base @ swap hex u. base ! ;
1.1 pazsan 633:
634: : typewhite ( addr u -- ) \ gforth
635: \ like type, but white space is printed instead of the characters
636: bounds ?do
637: i c@ #tab = if \ check for tab
638: #tab
639: else
640: bl
641: then
642: emit
643: loop ;
644:
645: DEFER DOERROR
1.33 jwilke 646:
647: has? backtrace [IF]
1.15 anton 648: Defer dobacktrace ( -- )
649: ' noop IS dobacktrace
1.33 jwilke 650: [THEN]
1.1 pazsan 651:
1.23 jwilke 652: : .error-string ( throw-code -- )
653: dup -2 =
654: IF "error @ ?dup IF count type THEN drop
655: ELSE .error
656: THEN ;
657:
658: : .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode )
659: \ addr2 u2: filename of included file
660: \ n2: line number
661: \ n1: error position in input line
662: \ addr1 u1: input line
663:
1.1 pazsan 664: cr error-stack @
665: IF
666: ." in file included from "
1.23 jwilke 667: type ." :" dec.r drop 2drop
1.1 pazsan 668: ELSE
1.23 jwilke 669: type ." :" dec.r ." : " 3 pick .error-string cr
670: dup 2over type cr drop
1.1 pazsan 671: nip -trailing 1- ( line-start index2 )
672: 0 >r BEGIN
673: 2dup + c@ bl > WHILE
674: r> 1+ >r 1- dup 0< UNTIL THEN 1+
675: ( line-start index1 )
676: typewhite
677: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
678: [char] ^ emit
679: loop
1.23 jwilke 680: THEN ;
1.1 pazsan 681:
682: : (DoError) ( throw-code -- )
683: [ has? os [IF] ]
1.8 pazsan 684: >stderr
1.1 pazsan 685: [ [THEN] ]
686: sourceline# IF
1.8 pazsan 687: source >in @ sourceline# 0 0 .error-frame
1.1 pazsan 688: THEN
689: error-stack @ 0 ?DO
690: -1 error-stack +!
691: error-stack dup @ 6 * cells + cell+
692: 6 cells bounds DO
693: I @
694: cell +LOOP
695: .error-frame
696: LOOP
1.33 jwilke 697: drop
698: [ has? backtrace [IF] ]
699: dobacktrace
700: [ [THEN] ]
1.8 pazsan 701: normal-dp dpp ! ;
1.1 pazsan 702:
703: ' (DoError) IS DoError
704:
705: : quit ( ?? -- ?? ) \ core
1.27 crook 706: \G Empty the return stack, make the user input device
707: \G the input source, enter interpret state and start
708: \G the text interpreter.
1.5 anton 709: rp0 @ rp! handler off clear-tibstack >tib @ >r
1.1 pazsan 710: BEGIN
711: [ has? compiler [IF] ]
712: postpone [
713: [ [THEN] ]
714: ['] 'quit CATCH dup
715: WHILE
1.22 anton 716: <# \ reset hold area, or we may get another error
1.1 pazsan 717: DoError r@ >tib ! r@ tibstack !
718: REPEAT
719: drop r> >tib ! ;
720:
721: \ \ Cold Boot 13feb93py
722:
723: : (bootmessage)
724: ." GForth " version-string type
1.11 anton 725: ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
1.1 pazsan 726: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
727: [ has? os [IF] ]
728: cr ." Type `bye' to exit"
729: [ [THEN] ] ;
730:
731: defer bootmessage
732: defer process-args
733:
734: ' (bootmessage) IS bootmessage
735:
1.10 anton 736: Defer 'cold ( -- ) \ gforth tick-cold
1.1 pazsan 737: \ hook (deferred word) for things to do right before interpreting the
738: \ command-line arguments
739: ' noop IS 'cold
740:
741:
742: Variable init8
743:
744: : cold ( -- ) \ gforth
745: [ has? file [IF] ]
746: pathstring 2@ fpath only-path
747: init-included-files
748: [ [THEN] ]
749: 'cold
750: init8 chainperform
751: [ has? file [IF] ]
1.8 pazsan 752: process-args
1.12 pazsan 753: loadline off
1.1 pazsan 754: [ [THEN] ]
755: bootmessage
1.12 pazsan 756: quit ;
1.1 pazsan 757:
1.5 anton 758: : clear-tibstack ( -- )
759: [ has? glocals [IF] ]
760: lp@ forthstart 7 cells + @ -
761: [ [ELSE] ]
762: [ has? os [IF] ]
1.8 pazsan 763: r0 @ forthstart 6 cells + @ -
1.5 anton 764: [ [ELSE] ]
1.16 pazsan 765: sp@ $10 cells +
1.5 anton 766: [ [THEN] ]
767: [ [THEN] ]
768: dup >tib ! tibstack ! #tib off >in off ;
769:
1.1 pazsan 770: : boot ( path **argv argc -- )
771: main-task up!
772: [ has? os [IF] ]
773: stdout TO outfile-id
1.7 pazsan 774: stdin TO infile-id
1.1 pazsan 775: \ !! [ [THEN] ]
776: \ !! [ has? file [IF] ]
777: argc ! argv ! pathstring 2!
778: [ [THEN] ]
779: sp@ sp0 !
1.5 anton 780: clear-tibstack
1.1 pazsan 781: rp@ rp0 !
782: [ has? floating [IF] ]
783: fp@ fp0 !
784: [ [THEN] ]
1.8 pazsan 785: ['] cold catch DoError cr
1.1 pazsan 786: [ has? os [IF] ]
1.35 anton 787: 1 (bye) \ !! determin exit code from throw code?
1.1 pazsan 788: [ [THEN] ]
789: ;
790:
791: has? os [IF]
792: : bye ( -- ) \ tools-ext
793: [ has? file [IF] ]
794: script? 0= IF cr THEN
795: [ [ELSE] ]
796: cr
797: [ [THEN] ]
798: 0 (bye) ;
799: [THEN]
800:
801: \ **argv may be scanned by the C starter to get some important
802: \ information, as -display and -geometry for an X client FORTH
803: \ or space and stackspace overrides
804:
805: \ 0 arg contains, however, the name of the program.
806:
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