File:  [gforth] / gforth / Attic / kernel.fs
Revision 1.14: download - view: text, annotated - select for diffs
Sat Feb 8 22:58:10 1997 UTC (22 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Merged in gforth-EC patches

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

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