File:  [gforth] / gforth / kernel / int.fs
Revision 1.18: download - view: text, annotated - select for diffs
Fri Feb 5 16:08:16 1999 UTC (25 years, 1 month ago) by anton
Branches: MAIN
CVS tags: HEAD
fixed DPL bug ("1." now gives a DPL of 0)

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>