Return to int.fs CVS log

Up to [gforth] / gforth / kernel

Makefile.in

-- changes to make documentation build with moofglos.fs
   rather than with mini-oof.fs (since the former contains glossary
   entries and the latter does not)

assert.fs blocks.fs debug.fs environ.fs errors.fs extend.fs float.fs
glocals.fs moofglos.fs prim search.fs struct.fs stuff.fs vt100.fs
kernel/args.fs kernel/basics.fs kernel/comp.fs kernel/cond.fs
kernel/files.fs kernel/getdoers.fs kernel/int.fs kernel/io.fs
kernel/nio.fs kernel/paths.fs kernel/require.fs kernel/special.fs
kernel/tools.fs kernel/toolsext.fs kernel/vars.fs

-- many small changes to glossary entries.. I think most are done
   now, so I hope to change far fewer files next time!

doc/gforth.ds

-- many, many small changes and a few large ones. Moved some sections
   around, fixed typos and formatting errors, added new section on
   exception handling, rearranged 'files' section.

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