Return to int.fs CVS log

Up to [gforth] / gforth / kernel

Major re-write of manual sections concerning text interpreter and
defining words. Much fine-tuning of other sections. The manual is
``nearly finished'' -- at least, all the major pieces of work that
I envisaged for the first mods (which were only going to take a
couple of weeks...). The manual has grown from 127 pages to 192
which is good news in terms of content but bad news in terms of the
time it takes to print out on my HP550C DeskJet.

Other changes are just tweaks to glossary entries.

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