Return to comp.fs CVS log

Up to [gforth] / gforth / kernel

Major re-write of manual sections concerning text interpreter and
defining words. Much fine-tuning of other sections. The manual is
``nearly finished'' -- at least, all the major pieces of work that
I envisaged for the first mods (which were only going to take a
couple of weeks...). The manual has grown from 127 pages to 192
which is good news in terms of content but bad news in terms of the
time it takes to print out on my HP550C DeskJet.

Other changes are just tweaks to glossary entries.

    1: \ compiler definitions						14sep97jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998 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: \ \ Revisions-Log
   22: 
   23: \	put in seperate file				14sep97jaw	
   24: 
   25: \ \ here allot , c, A,						17dec92py
   26: 
   27: [IFUNDEF] allot
   28: [IFUNDEF] forthstart
   29: : allot ( n -- ) \ core
   30:     \G Reserve or release @i{n} address units of data space; @i{n}
   31:     \G is a signed number. There are restrictions on releasing data
   32:     \G space.
   33:     dup unused u> -8 and throw
   34:     dp +! ;
   35: [THEN]
   36: [THEN]
   37: 
   38: \ we default to this version if we have nothing else 05May99jaw
   39: [IFUNDEF] allot
   40: : allot ( n -- ) \ core
   41:     \G Reserve or release @i{n} address units of data space; @i{n}
   42:     \G is a signed number. There are restrictions on releasing data
   43:     \G space.
   44:     here +
   45:     dup 1- usable-dictionary-end forthstart within -8 and throw
   46:     dp ! ;
   47: [THEN]
   48: 
   49: : c,    ( c -- ) \ core
   50:     \G Reserve data space for one char and store @i{c} in the space.
   51:     here 1 chars allot c! ;
   52: 
   53: : ,     ( w -- ) \ core
   54:     \G Reserve data space for one cell and store @i{w} in the space.
   55:     here cell allot  ! ;
   56: 
   57: : 2,	( w1 w2 -- ) \ gforth
   58:     \G Reserve data space for two cells and store the double @i{w1
   59:     \G w2} in the space.
   60:     here 2 cells allot 2! ;
   61: 
   62: \ : aligned ( addr -- addr' ) \ core
   63: \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   64: 
   65: : align ( -- ) \ core
   66:     \G If the data-space pointer is not aligned, reserve enough space to align it.
   67:     here dup aligned swap ?DO  bl c,  LOOP ;
   68: 
   69: \ : faligned ( addr -- f-addr ) \ float
   70: \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 
   71: 
   72: : falign ( -- ) \ float
   73:     \G If the data-space pointer is not float-aligned, reserve
   74:     \G enough space to align it.
   75:     here dup faligned swap
   76:     ?DO
   77: 	bl c,
   78:     LOOP ;
   79: 
   80: : maxalign ( -- ) \ gforth
   81:     here dup maxaligned swap
   82:     ?DO
   83: 	bl c,
   84:     LOOP ;
   85: 
   86: \ the code field is aligned if its body is maxaligned
   87: ' maxalign Alias cfalign ( -- ) \ gforth
   88: 
   89: ' , alias A, ( addr -- ) \ gforth
   90: 
   91: ' NOOP ALIAS const
   92: 
   93: \ \ Header							23feb93py
   94: 
   95: \ input-stream, nextname and noname are quite ugly (passing
   96: \ information through global variables), but they are useful for dealing
   97: \ with existing/independent defining words
   98: 
   99: defer (header)
  100: defer header ( -- ) \ gforth
  101: ' (header) IS header
  102: 
  103: : string, ( c-addr u -- ) \ gforth
  104:     \G puts down string as cstring
  105:     dup c, here swap chars dup allot move ;
  106: 
  107: : header, ( c-addr u -- ) \ gforth
  108:     name-too-long?
  109:     align here last !
  110:     current @ 1 or A,	\ link field; before revealing, it contains the
  111: 			\ tagged reveal-into wordlist
  112:     string, cfalign
  113:     alias-mask lastflags cset ;
  114: 
  115: : input-stream-header ( "name" -- )
  116:     name name-too-short? header, ;
  117: 
  118: : input-stream ( -- )  \ general
  119:     \G switches back to getting the name from the input stream ;
  120:     ['] input-stream-header IS (header) ;
  121: 
  122: ' input-stream-header IS (header)
  123: 
  124: \ !! make that a 2variable
  125: create nextname-buffer 32 chars allot
  126: 
  127: : nextname-header ( -- )
  128:     nextname-buffer count header,
  129:     input-stream ;
  130: 
  131: \ the next name is given in the string
  132: 
  133: : nextname ( c-addr u -- ) \ gforth
  134:     name-too-long?
  135:     nextname-buffer c! ( c-addr )
  136:     nextname-buffer count move
  137:     ['] nextname-header IS (header) ;
  138: 
  139: : noname-header ( -- )
  140:     0 last ! cfalign
  141:     input-stream ;
  142: 
  143: : noname ( -- ) \ gforth
  144: \ the next defined word remains anonymous. The xt of that word is given by lastxt
  145:     ['] noname-header IS (header) ;
  146: 
  147: : lastxt ( -- xt ) \ gforth
  148:     \G @i{xt} is the execution token of the last word defined.
  149:     \ The main purpose of this word is to get the xt of words defined using noname
  150:     lastcfa @ ;
  151: 
  152: \ \ literals							17dec92py
  153: 
  154: : Literal  ( compilation n -- ; run-time -- n ) \ core
  155:     \G Compile appropriate code such that, at run-time, @i{n} is placed
  156:     \G on the stack. Interpretation semantics are undefined.
  157: [ [IFDEF] lit, ]
  158:     lit,
  159: [ [ELSE] ]
  160:     postpone lit , 
  161: [ [THEN] ] ; immediate restrict
  162: 
  163: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  164: [ [IFDEF] alit, ]
  165:     alit,
  166: [ [ELSE] ]
  167:     postpone lit A, 
  168: [ [THEN] ] ; immediate restrict
  169: 
  170: : char   ( '<spaces>ccc' -- c ) \ core
  171:     \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
  172:     \G display code representing the first character of @i{ccc}.
  173:     bl word char+ c@ ;
  174: 
  175: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
  176:     \G Compilation: skip leading spaces. Parse the string
  177:     \G @i{ccc}. Run-time: return @i{c}, the display code
  178:     \G representing the first character of @i{ccc}.  Interpretation
  179:     \G semantics for this word are undefined.
  180:     char postpone Literal ; immediate restrict
  181: 
  182: \ \ threading							17mar93py
  183: 
  184: : cfa,     ( code-address -- )  \ gforth	cfa-comma
  185:     here
  186:     dup lastcfa !
  187:     0 A, 0 ,  code-address! ;
  188: 
  189: [IFUNDEF] compile,
  190: : compile, ( xt -- )	\ core-ext	compile-comma
  191:     \G  Compile the word represented by the execution token, @i{xt},
  192:     \G  into the current definition.
  193:     A, ;
  194: [THEN]
  195: 
  196: : !does    ( addr -- ) \ gforth	store-does
  197:     lastxt does-code! ;
  198: 
  199: : (does>)  ( R: addr -- )
  200:     r> cfaligned /does-handler + !does ;
  201: 
  202: : dodoes,  ( -- )
  203:   cfalign here /does-handler allot does-handler! ;
  204: 
  205: : (compile) ( -- ) \ gforth
  206:     r> dup cell+ >r @ compile, ;
  207: 
  208: : postpone, ( w xt -- ) \ gforth	postpone-comma
  209:     \g Compile the compilation semantics represented by @i{w xt}.
  210:     dup ['] execute =
  211:     if
  212: 	drop compile,
  213:     else
  214: 	dup ['] compile, =
  215: 	if
  216: 	    drop POSTPONE (compile) a,
  217: 	else
  218: 	    swap POSTPONE aliteral compile,
  219: 	then
  220:     then ;
  221: 
  222: : POSTPONE ( "name" -- ) \ core
  223:     \g Compiles the compilation semantics of @i{name}.
  224:     COMP' postpone, ; immediate restrict
  225: 
  226: struct
  227:     >body
  228:     cell% field interpret/compile-int
  229:     cell% field interpret/compile-comp
  230: end-struct interpret/compile-struct
  231: 
  232: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
  233:     Create immediate swap A, A,
  234: DOES>
  235:     abort" executed primary cfa of an interpret/compile: word" ;
  236: \    state @ IF  cell+  THEN  perform ;
  237: 
  238: \ \ ticks
  239: 
  240: : name>comp ( nt -- w xt ) \ gforth
  241:     \G @i{w xt} is the compilation token for the word @i{nt}.
  242:     (name>comp)
  243:     1 = if
  244:         ['] execute
  245:     else
  246:         ['] compile,
  247:     then ;
  248: 
  249: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
  250:     (') postpone ALiteral ; immediate restrict
  251: 
  252: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
  253:     \g @i{xt} represents @i{name}'s interpretation
  254:     \g semantics. Perform @code{-14 throw} if the word has no
  255:     \g interpretation semantics.
  256:     ' postpone ALiteral ; immediate restrict
  257: 
  258: : COMP'    ( "name" -- w xt ) \ gforth  comp-tick
  259:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  260:     (') name>comp ;
  261: 
  262: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
  263:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  264:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  265: 
  266: \ \ recurse							17may93jaw
  267: 
  268: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
  269:     \g Call the current definition.
  270:     lastxt compile, ; immediate restrict
  271: 
  272: \ \ compiler loop
  273: 
  274: : compiler ( c-addr u -- )
  275:     2dup find-name dup
  276:     if ( c-addr u nt )
  277: 	nip nip name>comp execute
  278:     else
  279: 	drop
  280: 	2dup snumber? dup
  281: 	IF
  282: 	    0>
  283: 	    IF
  284: 		swap postpone Literal
  285: 	    THEN
  286: 	    postpone Literal
  287: 	    2drop
  288: 	ELSE
  289: 	    drop compiler-notfound
  290: 	THEN
  291:     then ;
  292: 
  293: : [ ( -- ) \ core	left-bracket
  294:     \G Enter interpretation state. Immediate word.
  295:     ['] interpreter  IS parser state off ; immediate
  296: 
  297: : ] ( -- ) \ core	right-bracket
  298:     \G Enter compilation state.
  299:     ['] compiler     IS parser state on  ;
  300: 
  301: \ \ Strings							22feb93py
  302: 
  303: : ," ( "string"<"> -- ) [char] " parse
  304:   here over char+ allot  place align ;
  305: 
  306: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
  307:     \G Compilation: compile the string specified by @i{c-addr1},
  308:     \G @i{u} into the current definition. Run-time: return
  309:     \G @i{c-addr2 u} describing the address and length of the
  310:     \G string.
  311:     postpone (S") here over char+ allot  place align ;
  312:                                              immediate restrict
  313: 
  314: \ \ abort"							22feb93py
  315: 
  316: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext	abort-quote
  317:     \G If any bit of @i{f} is non-zero, perform the function of @code{-2 throw},
  318:     \G displaying the string @i{ccc} if there is no exception frame on the
  319:     \G exception stack.
  320:     postpone (abort") ," ;        immediate restrict
  321: 
  322: \ \ Header states						23feb93py
  323: 
  324: : cset ( bmask c-addr -- )
  325:     tuck c@ or swap c! ; 
  326: 
  327: : creset ( bmask c-addr -- )
  328:     tuck c@ swap invert and swap c! ; 
  329: 
  330: : ctoggle ( bmask c-addr -- )
  331:     tuck c@ xor swap c! ; 
  332: 
  333: : lastflags ( -- c-addr )
  334:     \ the address of the flags byte in the last header
  335:     \ aborts if the last defined word was headerless
  336:     last @ dup 0= abort" last word was headerless" cell+ ;
  337: 
  338: : immediate ( -- ) \ core
  339:     \G Make the compilation semantics of a word be to @code{execute}
  340:     \G the execution semantics.
  341:     immediate-mask lastflags cset ;
  342: 
  343: : restrict ( -- ) \ gforth
  344:     \G A synonym for @code{compile-only}
  345:     restrict-mask lastflags cset ;
  346: ' restrict alias compile-only ( -- ) \ gforth
  347: \G Remove the interpretation semantics of a word.
  348: 
  349: \ \ Create Variable User Constant                        	17mar93py
  350: 
  351: : Alias    ( xt "name" -- ) \ gforth
  352:     \ 29Apr1999nac The stack comment for this was cfa -- I changed it to xt because
  353:     \ they are the same thing in Gforth, and xt is a more appropriate thing to
  354:     \ document.
  355:     Header reveal
  356:     alias-mask lastflags creset
  357:     dup A, lastcfa ! ;
  358: 
  359: doer? :dovar [IF]
  360: 
  361: : Create ( "name" -- ) \ core
  362:     Header reveal dovar: cfa, ;
  363: [ELSE]
  364: 
  365: : Create ( "name" -- ) \ core
  366:     Header reveal here lastcfa ! 0 A, 0 , DOES> ;
  367: [THEN]
  368: 
  369: : Variable ( "name" -- ) \ core
  370:     Create 0 , ;
  371: 
  372: : AVariable ( "name" -- ) \ gforth
  373:     Create 0 A, ;
  374: 
  375: : 2Variable ( "name" -- ) \ double
  376:     create 0 , 0 , ;
  377: 
  378: : uallot ( n -- )  udp @ swap udp +! ;
  379: 
  380: doer? :douser [IF]
  381: 
  382: : User ( "name" -- ) \ gforth
  383:     Header reveal douser: cfa, cell uallot , ;
  384: 
  385: : AUser ( "name" -- ) \ gforth
  386:     User ;
  387: [ELSE]
  388: 
  389: : User Create cell uallot , DOES> @ up @ + ;
  390: 
  391: : AUser User ;
  392: [THEN]
  393: 
  394: doer? :docon [IF]
  395:     : (Constant)  Header reveal docon: cfa, ;
  396: [ELSE]
  397:     : (Constant)  Create DOES> @ ;
  398: [THEN]
  399: 
  400: : Constant ( w "name" -- ) \ core
  401:     \G Define a constant @i{name} with value @i{w}.
  402:     \G  
  403:     \G @i{name} execution: @i{-- w}
  404:     (Constant) , ;
  405: 
  406: : AConstant ( addr "name" -- ) \ gforth
  407:     (Constant) A, ;
  408: 
  409: : Value ( w "name" -- ) \ core-ext
  410:     (Constant) , ;
  411: 
  412: : 2Constant ( w1 w2 "name" -- ) \ double
  413:     Create ( w1 w2 "name" -- )
  414:         2,
  415:     DOES> ( -- w1 w2 )
  416:         2@ ;
  417:     
  418: doer? :dofield [IF]
  419:     : (Field)  Header reveal dofield: cfa, ;
  420: [ELSE]
  421:     : (Field)  Create DOES> @ + ;
  422: [THEN]
  423: \ IS Defer What's Defers TO                            24feb93py
  424: 
  425: doer? :dodefer [IF]
  426: 
  427: : Defer ( "name" -- ) \ gforth
  428:     \ !! shouldn't it be initialized with abort or something similar?
  429:     Header Reveal dodefer: cfa,
  430:     ['] noop A, ;
  431: [ELSE]
  432: 
  433: : Defer ( "name" -- ) \ gforth
  434:     Create ['] noop A,
  435: DOES> @ execute ;
  436: [THEN]
  437: 
  438: : Defers ( "name" -- ) \ gforth
  439:     ' >body @ compile, ; immediate
  440: 
  441: \ \ : ;                                                  	24feb93py
  442: 
  443: defer :-hook ( sys1 -- sys2 )
  444: 
  445: defer ;-hook ( sys2 -- sys1 )
  446: 
  447: [IFDEF] docol,
  448: : (:noname) ( -- colon-sys )
  449:     \ common factor of : and :noname
  450:     docol, ]comp defstart ] :-hook ;
  451: [ELSE]
  452: : (:noname) ( -- colon-sys )
  453:     \ common factor of : and :noname
  454:     docol: cfa, defstart ] :-hook ;
  455: [THEN]
  456: 
  457: : : ( "name" -- colon-sys ) \ core	colon
  458:     Header (:noname) ;
  459: 
  460: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
  461:     0 last !
  462:     cfalign here (:noname) ;
  463: 
  464: [IFDEF] fini,
  465: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core   semicolon
  466:     ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
  467: [ELSE]
  468: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
  469:     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
  470: [THEN]
  471: 
  472: \ \ Search list handling: reveal words, recursive		23feb93py
  473: 
  474: : last?   ( -- false / nfa nfa )
  475:     last @ ?dup ;
  476: 
  477: : (reveal) ( nt wid -- )
  478:     wordlist-id dup >r
  479:     @ over ( name>link ) ! 
  480:     r> ! ;
  481: 
  482: \ make entry in wordlist-map
  483: ' (reveal) f83search reveal-method !
  484: 
  485: Variable warnings ( -- addr ) \ gforth
  486: G -1 warnings T !
  487: 
  488: : check-shadow  ( addr count wid -- )
  489:     \G prints a warning if the string is already present in the wordlist
  490:     >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
  491: 	>stderr
  492: 	." redefined " name>string 2dup type
  493: 	compare 0<> if
  494: 	    ."  with " type
  495: 	else
  496: 	    2drop
  497: 	then
  498: 	space space EXIT
  499:     then
  500:     2drop 2drop ;
  501: 
  502: : reveal ( -- ) \ gforth
  503:     last?
  504:     if \ the last word has a header
  505: 	dup ( name>link ) @ 1 and
  506: 	if \ it is still hidden
  507: 	    dup ( name>link ) @ 1 xor		( nt wid )
  508: 	    2dup >r name>string r> check-shadow ( nt wid )
  509: 	    dup wordlist-map @ reveal-method perform
  510: 	else
  511: 	    drop
  512: 	then
  513:     then ;
  514: 
  515: : rehash  ( wid -- )
  516:     dup wordlist-map @ rehash-method perform ;
  517: 
  518: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
  519: \g Make the current definition visible, enabling it to call itself
  520: \g recursively.
  521: 	immediate restrict