Return to comp.fs CVS log

Up to [gforth] / gforth / kernel

Added section talking about different memory regions, and glossed
associated words. Glossed words associated with user input; the
manual still needs a bunch of examples for these.

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