File:  [gforth] / gforth / Attic / kernal.fs
Revision 1.43: download - view: text, annotated - select for diffs
Mon Oct 16 18:33:11 1995 UTC (25 years, 8 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

    1: \ KERNAL.FS    GForth 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: \ labels for some code addresses
   35: 
   36: : docon: ( -- addr )	\ gforth
   37:     \ the code address of a @code{CONSTANT}
   38:     ['] bl >code-address ;
   39: 
   40: : docol: ( -- addr )	\ gforth
   41:     \ the code address of a colon definition
   42:     ['] docon: >code-address ;
   43: 
   44: : dovar: ( -- addr )	\ gforth
   45:     \ the code address of a @code{CREATE}d word
   46:     ['] udp >code-address ;
   47: 
   48: : douser: ( -- addr )	\ gforth
   49:     \ the code address of a @code{USER} variable
   50:     ['] s0 >code-address ;
   51: 
   52: : dodefer: ( -- addr )	\ gforth
   53:     \ the code address of a @code{defer}ed word
   54:     ['] source >code-address ;
   55: 
   56: : dofield: ( -- addr )	\ gforth
   57:     \ the code address of a @code{field}
   58:     ['] reveal-method >code-address ;
   59: 
   60: \ Bit string manipulation                              06oct92py
   61: 
   62: Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
   63: DOES> ( n -- )  + c@ ;
   64: 
   65: : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
   66: : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   67: 
   68: : relinfo ( -- addr )  forthstart dup @ + ;
   69: : >rel  ( addr -- n )  forthstart - ;
   70: : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   71: 
   72: \ here allot , c, A,                                   17dec92py
   73: 
   74: : dp	( -- addr ) \ gforth
   75:     dpp @ ;
   76: : here  ( -- here ) \ core
   77:     dp @ ;
   78: : allot ( n -- ) \ core
   79:     dp +! ;
   80: : c,    ( c -- ) \ core
   81:     here 1 chars allot c! ;
   82: : ,     ( x -- ) \ core
   83:     here cell allot  ! ;
   84: : 2,	( w1 w2 -- ) \ gforth
   85:     here 2 cells allot 2! ;
   86: 
   87: : aligned ( addr -- addr' ) \ core
   88:     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   89: : align ( -- ) \ core
   90:     here dup aligned swap ?DO  bl c,  LOOP ;
   91: 
   92: : faligned ( addr -- f-addr ) \ float
   93:     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   94: 
   95: : falign ( -- ) \ float
   96:     here dup faligned swap
   97:     ?DO
   98: 	bl c,
   99:     LOOP ;
  100: 
  101: \ !! this is machine-dependent, but works on all but the strangest machines
  102: ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth
  103: ' falign Alias maxalign ( -- ) \ gforth
  104: 
  105: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
  106: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
  107: \ the code field is aligned if its body is maxaligned
  108: ' maxalign Alias cfalign ( -- ) \ gforth
  109: 
  110: : chars ( n1 -- n2 ) \ core
  111: ; immediate
  112: 
  113: 
  114: : A!    ( addr1 addr2 -- ) \ gforth
  115:     dup relon ! ;
  116: : A,    ( addr -- ) \ gforth
  117:     here cell allot A! ;
  118: 
  119: \ on off                                               23feb93py
  120: 
  121: : on  ( addr -- ) \ gforth
  122:     true  swap ! ;
  123: : off ( addr -- ) \ gforth
  124:     false swap ! ;
  125: 
  126: \ name> found                                          17dec92py
  127: 
  128: : (name>)  ( nfa -- cfa )
  129:     count  $1F and  +  cfaligned ;
  130: : name>    ( nfa -- cfa ) \ gforth
  131:     cell+
  132:     dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
  133: 
  134: : found ( nfa -- cfa n ) \ gforth
  135:     cell+
  136:     dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
  137:                     -1 r@ $40 and     IF  1-      THEN
  138:                        r> $20 and     IF  negate  THEN  ;
  139: 
  140: \ (find)                                               17dec92py
  141: 
  142: \ : (find) ( addr count nfa1 -- nfa2 / false )
  143: \   BEGIN  dup  WHILE  dup >r
  144: \          cell+ count $1F and dup >r 2over r> =
  145: \          IF  -text  0= IF  2drop r> EXIT  THEN
  146: \          ELSE  2drop drop  THEN  r> @
  147: \   REPEAT nip nip ;
  148: 
  149: \ place bounds                                         13feb93py
  150: 
  151: : place  ( addr len to -- ) \ gforth
  152:     over >r  rot over 1+  r> move c! ;
  153: : bounds ( beg count -- end beg ) \ gforth
  154:     over + swap ;
  155: 
  156: \ input stream primitives                              23feb93py
  157: 
  158: : tib ( -- c-addr ) \ core-ext
  159:     \ obsolescent
  160:     >tib @ ;
  161: Defer source ( -- addr count ) \ core
  162: \ used by dodefer:, must be defer
  163: : (source) ( -- addr count )
  164:     tib #tib @ ;
  165: ' (source) IS source
  166: 
  167: \ (word)                                               22feb93py
  168: 
  169: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
  170:     \ skip all characters not equal to char
  171:     >r
  172:     BEGIN
  173: 	dup
  174:     WHILE
  175: 	over c@ r@ <>
  176:     WHILE
  177: 	1 /string
  178:     REPEAT  THEN
  179:     rdrop ;
  180: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
  181:     \ skip all characters equal to char
  182:     >r
  183:     BEGIN
  184: 	dup
  185:     WHILE
  186: 	over c@ r@  =
  187:     WHILE
  188: 	1 /string
  189:     REPEAT  THEN
  190:     rdrop ;
  191: 
  192: : (word) ( addr1 n1 char -- addr2 n2 )
  193:   dup >r skip 2dup r> scan  nip - ;
  194: 
  195: \ (word) should fold white spaces
  196: \ this is what (parse-white) does
  197: 
  198: \ word parse                                           23feb93py
  199: 
  200: : parse-word  ( char -- addr len ) \ gforth
  201:   source 2dup >r >r >in @ over min /string
  202:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
  203:   2dup + r> - 1+ r> min >in ! ;
  204: : word   ( char -- addr ) \ core
  205:   parse-word here place  bl here count + c!  here ;
  206: 
  207: : parse    ( char -- addr len ) \ core-ext
  208:   >r  source  >in @ over min /string  over  swap r>  scan >r
  209:   over - dup r> IF 1+ THEN  >in +! ;
  210: 
  211: \ name                                                 13feb93py
  212: 
  213: : capitalize ( addr len -- addr len ) \ gforth
  214:   2dup chars chars bounds
  215:   ?DO  I c@ toupper I c! 1 chars +LOOP ;
  216: : (name) ( -- c-addr count )
  217:     source 2dup >r >r >in @ /string (parse-white)
  218:     2dup + r> - 1+ r> min >in ! ;
  219: \    name count ;
  220: 
  221: : name-too-short? ( c-addr u -- c-addr u )
  222:     dup 0= -&16 and throw ;
  223: 
  224: : name-too-long? ( c-addr u -- c-addr u )
  225:     dup $1F u> -&19 and throw ;
  226: 
  227: \ Literal                                              17dec92py
  228: 
  229: : Literal  ( compilation n -- ; run-time -- n ) \ core
  230:     state @ IF postpone lit  , THEN ; immediate
  231: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  232:     state @ IF postpone lit A, THEN ;
  233:                                                       immediate
  234: 
  235: : char   ( 'char' -- n ) \ core
  236:     bl word char+ c@ ;
  237: : [char] ( compilation 'char' -- ; run-time -- n )
  238:     char postpone Literal ; immediate
  239: ' [char] Alias Ascii immediate
  240: 
  241: : (compile) ( -- ) \ gforth
  242:     r> dup cell+ >r @ compile, ;
  243: : postpone ( "name" -- ) \ core
  244:   name sfind dup 0= abort" Can't compile "
  245:   0> IF  compile,  ELSE  postpone (compile) A,  THEN ;
  246:                                              immediate restrict
  247: 
  248: \ Use (compile) for the old behavior of compile!
  249: 
  250: \ digit?                                               17dec92py
  251: 
  252: : digit?   ( char -- digit true/ false ) \ gforth
  253:   base @ $100 =
  254:   IF
  255:     true EXIT
  256:   THEN
  257:   toupper [char] 0 - dup 9 u> IF
  258:     [ 'A '9 1 + -  ] literal -
  259:     dup 9 u<= IF
  260:       drop false EXIT
  261:     THEN
  262:   THEN
  263:   dup base @ u>= IF
  264:     drop false EXIT
  265:   THEN
  266:   true ;
  267: 
  268: : accumulate ( +d0 addr digit - +d1 addr )
  269:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  270: 
  271: : >number ( d addr count -- d addr count ) \ core
  272:     0
  273:     ?DO
  274: 	count digit?
  275:     WHILE
  276: 	accumulate
  277:     LOOP
  278:         0
  279:     ELSE
  280: 	1- I' I -
  281: 	UNLOOP
  282:     THEN ;
  283: 
  284: \ number? number                                       23feb93py
  285: 
  286: Create bases   10 ,   2 ,   A , 100 ,
  287: \              16     2    10   Zeichen
  288: \ !! this saving and restoring base is an abomination! - anton
  289: : getbase ( addr u -- addr' u' )
  290:     over c@ [char] $ - dup 4 u<
  291:     IF
  292: 	cells bases + @ base ! 1 /string
  293:     ELSE
  294: 	drop
  295:     THEN ;
  296: : s>number ( addr len -- d )
  297:     base @ >r  dpl on
  298:     over c@ '- =  dup >r
  299:     IF
  300: 	1 /string
  301:     THEN
  302:     getbase  dpl on  0 0 2swap
  303:     BEGIN
  304: 	dup >r >number dup
  305:     WHILE
  306: 	dup r> -
  307:     WHILE
  308: 	dup dpl ! over c@ [char] . =
  309:     WHILE
  310: 	1 /string
  311:     REPEAT  THEN
  312:         2drop rdrop dpl off
  313:     ELSE
  314: 	2drop rdrop r>
  315: 	IF
  316: 	    dnegate
  317: 	THEN
  318:     THEN
  319:     r> base ! ;
  320: 
  321: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
  322:     s>number dpl @ 0=
  323:     IF
  324: 	2drop false  EXIT
  325:     THEN
  326:     dpl @ dup 0> 0= IF
  327: 	nip
  328:     THEN ;
  329: : number? ( string -- string 0 / n -1 / d 0> )
  330:     dup >r count snumber? dup if
  331: 	rdrop
  332:     else
  333: 	r> swap
  334:     then ;
  335: : s>d ( n -- d ) \ core		s-to-d
  336:     dup 0< ;
  337: : number ( string -- d )
  338:     number? ?dup 0= abort" ?"  0<
  339:     IF
  340: 	s>d
  341:     THEN ;
  342: 
  343: \ space spaces ud/mod                                  21mar93py
  344: decimal
  345: Create spaces ( u -- ) \ core
  346: bl 80 times \ times from target compiler! 11may93jaw
  347: DOES>   ( u -- )
  348:     swap
  349:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
  350: Create backspaces
  351: 08 80 times \ times from target compiler! 11may93jaw
  352: DOES>   ( u -- )
  353:     swap
  354:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
  355: hex
  356: : space ( -- ) \ core
  357:     1 spaces ;
  358: 
  359: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
  360:     >r 0 r@ um/mod r> swap >r
  361:     um/mod r> ;
  362: 
  363: : pad    ( -- addr ) \ core-ext
  364:   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
  365: 
  366: \ hold <# #> sign # #s                                 25jan92py
  367: 
  368: : hold    ( char -- ) \ core
  369:     pad cell - -1 chars over +! @ c! ;
  370: 
  371: : <# ( -- ) \ core	less-number-sign
  372:     pad cell - dup ! ;
  373: 
  374: : #>      ( xd -- addr u ) \ core	number-sign-greater
  375:     2drop pad cell - dup @ tuck - ;
  376: 
  377: : sign    ( n -- ) \ core
  378:     0< IF  [char] - hold  THEN ;
  379: 
  380: : #       ( ud1 -- ud2 ) \ core		number-sign
  381:     base @ 2 max ud/mod rot 9 over <
  382:     IF
  383: 	[ char A char 9 - 1- ] Literal +
  384:     THEN
  385:     [char] 0 + hold ;
  386: 
  387: : #s      ( +d -- 0 0 ) \ core	number-sign-s
  388:     BEGIN
  389: 	# 2dup d0=
  390:     UNTIL ;
  391: 
  392: \ print numbers                                        07jun92py
  393: 
  394: : d.r ( d n -- ) \ double	d-dot-r
  395:     >r tuck  dabs  <# #s  rot sign #>
  396:     r> over - spaces  type ;
  397: 
  398: : ud.r ( ud n -- ) \ gforth	u-d-dot-r
  399:     >r <# #s #> r> over - spaces type ;
  400: 
  401: : .r ( n1 n2 -- ) \ core-ext	dot-r
  402:     >r s>d r> d.r ;
  403: : u.r ( u n -- )  \ core-ext	u-dot-r
  404:     0 swap ud.r ;
  405: 
  406: : d. ( d -- ) \ double	d-dot
  407:     0 d.r space ;
  408: : ud. ( ud -- ) \ gforth	u-d-dot
  409:     0 ud.r space ;
  410: 
  411: : . ( n -- ) \ core	dot
  412:     s>d d. ;
  413: : u. ( u -- ) \ core	u-dot
  414:     0 ud. ;
  415: 
  416: \ catch throw                                          23feb93py
  417: \ bounce                                                08jun93jaw
  418: 
  419: \ !! allow the user to add rollback actions    anton
  420: \ !! use a separate exception stack?           anton
  421: 
  422: : lp@ ( -- addr ) \ gforth	l-p-fetch
  423:  laddr# [ 0 , ] ;
  424: 
  425: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  426:   >r sp@ r> swap >r       \ don't count xt! jaw
  427:   fp@ >r
  428:   lp@ >r
  429:   handler @ >r
  430:   rp@ handler !
  431:   execute
  432:   r> handler ! rdrop rdrop rdrop 0 ;
  433: 
  434: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
  435:     ?DUP IF
  436: 	[ here 4 cells ! ]
  437: 	handler @ rp!
  438: 	r> handler !
  439: 	r> lp!
  440: 	r> fp!
  441: 	r> swap >r sp! r>
  442:     THEN ;
  443: 
  444: \ Bouncing is very fine,
  445: \ programming without wasting time...   jaw
  446: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
  447: \ a throw without data or fp stack restauration
  448:   ?DUP IF
  449:     handler @ rp!
  450:     r> handler !
  451:     r> lp!
  452:     rdrop
  453:     rdrop
  454:   THEN ;
  455: 
  456: \ ?stack                                               23feb93py
  457: 
  458: : ?stack ( ?? -- ?? ) \ gforth
  459:     sp@ s0 @ > IF    -4 throw  THEN
  460:     fp@ f0 @ > IF  -&45 throw  THEN  ;
  461: \ ?stack should be code -- it touches an empty stack!
  462: 
  463: \ interpret                                            10mar92py
  464: 
  465: Defer parser
  466: Defer name ( -- c-addr count ) \ gforth
  467: \ get the next word from the input buffer
  468: ' (name) IS name
  469: Defer notfound ( c-addr count -- )
  470: 
  471: : no.extensions  ( addr u -- )
  472:     2drop -&13 bounce ;
  473: ' no.extensions IS notfound
  474: 
  475: : interpret ( ?? -- ?? ) \ gforth
  476:     \ interpret/compile the (rest of the) input buffer
  477:     BEGIN
  478: 	?stack name dup
  479:     WHILE
  480: 	parser
  481:     REPEAT
  482:     2drop ;
  483: 
  484: \ interpreter compiler                                 30apr92py
  485: 
  486: : interpreter  ( c-addr u -- ) \ gforth
  487:     \ interpretation semantics for the name/number c-addr u
  488:     2dup sfind dup
  489:     IF
  490: 	1 and
  491: 	IF \ not restricted to compile state?
  492: 	    nip nip execute EXIT
  493: 	THEN
  494: 	-&14 throw
  495:     THEN
  496:     drop
  497:     2dup 2>r snumber?
  498:     IF
  499: 	2rdrop
  500:     ELSE
  501: 	2r> notfound
  502:     THEN ;
  503: 
  504: ' interpreter  IS  parser
  505: 
  506: : compiler     ( c-addr u -- ) \ gforth
  507:     \ compilation semantics for the name/number c-addr u
  508:     2dup sfind dup
  509:     IF
  510: 	0>
  511: 	IF
  512: 	    nip nip execute EXIT
  513: 	THEN
  514: 	compile, 2drop EXIT
  515:     THEN
  516:     drop
  517:     2dup snumber? dup
  518:     IF
  519: 	0>
  520: 	IF
  521: 	    swap postpone Literal
  522: 	THEN
  523: 	postpone Literal
  524: 	2drop
  525:     ELSE
  526: 	drop notfound
  527:     THEN ;
  528: 
  529: : [ ( -- ) \ core	left-bracket
  530:     ['] interpreter  IS parser state off ; immediate
  531: : ] ( -- ) \ core	right-bracket
  532:     ['] compiler     IS parser state on  ;
  533: 
  534: \ locals stuff needed for control structures
  535: 
  536: : compile-lp+! ( n -- ) \ gforth	compile-l-p-plus-store
  537:     dup negate locals-size +!
  538:     0 over = if
  539:     else -1 cells  over = if postpone lp-
  540:     else  1 floats over = if postpone lp+
  541:     else  2 floats over = if postpone lp+2
  542:     else postpone lp+!# dup ,
  543:     then then then then drop ;
  544: 
  545: : adjust-locals-size ( n -- ) \ gforth
  546:     \ sets locals-size to n and generates an appropriate lp+!
  547:     locals-size @ swap - compile-lp+! ;
  548: 
  549: 
  550: here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
  551: AConstant locals-list \ acts like a variable that contains
  552: 		      \ a linear list of locals names
  553: 
  554: 
  555: variable dead-code \ true if normal code at "here" would be dead
  556: variable backedge-locals
  557:     \ contains the locals list that BEGIN will assume to be live on
  558:     \ the back edge if the BEGIN is unreachable from above. Set by
  559:     \ ASSUME-LIVE, reset by UNREACHABLE.
  560: 
  561: : UNREACHABLE ( -- ) \ gforth
  562:     \ declares the current point of execution as unreachable
  563:     dead-code on
  564:     0 backedge-locals ! ; immediate
  565: 
  566: : ASSUME-LIVE ( orig -- orig ) \ gforth
  567:     \ used immediateliy before a BEGIN that is not reachable from
  568:     \ above.  causes the BEGIN to assume that the same locals are live
  569:     \ as at the orig point
  570:     dup orig?
  571:     2 pick backedge-locals ! ; immediate
  572:     
  573: \ locals list operations
  574: 
  575: : common-list ( list1 list2 -- list3 ) \ gforth-internal
  576: \ list1 and list2 are lists, where the heads are at higher addresses than
  577: \ the tail. list3 is the largest sublist of both lists.
  578:  begin
  579:    2dup u<>
  580:  while
  581:    2dup u>
  582:    if
  583:      swap
  584:    then
  585:    @
  586:  repeat
  587:  drop ;
  588: 
  589: : sub-list? ( list1 list2 -- f ) \ gforth-internal
  590: \ true iff list1 is a sublist of list2
  591:  begin
  592:    2dup u<
  593:  while
  594:    @
  595:  repeat
  596:  = ;
  597: 
  598: : list-size ( list -- u ) \ gforth-internal
  599: \ size of the locals frame represented by list
  600:  0 ( list n )
  601:  begin
  602:    over 0<>
  603:  while
  604:    over
  605:    name> >body @ max
  606:    swap @ swap ( get next )
  607:  repeat
  608:  faligned nip ;
  609: 
  610: : set-locals-size-list ( list -- )
  611:  dup locals-list !
  612:  list-size locals-size ! ;
  613: 
  614: : check-begin ( list -- )
  615: \ warn if list is not a sublist of locals-list
  616:  locals-list @ sub-list? 0= if
  617:    \ !! print current position
  618:    ." compiler was overly optimistic about locals at a BEGIN" cr
  619:    \ !! print assumption and reality
  620:  then ;
  621: 
  622: \ Control Flow Stack
  623: \ orig, etc. have the following structure:
  624: \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
  625: \ address (of the branch or the instruction to be branched to) (second)
  626: \ locals-list (valid at address) (third)
  627: 
  628: \ types
  629: 0 constant defstart
  630: 1 constant live-orig
  631: 2 constant dead-orig
  632: 3 constant dest \ the loopback branch is always assumed live
  633: 4 constant do-dest
  634: 5 constant scopestart
  635: 
  636: : def? ( n -- )
  637:     defstart <> abort" unstructured " ;
  638: 
  639: : orig? ( n -- )
  640:  dup live-orig <> swap dead-orig <> and abort" expected orig " ;
  641: 
  642: : dest? ( n -- )
  643:  dest <> abort" expected dest " ;
  644: 
  645: : do-dest? ( n -- )
  646:  do-dest <> abort" expected do-dest " ;
  647: 
  648: : scope? ( n -- )
  649:  scopestart <> abort" expected scope " ;
  650: 
  651: : non-orig? ( n -- )
  652:  dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
  653: 
  654: : cs-item? ( n -- )
  655:  live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
  656: 
  657: 3 constant cs-item-size
  658: 
  659: : CS-PICK ( ... u -- ... destu ) \ tools-ext
  660:  1+ cs-item-size * 1- >r
  661:  r@ pick  r@ pick  r@ pick
  662:  rdrop
  663:  dup non-orig? ;
  664: 
  665: : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext
  666:  1+ cs-item-size * 1- >r
  667:  r@ roll r@ roll r@ roll
  668:  rdrop
  669:  dup cs-item? ; 
  670: 
  671: : cs-push-part ( -- list addr )
  672:  locals-list @ here ;
  673: 
  674: : cs-push-orig ( -- orig )
  675:  cs-push-part dead-code @
  676:  if
  677:    dead-orig
  678:  else
  679:    live-orig
  680:  then ;   
  681: 
  682: \ Structural Conditionals                              12dec92py
  683: 
  684: : ?struc      ( flag -- )       abort" unstructured " ;
  685: : sys?        ( sys -- )        dup 0= ?struc ;
  686: : >mark ( -- orig )
  687:  cs-push-orig 0 , ;
  688: : >resolve    ( addr -- )        here over - swap ! ;
  689: : <resolve    ( addr -- )        here - , ;
  690: 
  691: : BUT
  692:     1 cs-roll ;                      immediate restrict
  693: : YET
  694:     0 cs-pick ;                       immediate restrict
  695: 
  696: \ Structural Conditionals                              12dec92py
  697: 
  698: : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
  699:     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
  700: 
  701: : IF ( compilation -- orig ; run-time f -- ) \ core
  702:  POSTPONE ?branch >mark ; immediate restrict
  703: 
  704: : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-if
  705: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
  706: \ better handled by tools like stack checkers
  707:     POSTPONE ?dup POSTPONE if ;       immediate restrict
  708: : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth	question-dupe-zero-equals-if
  709:     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
  710: 
  711: : THEN ( compilation orig -- ; run-time -- ) \ core
  712:     dup orig?
  713:     dead-orig =
  714:     if
  715:         >resolve drop
  716:     else
  717:         dead-code @
  718:         if
  719: 	    >resolve set-locals-size-list dead-code off
  720: 	else \ both live
  721: 	    over list-size adjust-locals-size
  722: 	    >resolve
  723: 	    locals-list @ common-list dup list-size adjust-locals-size
  724: 	    locals-list !
  725: 	then
  726:     then ; immediate restrict
  727: 
  728: ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
  729: immediate restrict
  730: \ Same as "THEN". This is what you use if your program will be seen by
  731: \ people who have not been brought up with Forth (or who have been
  732: \ brought up with fig-Forth).
  733: 
  734: : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core
  735:     POSTPONE ahead
  736:     1 cs-roll
  737:     POSTPONE then ; immediate restrict
  738: 
  739: 
  740: : BEGIN ( compilation -- dest ; run-time -- ) \ core
  741:     dead-code @ if
  742: 	\ set up an assumption of the locals visible here.  if the
  743: 	\ users want something to be visible, they have to declare
  744: 	\ that using ASSUME-LIVE
  745: 	backedge-locals @ set-locals-size-list
  746:     then
  747:     cs-push-part dest
  748:     dead-code off ; immediate restrict
  749: 
  750: \ AGAIN (the current control flow joins another, earlier one):
  751: \ If the dest-locals-list is not a subset of the current locals-list,
  752: \ issue a warning (see below). The following code is generated:
  753: \ lp+!# (current-local-size - dest-locals-size)
  754: \ branch <begin>
  755: : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
  756:     dest?
  757:     over list-size adjust-locals-size
  758:     POSTPONE branch
  759:     <resolve
  760:     check-begin
  761:     POSTPONE unreachable ; immediate restrict
  762: 
  763: \ UNTIL (the current control flow may join an earlier one or continue):
  764: \ Similar to AGAIN. The new locals-list and locals-size are the current
  765: \ ones. The following code is generated:
  766: \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
  767: : until-like ( list addr xt1 xt2 -- )
  768:     \ list and addr are a fragment of a cs-item
  769:     \ xt1 is the conditional branch without lp adjustment, xt2 is with
  770:     >r >r
  771:     locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
  772: 	r> drop r> compile,
  773: 	swap <resolve ( list adjustment ) ,
  774:     else ( list dest-addr adjustment )
  775: 	drop
  776: 	r> compile, <resolve
  777: 	r> drop
  778:     then ( list )
  779:     check-begin ;
  780: 
  781: : UNTIL ( compilation dest -- ; run-time f -- ) \ core
  782:     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
  783: 
  784: : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
  785:     POSTPONE if
  786:     1 cs-roll ; immediate restrict
  787: 
  788: : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
  789:     POSTPONE again
  790:     POSTPONE then ; immediate restrict
  791: 
  792: 
  793: \ counted loops
  794: 
  795: \ leave poses a little problem here
  796: \ we have to store more than just the address of the branch, so the
  797: \ traditional linked list approach is no longer viable.
  798: \ This is solved by storing the information about the leavings in a
  799: \ special stack.
  800: 
  801: \ !! remove the fixed size limit. 'Tis not hard.
  802: 20 constant leave-stack-size
  803: create leave-stack  60 cells allot
  804: Avariable leave-sp  leave-stack 3 cells + leave-sp !
  805: 
  806: : clear-leave-stack ( -- )
  807:     leave-stack leave-sp ! ;
  808: 
  809: \ : leave-empty? ( -- f )
  810: \  leave-sp @ leave-stack = ;
  811: 
  812: : >leave ( orig -- )
  813:     \ push on leave-stack
  814:     leave-sp @
  815:     dup [ leave-stack 60 cells + ] Aliteral
  816:     >= abort" leave-stack full"
  817:     tuck ! cell+
  818:     tuck ! cell+
  819:     tuck ! cell+
  820:     leave-sp ! ;
  821: 
  822: : leave> ( -- orig )
  823:     \ pop from leave-stack
  824:     leave-sp @
  825:     dup leave-stack <= IF
  826:        drop 0 0 0  EXIT  THEN
  827:     cell - dup @ swap
  828:     cell - dup @ swap
  829:     cell - dup @ swap
  830:     leave-sp ! ;
  831: 
  832: : DONE ( compilation orig -- ; run-time -- ) \ gforth
  833:     \ !! the original done had ( addr -- )
  834:     drop >r drop
  835:     begin
  836: 	leave>
  837: 	over r@ u>=
  838:     while
  839: 	POSTPONE then
  840:     repeat
  841:     >leave rdrop ; immediate restrict
  842: 
  843: : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
  844:     POSTPONE ahead
  845:     >leave ; immediate restrict
  846: 
  847: : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth	question-leave
  848:     POSTPONE 0= POSTPONE if
  849:     >leave ; immediate restrict
  850: 
  851: : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
  852:     POSTPONE (do)
  853:     POSTPONE begin drop do-dest
  854:     ( 0 0 0 >leave ) ; immediate restrict
  855: 
  856: : ?do-like ( -- do-sys )
  857:     ( 0 0 0 >leave )
  858:     >mark >leave
  859:     POSTPONE begin drop do-dest ;
  860: 
  861: : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ core-ext	question-do
  862:     POSTPONE (?do) ?do-like ; immediate restrict
  863: 
  864: : +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ gforth	plus-do
  865:     POSTPONE (+do) ?do-like ; immediate restrict
  866: 
  867: : U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ gforth	u-plus-do
  868:     POSTPONE (u+do) ?do-like ; immediate restrict
  869: 
  870: : -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ gforth	minus-do
  871:     POSTPONE (-do) ?do-like ; immediate restrict
  872: 
  873: : U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )	\ gforth	u-minus-do
  874:     POSTPONE (u-do) ?do-like ; immediate restrict
  875: 
  876: : FOR ( compilation -- do-sys ; run-time w -- loop-sys )	\ gforth
  877:     POSTPONE (for)
  878:     POSTPONE begin drop do-dest
  879:     ( 0 0 0 >leave ) ; immediate restrict
  880: 
  881: \ LOOP etc. are just like UNTIL
  882: 
  883: : loop-like ( do-sys xt1 xt2 -- )
  884:     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
  885:     until-like  POSTPONE done  POSTPONE unloop ;
  886: 
  887: : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )	\ core
  888:  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
  889: 
  890: : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )	\ core	plus-loop
  891:  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
  892: 
  893: \ !! should the compiler warn about +DO..-LOOP?
  894: : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 )	\ gforth	minus-loop
  895:  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
  896: 
  897: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"
  898: \ will iterate as often as "high low ?DO inc S+LOOP". For positive
  899: \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
  900: \ negative increments.
  901: : S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )	\ gforth	s-plus-loop
  902:  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
  903: 
  904: : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
  905:  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
  906: 
  907: \ Structural Conditionals                              12dec92py
  908: 
  909: : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
  910:     0 adjust-locals-size
  911:     POSTPONE ;s
  912:     POSTPONE unreachable ; immediate restrict
  913: 
  914: : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
  915:      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
  916: 
  917: \ Strings                                              22feb93py
  918: 
  919: : ," ( "string"<"> -- ) [char] " parse
  920:   here over char+ allot  place align ;
  921: : "lit ( -- addr )
  922:   r> r> dup count + aligned >r swap >r ;               restrict
  923: : (.")     "lit count type ;                           restrict
  924: : (S")     "lit count ;                                restrict
  925: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
  926:     postpone (S") here over char+ allot  place align ;
  927:                                              immediate restrict
  928: create s"-buffer /line chars allot
  929: : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )	\ core,file	s-quote
  930:     [char] " parse
  931:     state @
  932:     IF
  933: 	postpone SLiteral
  934:     ELSE
  935: 	/line min >r s"-buffer r@ cmove
  936: 	s"-buffer r>
  937:     THEN ; immediate
  938: 
  939: : ." ( compilation 'ccc"' -- ; run-time -- )  \ core	dot-quote
  940:     state @  IF    postpone (.") ,"  align
  941:                     ELSE  [char] " parse type  THEN  ;  immediate
  942: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file	paren
  943:     [char] ) parse 2drop ;                       immediate
  944: : \ ( -- ) \ core-ext backslash
  945:     blk @
  946:     IF
  947: 	>in @ c/l / 1+ c/l * >in !
  948: 	EXIT
  949:     THEN
  950:     source >in ! drop ; immediate
  951: 
  952: : \G ( -- ) \ gforth backslash
  953:     POSTPONE \ ; immediate
  954: 
  955: \ error handling                                       22feb93py
  956: \ 'abort thrown out!                                   11may93jaw
  957: 
  958: : (abort")
  959:     "lit >r
  960:     IF
  961: 	r> "error ! -2 throw
  962:     THEN
  963:     rdrop ;
  964: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext	abort-quote
  965:     postpone (abort") ," ;        immediate restrict
  966: 
  967: \ Header states                                        23feb93py
  968: 
  969: : flag! ( 8b -- )
  970:     last @ dup 0= abort" last word was headerless"
  971:     cell+ tuck c@ xor swap c! ;
  972: : immediate     $20 flag! ;
  973: : restrict      $40 flag! ;
  974: \ ' noop alias restrict
  975: 
  976: \ Header                                               23feb93py
  977: 
  978: \ input-stream, nextname and noname are quite ugly (passing
  979: \ information through global variables), but they are useful for dealing
  980: \ with existing/independent defining words
  981: 
  982: defer (header)
  983: defer header ( -- ) \ gforth
  984: ' (header) IS header
  985: 
  986: : string, ( c-addr u -- ) \ gforth
  987:     \ puts down string as cstring
  988:     dup c, here swap chars dup allot move ;
  989: 
  990: : name,  ( "name" -- ) \ gforth
  991:     name name-too-short? name-too-long?
  992:     string, cfalign ;
  993: : input-stream-header ( "name" -- )
  994:     \ !! this is f83-implementation-dependent
  995:     align here last !  -1 A,
  996:     name, $80 flag! ;
  997: 
  998: : input-stream ( -- )  \ general
  999: \ switches back to getting the name from the input stream ;
 1000:     ['] input-stream-header IS (header) ;
 1001: 
 1002: ' input-stream-header IS (header)
 1003: 
 1004: \ !! make that a 2variable
 1005: create nextname-buffer 32 chars allot
 1006: 
 1007: : nextname-header ( -- )
 1008:     \ !! f83-implementation-dependent
 1009:     nextname-buffer count
 1010:     align here last ! -1 A,
 1011:     string, cfalign
 1012:     $80 flag!
 1013:     input-stream ;
 1014: 
 1015: \ the next name is given in the string
 1016: : nextname ( c-addr u -- ) \ gforth
 1017:     name-too-long?
 1018:     nextname-buffer c! ( c-addr )
 1019:     nextname-buffer count move
 1020:     ['] nextname-header IS (header) ;
 1021: 
 1022: : noname-header ( -- )
 1023:     0 last ! cfalign
 1024:     input-stream ;
 1025: 
 1026: : noname ( -- ) \ gforth
 1027: \ the next defined word remains anonymous. The xt of that word is given by lastxt
 1028:     ['] noname-header IS (header) ;
 1029: 
 1030: : lastxt ( -- xt ) \ gforth
 1031: \ 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
 1032:     lastcfa @ ;
 1033: 
 1034: : Alias    ( cfa "name" -- ) \ gforth
 1035:   Header reveal , $80 flag! ;
 1036: 
 1037: : name>string ( nfa -- addr count ) \ gforth	name-to-string
 1038:  cell+ count $1F and ;
 1039: 
 1040: Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 1041: : >name ( cfa -- nfa ) \ gforth	to-name
 1042:  $21 cell do
 1043:    dup i - count $9F and + cfaligned over $80 + = if
 1044:      i - cell - unloop exit
 1045:    then
 1046:  cell +loop
 1047:  drop ??? ( wouldn't 0 be better? ) ;
 1048: 
 1049: \ threading                                   17mar93py
 1050: 
 1051: : cfa,     ( code-address -- )  \ gforth	cfa-comma
 1052:     here
 1053:     dup lastcfa !
 1054:     0 A, 0 ,  code-address! ;
 1055: : compile, ( xt -- )	\ core-ext	compile-comma
 1056:     A, ;
 1057: : !does    ( addr -- ) \ gforth	store-does
 1058:     lastxt does-code! ;
 1059: : (does>)  ( R: addr -- )
 1060:     r> /does-handler + !does ;
 1061: : dodoes,  ( -- )
 1062:   here /does-handler allot does-handler! ;
 1063: 
 1064: : Create ( -- ) \ core
 1065:     Header reveal dovar: cfa, ;
 1066: 
 1067: \ DOES>                                                17mar93py
 1068: 
 1069: : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core	does
 1070:     state @
 1071:     IF
 1072: 	;-hook postpone (does>) ?struc dodoes,
 1073:     ELSE
 1074: 	align dodoes, here !does ]
 1075:     THEN 
 1076:     defstart :-hook ; immediate
 1077: 
 1078: \ Create Variable User Constant                        17mar93py
 1079: 
 1080: : Variable ( -- ) \ core
 1081:     Create 0 , ;
 1082: : AVariable ( -- ) \ gforth
 1083:     Create 0 A, ;
 1084: : 2VARIABLE ( "name" -- ) \ double
 1085:     create 0 , 0 , ;
 1086:     
 1087: : User
 1088:     Variable ;
 1089: : AUser
 1090:     AVariable ;
 1091: 
 1092: : (Constant)  Header reveal docon: cfa, ;
 1093: : Constant ( w -- ) \ core
 1094:     (Constant) , ;
 1095: : AConstant ( addr -- ) \ gforth
 1096:     (Constant) A, ;
 1097: 
 1098: : 2Constant ( d -- ) \ double
 1099:     Create ( w1 w2 "name" -- )
 1100:         2,
 1101:     DOES> ( -- w1 w2 )
 1102:         2@ ;
 1103:     
 1104: \ IS Defer What's Defers TO                            24feb93py
 1105: 
 1106: : Defer ( -- ) \ gforth
 1107:     \ !! shouldn't it be initialized with abort or something similar?
 1108:     Header Reveal dodefer: cfa,
 1109:     ['] noop A, ;
 1110: \     Create ( -- ) 
 1111: \ 	['] noop A,
 1112: \     DOES> ( ??? )
 1113: \ 	@ execute ;
 1114: 
 1115: : IS ( addr "name" -- ) \ gforth
 1116:     ' >body
 1117:     state @
 1118:     IF    postpone ALiteral postpone !  
 1119:     ELSE  !
 1120:     THEN ;  immediate
 1121: ' IS Alias TO ( addr "name" -- ) \ core-ext
 1122: immediate
 1123: 
 1124: : What's ( "name" -- addr ) \ gforth
 1125:     ' >body
 1126:     state @
 1127:     IF
 1128: 	postpone ALiteral postpone @
 1129:     ELSE
 1130: 	@
 1131:     THEN ; immediate
 1132: : Defers ( "name" -- ) \ gforth
 1133:     ' >body @ compile, ; immediate
 1134: 
 1135: \ : ;                                                  24feb93py
 1136: 
 1137: defer :-hook ( sys1 -- sys2 )
 1138: defer ;-hook ( sys2 -- sys1 )
 1139: 
 1140: : : ( -- colon-sys ) \ core	colon
 1141:     Header docol: cfa, defstart ] :-hook ;
 1142: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
 1143:     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
 1144: 
 1145: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
 1146:     0 last !
 1147:     here docol: cfa, 0 ] :-hook ;
 1148: 
 1149: \ Search list handling                                 23feb93py
 1150: 
 1151: AVariable current ( -- addr ) \ gforth
 1152: 
 1153: : last?   ( -- false / nfa nfa )
 1154:     last @ ?dup ;
 1155: : (reveal) ( -- )
 1156:     last?
 1157:     IF
 1158: 	dup @ 0<
 1159: 	IF
 1160: 	    current @ @ over ! current @ !
 1161: 	ELSE
 1162: 	    drop
 1163: 	THEN
 1164:     THEN ;
 1165: 
 1166: \ object oriented search list                          17mar93py
 1167: 
 1168: \ word list structure:
 1169: 
 1170: struct
 1171:   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
 1172:   1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field
 1173:   1 cells: field rehash-method \ xt: ( wid -- )
 1174: \   \ !! what else
 1175: end-struct wordlist-map-struct
 1176: 
 1177: struct
 1178:   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
 1179:   1 cells: field wordlist-map \ pointer to a wordlist-map-struct
 1180:   1 cells: field wordlist-link \ link field to other wordlists
 1181:   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 1182: end-struct wordlist-struct
 1183: 
 1184: : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
 1185: 
 1186: \ Search list table: find reveal
 1187: Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,
 1188: 
 1189: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 1190: AVariable lookup       G forth-wordlist lookup T !
 1191: G forth-wordlist current T !
 1192: 
 1193: : (search-wordlist)  ( addr count wid -- nfa / false )
 1194:   dup wordlist-map @ find-method @ execute ;
 1195: 
 1196: : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
 1197:     (search-wordlist) dup  IF  found  THEN ;
 1198: 
 1199: Variable warnings ( -- addr ) \ gforth
 1200: G -1 warnings T !
 1201: 
 1202: : check-shadow  ( addr count wid -- )
 1203: \ prints a warning if the string is already present in the wordlist
 1204: \ !! should be refined so the user can suppress the warnings
 1205:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
 1206:    ." redefined " name>string 2dup type
 1207:    compare 0<> if
 1208:      ."  with " type
 1209:    else
 1210:      2drop
 1211:    then
 1212:    space space EXIT
 1213:  then
 1214:  2drop 2drop ;
 1215: 
 1216: : sfind ( c-addr u -- xt n / 0 ) \ gforth
 1217:     lookup @ search-wordlist ;
 1218: 
 1219: : find   ( addr -- cfa +-1 / string false ) \ core,search
 1220:     \ !! not ANS conformant: returns +-2 for restricted words
 1221:     dup count sfind dup if
 1222: 	rot drop
 1223:     then ;
 1224: 
 1225: : reveal ( -- ) \ gforth
 1226:  last? if
 1227:    name>string current @ check-shadow
 1228:  then
 1229:  current @ wordlist-map @ reveal-method @ execute ;
 1230: 
 1231: : rehash  ( wid -- )
 1232:     dup wordlist-map @ rehash-method @ execute ;
 1233: 
 1234: : '    ( "name" -- addr ) \ core	tick
 1235:     name sfind 0= if -&13 bounce then ;
 1236: : [']  ( compilation "name" -- ; run-time --addr ) \ core	bracket-tick
 1237:     ' postpone ALiteral ; immediate
 1238: \ Input                                                13feb93py
 1239: 
 1240: 07 constant #bell ( -- c ) \ gforth
 1241: 08 constant #bs ( -- c ) \ gforth
 1242: 09 constant #tab ( -- c ) \ gforth
 1243: 7F constant #del ( -- c ) \ gforth
 1244: 0D constant #cr   ( -- c ) \ gforth
 1245: \ the newline key code
 1246: 0C constant #ff ( -- c ) \ gforth
 1247: 0A constant #lf ( -- c ) \ gforth
 1248: 
 1249: : bell  #bell emit ;
 1250: 
 1251: \ : backspaces  0 ?DO  #bs emit  LOOP ;
 1252: : >string  ( span addr pos1 -- span addr pos1 addr2 len )
 1253:   over 3 pick 2 pick chars /string ;
 1254: : type-rest ( span addr pos1 -- span addr pos1 back )
 1255:   >string tuck type ;
 1256: : (del)  ( max span addr pos1 -- max span addr pos2 )
 1257:   1- >string over 1+ -rot move
 1258:   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;
 1259: : (ins)  ( max span addr pos1 char -- max span addr pos2 )
 1260:   >r >string over 1+ swap move 2dup chars + r> swap c!
 1261:   rot 1+ -rot type-rest 1- backspaces 1+ ;
 1262: : ?del ( max span addr pos1 -- max span addr pos2 0 )
 1263:   dup  IF  (del)  THEN  0 ;
 1264: : (ret)  type-rest drop true space ;
 1265: : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
 1266: : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
 1267: : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;
 1268: 
 1269: Create ctrlkeys
 1270:   ] false false back  false  eof   false forw  false
 1271:     ?del  false (ret) false  false (ret) false false
 1272:     false false false false  false false false false
 1273:     false false false false  false false false false [
 1274: 
 1275: defer everychar
 1276: ' noop IS everychar
 1277: 
 1278: : decode ( max span addr pos1 key -- max span addr pos2 flag )
 1279:   everychar
 1280:   dup #del = IF  drop #bs  THEN  \ del is rubout
 1281:   dup bl <   IF  cells ctrlkeys + @ execute  EXIT  THEN
 1282:   >r 2over = IF  rdrop bell 0 EXIT  THEN
 1283:   r> (ins) 0 ;
 1284: 
 1285: \ decode should better use a table for control key actions
 1286: \ to define keyboard bindings later
 1287: 
 1288: : accept   ( addr len -- len ) \ core
 1289:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
 1290: \ this allows to edit given strings
 1291:          ELSE  0  THEN rot over
 1292:   BEGIN  key decode  UNTIL
 1293:   2drop nip ;
 1294: 
 1295: \ Output                                               13feb93py
 1296: 
 1297: Defer type ( c-addr u -- ) \ core
 1298: \ defer type for a output buffer or fast
 1299: \ screen write
 1300: 
 1301: \ : (type) ( addr len -- )
 1302: \   bounds ?DO  I c@ emit  LOOP ;
 1303: 
 1304: ' (type) IS Type
 1305: 
 1306: Defer emit ( c -- ) \ core
 1307: ' (Emit) IS Emit
 1308: 
 1309: Defer key ( -- c ) \ core
 1310: ' (key) IS key
 1311: 
 1312: \ : form  ( -- rows cols )  &24 &80 ;
 1313: \ form should be implemented using TERMCAPS or CURSES
 1314: \ : rows  form drop ;
 1315: \ : cols  form nip  ;
 1316: 
 1317: \ Query                                                07apr93py
 1318: 
 1319: : refill ( -- flag ) \ core-ext,block-ext,file-ext
 1320:   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
 1321:   tib /line
 1322:   loadfile @ ?dup
 1323:   IF    read-line throw
 1324:   ELSE  loadline @ 0< IF 2drop false EXIT THEN
 1325:         accept true
 1326:   THEN
 1327:   1 loadline +!
 1328:   swap #tib ! 0 >in ! ;
 1329: 
 1330: : Query  ( -- ) \ core-ext
 1331:     \ obsolescent
 1332:     loadfile off  blk off  refill drop ;
 1333: 
 1334: \ File specifiers                                       11jun93jaw
 1335: 
 1336: 
 1337: \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,
 1338: \ 2 c, here char r c, char + c, 0 c,
 1339: \ 2 c, here char w c, char + c, 0 c, align
 1340: 4 Constant w/o ( -- fam ) \ file	w-o
 1341: 2 Constant r/w ( -- fam ) \ file	r-o
 1342: 0 Constant r/o ( -- fam ) \ file	r-w
 1343: 
 1344: \ BIN WRITE-LINE                                        11jun93jaw
 1345: 
 1346: \ : bin           dup 1 chars - c@
 1347: \                 r/o 4 chars + over - dup >r swap move r> ;
 1348: 
 1349: : bin ( fam1 -- fam2 ) \ file
 1350:     1 or ;
 1351: 
 1352: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
 1353:                            \ or not unix environments if
 1354:                            \ bin is not selected
 1355: 
 1356: : write-line ( c-addr u fileid -- ior ) \ file
 1357:     dup >r write-file
 1358:     ?dup IF
 1359: 	r> drop EXIT
 1360:     THEN
 1361:     nl$ count r> write-file ;
 1362: 
 1363: \ include-file                                         07apr93py
 1364: 
 1365: : push-file  ( -- )  r>
 1366:   loadline @ >r loadfile @ >r
 1367:   blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
 1368: 
 1369: : pop-file   ( throw-code -- throw-code )
 1370:   dup IF
 1371:          source >in @ loadline @ loadfilename 2@
 1372: 	 error-stack dup @ dup 1+
 1373: 	 max-errors 1- min error-stack !
 1374: 	 6 * cells + cell+
 1375: 	 5 cells bounds swap DO
 1376: 	                    I !
 1377: 	 -1 cells +LOOP
 1378:   THEN
 1379:   r>
 1380:   r> >in !  r> #tib !  r> >tib !  r> blk !
 1381:   r> loadfile ! r> loadline !  >r ;
 1382: 
 1383: : read-loop ( i*x -- j*x )
 1384:   BEGIN  refill  WHILE  interpret  REPEAT ;
 1385: 
 1386: : include-file ( i*x fid -- j*x ) \ file
 1387:   push-file  loadfile !
 1388:   0 loadline ! blk off  ['] read-loop catch
 1389:   loadfile @ close-file swap 2dup or
 1390:   pop-file  drop throw throw ;
 1391: 
 1392: create pathfilenamebuf 256 chars allot \ !! make this grow on demand
 1393: 
 1394: \ : check-file-prefix  ( addr len -- addr' len' flag )
 1395: \   dup 0=                    IF  true EXIT  THEN 
 1396: \   over c@ '/ =              IF  true EXIT  THEN 
 1397: \   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
 1398: \   over 3 S" ../" compare 0= IF  true EXIT  THEN
 1399: \   over 2 S" ~/" compare 0=
 1400: \   IF     1 /string
 1401: \          S" HOME" getenv tuck pathfilenamebuf swap move
 1402: \          2dup + >r pathfilenamebuf + swap move
 1403: \          pathfilenamebuf r> true
 1404: \   ELSE   false
 1405: \   THEN ;
 1406: 
 1407: : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
 1408:     \ opens a file for reading, searching in the path for it (unless
 1409:     \ the filename contains a slash); c-addr2 u2 is the full filename
 1410:     \ (valid until the next call); if the file is not found (or in
 1411:     \ case of other errors for each try), -38 (non-existant file) is
 1412:     \ thrown. Opening for other access modes makes little sense, as
 1413:     \ the path will usually contain dirs that are only readable for
 1414:     \ the user
 1415:     \ !! use file-status to determine access mode?
 1416:     2dup [char] / scan nip ( 0<> )
 1417:     if \ the filename contains a slash
 1418: 	2dup r/o open-file throw ( c-addr1 u1 file-id )
 1419: 	-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
 1420: 	pathfilenamebuf r> EXIT
 1421:     then
 1422:     pathdirs 2@ 0
 1423: \    check-file-prefix 0= 
 1424: \    IF  pathdirs 2@ 0
 1425:     ?DO ( c-addr1 u1 dirnamep )
 1426: 	dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
 1427: 	2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
 1428: 	pathfilenamebuf over r> + dup >r r/o open-file 0=
 1429: 	IF ( addr u file-id )
 1430: 	    nip nip r> rdrop 0 LEAVE
 1431: 	THEN
 1432: 	rdrop drop r> cell+ cell+
 1433:     LOOP
 1434: \    ELSE   2dup open-file throw -rot  THEN 
 1435:     0<> -&38 and throw ( file-id u2 )
 1436:     pathfilenamebuf swap ;
 1437: 
 1438: create included-files 0 , 0 , ( pointer to and count of included files )
 1439: create image-included-files 0 , 0 , ( pointer to and count of included files )
 1440: \ included-files points to ALLOCATEd space, while image-included-files
 1441: \ points to ALLOTed objects, so it survives a save-system
 1442: 
 1443: : init-included-files ( -- )
 1444:     image-included-files 2@ 2* cells save-string drop ( addr )
 1445:     image-included-files 2@ nip included-files 2! ;
 1446: 
 1447: : included? ( c-addr u -- f ) \ gforth
 1448:     \ true, iff filename c-addr u is in included-files
 1449:     included-files 2@ 0
 1450:     ?do ( c-addr u addr )
 1451: 	dup >r 2@ 2over compare 0=
 1452: 	if
 1453: 	    2drop rdrop unloop
 1454: 	    true EXIT
 1455: 	then
 1456: 	r> cell+ cell+
 1457:     loop
 1458:     2drop drop false ;
 1459: 
 1460: : add-included-file ( c-addr u -- ) \ gforth
 1461:     \ add name c-addr u to included-files
 1462:     included-files 2@ tuck 1+ 2* cells resize throw
 1463:     swap 2dup 1+ included-files 2!
 1464:     2* cells + 2! ;
 1465: 
 1466: : save-string		( addr1 u -- addr2 u ) \ gforth
 1467:     \ !! not a string, but a memblock word
 1468:     swap >r
 1469:     dup allocate throw
 1470:     swap 2dup r> -rot move ;
 1471: 
 1472: : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
 1473:     \ include the file file-id with the name given by c-addr u
 1474:     loadfilename 2@ >r >r
 1475:     save-string 2dup loadfilename 2! add-included-file ( file-id )
 1476:     ['] include-file catch
 1477:     r> r> loadfilename 2!  throw ;
 1478:     
 1479: : included ( i*x addr u -- j*x ) \ file
 1480:     open-path-file included1 ;
 1481: 
 1482: : required ( i*x addr u -- j*x ) \ gforth
 1483:     \ include the file with the name given by addr u, if it is not
 1484:     \ included already. Currently this works by comparing the name of
 1485:     \ the file (with path) against the names of earlier included
 1486:     \ files; however, it would probably be better to fstat the file,
 1487:     \ and compare the device and inode. The advantages would be: no
 1488:     \ problems with several paths to the same file (e.g., due to
 1489:     \ links) and we would catch files included with include-file and
 1490:     \ write a require-file.
 1491:     open-path-file 2dup included?
 1492:     if
 1493: 	2drop close-file throw
 1494:     else
 1495: 	included1
 1496:     then ;
 1497: 
 1498: \ HEX DECIMAL                                           2may93jaw
 1499: 
 1500: : decimal ( -- ) \ core
 1501:     a base ! ;
 1502: : hex ( -- ) \ core-ext
 1503:     10 base ! ;
 1504: 
 1505: \ DEPTH                                                 9may93jaw
 1506: 
 1507: : depth ( -- +n ) \ core
 1508:     sp@ s0 @ swap - cell / ;
 1509: : clearstack ( ... -- )
 1510:     s0 @ sp! ;
 1511: 
 1512: \ INCLUDE                                               9may93jaw
 1513: 
 1514: : include  ( "file" -- ) \ gforth
 1515:   name included ;
 1516: 
 1517: : require  ( "file" -- ) \ gforth
 1518:   name required ;
 1519: 
 1520: \ RECURSE                                               17may93jaw
 1521: 
 1522: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
 1523:     lastxt compile, ; immediate restrict
 1524: : recursive ( -- ) \ gforth
 1525:     reveal last off ; immediate
 1526: 
 1527: \ */MOD */                                              17may93jaw
 1528: 
 1529: \ !! I think */mod should have the same rounding behaviour as / - anton
 1530: : */mod ( n1 n2 n3 -- n4 n5 ) \ core	star-slash-mod
 1531:     >r m* r> sm/rem ;
 1532: 
 1533: : */ ( n1 n2 n3 -- n4 ) \ core	star-slash
 1534:     */mod nip ;
 1535: 
 1536: \ EVALUATE                                              17may93jaw
 1537: 
 1538: : evaluate ( c-addr len -- ) \ core,block
 1539:   push-file  dup #tib ! >tib @ swap move
 1540:   >in off blk off loadfile off -1 loadline !
 1541: \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
 1542:   ['] interpret catch
 1543:   pop-file throw ;
 1544: 
 1545: : abort ( ?? -- ?? ) \ core,exception-ext
 1546:     -1 throw ;
 1547: 
 1548: \+ environment? true ENV" CORE"
 1549: \ core wordset is now complete!
 1550: 
 1551: \ Quit                                                 13feb93py
 1552: 
 1553: Defer 'quit
 1554: Defer .status
 1555: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 1556: : (quit)        BEGIN .status cr query interpret prompt AGAIN ;
 1557: ' (quit) IS 'quit
 1558: 
 1559: \ DOERROR (DOERROR)                                     13jun93jaw
 1560: 
 1561: 8 Constant max-errors
 1562: Variable error-stack  0 error-stack !
 1563: max-errors 6 * cells allot
 1564: \ format of one cell:
 1565: \ source ( addr u )
 1566: \ >in
 1567: \ line-number
 1568: \ Loadfilename ( addr u )
 1569: 
 1570: : dec. ( n -- ) \ gforth
 1571:     \ print value in decimal representation
 1572:     base @ decimal swap . base ! ;
 1573: 
 1574: : typewhite ( addr u -- ) \ gforth
 1575:     \ like type, but white space is printed instead of the characters
 1576:     bounds ?do
 1577: 	i c@ 9 = if \ check for tab
 1578: 	    9
 1579: 	else
 1580: 	    bl
 1581: 	then
 1582: 	emit
 1583:     loop ;
 1584: 
 1585: DEFER DOERROR
 1586: 
 1587: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
 1588:   cr error-stack @
 1589:   IF
 1590:      ." in file included from "
 1591:      type ." :" dec.  drop 2drop
 1592:   ELSE
 1593:      type ." :" dec.
 1594:      cr dup 2over type cr drop
 1595:      nip -trailing 1- ( line-start index2 )
 1596:      0 >r  BEGIN
 1597:                   2dup + c@ bl >  WHILE
 1598: 		  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
 1599:      ( line-start index1 )
 1600:      typewhite
 1601:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
 1602:                   [char] ^ emit
 1603:      loop
 1604:   THEN
 1605: ;
 1606: 
 1607: : (DoError) ( throw-code -- )
 1608:   loadline @ IF
 1609:                source >in @ loadline @ 0 0 .error-frame
 1610:   THEN
 1611:   error-stack @ 0 ?DO
 1612:     -1 error-stack +!
 1613:     error-stack dup @ 6 * cells + cell+
 1614:     6 cells bounds DO
 1615:       I @
 1616:     cell +LOOP
 1617:     .error-frame
 1618:   LOOP
 1619:   dup -2 =
 1620:   IF 
 1621:      "error @ ?dup
 1622:      IF
 1623:         cr count type 
 1624:      THEN
 1625:      drop
 1626:   ELSE
 1627:      .error
 1628:   THEN
 1629:   normal-dp dpp ! ;
 1630: 
 1631: ' (DoError) IS DoError
 1632: 
 1633: : quit ( ?? -- ?? ) \ core
 1634:     r0 @ rp! handler off >tib @ >r
 1635:     BEGIN
 1636: 	postpone [
 1637: 	['] 'quit CATCH dup
 1638:     WHILE
 1639: 	DoError r@ >tib !
 1640:     REPEAT
 1641:     drop r> >tib ! ;
 1642: 
 1643: \ Cold                                                 13feb93py
 1644: 
 1645: \ : .name ( name -- ) cell+ count $1F and type space ;
 1646: \ : words  listwords @
 1647: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
 1648: 
 1649: : cstring>sstring  ( cstring -- addr n ) \ gforth	cstring-to-sstring
 1650:     -1 0 scan 0 swap 1+ /string ;
 1651: : arg ( n -- addr count ) \ gforth
 1652:     cells argv @ + @ cstring>sstring ;
 1653: : #!       postpone \ ;  immediate
 1654: 
 1655: Create pathstring 2 cells allot \ string
 1656: Create pathdirs   2 cells allot \ dir string array, pointer and count
 1657: Variable argv
 1658: Variable argc
 1659: 
 1660: 0 Value script? ( -- flag )
 1661: 
 1662: : process-path ( addr1 u1 -- addr2 u2 )
 1663:     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
 1664:     here >r
 1665:     BEGIN
 1666: 	over >r [char] : scan
 1667: 	over r> tuck - ( rest-str this-str )
 1668: 	dup
 1669: 	IF
 1670: 	    2dup 1- chars + c@ [char] / <>
 1671: 	    IF
 1672: 		2dup chars + [char] / swap c!
 1673: 		1+
 1674: 	    THEN
 1675: 	    2,
 1676: 	ELSE
 1677: 	    2drop
 1678: 	THEN
 1679: 	dup
 1680:     WHILE
 1681: 	1 /string
 1682:     REPEAT
 1683:     2drop
 1684:     here r> tuck - 2 cells / ;
 1685: 
 1686: : do-option ( addr1 len1 addr2 len2 -- n )
 1687:     2swap
 1688:     2dup s" -e"         compare  0= >r
 1689:     2dup s" --evaluate" compare  0= r> or
 1690:     IF  2drop dup >r ['] evaluate catch
 1691: 	?dup IF  dup >r DoError r> negate (bye)  THEN
 1692: 	r> >tib +!  2 EXIT  THEN
 1693:     ." Unknown option: " type cr 2drop 1 ;
 1694: 
 1695: : process-args ( -- )
 1696:     >tib @ >r
 1697:     argc @ 1
 1698:     ?DO
 1699: 	I arg over c@ [char] - <>
 1700: 	IF
 1701: 	    required 1
 1702: 	ELSE
 1703: 	    I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
 1704: 	    do-option
 1705: 	THEN
 1706:     +LOOP
 1707:     r> >tib ! ;
 1708: 
 1709: Defer 'cold ' noop IS 'cold
 1710: 
 1711: : cold ( -- ) \ gforth
 1712:     pathstring 2@ process-path pathdirs 2!
 1713:     init-included-files
 1714:     'cold
 1715:     argc @ 1 >
 1716:     IF
 1717: 	true to script?
 1718: 	['] process-args catch ?dup
 1719: 	IF
 1720: 	    dup >r DoError cr r> negate (bye)
 1721: 	THEN
 1722: 	cr
 1723:     THEN
 1724:     false to script?
 1725:     ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
 1726:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
 1727:     ." Type `bye' to exit"
 1728:     loadline off quit ;
 1729: 
 1730: : license ( -- ) \ gforth
 1731:  cr
 1732:  ." This program is free software; you can redistribute it and/or modify" cr
 1733:  ." it under the terms of the GNU General Public License as published by" cr
 1734:  ." the Free Software Foundation; either version 2 of the License, or" cr
 1735:  ." (at your option) any later version." cr cr
 1736: 
 1737:  ." This program is distributed in the hope that it will be useful," cr
 1738:  ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
 1739:  ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
 1740:  ." GNU General Public License for more details." cr cr
 1741: 
 1742:  ." You should have received a copy of the GNU General Public License" cr
 1743:  ." along with this program; if not, write to the Free Software" cr
 1744:  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
 1745: 
 1746: : boot ( path **argv argc -- )
 1747:   argc ! argv ! cstring>sstring pathstring 2!  main-task up!
 1748:   sp@ dup s0 ! $10 + >tib ! #tib off >in off
 1749:   rp@ r0 !  fp@ f0 !  cold ;
 1750: 
 1751: : bye ( -- ) \ tools-ext
 1752:     script? 0= IF  cr  THEN  0 (bye) ;
 1753: 
 1754: \ **argv may be scanned by the C starter to get some important
 1755: \ information, as -display and -geometry for an X client FORTH
 1756: \ or space and stackspace overrides
 1757: 
 1758: \ 0 arg contains, however, the name of the program.

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