File:  [gforth] / gforth / Attic / kernel.fs
Revision 1.15: download - view: text, annotated - select for diffs
Sun Feb 9 21:51:39 1997 UTC (22 years, 9 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
A few additional fixes. gforth EC should run now with only three
doers: docol, dovar and dodoes. Tried without dovar, failed (strange).

    1: \ kernel.fs    GForth kernel                        17dec92py
    2: 
    3: \ Copyright (C) 1995 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: \ Idea and implementation: Bernd Paysan (py)
   22: 
   23: HEX
   24: 
   25: \ labels for some code addresses
   26: 
   27: doer? :docon [IF]
   28: : docon: ( -- addr )	\ gforth
   29:     \G the code address of a @code{CONSTANT}
   30:     ['] bl >code-address ;
   31: [THEN]
   32: 
   33: : docol: ( -- addr )	\ gforth
   34:     \G the code address of a colon definition
   35:     ['] docol: >code-address ;
   36: 
   37: doer? :dovar [IF]
   38: : dovar: ( -- addr )	\ gforth
   39:     \G the code address of a @code{CREATE}d word
   40:     ['] udp >code-address ;
   41: [THEN]
   42: 
   43: doer? :douser [IF]
   44: : douser: ( -- addr )	\ gforth
   45:     \G the code address of a @code{USER} variable
   46:     ['] s0 >code-address ;
   47: [THEN]
   48: 
   49: doer? :dodefer [IF]
   50: : dodefer: ( -- addr )	\ gforth
   51:     \G the code address of a @code{defer}ed word
   52:     ['] source >code-address ;
   53: [THEN]
   54: 
   55: doer? :dofield [IF]
   56: : dofield: ( -- addr )	\ gforth
   57:     \G the code address of a @code{field}
   58:     ['] reveal-method >code-address ;
   59: [THEN]
   60: 
   61: has-prims 0= [IF]
   62: : dodoes: ( -- addr )	\ gforth
   63:     \G the code address of a @code{field}
   64:     ['] spaces >code-address ;
   65: [THEN]
   66: 
   67: NIL AConstant NIL \ gforth
   68: 
   69: \ Aliases
   70: 
   71: ' i Alias r@
   72: 
   73: \ Bit string manipulation                              06oct92py
   74: 
   75: \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
   76: \ DOES> ( n -- )  + c@ ;
   77: 
   78: \ : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
   79: \ : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   80: 
   81: \ : relinfo ( -- addr )  forthstart dup @ + !!bug!! ;
   82: \ : >rel  ( addr -- n )  forthstart - ;
   83: \ : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   84: 
   85: \ here allot , c, A,                                   17dec92py
   86: 
   87: : dp	( -- addr ) \ gforth
   88:     dpp @ ;
   89: : here  ( -- here ) \ core
   90:     dp @ ;
   91: : allot ( n -- ) \ core
   92:     dp +! ;
   93: : c,    ( c -- ) \ core
   94:     here 1 chars allot c! ;
   95: : ,     ( x -- ) \ core
   96:     here cell allot  ! ;
   97: : 2,	( w1 w2 -- ) \ gforth
   98:     here 2 cells allot 2! ;
   99: 
  100: \ : aligned ( addr -- addr' ) \ core
  101: \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
  102: : align ( -- ) \ core
  103:     here dup aligned swap ?DO  bl c,  LOOP ;
  104: 
  105: \ : faligned ( addr -- f-addr ) \ float
  106: \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
  107: 
  108: : falign ( -- ) \ float
  109:     here dup faligned swap
  110:     ?DO
  111: 	bl c,
  112:     LOOP ;
  113: 
  114: \ !! this is machine-dependent, but works on all but the strangest machines
  115: 
  116: : maxaligned ( addr -- f-addr ) \ float
  117:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
  118: : maxalign ( -- ) \ float
  119:     here dup maxaligned swap
  120:     ?DO
  121: 	bl c,
  122:     LOOP ;
  123: 
  124: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
  125: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
  126: \ the code field is aligned if its body is maxaligned
  127: ' maxalign Alias cfalign ( -- ) \ gforth
  128: 
  129: : chars ( n1 -- n2 ) \ core
  130: ; immediate
  131: 
  132: 
  133: \ : A!    ( addr1 addr2 -- ) \ gforth
  134: \    dup relon ! ;
  135: \ : A,    ( addr -- ) \ gforth
  136: \    here cell allot A! ;
  137: ' ! alias A! ( addr1 addr2 -- ) \ gforth
  138: ' , alias A, ( addr -- ) \ gforth 
  139: 
  140: 
  141: \ on off                                               23feb93py
  142: 
  143: : on  ( addr -- ) \ gforth
  144:     true  swap ! ;
  145: : off ( addr -- ) \ gforth
  146:     false swap ! ;
  147: 
  148: \ dabs roll                                           17may93jaw
  149: 
  150: : dabs ( d1 -- d2 ) \ double
  151:     dup 0< IF dnegate THEN ;
  152: 
  153: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
  154:   dup 1+ pick >r
  155:   cells sp@ cell+ dup cell+ rot move drop r> ;
  156: 
  157: \ name> found                                          17dec92py
  158: 
  159: $80 constant alias-mask \ set when the word is not an alias!
  160: $40 constant immediate-mask
  161: $20 constant restrict-mask
  162: 
  163: : ((name>))  ( nfa -- cfa )
  164:     name>string +  cfaligned ;
  165: 
  166: : (name>x) ( nfa -- cfa b )
  167:     \ cfa is an intermediate cfa and b is the flags byte of nfa
  168:     dup ((name>))
  169:     swap cell+ c@ dup alias-mask and 0=
  170:     IF
  171: 	swap @ swap
  172:     THEN ;
  173: 
  174: \ place bounds                                         13feb93py
  175: 
  176: : place  ( addr len to -- ) \ gforth
  177:     over >r  rot over 1+  r> move c! ;
  178: : bounds ( beg count -- end beg ) \ gforth
  179:     over + swap ;
  180: 
  181: \ input stream primitives                              23feb93py
  182: 
  183: : tib ( -- c-addr ) \ core-ext
  184:     \ obsolescent
  185:     >tib @ ;
  186: Defer source ( -- addr count ) \ core
  187: \ used by dodefer:, must be defer
  188: : (source) ( -- addr count )
  189:     tib #tib @ ;
  190: ' (source) IS source
  191: 
  192: \ (word)                                               22feb93py
  193: 
  194: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
  195:     \ skip all characters not equal to char
  196:     >r
  197:     BEGIN
  198: 	dup
  199:     WHILE
  200: 	over c@ r@ <>
  201:     WHILE
  202: 	1 /string
  203:     REPEAT  THEN
  204:     rdrop ;
  205: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
  206:     \ skip all characters equal to char
  207:     >r
  208:     BEGIN
  209: 	dup
  210:     WHILE
  211: 	over c@ r@  =
  212:     WHILE
  213: 	1 /string
  214:     REPEAT  THEN
  215:     rdrop ;
  216: 
  217: : (word) ( addr1 n1 char -- addr2 n2 )
  218:   dup >r skip 2dup r> scan  nip - ;
  219: 
  220: \ (word) should fold white spaces
  221: \ this is what (parse-white) does
  222: 
  223: \ word parse                                           23feb93py
  224: 
  225: : parse-word  ( char -- addr len ) \ gforth
  226:   source 2dup >r >r >in @ over min /string
  227:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
  228:   2dup + r> - 1+ r> min >in ! ;
  229: : word   ( char -- addr ) \ core
  230:   parse-word here place  bl here count + c!  here ;
  231: 
  232: : parse    ( char -- addr len ) \ core-ext
  233:   >r  source  >in @ over min /string  over  swap r>  scan >r
  234:   over - dup r> IF 1+ THEN  >in +! ;
  235: 
  236: \ name                                                 13feb93py
  237: 
  238: : capitalize ( addr len -- addr len ) \ gforth
  239:   2dup chars chars bounds
  240:   ?DO  I c@ toupper I c! 1 chars +LOOP ;
  241: : (name) ( -- c-addr count )
  242:     source 2dup >r >r >in @ /string (parse-white)
  243:     2dup + r> - 1+ r> min >in ! ;
  244: \    name count ;
  245: 
  246: : name-too-short? ( c-addr u -- c-addr u )
  247:     dup 0= -&16 and throw ;
  248: 
  249: : name-too-long? ( c-addr u -- c-addr u )
  250:     dup $1F u> -&19 and throw ;
  251: 
  252: \ Literal                                              17dec92py
  253: 
  254: : Literal  ( compilation n -- ; run-time -- n ) \ core
  255:     postpone lit  , ; immediate restrict
  256: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  257:     postpone lit A, ; immediate restrict
  258: 
  259: : char   ( 'char' -- n ) \ core
  260:     bl word char+ c@ ;
  261: : [char] ( compilation 'char' -- ; run-time -- n )
  262:     char postpone Literal ; immediate restrict
  263: 
  264: : (compile) ( -- ) \ gforth
  265:     r> dup cell+ >r @ compile, ;
  266: 
  267: : postpone, ( w xt -- )
  268:     \g Compiles the compilation semantics represented by @var{w xt}.
  269:     dup ['] execute =
  270:     if
  271: 	drop compile,
  272:     else
  273: 	dup ['] compile, =
  274: 	if
  275: 	    drop POSTPONE (compile) compile,
  276: 	else
  277: 	    swap POSTPONE aliteral compile,
  278: 	then
  279:     then ;
  280: 
  281: : POSTPONE ( "name" -- ) \ core
  282:     \g Compiles the compilation semantics of @var{name}.
  283:     COMP' postpone, ; immediate restrict
  284: 
  285: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
  286:     Create immediate swap A, A,
  287: DOES>
  288:     abort" executed primary cfa of an interpret/compile: word" ;
  289: \    state @ IF  cell+  THEN  perform ;
  290: 
  291: \ Use (compile) for the old behavior of compile!
  292: 
  293: \ digit?                                               17dec92py
  294: 
  295: : digit?   ( char -- digit true/ false ) \ gforth
  296:   base @ $100 =
  297:   IF
  298:     true EXIT
  299:   THEN
  300:   toupper [char] 0 - dup 9 u> IF
  301:     [ 'A '9 1 + -  ] literal -
  302:     dup 9 u<= IF
  303:       drop false EXIT
  304:     THEN
  305:   THEN
  306:   dup base @ u>= IF
  307:     drop false EXIT
  308:   THEN
  309:   true ;
  310: 
  311: : accumulate ( +d0 addr digit - +d1 addr )
  312:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  313: 
  314: : >number ( d addr count -- d addr count ) \ core
  315:     0
  316:     ?DO
  317: 	count digit?
  318:     WHILE
  319: 	accumulate
  320:     LOOP
  321:         0
  322:     ELSE
  323: 	1- I' I -
  324: 	UNLOOP
  325:     THEN ;
  326: 
  327: \ number? number                                       23feb93py
  328: 
  329: Create bases   10 ,   2 ,   A , 100 ,
  330: \              16     2    10   character
  331: \ !! this saving and restoring base is an abomination! - anton
  332: : getbase ( addr u -- addr' u' )
  333:     over c@ [char] $ - dup 4 u<
  334:     IF
  335: 	cells bases + @ base ! 1 /string
  336:     ELSE
  337: 	drop
  338:     THEN ;
  339: : s>number ( addr len -- d )
  340:     base @ >r  dpl on
  341:     over c@ '- =  dup >r
  342:     IF
  343: 	1 /string
  344:     THEN
  345:     getbase  dpl on  0 0 2swap
  346:     BEGIN
  347: 	dup >r >number dup
  348:     WHILE
  349: 	dup r> -
  350:     WHILE
  351: 	dup dpl ! over c@ [char] . =
  352:     WHILE
  353: 	1 /string
  354:     REPEAT  THEN
  355:         2drop rdrop dpl off
  356:     ELSE
  357: 	2drop rdrop r>
  358: 	IF
  359: 	    dnegate
  360: 	THEN
  361:     THEN
  362:     r> base ! ;
  363: 
  364: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
  365:     s>number dpl @ 0=
  366:     IF
  367: 	2drop false  EXIT
  368:     THEN
  369:     dpl @ dup 0> 0= IF
  370: 	nip
  371:     THEN ;
  372: : number? ( string -- string 0 / n -1 / d 0> )
  373:     dup >r count snumber? dup if
  374: 	rdrop
  375:     else
  376: 	r> swap
  377:     then ;
  378: : s>d ( n -- d ) \ core		s-to-d
  379:     dup 0< ;
  380: : number ( string -- d )
  381:     number? ?dup 0= abort" ?"  0<
  382:     IF
  383: 	s>d
  384:     THEN ;
  385: 
  386: \ space spaces ud/mod                                  21mar93py
  387: decimal
  388: Create spaces ( u -- ) \ core
  389: bl 80 times \ times from target compiler! 11may93jaw
  390: DOES>   ( u -- )
  391:     swap
  392:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
  393: Create backspaces
  394: 08 80 times \ times from target compiler! 11may93jaw
  395: DOES>   ( u -- )
  396:     swap
  397:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
  398: hex
  399: : space ( -- ) \ core
  400:     1 spaces ;
  401: 
  402: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
  403:     >r 0 r@ um/mod r> swap >r
  404:     um/mod r> ;
  405: 
  406: : pad    ( -- addr ) \ core-ext
  407:   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
  408: 
  409: \ hold <# #> sign # #s                                 25jan92py
  410: 
  411: : hold    ( char -- ) \ core
  412:     pad cell - -1 chars over +! @ c! ;
  413: 
  414: : <# ( -- ) \ core	less-number-sign
  415:     pad cell - dup ! ;
  416: 
  417: : #>      ( xd -- addr u ) \ core	number-sign-greater
  418:     2drop pad cell - dup @ tuck - ;
  419: 
  420: : sign    ( n -- ) \ core
  421:     0< IF  [char] - hold  THEN ;
  422: 
  423: : #       ( ud1 -- ud2 ) \ core		number-sign
  424:     base @ 2 max ud/mod rot 9 over <
  425:     IF
  426: 	[ char A char 9 - 1- ] Literal +
  427:     THEN
  428:     [char] 0 + hold ;
  429: 
  430: : #s      ( +d -- 0 0 ) \ core	number-sign-s
  431:     BEGIN
  432: 	# 2dup or 0=
  433:     UNTIL ;
  434: 
  435: \ print numbers                                        07jun92py
  436: 
  437: : d.r ( d n -- ) \ double	d-dot-r
  438:     >r tuck  dabs  <# #s  rot sign #>
  439:     r> over - spaces  type ;
  440: 
  441: : ud.r ( ud n -- ) \ gforth	u-d-dot-r
  442:     >r <# #s #> r> over - spaces type ;
  443: 
  444: : .r ( n1 n2 -- ) \ core-ext	dot-r
  445:     >r s>d r> d.r ;
  446: : u.r ( u n -- )  \ core-ext	u-dot-r
  447:     0 swap ud.r ;
  448: 
  449: : d. ( d -- ) \ double	d-dot
  450:     0 d.r space ;
  451: : ud. ( ud -- ) \ gforth	u-d-dot
  452:     0 ud.r space ;
  453: 
  454: : . ( n -- ) \ core	dot
  455:     s>d d. ;
  456: : u. ( u -- ) \ core	u-dot
  457:     0 ud. ;
  458: 
  459: \ catch throw                                          23feb93py
  460: \ bounce                                                08jun93jaw
  461: 
  462: \ !! allow the user to add rollback actions    anton
  463: \ !! use a separate exception stack?           anton
  464: 
  465: has-locals [IF]
  466: : lp@ ( -- addr ) \ gforth	l-p-fetch
  467:  laddr# [ 0 , ] ;
  468: [THEN]
  469: 
  470: Defer 'catch
  471: Defer 'throw
  472: 
  473: ' noop IS 'catch
  474: ' noop IS 'throw
  475: 
  476: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  477:     'catch
  478:     sp@ >r
  479: [ has-floats [IF] ]
  480:     fp@ >r
  481: [ [THEN] ]
  482: [ has-locals [IF] ]
  483:     lp@ >r
  484: [ [THEN] ]
  485:     handler @ >r
  486:     rp@ handler !
  487:     execute
  488:     r> handler ! rdrop rdrop rdrop 0 ;
  489: 
  490: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
  491:     ?DUP IF
  492: 	[ here 9 cells ! ] \ entry point for signal handler
  493: 	handler @ dup 0= IF
  494: [ has-os [IF] ]
  495: 	    2 (bye)
  496: [ [ELSE] ]
  497: 	    quit
  498: [ [THEN] ]
  499: 	THEN
  500: 	rp!
  501: 	r> handler !
  502: [ has-locals [IF] ]
  503:         r> lp!
  504: [ [THEN] ]
  505: [ has-floats [IF] ]
  506: 	r> fp!
  507: [ [THEN] ]
  508: 	r> swap >r sp! drop r>
  509: 	'throw
  510:     THEN ;
  511: 
  512: \ Bouncing is very fine,
  513: \ programming without wasting time...   jaw
  514: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
  515: \ a throw without data or fp stack restauration
  516:   ?DUP IF
  517:       handler @ rp!
  518:       r> handler !
  519: [ has-locals [IF] ]
  520:       r> lp!
  521: [ [THEN] ]
  522: [ has-floats [IF] ]
  523:       rdrop
  524: [ [THEN] ]
  525:       rdrop
  526:       'throw
  527:   THEN ;
  528: 
  529: \ ?stack                                               23feb93py
  530: 
  531: : ?stack ( ?? -- ?? ) \ gforth
  532:     sp@ s0 @ u> IF    -4 throw  THEN
  533: [ has-floats [IF] ]
  534:     fp@ f0 @ u> IF  -&45 throw  THEN
  535: [ [THEN] ]
  536: ;
  537: \ ?stack should be code -- it touches an empty stack!
  538: 
  539: \ interpret                                            10mar92py
  540: 
  541: Defer parser
  542: Defer name ( -- c-addr count ) \ gforth
  543: \ get the next word from the input buffer
  544: ' (name) IS name
  545: Defer compiler-notfound ( c-addr count -- )
  546: Defer interpreter-notfound ( c-addr count -- )
  547: 
  548: : no.extensions  ( addr u -- )
  549:     2drop -&13 bounce ;
  550: ' no.extensions IS compiler-notfound
  551: ' no.extensions IS interpreter-notfound
  552: 
  553: : compile-only-error ( ... -- )
  554:     -&14 throw ;
  555: 
  556: : interpret ( ?? -- ?? ) \ gforth
  557:     \ interpret/compile the (rest of the) input buffer
  558:     BEGIN
  559: 	?stack name dup
  560:     WHILE
  561: 	parser
  562:     REPEAT
  563:     2drop ;
  564: 
  565: \ interpreter compiler                                 30apr92py
  566: 
  567: \ not the most efficient implementations of interpreter and compiler
  568: : interpreter ( c-addr u -- ) 
  569:     2dup find-name dup
  570:     if
  571: 	nip nip name>int execute
  572:     else
  573: 	drop
  574: 	2dup 2>r snumber?
  575: 	IF
  576: 	    2rdrop
  577: 	ELSE
  578: 	    2r> interpreter-notfound
  579: 	THEN
  580:     then ;
  581: 
  582: : compiler ( c-addr u -- )
  583:     2dup find-name dup
  584:     if ( c-addr u nt )
  585: 	nip nip name>comp execute
  586:     else
  587: 	drop
  588: 	2dup snumber? dup
  589: 	IF
  590: 	    0>
  591: 	    IF
  592: 		swap postpone Literal
  593: 	    THEN
  594: 	    postpone Literal
  595: 	    2drop
  596: 	ELSE
  597: 	    drop compiler-notfound
  598: 	THEN
  599:     then ;
  600: 
  601: ' interpreter  IS  parser
  602: 
  603: : [ ( -- ) \ core	left-bracket
  604:     ['] interpreter  IS parser state off ; immediate
  605: : ] ( -- ) \ core	right-bracket
  606:     ['] compiler     IS parser state on  ;
  607: 
  608: \ Strings                                              22feb93py
  609: 
  610: : ," ( "string"<"> -- ) [char] " parse
  611:   here over char+ allot  place align ;
  612: : "lit ( -- addr )
  613:   r> r> dup count + aligned >r swap >r ;
  614: : (.")     "lit count type ;
  615: : (S")     "lit count ;
  616: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
  617:     postpone (S") here over char+ allot  place align ;
  618:                                              immediate restrict
  619: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file	paren
  620:     [char] ) parse 2drop ; immediate
  621: 
  622: : \ ( -- ) \ core-ext backslash
  623:     blk @
  624:     IF
  625: 	>in @ c/l / 1+ c/l * >in !
  626: 	EXIT
  627:     THEN
  628:     source >in ! drop ; immediate
  629: 
  630: : \G ( -- ) \ gforth backslash
  631:     POSTPONE \ ; immediate
  632: 
  633: \ error handling                                       22feb93py
  634: \ 'abort thrown out!                                   11may93jaw
  635: 
  636: : (abort")
  637:     "lit >r
  638:     IF
  639: 	r> "error ! -2 throw
  640:     THEN
  641:     rdrop ;
  642: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext	abort-quote
  643:     postpone (abort") ," ;        immediate restrict
  644: 
  645: \ Header states                                        23feb93py
  646: 
  647: : cset ( bmask c-addr -- )
  648:     tuck c@ or swap c! ; 
  649: : creset ( bmask c-addr -- )
  650:     tuck c@ swap invert and swap c! ; 
  651: : ctoggle ( bmask c-addr -- )
  652:     tuck c@ xor swap c! ; 
  653: 
  654: : lastflags ( -- c-addr )
  655:     \ the address of the flags byte in the last header
  656:     \ aborts if the last defined word was headerless
  657:     last @ dup 0= abort" last word was headerless" cell+ ;
  658: 
  659: : immediate ( -- ) \ core
  660:     immediate-mask lastflags cset ;
  661: : restrict ( -- ) \ gforth
  662:     restrict-mask lastflags cset ;
  663: ' restrict alias compile-only ( -- ) \ gforth
  664: 
  665: \ Header                                               23feb93py
  666: 
  667: \ input-stream, nextname and noname are quite ugly (passing
  668: \ information through global variables), but they are useful for dealing
  669: \ with existing/independent defining words
  670: 
  671: defer (header)
  672: defer header ( -- ) \ gforth
  673: ' (header) IS header
  674: 
  675: : string, ( c-addr u -- ) \ gforth
  676:     \G puts down string as cstring
  677:     dup c, here swap chars dup allot move ;
  678: 
  679: : header, ( c-addr u -- ) \ gforth
  680:     name-too-long?
  681:     align here last !
  682:     current @ 1 or A,	\ link field; before revealing, it contains the
  683: 			\ tagged reveal-into wordlist
  684:     string, cfalign
  685:     alias-mask lastflags cset ;
  686: 
  687: : input-stream-header ( "name" -- )
  688:     name name-too-short? header, ;
  689: : input-stream ( -- )  \ general
  690:     \G switches back to getting the name from the input stream ;
  691:     ['] input-stream-header IS (header) ;
  692: 
  693: ' input-stream-header IS (header)
  694: 
  695: \ !! make that a 2variable
  696: create nextname-buffer 32 chars allot
  697: 
  698: : nextname-header ( -- )
  699:     nextname-buffer count header,
  700:     input-stream ;
  701: 
  702: \ the next name is given in the string
  703: : nextname ( c-addr u -- ) \ gforth
  704:     name-too-long?
  705:     nextname-buffer c! ( c-addr )
  706:     nextname-buffer count move
  707:     ['] nextname-header IS (header) ;
  708: 
  709: : noname-header ( -- )
  710:     0 last ! cfalign
  711:     input-stream ;
  712: 
  713: : noname ( -- ) \ gforth
  714: \ the next defined word remains anonymous. The xt of that word is given by lastxt
  715:     ['] noname-header IS (header) ;
  716: 
  717: : lastxt ( -- xt ) \ gforth
  718: \ 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
  719:     lastcfa @ ;
  720: 
  721: : Alias    ( cfa "name" -- ) \ gforth
  722:     Header reveal
  723:     alias-mask lastflags creset
  724:     dup A, lastcfa ! ;
  725: 
  726: : name>string ( nt -- addr count ) \ gforth	name-to-string
  727:     \g @var{addr count} is the name of the word represented by @var{nt}.
  728:     cell+ count $1F and ;
  729: 
  730: Create ???  0 , 3 c, char ? c, char ? c, char ? c,
  731: : >name ( cfa -- nt ) \ gforth	to-name
  732:  $21 cell do
  733:    dup i - count $9F and + cfaligned over alias-mask + = if
  734:      i - cell - unloop exit
  735:    then
  736:  cell +loop
  737:  drop ??? ( wouldn't 0 be better? ) ;
  738: 
  739: \ threading                                   17mar93py
  740: 
  741: : cfa,     ( code-address -- )  \ gforth	cfa-comma
  742:     here
  743:     dup lastcfa !
  744:     0 A, 0 ,  code-address! ;
  745: : compile, ( xt -- )	\ core-ext	compile-comma
  746:     A, ;
  747: : !does    ( addr -- ) \ gforth	store-does
  748:     lastxt does-code! ;
  749: : (does>)  ( R: addr -- )
  750:     r> /does-handler + !does ;
  751: : dodoes,  ( -- )
  752:   here /does-handler allot does-handler! ;
  753: 
  754: doer? :dovar [IF]
  755: : Create ( "name" -- ) \ core
  756:     Header reveal dovar: cfa, ;
  757: [ELSE]
  758: : Create ( "name" -- ) \ core
  759:     Header reveal here lastcfa ! 0 A, 0 , DOES> ;
  760: [THEN]
  761: 
  762: \ Create Variable User Constant                        17mar93py
  763: 
  764: : Variable ( "name" -- ) \ core
  765:     Create 0 , ;
  766: : AVariable ( "name" -- ) \ gforth
  767:     Create 0 A, ;
  768: : 2Variable ( "name" -- ) \ double
  769:     create 0 , 0 , ;
  770: 
  771: : uallot ( n -- )  udp @ swap udp +! ;
  772: 
  773: doer? :douser [IF]
  774: : User ( "name" -- ) \ gforth
  775:     Header reveal douser: cfa, cell uallot , ;
  776: : AUser ( "name" -- ) \ gforth
  777:     User ;
  778: [ELSE]
  779: : User Create uallot , DOES> @ up @ + ;
  780: : AUser User ;
  781: [THEN]
  782: 
  783: doer? :docon [IF]
  784:     : (Constant)  Header reveal docon: cfa, ;
  785: [ELSE]
  786:     : (Constant)  Create DOES> @ ;
  787: [THEN]
  788: : Constant ( w "name" -- ) \ core
  789:     \G Defines constant @var{name}
  790:     \G  
  791:     \G @var{name} execution: @var{-- w}
  792:     (Constant) , ;
  793: : AConstant ( addr "name" -- ) \ gforth
  794:     (Constant) A, ;
  795: : Value ( w "name" -- ) \ core-ext
  796:     (Constant) , ;
  797: 
  798: : 2Constant ( w1 w2 "name" -- ) \ double
  799:     Create ( w1 w2 "name" -- )
  800:         2,
  801:     DOES> ( -- w1 w2 )
  802:         2@ ;
  803:     
  804: doer? :dofield [IF]
  805:     : (Field)  Header reveal dofield: cfa, ;
  806: [ELSE]
  807:     : (Field)  Create DOES> @ + ;
  808: [THEN]
  809: \ IS Defer What's Defers TO                            24feb93py
  810: 
  811: doer? :dodefer [IF]
  812: : Defer ( "name" -- ) \ gforth
  813:     \ !! shouldn't it be initialized with abort or something similar?
  814:     Header Reveal dodefer: cfa,
  815:     ['] noop A, ;
  816: [ELSE]
  817: : Defer ( "name" -- ) \ gforth
  818:     Create ['] noop A,
  819: DOES> @ execute ;
  820: [THEN]
  821: 
  822: : Defers ( "name" -- ) \ gforth
  823:     ' >body @ compile, ; immediate
  824: 
  825: \ : ;                                                  24feb93py
  826: 
  827: defer :-hook ( sys1 -- sys2 )
  828: defer ;-hook ( sys2 -- sys1 )
  829: 
  830: : : ( "name" -- colon-sys ) \ core	colon
  831:     Header docol: cfa, defstart ] :-hook ;
  832: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
  833:     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
  834: 
  835: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
  836:     0 last !
  837:     cfalign here docol: cfa, 0 ] :-hook ;
  838: 
  839: \ Search list handling                                 23feb93py
  840: 
  841: AVariable current ( -- addr ) \ gforth
  842: 
  843: : last?   ( -- false / nfa nfa )
  844:     last @ ?dup ;
  845: : (reveal) ( nt wid -- )
  846:     ( wid>wordlist-id ) dup >r
  847:     @ over ( name>link ) ! 
  848:     r> ! ;
  849: 
  850: \ object oriented search list                          17mar93py
  851: 
  852: \ word list structure:
  853: 
  854: struct
  855:   1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
  856:   1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
  857:   1 cells: field rehash-method \ xt: ( wid -- )
  858: \   \ !! what else
  859: end-struct wordlist-map-struct
  860: 
  861: struct
  862:   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
  863:   1 cells: field wordlist-map \ pointer to a wordlist-map-struct
  864:   1 cells: field wordlist-link \ link field to other wordlists
  865:   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
  866: end-struct wordlist-struct
  867: 
  868: : f83find      ( addr len wordlist -- nt / false )
  869:     ( wid>wordlist-id ) @ (f83find) ;
  870: 
  871: \ Search list table: find reveal
  872: Create f83search ( -- wordlist-map )
  873:     ' f83find A,  ' (reveal) A,  ' drop A,
  874: 
  875: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
  876: AVariable lookup       G forth-wordlist lookup T !
  877: G forth-wordlist current T !
  878: 
  879: \ higher level parts of find
  880: 
  881: ( struct )
  882: 0 >body cell
  883:   1 cells: field interpret/compile-int
  884:   1 cells: field interpret/compile-comp
  885: end-struct interpret/compile-struct
  886: 
  887: : interpret/compile? ( xt -- flag )
  888:     >does-code ['] S" >does-code = ;
  889: 
  890: : (cfa>int) ( cfa -- xt )
  891:     dup interpret/compile?
  892:     if
  893: 	interpret/compile-int @
  894:     then ;
  895: 
  896: : (x>int) ( cfa b -- xt )
  897:     \ get interpretation semantics of name
  898:     restrict-mask and
  899:     if
  900: 	drop ['] compile-only-error
  901:     else
  902: 	(cfa>int)
  903:     then ;
  904: 
  905: : name>int ( nt -- xt ) \ gforth
  906:     \G @var{xt} represents the interpretation semantics of the word
  907:     \G @var{nt}. Produces @code{' compile-only-error} if
  908:     \G @var{nt} is compile-only.
  909:     (name>x) (x>int) ;
  910: 
  911: : name?int ( nt -- xt ) \ gforth
  912:     \G Like name>int, but throws an error if compile-only.
  913:     (name>x) restrict-mask and
  914:     if
  915: 	compile-only-error \ does not return
  916:     then
  917:     (cfa>int) ;
  918: 
  919: : name>comp ( nt -- w xt ) \ gforth
  920:     \G @var{w xt} is the compilation token for the word @var{nt}.
  921:     (name>x) >r dup interpret/compile?
  922:     if
  923: 	interpret/compile-comp @
  924:     then
  925:     r> immediate-mask and if
  926: 	['] execute
  927:     else
  928: 	['] compile,
  929:     then ;
  930: 
  931: : (search-wordlist)  ( addr count wid -- nt / false )
  932:     dup wordlist-map @ find-method perform ;
  933: 
  934: : flag-sign ( f -- 1|-1 )
  935:     \ true becomes 1, false -1
  936:     0= 2* 1+ ;
  937: 
  938: : (name>intn) ( nfa -- xt +-1 )
  939:     (name>x) tuck (x>int) ( b xt )
  940:     swap immediate-mask and flag-sign ;
  941: 
  942: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
  943:     \ xt is the interpretation semantics
  944:     (search-wordlist) dup if
  945: 	(name>intn)
  946:     then ;
  947: 
  948: : find-name ( c-addr u -- nt/0 ) \ gforth
  949:     \g Find the name @var{c-addr u} in the current search
  950:     \g order. Return its nt, if found, otherwise 0.
  951:     lookup @ (search-wordlist) ;
  952: 
  953: : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
  954:     find-name dup
  955:     if ( nt )
  956: 	state @
  957: 	if
  958: 	    name>comp ['] execute = flag-sign
  959: 	else
  960: 	    (name>intn)
  961: 	then
  962:     then ;
  963: 
  964: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
  965:     dup count sfind dup
  966:     if
  967: 	rot drop
  968:     then ;
  969: 
  970: : (') ( "name" -- nt ) \ gforth
  971:     name find-name dup 0=
  972:     IF
  973: 	drop -&13 bounce
  974:     THEN  ;
  975: 
  976: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth	bracket-paren-tick
  977:     (') postpone ALiteral ; immediate restrict
  978: 
  979: : '    ( "name" -- xt ) \ core	tick
  980:     \g @var{xt} represents @var{name}'s interpretation
  981:     \g semantics. Performs @code{-14 throw} if the word has no
  982:     \g interpretation semantics.
  983:     (') name?int ;
  984: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core	bracket-tick
  985:     \g @var{xt} represents @var{name}'s interpretation
  986:     \g semantics. Performs @code{-14 throw} if the word has no
  987:     \g interpretation semantics.
  988:     ' postpone ALiteral ; immediate restrict
  989: 
  990: : COMP'    ( "name" -- w xt ) \ gforth	c-tick
  991:     \g @var{w xt} represents @var{name}'s compilation semantics.
  992:     (') name>comp ;
  993: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth	bracket-comp-tick
  994:     \g @var{w xt} represents @var{name}'s compilation semantics.
  995:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  996: 
  997: \ reveal words
  998: 
  999: Variable warnings ( -- addr ) \ gforth
 1000: G -1 warnings T !
 1001: 
 1002: : check-shadow  ( addr count wid -- )
 1003: \G prints a warning if the string is already present in the wordlist
 1004:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
 1005:    ." redefined " name>string 2dup type
 1006:    compare 0<> if
 1007:      ."  with " type
 1008:    else
 1009:      2drop
 1010:    then
 1011:    space space EXIT
 1012:  then
 1013:  2drop 2drop ;
 1014: 
 1015: : reveal ( -- ) \ gforth
 1016:     last?
 1017:     if \ the last word has a header
 1018: 	dup ( name>link ) @ 1 and
 1019: 	if \ it is still hidden
 1020: 	    dup ( name>link ) @ 1 xor		( nt wid )
 1021: 	    2dup >r name>string r> check-shadow ( nt wid )
 1022: 	    dup wordlist-map @ reveal-method perform
 1023: 	then
 1024:     then ;
 1025: 
 1026: : rehash  ( wid -- )
 1027:     dup wordlist-map @ rehash-method perform ;
 1028: 
 1029: \ Input                                                13feb93py
 1030: 
 1031: 07 constant #bell ( -- c ) \ gforth
 1032: 08 constant #bs ( -- c ) \ gforth
 1033: 09 constant #tab ( -- c ) \ gforth
 1034: 7F constant #del ( -- c ) \ gforth
 1035: 0D constant #cr   ( -- c ) \ gforth
 1036: \ the newline key code
 1037: 0C constant #ff ( -- c ) \ gforth
 1038: 0A constant #lf ( -- c ) \ gforth
 1039: 
 1040: : bell  #bell emit ;
 1041: : cr ( -- ) \ core
 1042:     \ emit a newline
 1043:     #lf ( sic! ) emit ;
 1044: 
 1045: \ : backspaces  0 ?DO  #bs emit  LOOP ;
 1046: 
 1047: : (ins) ( max span addr pos1 key -- max span addr pos2 )
 1048:     >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
 1049: : (bs) ( max span addr pos1 -- max span addr pos2 flag )
 1050:     dup IF
 1051: 	#bs emit bl emit #bs emit 1- rot 1- -rot
 1052:     THEN false ;
 1053: : (ret)  true bl emit ;
 1054: 
 1055: Create ctrlkeys
 1056:   ] false false false false  false false false false
 1057:     (bs)  false (ret) false  false (ret) false false
 1058:     false false false false  false false false false
 1059:     false false false false  false false false false [
 1060: 
 1061: defer insert-char
 1062: ' (ins) IS insert-char
 1063: defer everychar
 1064: ' noop IS everychar
 1065: 
 1066: : decode ( max span addr pos1 key -- max span addr pos2 flag )
 1067:   everychar
 1068:   dup #del = IF  drop #bs  THEN  \ del is rubout
 1069:   dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN
 1070:   >r 2over = IF  rdrop bell 0 EXIT  THEN
 1071:   r> insert-char 0 ;
 1072: 
 1073: : accept   ( addr len -- len ) \ core
 1074:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
 1075: \ this allows to edit given strings
 1076:   ELSE  0  THEN rot over
 1077:   BEGIN  key decode  UNTIL
 1078:   2drop nip ;
 1079: 
 1080: \ Output                                               13feb93py
 1081: 
 1082: has-os [IF]
 1083: 0 Value outfile-id ( -- file-id ) \ gforth
 1084: 
 1085: : (type) ( c-addr u -- ) \ gforth
 1086:     outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 1087: ;
 1088: 
 1089: : (emit) ( c -- ) \ gforth
 1090:     outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 1091: ;
 1092: [THEN]
 1093: 
 1094: Defer type ( c-addr u -- ) \ core
 1095: ' (type) IS Type
 1096: 
 1097: Defer emit ( c -- ) \ core
 1098: ' (Emit) IS Emit
 1099: 
 1100: Defer key ( -- c ) \ core
 1101: ' (key) IS key
 1102: 
 1103: \ Query                                                07apr93py
 1104: 
 1105: has-files 0= [IF]
 1106: : sourceline# ( -- n )  loadline @ ;
 1107: [THEN]
 1108: 
 1109: : refill ( -- flag ) \ core-ext,block-ext,file-ext
 1110:   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
 1111:   tib /line
 1112: [ has-files [IF] ]
 1113:   loadfile @ ?dup
 1114:   IF    read-line throw
 1115:   ELSE
 1116: [ [THEN] ]
 1117:       sourceline# 0< IF 2drop false EXIT THEN
 1118:       accept true
 1119: [ has-files [IF] ]
 1120:   THEN
 1121: [ [THEN] ]
 1122:   1 loadline +!
 1123:   swap #tib ! 0 >in ! ;
 1124: 
 1125: : query   ( -- ) \ core-ext
 1126:     \G obsolescent
 1127:     blk off loadfile off
 1128:     tib /line accept #tib ! 0 >in ! ;
 1129: 
 1130: \ save-mem extend-mem
 1131: 
 1132: has-os [IF]
 1133: : save-mem	( addr1 u -- addr2 u ) \ gforth
 1134:     \g copy a memory block into a newly allocated region in the heap
 1135:     swap >r
 1136:     dup allocate throw
 1137:     swap 2dup r> -rot move ;
 1138: 
 1139: : extend-mem	( addr1 u1 u -- addr addr2 u2 )
 1140:     \ extend memory block allocated from the heap by u aus
 1141:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
 1142:     over >r + dup >r resize throw
 1143:     r> over r> + -rot ;
 1144: [THEN]
 1145: 
 1146: \ HEX DECIMAL                                           2may93jaw
 1147: 
 1148: : decimal ( -- ) \ core
 1149:     a base ! ;
 1150: : hex ( -- ) \ core-ext
 1151:     10 base ! ;
 1152: 
 1153: \ DEPTH                                                 9may93jaw
 1154: 
 1155: : depth ( -- +n ) \ core
 1156:     sp@ s0 @ swap - cell / ;
 1157: : clearstack ( ... -- )
 1158:     s0 @ sp! ;
 1159: 
 1160: \ RECURSE                                               17may93jaw
 1161: 
 1162: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
 1163:     lastxt compile, ; immediate restrict
 1164: ' reveal alias recursive ( -- ) \ gforth
 1165: 	immediate
 1166: 
 1167: \ */MOD */                                              17may93jaw
 1168: 
 1169: \ !! I think */mod should have the same rounding behaviour as / - anton
 1170: : */mod ( n1 n2 n3 -- n4 n5 ) \ core	star-slash-mod
 1171:     >r m* r> sm/rem ;
 1172: 
 1173: : */ ( n1 n2 n3 -- n4 ) \ core	star-slash
 1174:     */mod nip ;
 1175: 
 1176: \ EVALUATE                                              17may93jaw
 1177: 
 1178: has-files 0= [IF]
 1179: : push-file  ( -- )  r>
 1180:   sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
 1181:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
 1182:   tibstack @ >tib ! >in @ >r  >r ;
 1183: 
 1184: : pop-file   ( throw-code -- throw-code )
 1185:   r>
 1186:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
 1187: [THEN]
 1188: 
 1189: : evaluate ( c-addr len -- ) \ core,block
 1190:   push-file  #tib ! >tib !
 1191:   >in off blk off loadfile off -1 loadline !
 1192:   ['] interpret catch
 1193:   pop-file throw ;
 1194: 
 1195: : abort ( ?? -- ?? ) \ core,exception-ext
 1196:     -1 throw ;
 1197: 
 1198: \+ environment? true ENV" CORE"
 1199: \ core wordset is now complete!
 1200: 
 1201: \ Quit                                                 13feb93py
 1202: 
 1203: Defer 'quit
 1204: Defer .status
 1205: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 1206: : (Query)  ( -- )
 1207:     loadfile off  blk off  refill drop ;
 1208: : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
 1209: ' (quit) IS 'quit
 1210: 
 1211: \ DOERROR (DOERROR)                                     13jun93jaw
 1212: 
 1213: 8 Constant max-errors
 1214: Variable error-stack  0 error-stack !
 1215: max-errors 6 * cells allot
 1216: \ format of one cell:
 1217: \ source ( addr u )
 1218: \ >in
 1219: \ line-number
 1220: \ Loadfilename ( addr u )
 1221: 
 1222: : dec. ( n -- ) \ gforth
 1223:     \ print value in decimal representation
 1224:     base @ decimal swap . base ! ;
 1225: 
 1226: : hex. ( u -- ) \ gforth
 1227:     \ print value as unsigned hex number
 1228:     '$ emit base @ swap hex u. base ! ;
 1229: 
 1230: : typewhite ( addr u -- ) \ gforth
 1231:     \ like type, but white space is printed instead of the characters
 1232:     bounds ?do
 1233: 	i c@ #tab = if \ check for tab
 1234: 	    #tab
 1235: 	else
 1236: 	    bl
 1237: 	then
 1238: 	emit
 1239:     loop ;
 1240: 
 1241: DEFER DOERROR
 1242: 
 1243: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
 1244:   cr error-stack @
 1245:   IF
 1246:      ." in file included from "
 1247:      type ." :" dec.  drop 2drop
 1248:   ELSE
 1249:      type ." :" dec.
 1250:      cr dup 2over type cr drop
 1251:      nip -trailing 1- ( line-start index2 )
 1252:      0 >r  BEGIN
 1253:                   2dup + c@ bl >  WHILE
 1254: 		  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
 1255:      ( line-start index1 )
 1256:      typewhite
 1257:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
 1258:                   [char] ^ emit
 1259:      loop
 1260:   THEN
 1261: ;
 1262: 
 1263: : (DoError) ( throw-code -- )
 1264:   sourceline# IF
 1265:                source >in @ sourceline# 0 0 .error-frame
 1266:   THEN
 1267:   error-stack @ 0 ?DO
 1268:     -1 error-stack +!
 1269:     error-stack dup @ 6 * cells + cell+
 1270:     6 cells bounds DO
 1271:       I @
 1272:     cell +LOOP
 1273:     .error-frame
 1274:   LOOP
 1275:   dup -2 =
 1276:   IF 
 1277:      "error @ ?dup
 1278:      IF
 1279:         cr count type 
 1280:      THEN
 1281:      drop
 1282:   ELSE
 1283:      .error
 1284:   THEN
 1285:   normal-dp dpp ! ;
 1286: 
 1287: ' (DoError) IS DoError
 1288: 
 1289: : quit ( ?? -- ?? ) \ core
 1290:     r0 @ rp! handler off >tib @ >r
 1291:     BEGIN
 1292: 	postpone [
 1293: 	['] 'quit CATCH dup
 1294:     WHILE
 1295: 	DoError r@ >tib ! r@ tibstack !
 1296:     REPEAT
 1297:     drop r> >tib ! ;
 1298: 
 1299: \ Cold                                                 13feb93py
 1300: 
 1301: \ : .name ( name -- ) name>string type space ;
 1302: \ : words  listwords @
 1303: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
 1304: Defer 'cold ' noop IS 'cold
 1305: 
 1306: : cold ( -- ) \ gforth
 1307: [ has-files [IF] ]
 1308:     pathstring 2@ process-path pathdirs 2!
 1309:     init-included-files
 1310: [ [THEN] ]
 1311:     'cold
 1312: [ has-files [IF] ]
 1313:     argc @ 1 >
 1314:     IF
 1315: 	['] process-args catch ?dup
 1316: 	IF
 1317: 	    dup >r DoError cr r> negate (bye)
 1318: 	THEN
 1319: 	cr
 1320:     THEN
 1321: [ [THEN] ]
 1322:     ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
 1323:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
 1324: [ has-os [IF] ]
 1325:      cr ." Type `bye' to exit"
 1326: [ [THEN] ]
 1327:     loadline off quit ;
 1328: 
 1329: : license ( -- ) \ gforth
 1330:  cr
 1331:  ." This program is free software; you can redistribute it and/or modify" cr
 1332:  ." it under the terms of the GNU General Public License as published by" cr
 1333:  ." the Free Software Foundation; either version 2 of the License, or" cr
 1334:  ." (at your option) any later version." cr cr
 1335: 
 1336:  ." This program is distributed in the hope that it will be useful," cr
 1337:  ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
 1338:  ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
 1339:  ." GNU General Public License for more details." cr cr
 1340: 
 1341:  ." You should have received a copy of the GNU General Public License" cr
 1342:  ." along with this program; if not, write to the Free Software" cr
 1343:  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
 1344: 
 1345: : boot ( path **argv argc -- )
 1346:     main-task up!
 1347: [ has-os [IF] ]
 1348:     stdout TO outfile-id
 1349: [ [THEN] ]
 1350: [ has-files [IF] ]
 1351:     argc ! argv ! pathstring 2!
 1352: [ [THEN] ]
 1353:     sp@ s0 !
 1354: [ has-locals [IF] ]
 1355:     lp@ forthstart 7 cells + @ - 
 1356: [ [ELSE] ]
 1357:     [ has-os [IF] ]
 1358:     sp@ $1040 +
 1359:     [ [ELSE] ]
 1360:     sp@ $40 +
 1361:     [ [THEN] ]
 1362: [ [THEN] ]
 1363:     dup >tib ! tibstack ! #tib off >in off
 1364:     rp@ r0 !
 1365: [ has-floats [IF] ]
 1366:     fp@ f0 !
 1367: [ [THEN] ]
 1368:     ['] cold catch DoError
 1369: [ has-os [IF] ]
 1370:     bye
 1371: [ [THEN] ]
 1372: ;
 1373: 
 1374: has-os [IF]
 1375: : bye ( -- ) \ tools-ext
 1376: [ has-files [IF] ]
 1377:     script? 0= IF  cr  THEN
 1378: [ [ELSE] ]
 1379:     cr
 1380: [ [THEN] ]
 1381:     0 (bye) ;
 1382: [THEN]
 1383: 
 1384: \ **argv may be scanned by the C starter to get some important
 1385: \ information, as -display and -geometry for an X client FORTH
 1386: \ or space and stackspace overrides
 1387: 
 1388: \ 0 arg contains, however, the name of the program.
 1389: 
 1390: 

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