File:  [gforth] / gforth / Attic / kernal.fs
Revision 1.11: download - view: text, annotated - select for diffs
Wed Jul 13 19:21:03 1994 UTC (27 years ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Moved setjmp from engine to go_forth, because the socalled "globbered"
variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.

    1: \ KERNAL.FS    ANS figFORTH kernal                     17dec92py
    2: \ $ID:
    3: \ Idea and implementation: Bernd Paysan (py)
    4: \ Copyright 1992 by the ANSI figForth Development Group
    5: 
    6: \ Log:  ', '- usw. durch [char] ... ersetzt
    7: \       man sollte die unterschiedlichen zahlensysteme
    8: \       mit $ und & zumindest im interpreter weglassen
    9: \       schon erledigt!
   10: \       11may93jaw
   11: \ name>         0= nicht vorhanden              17may93jaw
   12: \               nfa can be lfa or nfa!
   13: \ find          splited into find and (find)
   14: \               (find) for later use            17may93jaw
   15: \ search        replaced by lookup because
   16: \               it is a word of the string wordset
   17: \                                               20may93jaw
   18: \ postpone      added immediate                 21may93jaw
   19: \ to            added immediate                 07jun93jaw
   20: \ cfa, header   put "here lastcfa !" in
   21: \               cfa, this is more logical
   22: \               and noname: works wothout
   23: \               extra "here lastcfa !"          08jun93jaw
   24: \ (parse-white) thrown out
   25: \ refill        added outer trick
   26: \               to show there is something
   27: \               going on                        09jun93jaw
   28: \ leave ?leave  somebody forgot UNLOOP!!!       09jun93jaw
   29: \ leave ?leave  unloop thrown out
   30: \               unloop after loop is used       10jun93jaw
   31: 
   32: HEX
   33: 
   34: \ Bit string manipulation                              06oct92py
   35: 
   36: Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
   37: DOES> ( n -- )  + c@ ;
   38: 
   39: : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
   40: : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   41: 
   42: : relinfo ( -- addr )  forthstart dup @ + ;
   43: : >rel  ( addr -- n )  forthstart - ;
   44: : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   45: 
   46: \ here allot , c, A,                                   17dec92py
   47: 
   48: : dp	( -- addr )  dpp @ ;
   49: : here  ( -- here )  dp @ ;
   50: : allot ( n -- )     dp +! ;
   51: : c,    ( c -- )     here 1 chars allot c! ;
   52: : ,     ( x -- )     here cell allot  ! ;
   53: : 2,    ( w1 w2 -- ) \ general
   54:     here 2 cells allot 2! ;
   55: 
   56: : aligned ( addr -- addr' )
   57:   [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   58: : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;
   59: 
   60: : faligned ( addr -- f-addr )
   61:   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   62: 
   63: : falign ( -- )
   64:   here dup faligned swap
   65:   ?DO
   66:       bl c,
   67:   LOOP ;
   68: 
   69: 
   70: 
   71: : A!    ( addr1 addr2 -- )  dup relon ! ;
   72: : A,    ( addr -- )     here cell allot A! ;
   73: 
   74: \ on off                                               23feb93py
   75: 
   76: : on  ( addr -- )  true  swap ! ;
   77: : off ( addr -- )  false swap ! ;
   78: 
   79: \ name> found                                          17dec92py
   80: 
   81: : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;
   82: : name>    ( nfa -- cfa )    cell+
   83:   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
   84: 
   85: : found ( nfa -- cfa n )  cell+
   86:   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
   87:                   -1 r@ $40 and     IF  1-      THEN
   88:                      r> $20 and     IF  negate  THEN  ;
   89: 
   90: \ (find)                                               17dec92py
   91: 
   92: \ : (find) ( addr count nfa1 -- nfa2 / false )
   93: \   BEGIN  dup  WHILE  dup >r
   94: \          cell+ count $1F and dup >r 2over r> =
   95: \          IF  -text  0= IF  2drop r> EXIT  THEN
   96: \          ELSE  2drop drop  THEN  r> @
   97: \   REPEAT nip nip ;
   98: 
   99: \ place bounds                                         13feb93py
  100: 
  101: : place  ( addr len to -- ) over >r  rot over 1+  r> move c! ;
  102: : bounds ( beg count -- end beg )  over + swap ;
  103: 
  104: \ input stream primitives                              23feb93py
  105: 
  106: : tib   >tib @ ;
  107: Defer source
  108: : (source) ( -- addr count ) tib #tib @ ;
  109: ' (source) IS source
  110: 
  111: \ (word)                                               22feb93py
  112: 
  113: : scan   ( addr1 n1 char -- addr2 n2 )  >r
  114:   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string
  115:   REPEAT  THEN  rdrop ;
  116: : skip   ( addr1 n1 char -- addr2 n2 )  >r
  117:   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string
  118:   REPEAT  THEN  rdrop ;
  119: 
  120: : (word) ( addr1 n1 char -- addr2 n2 )
  121:   dup >r skip 2dup r> scan  nip - ;
  122: 
  123: \ (word) should fold white spaces
  124: \ this is what (parse-white) does
  125: 
  126: \ word parse                                           23feb93py
  127: 
  128: : parse-word  ( char -- addr len )
  129:   source 2dup >r >r >in @ /string
  130:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
  131:   2dup + r> - 1+ r> min >in ! ;
  132: : word   ( char -- addr )
  133:   parse-word here place  bl here count + c!  here ;
  134: 
  135: : parse    ( char -- addr len )
  136:   >r  source  >in @ /string  over  swap r>  scan >r
  137:   over - dup r> IF 1+ THEN  >in +! ;
  138: 
  139: \ name                                                 13feb93py
  140: 
  141: : capitalize ( addr -- addr )
  142:   dup count chars bounds
  143:   ?DO  I c@ toupper I c! 1 chars +LOOP ;
  144: : (name)  ( -- addr )  bl word ;
  145: : (cname) ( -- addr )  bl word capitalize ;
  146: 
  147: \ Literal                                              17dec92py
  148: 
  149: : Literal  ( n -- )  state @ IF postpone lit  , THEN ;
  150:                                                       immediate
  151: : ALiteral ( n -- )  state @ IF postpone lit A, THEN ;
  152:                                                       immediate
  153: 
  154: : char   ( 'char' -- n )  bl word char+ c@ ;
  155: : [char] ( 'char' -- n )  char postpone Literal ; immediate
  156: ' [char] Alias Ascii immediate
  157: 
  158: : (compile) ( -- )  r> dup cell+ >r @ A, ;
  159: : postpone ( "name" -- )
  160:   name find dup 0= abort" Can't compile "
  161:   0> IF  A,  ELSE  postpone (compile) A,  THEN ;
  162:                                              immediate restrict
  163: 
  164: \ Use (compile) for the old behavior of compile!
  165: 
  166: \ digit?                                               17dec92py
  167: 
  168: : digit?   ( char -- digit true/ false )
  169:   base @ $100 =
  170:   IF
  171:     true EXIT
  172:   THEN
  173:   toupper [char] 0 - dup 9 u> IF
  174:     [ 'A '9 1 + -  ] literal -
  175:     dup 9 u<= IF
  176:       drop false EXIT
  177:     THEN
  178:   THEN
  179:   dup base @ u>= IF
  180:     drop false EXIT
  181:   THEN
  182:   true ;
  183: 
  184: : accumulate ( +d0 addr digit - +d1 addr )
  185:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  186: : >number ( d addr count -- d addr count )
  187:   0 ?DO  count digit? WHILE  accumulate  LOOP 0
  188:   ELSE  1- I' I - UNLOOP  THEN ;
  189: 
  190: \ number? number                                       23feb93py
  191: 
  192: Create bases   10 ,   2 ,   A , 100 ,
  193: \              16     2    10   Zeichen
  194: \ !! this saving and restoring base is an abomination! - anton
  195: : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<
  196:   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;
  197: : number?  ( string -- string 0 / n -1 )  base @ >r
  198:   dup count over c@ [char] - = dup >r  IF 1 /string  THEN
  199:   getbase  dpl on  0 0 2swap
  200:   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE
  201:          dup dpl ! over c@ [char] . =  WHILE
  202:          1 /string
  203:   REPEAT  THEN  2drop 2drop rdrop false r> base ! EXIT  THEN
  204:   2drop rot drop rdrop r> IF dnegate THEN
  205:   dpl @ dup 0< IF  nip  THEN  r> base ! ;
  206: : s>d ( n -- d ) dup 0< ;
  207: : number ( string -- d )
  208:   number? ?dup 0= abort" ?"  0< IF s>d THEN ;
  209: 
  210: \ space spaces ud/mod                                  21mar93py
  211: decimal
  212: Create spaces  bl 80 times \ times from target compiler! 11may93jaw
  213: DOES>   ( u -- )  swap
  214:         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
  215: hex
  216: : space   1 spaces ;
  217: 
  218: : ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r
  219:                                     um/mod r> ;
  220: 
  221: : pad    ( -- addr )
  222:   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
  223: 
  224: \ hold <# #> sign # #s                                 25jan92py
  225: 
  226: : hold    ( char -- )         pad cell - -1 chars over +! @ c! ;
  227: 
  228: : <#                          pad cell - dup ! ;
  229: 
  230: : #>      ( 64b -- addr +n )  2drop pad cell - dup @ tuck - ;
  231: 
  232: : sign    ( n -- )            0< IF  [char] - hold  THEN ;
  233: 
  234: : #       ( +d1 -- +d2 )    base @ 2 max ud/mod rot 9 over <
  235:   IF [ char A char 9 - 1- ] Literal +  THEN  [char] 0 + hold ;
  236: 
  237: : #s      ( +d -- 0 0 )         BEGIN  # 2dup d0=  UNTIL ;
  238: 
  239: \ print numbers                                        07jun92py
  240: 
  241: : d.r      >r tuck  dabs  <# #s  rot sign #>
  242:            r> over - spaces  type ;
  243: 
  244: : ud.r     >r <# #s #> r> over - spaces type ;
  245: 
  246: : .r       >r s>d r> d.r ;
  247: : u.r      0 swap ud.r ;
  248: 
  249: : d.       0 d.r space ;
  250: : ud.      0 ud.r space ;
  251: 
  252: : .        s>d d. ;
  253: : u.       0 ud. ;
  254: 
  255: \ catch throw                                          23feb93py
  256: \ bounce                                                08jun93jaw
  257: 
  258: \ !! allow the user to add rollback actions    anton
  259: \ !! use a separate exception stack?           anton
  260: 
  261: : lp@ ( -- addr )
  262:  laddr# [ 0 , ] ;
  263: 
  264: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
  265:   >r sp@ r> swap >r       \ don't count xt! jaw
  266:   fp@ >r
  267:   lp@ >r
  268:   handler @ >r
  269:   rp@ handler !
  270:   execute
  271:   r> handler ! rdrop rdrop rdrop 0 ;
  272: 
  273: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
  274:     ?DUP IF
  275: 	[ here 4 cells ! ]
  276: 	handler @ rp!
  277: 	r> handler !
  278: 	r> lp!
  279: 	r> fp!
  280: 	r> swap >r sp! r>
  281:     THEN ;
  282: 
  283: \ Bouncing is very fine,
  284: \ programming without wasting time...   jaw
  285: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
  286: \ a throw without data or fp stack restauration
  287:   ?DUP IF
  288:     handler @ rp!
  289:     r> handler !
  290:     r> lp!
  291:     rdrop
  292:     rdrop
  293:   THEN ;
  294: 
  295: \ ?stack                                               23feb93py
  296: 
  297: : ?stack ( ?? -- ?? )  sp@ s0 @ > IF  -4 throw  THEN ;
  298: \ ?stack should be code -- it touches an empty stack!
  299: 
  300: \ interpret                                            10mar92py
  301: 
  302: Defer parser
  303: Defer name      ' (name) IS name
  304: Defer notfound
  305: 
  306: : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;
  307: 
  308: ' no.extensions IS notfound
  309: 
  310: : interpret
  311:   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;
  312: 
  313: \ interpreter compiler                                 30apr92py
  314: 
  315: : interpreter  ( name -- ) find ?dup
  316:   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN
  317:   number? 0= IF  notfound THEN ;
  318: 
  319: ' interpreter  IS  parser
  320: 
  321: : compiler     ( name -- ) find  ?dup
  322:   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup
  323:   IF  0> IF  swap postpone Literal  THEN  postpone Literal
  324:   ELSE  drop notfound  THEN ;
  325: 
  326: : [     ['] interpreter  IS parser state off ; immediate
  327: : ]     ['] compiler     IS parser state on  ;
  328: 
  329: \ locals stuff needed for control structures
  330: 
  331: : compile-lp+! ( n -- )
  332:     dup negate locals-size +!
  333:     0 over = if
  334:     else -4 over = if postpone -4lp+!
  335:     else  8 over = if postpone  8lp+!
  336:     else 16 over = if postpone 16lp+!
  337:     else postpone lp+!# dup ,
  338:     then then then then drop ;
  339: 
  340: : adjust-locals-size ( n -- )
  341:     \ sets locals-size to n and generates an appropriate lp+!
  342:     locals-size @ swap - compile-lp+! ;
  343: 
  344: 
  345: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
  346: AConstant locals-list \ acts like a variable that contains
  347: 		      \ a linear list of locals names
  348: 
  349: 
  350: variable dead-code \ true if normal code at "here" would be dead
  351: 
  352: : unreachable ( -- )
  353: \ declares the current point of execution as unreachable
  354:  dead-code on ;
  355: 
  356: \ locals list operations
  357: 
  358: : common-list ( list1 list2 -- list3 )
  359: \ list1 and list2 are lists, where the heads are at higher addresses than
  360: \ the tail. list3 is the largest sublist of both lists.
  361:  begin
  362:    2dup u<>
  363:  while
  364:    2dup u>
  365:    if
  366:      swap
  367:    then
  368:    @
  369:  repeat
  370:  drop ;
  371: 
  372: : sub-list? ( list1 list2 -- f )
  373: \ true iff list1 is a sublist of list2
  374:  begin
  375:    2dup u<
  376:  while
  377:    @
  378:  repeat
  379:  = ;
  380: 
  381: : list-size ( list -- u )
  382: \ size of the locals frame represented by list
  383:  0 ( list n )
  384:  begin
  385:    over 0<>
  386:  while
  387:    over
  388:    name> >body @ max
  389:    swap @ swap ( get next )
  390:  repeat
  391:  faligned nip ;
  392: 
  393: : set-locals-size-list ( list -- )
  394:  dup locals-list !
  395:  list-size locals-size ! ;
  396: 
  397: : check-begin ( list -- )
  398: \ warn if list is not a sublist of locals-list
  399:  locals-list @ sub-list? 0= if
  400:    \ !! print current position
  401:    ." compiler was overly optimistic about locals at a BEGIN" cr
  402:    \ !! print assumption and reality
  403:  then ;
  404: 
  405: \ Control Flow Stack
  406: \ orig, etc. have the following structure:
  407: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
  408: \ address (of the branch or the instruction to be branched to) (second)
  409: \ locals-list (valid at address) (third)
  410: 
  411: \ types
  412: 0 constant defstart
  413: 1 constant live-orig
  414: 2 constant dead-orig
  415: 3 constant dest \ the loopback branch is always assumed live
  416: 4 constant do-dest
  417: 5 constant scopestart
  418: 
  419: : def? ( n -- )
  420:     defstart <> abort" unstructured " ;
  421: 
  422: : orig? ( n -- )
  423:  dup live-orig <> swap dead-orig <> and abort" expected orig " ;
  424: 
  425: : dest? ( n -- )
  426:  dest <> abort" expected dest " ;
  427: 
  428: : do-dest? ( n -- )
  429:  do-dest <> abort" expected do-dest " ;
  430: 
  431: : scope? ( n -- )
  432:  scopestart <> abort" expected scope " ;
  433: 
  434: : non-orig? ( n -- )
  435:  dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
  436: 
  437: : cs-item? ( n -- )
  438:  live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
  439: 
  440: 3 constant cs-item-size
  441: 
  442: : CS-PICK ( ... u -- ... destu )
  443:  1+ cs-item-size * 1- >r
  444:  r@ pick  r@ pick  r@ pick
  445:  rdrop
  446:  dup non-orig? ;
  447: 
  448: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )
  449:  1+ cs-item-size * 1- >r
  450:  r@ roll r@ roll r@ roll
  451:  rdrop
  452:  dup cs-item? ; 
  453: 
  454: : cs-push-part ( -- list addr )
  455:  locals-list @ here ;
  456: 
  457: : cs-push-orig ( -- orig )
  458:  cs-push-part dead-code @
  459:  if
  460:    dead-orig
  461:  else
  462:    live-orig
  463:  then ;   
  464: 
  465: \ Structural Conditionals                              12dec92py
  466: 
  467: : ?struc      ( flag -- )       abort" unstructured " ;
  468: : sys?        ( sys -- )        dup 0= ?struc ;
  469: : >mark ( -- orig )
  470:  cs-push-orig 0 , ;
  471: : >resolve    ( addr -- )        here over - swap ! ;
  472: : <resolve    ( addr -- )        here - , ;
  473: 
  474: : BUT       1 cs-roll ;                      immediate restrict
  475: : YET       0 cs-pick ;                       immediate restrict
  476: 
  477: \ Structural Conditionals                              12dec92py
  478: 
  479: : AHEAD ( -- orig )
  480:  POSTPONE branch >mark unreachable ; immediate restrict
  481: 
  482: : IF ( -- orig )
  483:  POSTPONE ?branch >mark ; immediate restrict
  484: 
  485: : ?DUP-IF \ general
  486: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
  487: \ better handled by tools like stack checkers
  488:     POSTPONE ?dup POSTPONE if ;       immediate restrict
  489: : ?DUP-NOT-IF \ general
  490:     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
  491: 
  492: : THEN ( orig -- )
  493:     dup orig?
  494:     dead-code @
  495:     if
  496: 	dead-orig =
  497: 	if
  498: 	    >resolve drop
  499: 	else
  500: 	    >resolve set-locals-size-list dead-code off
  501: 	then
  502:     else
  503: 	dead-orig =
  504: 	if
  505: 	    >resolve drop
  506: 	else \ both live
  507: 	    over list-size adjust-locals-size
  508: 	    >resolve
  509: 	    locals-list @ common-list dup list-size adjust-locals-size
  510: 	    locals-list !
  511: 	then
  512:     then ; immediate restrict
  513: 
  514: ' THEN alias ENDIF immediate restrict \ general
  515: \ Same as "THEN". This is what you use if your program will be seen by
  516: \ people who have not been brought up with Forth (or who have been
  517: \ brought up with fig-Forth).
  518: 
  519: : ELSE ( orig1 -- orig2 )
  520:     POSTPONE ahead
  521:     1 cs-roll
  522:     POSTPONE then ; immediate restrict
  523: 
  524: 
  525: : BEGIN ( -- dest )
  526:     dead-code @ if
  527: 	\ set up an assumption of the locals visible here
  528: 	\ currently we just take the top cs-item
  529: 	\ it would be more intelligent to take the top orig
  530: 	\   but that can be arranged by the user
  531: 	dup defstart <> if
  532: 	    dup cs-item?
  533: 	    2 pick
  534: 	else
  535: 	    0
  536: 	then
  537: 	set-locals-size-list
  538:     then
  539:     cs-push-part dest
  540:     dead-code off ; immediate restrict
  541: 
  542: \ AGAIN (the current control flow joins another, earlier one):
  543: \ If the dest-locals-list is not a subset of the current locals-list,
  544: \ issue a warning (see below). The following code is generated:
  545: \ lp+!# (current-local-size - dest-locals-size)
  546: \ branch <begin>
  547: : AGAIN ( dest -- )
  548:     dest?
  549:     over list-size adjust-locals-size
  550:     POSTPONE branch
  551:     <resolve
  552:     check-begin
  553:     unreachable ; immediate restrict
  554: 
  555: \ UNTIL (the current control flow may join an earlier one or continue):
  556: \ Similar to AGAIN. The new locals-list and locals-size are the current
  557: \ ones. The following code is generated:
  558: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
  559: : until-like ( list addr xt1 xt2 -- )
  560:     \ list and addr are a fragment of a cs-item
  561:     \ xt1 is the conditional branch without lp adjustment, xt2 is with
  562:     >r >r
  563:     locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
  564: 	r> drop r> compile,
  565: 	swap <resolve ( list adjustment ) ,
  566:     else ( list dest-addr adjustment )
  567: 	drop
  568: 	r> compile, <resolve
  569: 	r> drop
  570:     then ( list )
  571:     check-begin ;
  572: 
  573: : UNTIL ( dest -- )
  574:     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
  575: 
  576: : WHILE ( dest -- orig dest )
  577:     POSTPONE if
  578:     1 cs-roll ; immediate restrict
  579: 
  580: : REPEAT ( orig dest -- )
  581:     POSTPONE again
  582:     POSTPONE then ; immediate restrict
  583: 
  584: 
  585: \ counted loops
  586: 
  587: \ leave poses a little problem here
  588: \ we have to store more than just the address of the branch, so the
  589: \ traditional linked list approach is no longer viable.
  590: \ This is solved by storing the information about the leavings in a
  591: \ special stack.
  592: 
  593: \ !! remove the fixed size limit. 'Tis not hard.
  594: 20 constant leave-stack-size
  595: create leave-stack  60 cells allot
  596: Avariable leave-sp  leave-stack 3 cells + leave-sp !
  597: 
  598: : clear-leave-stack ( -- )
  599:     leave-stack leave-sp ! ;
  600: 
  601: \ : leave-empty? ( -- f )
  602: \  leave-sp @ leave-stack = ;
  603: 
  604: : >leave ( orig -- )
  605:     \ push on leave-stack
  606:     leave-sp @
  607:     dup [ leave-stack 60 cells + ] Aliteral
  608:     >= abort" leave-stack full"
  609:     tuck ! cell+
  610:     tuck ! cell+
  611:     tuck ! cell+
  612:     leave-sp ! ;
  613: 
  614: : leave> ( -- orig )
  615:     \ pop from leave-stack
  616:     leave-sp @
  617:     dup leave-stack <= IF
  618:        drop 0 0 0  EXIT  THEN
  619:     cell - dup @ swap
  620:     cell - dup @ swap
  621:     cell - dup @ swap
  622:     leave-sp ! ;
  623: 
  624: : DONE ( orig -- )  drop >r drop
  625:     \ !! the original done had ( addr -- )
  626:     begin
  627: 	leave>
  628: 	over r@ u>=
  629:     while
  630: 	POSTPONE then
  631:     repeat
  632:     >leave rdrop ; immediate restrict
  633: 
  634: : LEAVE ( -- )
  635:     POSTPONE ahead
  636:     >leave ; immediate restrict
  637: 
  638: : ?LEAVE ( -- )
  639:     POSTPONE 0= POSTPONE if
  640:     >leave ; immediate restrict
  641: 
  642: : DO ( -- do-sys )
  643:     POSTPONE (do)
  644:     POSTPONE begin drop do-dest
  645:     ( 0 0 0 >leave ) ; immediate restrict
  646: 
  647: : ?DO ( -- do-sys )
  648:     ( 0 0 0 >leave )
  649:     POSTPONE (?do)
  650:     >mark >leave
  651:     POSTPONE begin drop do-dest ; immediate restrict
  652: 
  653: : FOR ( -- do-sys )
  654:     POSTPONE (for)
  655:     POSTPONE begin drop do-dest
  656:     ( 0 0 0 >leave ) ; immediate restrict
  657: 
  658: \ LOOP etc. are just like UNTIL
  659: 
  660: : loop-like ( do-sys xt1 xt2 -- )
  661:     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
  662:     until-like  POSTPONE done  POSTPONE unloop ;
  663: 
  664: : LOOP ( do-sys -- )
  665:  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
  666: 
  667: : +LOOP ( do-sys -- )
  668:  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
  669: 
  670: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
  671: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
  672: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
  673: \ negative increments.
  674: : S+LOOP ( do-sys -- )
  675:  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
  676: 
  677: : NEXT ( do-sys -- )
  678:  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
  679: 
  680: \ Structural Conditionals                              12dec92py
  681: 
  682: : EXIT ( -- )
  683:     0 adjust-locals-size
  684:     POSTPONE ;s
  685:     unreachable ; immediate restrict
  686: 
  687: : ?EXIT ( -- )
  688:      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
  689: 
  690: \ Strings                                              22feb93py
  691: 
  692: : ," ( "string"<"> -- ) [char] " parse
  693:   here over char+ allot  place align ;
  694: : "lit ( -- addr )
  695:   r> r> dup count + aligned >r swap >r ;               restrict
  696: : (.")     "lit count type ;                           restrict
  697: : (S")     "lit count ;                                restrict
  698: : SLiteral postpone (S") here over char+ allot  place align ;
  699:                                              immediate restrict
  700: : S"       [char] " parse  state @ IF  postpone SLiteral  THEN ;
  701:                                              immediate
  702: : ."       state @  IF    postpone (.") ,"  align
  703:                     ELSE  [char] " parse type  THEN  ;  immediate
  704: : (        [char] ) parse 2drop ;                       immediate
  705: : \        source >in ! drop ;                          immediate
  706: 
  707: \ error handling                                       22feb93py
  708: \ 'abort thrown out!                                   11may93jaw
  709: 
  710: : (abort")      "lit >r IF  r> "error ! -2 throw  THEN
  711:                 rdrop ;
  712: : abort"        postpone (abort") ," ;        immediate restrict
  713: 
  714: \ Header states                                        23feb93py
  715: 
  716: : flag! ( 8b -- )
  717:     last @ dup 0= abort" last word was headerless"
  718:     cell+ tuck c@ xor swap c! ;
  719: : immediate     $20 flag! ;
  720: : restrict      $40 flag! ;
  721: \ ' noop alias restrict
  722: 
  723: \ Header                                               23feb93py
  724: 
  725: \ input-stream, nextname and noname are quite ugly (passing
  726: \ information through global variables), but they are useful for dealing
  727: \ with existing/independent defining words
  728: 
  729: defer header
  730: 
  731: : name,  ( "name" -- )
  732:     name c@
  733:     dup $1F u> &-19 and throw ( is name too long? )
  734:     1+ chars allot align ;
  735: : input-stream-header ( "name" -- )
  736:     \ !! this is f83-implementation-dependent
  737:     align here last !  -1 A,
  738:     name, $80 flag! ;
  739: 
  740: : input-stream ( -- )  \ general
  741: \ switches back to getting the name from the input stream ;
  742:     ['] input-stream-header IS header ;
  743: 
  744: ' input-stream-header IS header
  745: 
  746: \ !! make that a 2variable
  747: create nextname-buffer 32 chars allot
  748: 
  749: : nextname-header ( -- )
  750:     \ !! f83-implementation-dependent
  751:     nextname-buffer count
  752:     align here last ! -1 A,
  753:     dup c,  here swap chars  dup allot  move  align
  754:     $80 flag!
  755:     input-stream ;
  756: 
  757: \ the next name is given in the string
  758: : nextname ( c-addr u -- ) \ general
  759:     dup $1F u> &-19 and throw ( is name too long? )
  760:     nextname-buffer c! ( c-addr )
  761:     nextname-buffer count move
  762:     ['] nextname-header IS header ;
  763: 
  764: : noname-header ( -- )
  765:     0 last !
  766:     input-stream ;
  767: 
  768: : noname ( -- ) \ general
  769: \ the next defined word remains anonymous. The xt of that word is given by lastxt
  770:     ['] noname-header IS header ;
  771: 
  772: : lastxt ( -- xt ) \ general
  773: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
  774:     lastcfa @ ;
  775: 
  776: : Alias    ( cfa "name" -- )
  777:   Header reveal , $80 flag! ;
  778: 
  779: : name>string ( nfa -- addr count )
  780:  cell+ count $1F and ;
  781: 
  782: Create ???  0 , 3 c, char ? c, char ? c, char ? c,
  783: : >name ( cfa -- nfa )
  784:  $21 cell do
  785:    dup i - count $9F and + aligned over $80 + = if
  786:      i - cell - unloop exit
  787:    then
  788:  cell +loop
  789:  drop ??? ( wouldn't 0 be better? ) ;
  790: 
  791: \ indirect threading                                   17mar93py
  792: 
  793: : cfa,     ( code-address -- )
  794:     here lastcfa !
  795:     here  0 A, 0 ,  code-address! ;
  796: : compile, ( xt -- )		A, ;
  797: : !does    ( addr -- )		lastcfa @ does-code! ;
  798: : (;code)  ( R: addr -- )	r> /does-handler + !does ;
  799: : dodoes,  ( -- )
  800:   here /does-handler allot does-handler! ;
  801: 
  802: \ direct threading is implementation dependent
  803: 
  804: : Create    Header reveal [ :dovar ] Literal cfa, ;
  805: 
  806: \ DOES>                                                17mar93py
  807: 
  808: : DOES>  ( compilation: -- )
  809:     state @
  810:     IF
  811: 	;-hook postpone (;code) dodoes,
  812:     ELSE
  813: 	dodoes, here !does 0 ]
  814:     THEN 
  815:     :-hook ; immediate
  816: 
  817: \ Create Variable User Constant                        17mar93py
  818: 
  819: : Variable  Create 0 , ;
  820: : AVariable Create 0 A, ;
  821: : 2VARIABLE ( "name" -- ) \ double
  822:     create 0 , 0 , ;
  823:     
  824: : User      Variable ;
  825: : AUser     AVariable ;
  826: 
  827: : (Constant)  Header reveal [ :docon ] Literal cfa, ;
  828: : Constant  (Constant) , ;
  829: : AConstant (Constant) A, ;
  830: 
  831: : 2CONSTANT
  832:     create ( w1 w2 "name" -- )
  833:         2,
  834:     does> ( -- w1 w2 )
  835:         2@ ;
  836:     
  837: \ IS Defer What's Defers TO                            24feb93py
  838: 
  839: : Defer
  840:   Create ( -- ) 
  841:     ['] noop A,
  842:   DOES> ( ??? )
  843:     @ execute ;
  844: 
  845: : IS ( addr "name" -- )
  846:     ' >body
  847:     state @
  848:     IF    postpone ALiteral postpone !  
  849:     ELSE  !
  850:     THEN ;  immediate
  851: ' IS Alias TO immediate
  852: 
  853: : What's ( "name" -- addr )  ' >body
  854:   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;
  855:                                              immediate
  856: : Defers ( "name" -- )  ' >body @ compile, ;
  857:                                              immediate restrict
  858: 
  859: \ : ;                                                  24feb93py
  860: 
  861: defer :-hook ( sys1 -- sys2 )
  862: defer ;-hook ( sys2 -- sys1 )
  863: 
  864: : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;
  865: : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
  866:   immediate restrict
  867: 
  868: : :noname ( -- xt colon-sys )
  869:     0 last !
  870:     here [ :docol ] Literal cfa, 0 ] :-hook ;
  871: 
  872: \ Search list handling                                 23feb93py
  873: 
  874: AVariable current
  875: 
  876: : last?   ( -- false / nfa nfa )    last @ ?dup ;
  877: : (reveal) ( -- )
  878:   last?
  879:   IF
  880:       dup @ 0<
  881:       IF
  882: 	current @ @ over ! current @ !
  883:       ELSE
  884: 	drop
  885:       THEN
  886:   THEN ;
  887: 
  888: \ object oriented search list                          17mar93py
  889: 
  890: \ word list structure:
  891: \ struct
  892: \   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
  893: \   1 cells: field reveal-method \ xt: ( -- )
  894: \   1 cells: field rehash-method \ xt: ( wid -- )
  895: \   \ !! what else
  896: \ end-struct wordlist-map-struct
  897: 
  898: \ struct
  899: \   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
  900: \   1 cells: field wordlist-map \ pointer to a wordlist-map-struct
  901: \   1 cells: field wordlist-link \ link field to other wordlists
  902: \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
  903: \ end-struct wordlist-struct
  904: 
  905: : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
  906: : f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;
  907: 
  908: \ Search list table: find reveal
  909: Create f83search       ' f83casefind A,  ' (reveal) A,  ' drop A,
  910: 
  911: : caps-name       ['] (cname) IS name  ['] f83find     f83search ! ;
  912: : case-name       ['] (name)  IS name  ['] f83casefind f83search ! ;
  913: : case-sensitive  ['] (name)  IS name  ['] f83find     f83search ! ;
  914: 
  915: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
  916: AVariable search       G forth-wordlist search T !
  917: G forth-wordlist current T !
  918: 
  919: : (search-wordlist)  ( addr count wid -- nfa / false )
  920:   dup ( @ swap ) cell+ @ @ execute ;
  921: 
  922: : search-wordlist  ( addr count wid -- 0 / xt +-1 )
  923:   (search-wordlist) dup  IF  found  THEN ;
  924: 
  925: Variable warnings  G -1 warnings T !
  926: 
  927: : check-shadow  ( addr count wid -- )
  928: \ prints a warning if the string is already present in the wordlist
  929: \ !! should be refined so the user can suppress the warnings
  930:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
  931:    ." redefined " name>string 2dup type
  932:    compare 0<> if
  933:      ."  with " type
  934:    else
  935:      2drop
  936:    then
  937:    space space EXIT
  938:  then
  939:  2drop 2drop ;
  940: 
  941: : find   ( addr -- cfa +-1 / string false )  dup
  942:   count search @ search-wordlist  dup IF  rot drop  THEN ;
  943: 
  944: : reveal ( -- )
  945:  last? if
  946:    name>string current @ check-shadow
  947:  then
  948:  current @ cell+ @ cell+ @ execute ;
  949: 
  950: : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
  951: 
  952: : '    ( "name" -- addr )  name find 0= no.extensions ;
  953: : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
  954: \ Input                                                13feb93py
  955: 
  956: 07 constant #bell
  957: 08 constant #bs
  958: 7F constant #del
  959: 0D constant #cr                \ the newline key code
  960: 0A constant #lf
  961: 
  962: : bell  #bell emit ;
  963: 
  964: : backspaces  0 ?DO  #bs emit  LOOP ;
  965: : >string  ( span addr pos1 -- span addr pos1 addr2 len )
  966:   over 3 pick 2 pick chars /string ;
  967: : type-rest ( span addr pos1 -- span addr pos1 back )
  968:   >string tuck type ;
  969: : (del)  ( max span addr pos1 -- max span addr pos2 )
  970:   1- >string over 1+ -rot move
  971:   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;
  972: : (ins)  ( max span addr pos1 char -- max span addr pos2 )
  973:   >r >string over 1+ swap move 2dup chars + r> swap c!
  974:   rot 1+ -rot type-rest 1- backspaces 1+ ;
  975: : ?del ( max span addr pos1 -- max span addr pos2 0 )
  976:   dup  IF  (del)  THEN  0 ;
  977: : (ret)  type-rest drop true space ;
  978: : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
  979: : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
  980: 
  981: Create crtlkeys
  982:   ] false false back  false  false false forw  false
  983:     ?del  false (ret) false  false (ret) false false
  984:     false false false false  false false false false
  985:     false false false false  false false false false [
  986: 
  987: : decode ( max span addr pos1 key -- max span addr pos2 flag )
  988:   dup #del = IF  drop #bs  THEN  \ del is rubout
  989:   dup bl <   IF  cells crtlkeys + @ execute  EXIT  THEN
  990:   >r 2over = IF  rdrop bell 0 EXIT  THEN
  991:   r> (ins) 0 ;
  992: 
  993: \ decode should better use a table for control key actions
  994: \ to define keyboard bindings later
  995: 
  996: : accept   ( addr len -- len )
  997:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
  998: \ this allows to edit given strings
  999:          ELSE  0  THEN rot over
 1000:   BEGIN  key decode  UNTIL
 1001:   2drop nip ;
 1002: 
 1003: \ Output                                               13feb93py
 1004: 
 1005: DEFER type      \ defer type for a output buffer or fast
 1006:                 \ screen write
 1007: 
 1008: \ : (type) ( addr len -- )
 1009: \   bounds ?DO  I c@ emit  LOOP ;
 1010: 
 1011: ' (TYPE) IS Type
 1012: 
 1013: DEFER Emit
 1014: 
 1015: ' (Emit) IS Emit
 1016: 
 1017: \ : form  ( -- rows cols )  &24 &80 ;
 1018: \ form should be implemented using TERMCAPS or CURSES
 1019: \ : rows  form drop ;
 1020: \ : cols  form nip  ;
 1021: 
 1022: \ Query                                                07apr93py
 1023: 
 1024: : refill ( -- flag )
 1025:   tib /line
 1026:   loadfile @ ?dup
 1027:   IF    dup file-position throw linestart 2!
 1028:         read-line throw
 1029:   ELSE  linestart @ IF 2drop false EXIT THEN
 1030:         accept true
 1031:   THEN
 1032:   1 loadline +!
 1033:   swap #tib ! 0 >in ! ;
 1034: 
 1035: : Query  ( -- )  0 loadfile ! refill drop ;
 1036: 
 1037: \ File specifiers                                       11jun93jaw
 1038: 
 1039: 
 1040: \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,
 1041: \ 2 c, here char r c, char + c, 0 c,
 1042: \ 2 c, here char w c, char + c, 0 c, align
 1043: 4 Constant w/o
 1044: 2 Constant r/w
 1045: 0 Constant r/o
 1046: 
 1047: \ BIN WRITE-LINE                                        11jun93jaw
 1048: 
 1049: \ : bin           dup 1 chars - c@
 1050: \                 r/o 4 chars + over - dup >r swap move r> ;
 1051: 
 1052: : bin  1+ ;
 1053: 
 1054: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
 1055:                            \ or not unix environments if
 1056:                            \ bin is not selected
 1057: 
 1058: : write-line    dup >r write-file ?dup IF r> drop EXIT THEN
 1059:                 nl$ count r> write-file ;
 1060: 
 1061: \ include-file                                         07apr93py
 1062: 
 1063: : include-file ( i*x fid -- j*x )
 1064:   linestart @ >r loadline @ >r loadfile @ >r
 1065:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
 1066: 
 1067:   >tib +! loadfile !
 1068:   0 loadline ! blk off
 1069:   BEGIN  refill  WHILE  interpret  REPEAT
 1070:   loadfile @ close-file throw
 1071: 
 1072:   r> >in !  r> #tib !  r> >tib ! r> blk !
 1073:   r> loadfile ! r> loadline ! r> linestart ! ;
 1074: 
 1075: : included ( i*x addr u -- j*x )
 1076:     loadfilename 2@ >r >r
 1077:     dup allocate throw over loadfilename 2!
 1078:     over loadfilename 2@ move
 1079:     r/o open-file throw include-file
 1080:     \ don't free filenames; they don't take much space
 1081:     \ and are used for debugging
 1082:     r> r> loadfilename 2! ;
 1083: 
 1084: \ HEX DECIMAL                                           2may93jaw
 1085: 
 1086: : decimal a base ! ;
 1087: : hex     10 base ! ;
 1088: 
 1089: \ DEPTH                                                 9may93jaw
 1090: 
 1091: : depth ( -- +n )  sp@ s0 @ swap - cell / ;
 1092: 
 1093: \ INCLUDE                                               9may93jaw
 1094: 
 1095: : include  ( "file" -- )
 1096:   bl word count included ;
 1097: 
 1098: \ RECURSE                                               17may93jaw
 1099: 
 1100: : recurse ( -- )
 1101:     lastxt compile, ; immediate restrict
 1102: : recursive ( -- )
 1103:     reveal ; immediate
 1104: 
 1105: \ */MOD */                                              17may93jaw
 1106: 
 1107: : */mod >r m* r> sm/rem ;
 1108: 
 1109: : */ */mod nip ;
 1110: 
 1111: \ EVALUATE                                              17may93jaw
 1112: 
 1113: : evaluate ( c-addr len -- )
 1114:   linestart @ >r loadline @ >r loadfile @ >r
 1115:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
 1116: 
 1117:   >tib +! dup #tib ! >tib @ swap move
 1118:   >in off blk off loadfile off -1 linestart !
 1119: 
 1120:   BEGIN  interpret  >in @ #tib @ u>= UNTIL
 1121: 
 1122:   r> >in !  r> #tib !  r> >tib ! r> blk !
 1123:   r> loadfile ! r> loadline ! r> linestart ! ;
 1124: 
 1125: 
 1126: : abort -1 throw ;
 1127: 
 1128: \+ environment? true ENV" CORE"
 1129: \ core wordset is now complete!
 1130: 
 1131: \ Quit                                                 13feb93py
 1132: 
 1133: Defer 'quit
 1134: Defer .status
 1135: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 1136: : (quit)        BEGIN .status cr query interpret prompt AGAIN ;
 1137: ' (quit) IS 'quit
 1138: 
 1139: \ DOERROR (DOERROR)                                     13jun93jaw
 1140: 
 1141: : dec. ( n -- )
 1142:     \ print value in decimal representation
 1143:     base @ decimal swap . base ! ;
 1144: 
 1145: : typewhite ( addr u -- )
 1146:     \ like type, but white space is printed instead of the characters
 1147:     0 ?do
 1148: 	dup i + c@ 9 = if \ check for tab
 1149: 	    9
 1150: 	else
 1151: 	    bl
 1152: 	then
 1153: 	emit
 1154:     loop
 1155:     drop ;
 1156: 
 1157: DEFER DOERROR
 1158: 
 1159: : (DoError) ( throw-code -- )
 1160:     LoadFile @
 1161:     IF
 1162: 	cr loadfilename 2@ type ." :" Loadline @ dec.
 1163:     THEN
 1164:     cr source type cr
 1165:     source drop >in @ -trailing ( throw-code line-start index2 )
 1166:     here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
 1167:     typewhite
 1168:     r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
 1169: 	." ^"
 1170:     loop
 1171:     dup -2 =
 1172:     IF 
 1173: 	"error @ ?dup
 1174: 	IF
 1175: 	    cr count type 
 1176: 	THEN
 1177: 	drop
 1178:     ELSE
 1179: 	.error
 1180:     THEN
 1181:     normal-dp dpp ! ;
 1182: 
 1183: ' (DoError) IS DoError
 1184: 
 1185: : quit   r0 @ rp! handler off >tib @ >r
 1186:   BEGIN
 1187:     postpone [
 1188:     ['] 'quit CATCH dup
 1189:   WHILE
 1190:     DoError r@ >tib !
 1191:   REPEAT
 1192:   drop r> >tib ! ;
 1193: 
 1194: \ Cold                                                 13feb93py
 1195: 
 1196: \ : .name ( name -- ) cell+ count $1F and type space ;
 1197: \ : words  listwords @
 1198: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
 1199: 
 1200: : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;
 1201: : arg ( n -- addr count )  cells argv @ + @ >len ;
 1202: : #!       postpone \ ;  immediate
 1203: 
 1204: Variable env
 1205: Variable argv
 1206: Variable argc
 1207: 
 1208: : get-args ( -- )  #tib off
 1209:   argc @ 1 ?DO  I arg 2dup source + swap move
 1210:                 #tib +! drop  bl source + c! 1 #tib +!  LOOP
 1211:   >in off #tib @ 0<> #tib +! ;
 1212: 
 1213: : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;
 1214: 
 1215: : cold ( -- )  
 1216:     argc @ 1 >
 1217:     IF  script?
 1218: 	IF
 1219: 	    1 arg ['] included
 1220: 	ELSE
 1221: 	    get-args ['] interpret
 1222: 	THEN
 1223: 	catch ?dup
 1224: 	IF
 1225: 	    dup >r DoError cr r> (bye)
 1226: 	THEN
 1227:     THEN
 1228:     cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"
 1229:     cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" 
 1230:     cr quit ;
 1231: 
 1232: : boot ( **env **argv argc -- )
 1233:   argc ! argv ! env !  main-task up!
 1234:   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;
 1235: 
 1236: : bye  cr 0 (bye) ;
 1237: 
 1238: \ **argv may be scanned by the C starter to get some important
 1239: \ information, as -display and -geometry for an X client FORTH
 1240: \ or space and stackspace overrides
 1241: 
 1242: \ 0 arg contains, however, the name of the program.

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