Return to comp.fs CVS log

Up to [gforth] / gforth / kernel

renamed ;CODE-EXEC into LIT-EXECUTE (more general)
static stack caching for faster abi-call and ;abi-code-exec
Usage of VM_JUMP in static superinstructions is now flagged

    1: \ compiler definitions						14sep97jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   20: \ \ Revisions-Log
   21: 
   22: \	put in seperate file				14sep97jaw	
   23: 
   24: \ \ here allot , c, A,						17dec92py
   25: 
   26: [IFUNDEF] allot
   27: [IFUNDEF] forthstart
   28: : allot ( n -- ) \ core
   29:     dup unused u> -8 and throw
   30:     dp +! ;
   31: [THEN]
   32: [THEN]
   33: 
   34: \ we default to this version if we have nothing else 05May99jaw
   35: [IFUNDEF] allot
   36: : allot ( n -- ) \ core
   37:     \G Reserve @i{n} address units of data space without
   38:     \G initialization. @i{n} is a signed number, passing a negative
   39:     \G @i{n} releases memory.  In ANS Forth you can only deallocate
   40:     \G memory from the current contiguous region in this way.  In
   41:     \G Gforth you can deallocate anything in this way but named words.
   42:     \G The system does not check this restriction.
   43:     here +
   44:     dup 1- usable-dictionary-end forthstart within -8 and throw
   45:     dp ! ;
   46: [THEN]
   47: 
   48: : c,    ( c -- ) \ core c-comma
   49:     \G Reserve data space for one char and store @i{c} in the space.
   50:     here 1 chars allot [ has? flash [IF] ] flashc! [ [ELSE] ] c! [ [THEN] ] ;
   51: 
   52: : ,     ( w -- ) \ core comma
   53:     \G Reserve data space for one cell and store @i{w} in the space.
   54:     here cell allot [ has? flash [IF] ] flash! [ [ELSE] ] ! [ [THEN] ] ;
   55: 
   56: : 2,	( w1 w2 -- ) \ gforth
   57:     \G Reserve data space for two cells and store the double @i{w1
   58:     \G w2} there, @i{w2} first (lower address).
   59:     here 2 cells allot  [ has? flash [IF] ] tuck flash! cell+ flash!
   60: 	[ [ELSE] ] 2! [ [THEN] ] ;
   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 f-aligned
   70: \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 
   71: 
   72: : falign ( -- ) \ float f-align
   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:     \G Align data-space pointer for all alignment requirements.
   82:     here dup maxaligned swap
   83:     ?DO
   84: 	bl c,
   85:     LOOP ;
   86: 
   87: \ the code field is aligned if its body is maxaligned
   88: ' maxalign Alias cfalign ( -- ) \ gforth
   89: \G Align data-space pointer for code field requirements (i.e., such
   90: \G that the corresponding body is maxaligned).
   91: 
   92: ' , alias A, ( addr -- ) \ gforth
   93: 
   94: ' NOOP ALIAS const
   95: 
   96: \ \ Header							23feb93py
   97: 
   98: \ input-stream, nextname and noname are quite ugly (passing
   99: \ information through global variables), but they are useful for dealing
  100: \ with existing/independent defining words
  101: 
  102: defer (header)
  103: defer header ( -- ) \ gforth
  104: ' (header) IS header
  105: 
  106: : string, ( c-addr u -- ) \ gforth
  107:     \G puts down string as cstring
  108:     dup [ has? rom [IF] ] $E0 [ [ELSE] ] alias-mask [ [THEN] ] or c,
  109: [ has? flash [IF] ]
  110:     bounds ?DO  I c@ c,  LOOP
  111: [ [ELSE] ]
  112:     here swap chars dup allot move
  113: [ [THEN] ] ;
  114: 
  115: : longstring, ( c-addr u -- ) \ gforth
  116:     \G puts down string as longcstring
  117:     dup , here swap chars dup allot move ;
  118: 
  119: [IFDEF] prelude-mask
  120: variable next-prelude
  121: 
  122: : prelude, ( -- )
  123:     next-prelude @ if
  124: 	align next-prelude @ ,
  125:     then ;
  126: [THEN]
  127: 
  128: : header, ( c-addr u -- ) \ gforth
  129:     name-too-long?
  130:     dup max-name-length @ max max-name-length !
  131:     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
  132:     align here last !
  133: [ has? ec [IF] ]
  134:     -1 A,
  135: [ [ELSE] ]
  136:     current @ 1 or A,	\ link field; before revealing, it contains the
  137: 			\ tagged reveal-into wordlist
  138: [ [THEN] ]
  139: [ has? f83headerstring [IF] ]
  140: 	string,
  141: [ [ELSE] ]
  142: 	longstring, alias-mask lastflags cset
  143: 	next-prelude @ 0<> prelude-mask and lastflags cset
  144: 	next-prelude off
  145: [ [THEN] ]
  146:     cfalign ;
  147: 
  148: : input-stream-header ( "name" -- )
  149:     parse-name name-too-short? header, ;
  150: 
  151: : input-stream ( -- )  \ general
  152:     \G switches back to getting the name from the input stream ;
  153:     ['] input-stream-header IS (header) ;
  154: 
  155: ' input-stream-header IS (header)
  156: 
  157: 2variable nextname-string
  158: 
  159: has? OS [IF]
  160: : nextname-header ( -- )
  161:     nextname-string 2@ header,
  162:     nextname-string free-mem-var
  163:     input-stream ;
  164: [THEN]
  165: 
  166: \ the next name is given in the string
  167: 
  168: has? OS [IF]
  169: : nextname ( c-addr u -- ) \ gforth
  170:     \g The next defined word will have the name @var{c-addr u}; the
  171:     \g defining word will leave the input stream alone.
  172:     name-too-long?
  173:     nextname-string free-mem-var
  174:     save-mem nextname-string 2!
  175:     ['] nextname-header IS (header) ;
  176: [THEN]
  177: 
  178: : noname-header ( -- )
  179:     0 last ! cfalign
  180:     input-stream ;
  181: 
  182: : noname ( -- ) \ gforth
  183:     \g The next defined word will be anonymous. The defining word will
  184:     \g leave the input stream alone. The xt of the defined word will
  185:     \g be given by @code{latestxt}.
  186:     ['] noname-header IS (header) ;
  187: 
  188: : latestxt ( -- xt ) \ gforth
  189:     \G @i{xt} is the execution token of the last word defined.
  190:     \ The main purpose of this word is to get the xt of words defined using noname
  191:     lastcfa @ ;
  192: 
  193: ' latestxt alias lastxt \ gforth-obsolete
  194: \G old name for @code{latestxt}.
  195: 
  196: : latest ( -- nt ) \ gforth
  197: \G @var{nt} is the name token of the last word defined; it is 0 if the
  198: \G last word has no name.
  199:     last @ ;
  200: 
  201: \ \ literals							17dec92py
  202: 
  203: : Literal  ( compilation n -- ; run-time -- n ) \ core
  204:     \G Compilation semantics: compile the run-time semantics.@*
  205:     \G Run-time Semantics: push @i{n}.@*
  206:     \G Interpretation semantics: undefined.
  207: [ [IFDEF] lit, ]
  208:     lit,
  209: [ [ELSE] ]
  210:     postpone lit ,
  211: [ [THEN] ] ; immediate restrict
  212: 
  213: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
  214:     \G Compile appropriate code such that, at run-time, @i{w1 w2} are
  215:     \G placed on the stack. Interpretation semantics are undefined.
  216:     swap postpone Literal  postpone Literal ; immediate restrict
  217: 
  218: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  219: [ [IFDEF] alit, ]
  220:     alit,
  221: [ [ELSE] ]
  222:     postpone lit A, 
  223: [ [THEN] ] ; immediate restrict
  224: 
  225: Defer char@ ( addr u -- char addr' u' )
  226: :noname  over c@ -rot 1 /string ; IS char@
  227: 
  228: : char   ( '<spaces>ccc' -- c ) \ core
  229:     \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
  230:     \G display code representing the first character of @i{ccc}.
  231:     parse-name char@ 2drop ;
  232: 
  233: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
  234:     \G Compilation: skip leading spaces. Parse the string
  235:     \G @i{ccc}. Run-time: return @i{c}, the display code
  236:     \G representing the first character of @i{ccc}.  Interpretation
  237:     \G semantics for this word are undefined.
  238:     char postpone Literal ; immediate restrict
  239: 
  240: \ \ threading							17mar93py
  241: 
  242: : cfa,     ( code-address -- )  \ gforth	cfa-comma
  243:     here
  244:     dup lastcfa !
  245:     [ has? rom [IF] ] 2 cells allot [ [ELSE] ] 0 A, 0 , [ [THEN] ]
  246:     code-address! ;
  247: 
  248: [IFUNDEF] compile,
  249: defer compile, ( xt -- )	\ core-ext	compile-comma
  250: \G  Compile the word represented by the execution token @i{xt}
  251: \G  into the current definition.
  252: 
  253: ' , is compile,
  254: [THEN]
  255: 
  256: has? ec 0= [IF]
  257: defer basic-block-end ( -- )
  258: 
  259: :noname ( -- )
  260:     0 compile-prim1 ;
  261: is basic-block-end
  262: [THEN]
  263: 
  264: has? primcentric [IF]
  265:     has? peephole [IF]
  266: 	\ dynamic only    
  267: 	: peephole-compile, ( xt -- )
  268: 	    \ compile xt, appending its code to the current dynamic superinstruction
  269: 	    here swap , compile-prim1 ;
  270:     [ELSE]
  271: 	: peephole-compile, ( xt -- addr ) @ , ;
  272:     [THEN]
  273: 
  274: : compile-to-prims, ( xt -- )
  275:     \G compile xt to use primitives (and their peephole optimization)
  276:     \G instead of ","-ing the xt.
  277:     \ !! all POSTPONEs here postpone primitives; this can be optimized
  278:     dup >does-code if
  279: 	['] does-exec peephole-compile, , EXIT
  280: 	\ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
  281:     then
  282:     dup >code-address CASE
  283: 	dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF
  284: 	docon:   OF >body @ ['] lit peephole-compile, , EXIT ENDOF
  285: 	\ docon:   OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
  286: 	\ docon is also used by VALUEs, so don't @ at compile time
  287: 	docol:   OF >body ['] call peephole-compile, , EXIT ENDOF
  288: 	dovar:   OF >body ['] lit peephole-compile, , EXIT ENDOF
  289: 	douser:  OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
  290: 	dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
  291: 	dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
  292: 	\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
  293: 	doabicode: OF >body ['] abi-call peephole-compile, , EXIT ENDOF
  294: 	do;abicode: OF ['] ;abi-code-exec peephole-compile, , EXIT ENDOF
  295: 	\ code words and ;code-defined words (code words could be
  296: 	\ optimized, if we could identify them):
  297: 	dup in-dictionary? IF
  298: 	    drop ['] lit-execute peephole-compile, , EXIT
  299: 	    \ drop POSTPONE literal ['] execute peephole-compile, EXIT
  300: 	THEN
  301:     ENDCASE
  302:     peephole-compile, ;
  303: 
  304: ' compile-to-prims, IS compile,
  305: [ELSE]
  306: ' , is compile,
  307: [THEN]
  308: 
  309: : !does    ( addr -- ) \ gforth	store-does
  310:     latestxt does-code! ;
  311: 
  312: \ : (does>)  ( R: addr -- )
  313: \     r> cfaligned /does-handler + !does ; \ !! no gforth-native
  314: 
  315: \ \ !! unused, but ifdefed/gosted in some places
  316: \ : (does>2)  ( addr -- )
  317: \     cfaligned /does-handler + !does ;
  318: 
  319: : (compile) ( -- ) \ gforth-obsolete: dummy
  320:     true abort" (compile) doesn't work, use POSTPONE instead" ;
  321: 
  322: \ \ ticks
  323: 
  324: : name>comp ( nt -- w xt ) \ gforth name-to-comp
  325:     \G @i{w xt} is the compilation token for the word @i{nt}.
  326:     (name>comp)
  327:     1 = if
  328:         ['] execute
  329:     else
  330:         ['] compile,
  331:     then ;
  332: 
  333: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
  334:     (') postpone ALiteral ; immediate restrict
  335: 
  336: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
  337:     \g @i{xt} represents @i{name}'s interpretation
  338:     \g semantics. Perform @code{-14 throw} if the word has no
  339:     \g interpretation semantics.
  340:     ' postpone ALiteral ; immediate restrict
  341: 
  342: : COMP'    ( "name" -- w xt ) \ gforth  comp-tick
  343:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  344:     (') name>comp ;
  345: 
  346: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
  347:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  348:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  349: 
  350: : postpone, ( w xt -- ) \ gforth	postpone-comma
  351:     \g Compile the compilation semantics represented by the
  352:     \g compilation token @i{w xt}.
  353:     dup ['] execute =
  354:     if
  355: 	drop compile,
  356:     else
  357: 	swap POSTPONE aliteral compile,
  358:     then ;
  359: 
  360: : POSTPONE ( "name" -- ) \ core
  361:     \g Compiles the compilation semantics of @i{name}.
  362:     COMP' postpone, ; immediate
  363: 
  364: \ \ recurse							17may93jaw
  365: 
  366: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
  367:     \g Call the current definition.
  368:     latestxt compile, ; immediate restrict
  369: 
  370: \ \ compiler loop
  371: 
  372: : compiler1 ( c-addr u -- ... xt )
  373:     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
  374:     if ( c-addr u nt )
  375: 	nip nip name>comp
  376:     else
  377: 	drop
  378: 	2dup 2>r snumber? dup
  379: 	IF
  380: 	    0>
  381: 	    IF
  382: 		['] 2literal
  383: 	    ELSE
  384: 		['] literal
  385: 	    THEN
  386: 	    2rdrop
  387: 	ELSE
  388: 	    drop 2r> compiler-notfound1
  389: 	THEN
  390:     then ;
  391: 
  392: : [ ( -- ) \  core	left-bracket
  393:     \G Enter interpretation state. Immediate word.
  394:     ['] interpreter1  IS parser1 state off ; immediate
  395: 
  396: : ] ( -- ) \ core	right-bracket
  397:     \G Enter compilation state.
  398:     ['] compiler1     IS parser1 state on  ;
  399: 
  400: \ \ Strings							22feb93py
  401: 
  402: : S, ( addr u -- )
  403:     \ allot string as counted string
  404: [ has? flash [IF] ]
  405:     dup c, bounds ?DO  I c@ c,  LOOP
  406: [ [ELSE] ]
  407:     here over char+ allot  place align
  408: [ [THEN] ] ;
  409: 
  410: : mem, ( addr u -- )
  411:     \ allot the memory block HERE (do alignment yourself)
  412: [ has? flash [IF] ]
  413:     bounds ?DO  I c@ c,  LOOP
  414: [ [ELSE] ]
  415:     here over allot swap move
  416: [ [THEN] ] ;
  417: 
  418: : ," ( "string"<"> -- )
  419:     [char] " parse s, ;
  420: 
  421: \ \ Header states						23feb93py
  422: 
  423: \ problematic only for big endian machines
  424: 
  425: has? f83headerstring [IF]
  426: : cset ( bmask c-addr -- )
  427:     tuck c@ or swap c! ; 
  428: 
  429: : creset ( bmask c-addr -- )
  430:     tuck c@ swap invert and swap c! ; 
  431: 
  432: : ctoggle ( bmask c-addr -- )
  433:     tuck c@ xor swap c! ; 
  434: [ELSE]
  435: : cset ( bmask c-addr -- )
  436:     tuck @ or swap ! ; 
  437: 
  438: : creset ( bmask c-addr -- )
  439:     tuck @ swap invert and swap ! ; 
  440: 
  441: : ctoggle ( bmask c-addr -- )
  442:     tuck @ xor swap ! ; 
  443: [THEN]
  444: 
  445: : lastflags ( -- c-addr )
  446:     \ the address of the flags byte in the last header
  447:     \ aborts if the last defined word was headerless
  448:     latest dup 0= abort" last word was headerless" cell+ ;
  449: 
  450: : immediate ( -- ) \ core
  451:     \G Make the compilation semantics of a word be to @code{execute}
  452:     \G the execution semantics.
  453:     immediate-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
  454: 
  455: : restrict ( -- ) \ gforth
  456:     \G A synonym for @code{compile-only}
  457:     restrict-mask lastflags [ has? rom [IF] ] creset [ [ELSE] ] cset [ [THEN] ] ;
  458: 
  459: ' restrict alias compile-only ( -- ) \ gforth
  460: \G Remove the interpretation semantics of a word.
  461: 
  462: \ \ Create Variable User Constant                        	17mar93py
  463: 
  464: : Alias    ( xt "name" -- ) \ gforth
  465:     Header reveal
  466:     alias-mask lastflags creset
  467:     dup A, lastcfa ! ;
  468: 
  469: doer? :dovar [IF]
  470: 
  471: : Create ( "name" -- ) \ core
  472:     Header reveal dovar: cfa, ;
  473: [ELSE]
  474: 
  475: : Create ( "name" -- ) \ core
  476:     Header reveal here lastcfa ! 0 A, 0 , DOES> ;
  477: [THEN]
  478: 
  479: has? flash [IF]
  480:     : (variable) dpp @ normal-dp = IF  Create dpp @
  481: 	ELSE  normal-dp @ Constant dpp @ ram  THEN ;
  482: : Variable ( "name" -- ) \ core
  483:     (Variable) 0 , dpp ! ;
  484: 
  485: : AVariable ( "name" -- ) \ gforth
  486:     (Variable) 0 A, dpp ! ;
  487: 
  488: : 2Variable ( "name" -- ) \ double two-variable
  489:     (Variable) 0 , 0 , dpp ! ;
  490: [ELSE]
  491: : Variable ( "name" -- ) \ core
  492:     Create 0 , ;
  493: 
  494: : AVariable ( "name" -- ) \ gforth
  495:     Create 0 A, ;
  496: 
  497: : 2Variable ( "name" -- ) \ double two-variable
  498:     Create 0 , 0 , ;
  499: [THEN]
  500: 
  501: has? no-userspace 0= [IF]
  502: : uallot ( n -- ) \ gforth
  503:     udp @ swap udp +! ;
  504: 
  505: doer? :douser [IF]
  506: 
  507: : User ( "name" -- ) \ gforth
  508:     Header reveal douser: cfa, cell uallot , ;
  509: 
  510: : AUser ( "name" -- ) \ gforth
  511:     User ;
  512: [ELSE]
  513: 
  514: : User Create cell uallot , DOES> @ up @ + ;
  515: 
  516: : AUser User ;
  517: [THEN]
  518: [THEN]
  519: 
  520: doer? :docon [IF]
  521:     : (Constant)  Header reveal docon: cfa, ;
  522: [ELSE]
  523:     : (Constant)  Create DOES> @ ;
  524: [THEN]
  525: 
  526: doer? :dovalue [IF]
  527:     : (Value)  Header reveal dovalue: cfa, ;
  528: [ELSE]
  529:     has? rom [IF]
  530: 	: (Value)  Create DOES> @ @ ;
  531:     [ELSE]
  532: 	: (Value)  Create DOES> @ ;
  533:     [THEN]
  534: [THEN]
  535: 
  536: : Constant ( w "name" -- ) \ core
  537:     \G Define a constant @i{name} with value @i{w}.
  538:     \G  
  539:     \G @i{name} execution: @i{-- w}
  540:     (Constant) , ;
  541: 
  542: : AConstant ( addr "name" -- ) \ gforth
  543:     (Constant) A, ;
  544: 
  545: has? flash [IF]
  546: : Value ( w "name" -- ) \ core-ext
  547:     (Value) dpp @ >r here cell allot >r
  548:     ram here >r , r> r> flash! r> dpp ! ;
  549: 
  550: ' Value alias AValue
  551: [ELSE]
  552: : Value ( w "name" -- ) \ core-ext
  553:     (Value) , ;
  554: 
  555: : AValue ( w "name" -- ) \ core-ext
  556:     (Value) A, ;
  557: [THEN]
  558: 
  559: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
  560:     Create ( w1 w2 "name" -- )
  561:         2,
  562:     DOES> ( -- w1 w2 )
  563:         2@ ;
  564:     
  565: doer? :dofield [IF]
  566:     : (Field)  Header reveal dofield: cfa, ;
  567: [ELSE]
  568:     : (Field)  Create DOES> @ + ;
  569: [THEN]
  570: 
  571: \ \ interpret/compile:
  572: 
  573: struct
  574:     >body
  575:     cell% field interpret/compile-int
  576:     cell% field interpret/compile-comp
  577: end-struct interpret/compile-struct
  578: 
  579: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
  580:     Create immediate swap A, A,
  581: DOES>
  582:     abort" executed primary cfa of an interpret/compile: word" ;
  583: \    state @ IF  cell+  THEN  perform ;
  584: 
  585: \ IS Defer What's Defers TO                            24feb93py
  586: 
  587: defer defer-default ( -- )
  588: ' abort is defer-default
  589: \ default action for deferred words (overridden by a warning later)
  590:     
  591: doer? :dodefer [IF]
  592: 
  593: : Defer ( "name" -- ) \ gforth
  594: \G Define a deferred word @i{name}; its execution semantics can be
  595: \G set with @code{defer!} or @code{is} (and they have to, before first
  596: \G executing @i{name}.
  597:     Header Reveal dodefer: cfa,
  598:     [ has? rom [IF] ] here >r cell allot
  599:     dpp @ ram here r> flash! ['] defer-default A, dpp !
  600:     [ [ELSE] ] ['] defer-default A, [ [THEN] ] ;
  601: 
  602: [ELSE]
  603: 
  604:     has? rom [IF]
  605: 	: Defer ( "name" -- ) \ gforth
  606: 	    Create here >r cell allot
  607: 	    dpp @ ram here r> flash! ['] defer-default A, dpp !
  608: 	  DOES> @ @ execute ;
  609:     [ELSE]
  610: 	: Defer ( "name" -- ) \ gforth
  611: 	    Create ['] defer-default A,
  612: 	  DOES> @ execute ;
  613:     [THEN]
  614: [THEN]
  615: 
  616: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
  617: \G @i{xt} represents the word currently associated with the deferred
  618: \G word @i{xt-deferred}.
  619:     >body @ [ has? rom [IF] ] @ [ [THEN] ] ;
  620: 
  621: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
  622:     \G Compiles the present contents of the deferred word @i{name}
  623:     \G into the current definition.  I.e., this produces static
  624:     \G binding as if @i{name} was not deferred.
  625:     ' defer@ compile, ; immediate
  626: 
  627: : does>-like ( xt -- )
  628:     \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
  629:     \ that should be stored right after the code address.
  630:     >r ;-hook ?struc
  631:     [ has? xconds [IF] ] exit-like [ [THEN] ]
  632:     here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
  633:     postpone aliteral r> compile, [compile] exit
  634:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  635:     defstart ;
  636: 
  637: :noname
  638:     here !does ]
  639:     defstart :-hook ;
  640: :noname
  641:     ['] !does does>-like :-hook ;
  642: interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
  643: 
  644: : defer! ( xt xt-deferred -- ) \ gforth  defer-store
  645: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
  646:     >body [ has? rom [IF] ] @ [ [THEN] ] ! ;
  647:     
  648: : <IS> ( "name" xt -- ) \ gforth
  649:     \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
  650:     ' defer! ;
  651: 
  652: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
  653:     \g At run-time, changes the @code{defer}red word @var{name} to
  654:     \g execute @var{xt}.
  655:     ' postpone ALiteral postpone defer! ; immediate restrict
  656: 
  657: ' <IS>
  658: ' [IS]
  659: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
  660: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
  661: \G Its compilation semantics parses at compile time.
  662: 
  663: ' <IS>
  664: ' [IS]
  665: interpret/compile: TO ( w "name" -- ) \ core-ext
  666: 
  667: : interpret/compile? ( xt -- flag )
  668:     >does-code ['] DOES> >does-code = ;
  669: 
  670: \ \ : ;                                                  	24feb93py
  671: 
  672: defer :-hook ( sys1 -- sys2 )
  673: 
  674: defer ;-hook ( sys2 -- sys1 )
  675: 
  676: 0 Constant defstart
  677: 
  678: [IFDEF] docol,
  679: : (:noname) ( -- colon-sys )
  680:     \ common factor of : and :noname
  681:     docol, ]comp
  682: [ELSE]
  683: : (:noname) ( -- colon-sys )
  684:     \ common factor of : and :noname
  685:     docol: cfa,
  686: [THEN]
  687:     defstart ] :-hook ;
  688: 
  689: : : ( "name" -- colon-sys ) \ core	colon
  690:     Header (:noname) ;
  691: 
  692: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
  693:     0 last !
  694:     cfalign here (:noname) ;
  695: 
  696: [IFDEF] fini,
  697: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core   semicolon
  698:     ;-hook ?struc fini, comp[ reveal postpone [ ; immediate restrict
  699: [ELSE]
  700: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
  701:     ;-hook ?struc [compile] exit
  702:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  703:     reveal postpone [ ; immediate restrict
  704: [THEN]
  705: 
  706: \ \ Search list handling: reveal words, recursive		23feb93py
  707: 
  708: : last?   ( -- false / nfa nfa )
  709:     latest ?dup ;
  710: 
  711: Variable warnings ( -- addr ) \ gforth
  712: G -1 warnings T !
  713: 
  714: has? ec [IF]
  715: : reveal ( -- ) \ gforth
  716:     last?
  717:     if \ the last word has a header
  718: 	dup ( name>link ) @ -1 =
  719: 	if \ it is still hidden
  720: 	    forth-wordlist dup >r @ over
  721: 	    [ has? flash [IF] ] flash! [ [ELSE] ] ! [  [THEN] ] r> !
  722: 	else
  723: 	    drop
  724: 	then
  725:     then ;
  726: [ELSE]
  727: : (reveal) ( nt wid -- )
  728:     wordlist-id dup >r
  729:     @ over ( name>link ) ! 
  730:     r> ! ;
  731: 
  732: \ make entry in wordlist-map
  733: ' (reveal) f83search reveal-method !
  734: 
  735: : check-shadow  ( addr count wid -- )
  736:     \G prints a warning if the string is already present in the wordlist
  737:     >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
  738: 	>stderr
  739: 	." redefined " name>string 2dup type
  740: 	str= 0= if
  741: 	    ."  with " type
  742: 	else
  743: 	    2drop
  744: 	then
  745: 	space space EXIT
  746:     then
  747:     2drop 2drop ;
  748: 
  749: : reveal ( -- ) \ gforth
  750:     last?
  751:     if \ the last word has a header
  752: 	dup ( name>link ) @ 1 and
  753: 	if \ it is still hidden
  754: 	    dup ( name>link ) @ 1 xor		( nt wid )
  755: 	    2dup >r name>string r> check-shadow ( nt wid )
  756: 	    dup wordlist-map @ reveal-method perform
  757: 	else
  758: 	    drop
  759: 	then
  760:     then ;
  761: 
  762: : rehash  ( wid -- )
  763:     dup wordlist-map @ rehash-method perform ;
  764: [THEN]
  765: 
  766: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
  767: \g Make the current definition visible, enabling it to call itself
  768: \g recursively.
  769: 	immediate restrict