File:  [gforth] / gforth / Attic / kernel.fs
Revision 1.13: download - view: text, annotated - select for diffs
Thu Feb 6 21:23:01 1997 UTC (22 years, 5 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Started to merge in changes made for gforth-EC project.

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

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