File:  [gforth] / gforth / Attic / kernal.fs
Revision 1.18: download - view: text, annotated - select for diffs
Fri Sep 2 15:23:36 1994 UTC (26 years, 1 month ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Corrected bug in error reporting due to input stream restoration
Corrected bug in cross compiler du to later defined constants
renamed search into lookup and implemented the correct "search"
UPS: removed double deferred header and (header) - if problems tell
me why double deferred?

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

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