File:  [gforth] / gforth / Attic / kernel.fs
Revision 1.18: download - view: text, annotated - select for diffs
Wed Mar 19 18:27:16 1997 UTC (22 years, 4 months ago) by anton
Branches: MAIN
CVS tags: HEAD
fixed some documentation bugs
updated dates on copyright messages
updated NEWS
some fixes in Makefile.in

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

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