File:  [gforth] / gforth / kernel / comp.fs
Revision 1.116: download - view: text, annotated - select for diffs
Mon Dec 31 15:25:19 2012 UTC (9 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright year

    1: \ compiler definitions						14sep97jaw
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 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 c! ;
   51: 
   52: : ,     ( w -- ) \ core comma
   53:     \G Reserve data space for one cell and store @i{w} in the space.
   54:     here cell allot ! ;
   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 2! ;
   60: 
   61: \ : aligned ( addr -- addr' ) \ core
   62: \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   63: 
   64: : align ( -- ) \ core
   65:     \G If the data-space pointer is not aligned, reserve enough space to align it.
   66:     here dup aligned swap ?DO  bl c,  LOOP ;
   67: 
   68: \ : faligned ( addr -- f-addr ) \ float f-aligned
   69: \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; 
   70: 
   71: : falign ( -- ) \ float f-align
   72:     \G If the data-space pointer is not float-aligned, reserve
   73:     \G enough space to align it.
   74:     here dup faligned swap
   75:     ?DO
   76: 	bl c,
   77:     LOOP ;
   78: 
   79: : maxalign ( -- ) \ gforth
   80:     \G Align data-space pointer for all alignment requirements.
   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: \G Align data-space pointer for code field requirements (i.e., such
   89: \G that the corresponding body is maxaligned).
   90: 
   91: ' , alias A, ( addr -- ) \ gforth
   92: 
   93: ' NOOP ALIAS const
   94: 
   95: \ \ Header							23feb93py
   96: 
   97: \ input-stream, nextname and noname are quite ugly (passing
   98: \ information through global variables), but they are useful for dealing
   99: \ with existing/independent defining words
  100: 
  101: : string, ( c-addr u -- ) \ gforth
  102:     \G puts down string as cstring
  103:     dup alias-mask or c,
  104:     here swap chars dup allot move ;
  105: 
  106: : longstring, ( c-addr u -- ) \ gforth
  107:     \G puts down string as longcstring
  108:     dup , here swap chars dup allot move ;
  109: 
  110: [IFDEF] prelude-mask
  111: variable next-prelude
  112: 
  113: : prelude, ( -- )
  114:     next-prelude @ if
  115: 	align next-prelude @ ,
  116:     then ;
  117: [THEN]
  118: 
  119: : header, ( c-addr u -- ) \ gforth
  120:     name-too-long?
  121:     dup max-name-length @ max max-name-length !
  122:     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
  123:     align here last !
  124:     current @ 1 or A,	\ link field; before revealing, it contains the
  125: 			\ tagged reveal-into wordlist
  126:     longstring, alias-mask lastflags cset
  127:     next-prelude @ 0<> prelude-mask and lastflags cset
  128:     next-prelude off
  129:     cfalign ;
  130: 
  131: defer record-name ( -- ) ' noop is record-name
  132: \ record next name in tags file
  133: defer (header)
  134: defer header ( -- ) \ gforth
  135: ' (header) IS header
  136: 
  137: : input-stream-header ( "name" -- )
  138:     parse-name name-too-short? header, ;
  139: 
  140: : input-stream ( -- )  \ general
  141:     \G switches back to getting the name from the input stream ;
  142:     ['] input-stream-header IS (header) ;
  143: 
  144: ' input-stream-header IS (header)
  145: 
  146: 2variable nextname-string
  147: 
  148: : nextname-header ( -- )
  149:     nextname-string 2@ header,
  150:     nextname-string free-mem-var
  151:     input-stream ;
  152: 
  153: \ the next name is given in the string
  154: 
  155: : nextname ( c-addr u -- ) \ gforth
  156:     \g The next defined word will have the name @var{c-addr u}; the
  157:     \g defining word will leave the input stream alone.
  158:     name-too-long?
  159:     nextname-string free-mem-var
  160:     save-mem nextname-string 2!
  161:     ['] nextname-header IS (header) ;
  162: 
  163: : noname-header ( -- )
  164:     0 last ! cfalign
  165:     input-stream ;
  166: 
  167: : noname ( -- ) \ gforth
  168:     \g The next defined word will be anonymous. The defining word will
  169:     \g leave the input stream alone. The xt of the defined word will
  170:     \g be given by @code{latestxt}.
  171:     ['] noname-header IS (header) ;
  172: 
  173: : latestxt ( -- xt ) \ gforth
  174:     \G @i{xt} is the execution token of the last word defined.
  175:     \ The main purpose of this word is to get the xt of words defined using noname
  176:     lastcfa @ ;
  177: 
  178: ' latestxt alias lastxt \ gforth-obsolete
  179: \G old name for @code{latestxt}.
  180: 
  181: : latest ( -- nt ) \ gforth
  182: \G @var{nt} is the name token of the last word defined; it is 0 if the
  183: \G last word has no name.
  184:     last @ ;
  185: 
  186: \ \ literals							17dec92py
  187: 
  188: : Literal  ( compilation n -- ; run-time -- n ) \ core
  189:     \G Compilation semantics: compile the run-time semantics.@*
  190:     \G Run-time Semantics: push @i{n}.@*
  191:     \G Interpretation semantics: undefined.
  192:     postpone lit , ; immediate restrict
  193: 
  194: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
  195:     \G Compile appropriate code such that, at run-time, @i{w1 w2} are
  196:     \G placed on the stack. Interpretation semantics are undefined.
  197:     swap postpone Literal  postpone Literal ; immediate restrict
  198: 
  199: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
  200:     postpone lit A, ; immediate restrict
  201: 
  202: Defer char@ ( addr u -- char addr' u' )
  203: :noname  over c@ -rot 1 /string ; IS char@
  204: 
  205: : char   ( '<spaces>ccc' -- c ) \ core
  206:     \G Skip leading spaces. Parse the string @i{ccc} and return @i{c}, the
  207:     \G display code representing the first character of @i{ccc}.
  208:     parse-name char@ 2drop ;
  209: 
  210: : [char] ( compilation '<spaces>ccc' -- ; run-time -- c ) \ core bracket-char
  211:     \G Compilation: skip leading spaces. Parse the string
  212:     \G @i{ccc}. Run-time: return @i{c}, the display code
  213:     \G representing the first character of @i{ccc}.  Interpretation
  214:     \G semantics for this word are undefined.
  215:     char postpone Literal ; immediate restrict
  216: 
  217: \ \ threading							17mar93py
  218: 
  219: has? ec 0= [IF]
  220:     ' noop Alias recurse
  221:     \g Call the current definition.
  222:     unlock tlastcfa @ lock AConstant lastcfa
  223:     \ this is the alias pointer in the recurse header, named lastcfa.
  224:     \ changing lastcfa now changes where recurse aliases to
  225:     \ it's always an alias of the current definition
  226:     \ it won't work in a flash/rom environment, therefore for Gforth EC
  227:     \ we stick to the traditional implementation
  228: [ELSE]
  229:     : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
  230: 	\g Call the current definition.
  231: 	latestxt compile, ; immediate restrict
  232: [THEN]
  233: 
  234: : cfa,     ( code-address -- )  \ gforth	cfa-comma
  235:     here
  236:     dup lastcfa !
  237:     0 A, 0 ,
  238:     code-address! ;
  239: 
  240: [IFUNDEF] compile,
  241: defer compile, ( xt -- )	\ core-ext	compile-comma
  242: \G  Compile the word represented by the execution token @i{xt}
  243: \G  into the current definition.
  244: 
  245: ' , is compile,
  246: [THEN]
  247: 
  248: defer basic-block-end ( -- )
  249: 
  250: :noname ( -- )
  251:     0 compile-prim1 ;
  252: is basic-block-end
  253: 
  254: has? primcentric [IF]
  255:     has? peephole [IF]
  256: 	\ dynamic only    
  257: 	: peephole-compile, ( xt -- )
  258: 	    \ compile xt, appending its code to the current dynamic superinstruction
  259: 	    here swap , compile-prim1 ;
  260:     [ELSE]
  261: 	: peephole-compile, ( xt -- addr ) @ , ;
  262:     [THEN]
  263: 
  264: : compile-to-prims, ( xt -- )
  265:     \G compile xt to use primitives (and their peephole optimization)
  266:     \G instead of ","-ing the xt.
  267:     \ !! all POSTPONEs here postpone primitives; this can be optimized
  268:     dup >does-code if
  269: 	['] does-exec peephole-compile, , EXIT
  270: 	\ dup >body POSTPONE literal ['] call peephole-compile, >does-code , EXIT
  271:     then
  272:     dup >code-address CASE
  273: 	dovalue: OF >body ['] lit@ peephole-compile, , EXIT ENDOF
  274: 	docon:   OF >body @ ['] lit peephole-compile, , EXIT ENDOF
  275: 	\ docon:   OF >body POSTPONE literal ['] @ peephole-compile, EXIT ENDOF
  276: 	\ docon is also used by VALUEs, so don't @ at compile time
  277: 	docol:   OF >body ['] call peephole-compile, , EXIT ENDOF
  278: 	dovar:   OF >body ['] lit peephole-compile, , EXIT ENDOF
  279: 	douser:  OF >body @ ['] useraddr peephole-compile, , EXIT ENDOF
  280: 	dodefer: OF >body ['] lit-perform peephole-compile, , EXIT ENDOF
  281: 	dofield: OF >body @ ['] lit+ peephole-compile, , EXIT ENDOF
  282: 	\ dofield: OF >body @ POSTPONE literal ['] + peephole-compile, EXIT ENDOF
  283: 	doabicode: OF >body ['] abi-call peephole-compile, , EXIT ENDOF
  284: 	do;abicode: OF ['] ;abi-code-exec peephole-compile, , EXIT ENDOF
  285: 	\ code words and ;code-defined words (code words could be
  286: 	\ optimized, if we could identify them):
  287: 	dup in-dictionary? IF ( xt code-address )
  288: 	    over >body = if ( xt )
  289: 		\ definitely a CODE word
  290: 		peephole-compile, EXIT THEN
  291: 	    \ not sure, might be a ;CODE word
  292: 	    ['] lit-execute peephole-compile, , EXIT
  293: 	    \ drop POSTPONE literal ['] execute peephole-compile, EXIT
  294: 	THEN
  295:     ENDCASE
  296:     peephole-compile, ;
  297: 
  298: ' compile-to-prims, IS compile,
  299: [ELSE]
  300: ' , is compile,
  301: [THEN]
  302: 
  303: : !does    ( addr -- ) \ gforth	store-does
  304:     latestxt does-code! ;
  305: 
  306: : (compile) ( -- ) \ gforth-obsolete: dummy
  307:     true abort" (compile) doesn't work, use POSTPONE instead" ;
  308: 
  309: \ \ ticks
  310: 
  311: : name>comp ( nt -- w xt ) \ gforth name-to-comp
  312:     \G @i{w xt} is the compilation token for the word @i{nt}.
  313:     (name>comp)
  314:     1 = if
  315:         ['] execute
  316:     else
  317:         ['] compile,
  318:     then ;
  319: 
  320: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
  321:     (') postpone ALiteral ; immediate restrict
  322: 
  323: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
  324:     \g @i{xt} represents @i{name}'s interpretation
  325:     \g semantics. Perform @code{-14 throw} if the word has no
  326:     \g interpretation semantics.
  327:     ' postpone ALiteral ; immediate restrict
  328: 
  329: : COMP'    ( "name" -- w xt ) \ gforth  comp-tick
  330:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  331:     (') name>comp ;
  332: 
  333: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick
  334:     \g Compilation token @i{w xt} represents @i{name}'s compilation semantics.
  335:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
  336: 
  337: : postpone, ( w xt -- ) \ gforth	postpone-comma
  338:     \g Compile the compilation semantics represented by the
  339:     \g compilation token @i{w xt}.
  340:     dup ['] execute =
  341:     if
  342: 	drop compile,
  343:     else
  344: 	swap POSTPONE aliteral compile,
  345:     then ;
  346: 
  347: has? recognizer [IF]
  348:     include ./recognizer.fs
  349: [ELSE]
  350: : POSTPONE ( "name" -- ) \ core
  351:     \g Compiles the compilation semantics of @i{name}.
  352:     COMP' postpone, ; immediate
  353: [THEN]
  354: 
  355: \ \ compiler loop
  356: 
  357: has? recognizer 0= [IF]
  358: : compiler1 ( c-addr u -- ... xt )
  359:     2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
  360:     if ( c-addr u nt )
  361: 	nip nip name>comp
  362:     else
  363: 	drop
  364: 	2dup 2>r snumber? dup
  365: 	IF
  366: 	    0>
  367: 	    IF
  368: 		['] 2literal
  369: 	    ELSE
  370: 		['] literal
  371: 	    THEN
  372: 	    2rdrop
  373: 	ELSE
  374: 	    drop 2r> compiler-notfound1
  375: 	THEN
  376:     then ;
  377: 
  378: : [ ( -- ) \  core	left-bracket
  379:     \G Enter interpretation state. Immediate word.
  380:     ['] interpreter1  IS parser1 state off ; immediate
  381: 
  382: : ] ( -- ) \ core	right-bracket
  383:     \G Enter compilation state.
  384:     ['] compiler1     IS parser1 state on  ;
  385: [THEN]
  386: 
  387: \ \ Strings							22feb93py
  388: 
  389: : S, ( addr u -- )
  390:     \ allot string as counted string
  391:     here over char+ allot  place align ;
  392: 
  393: : mem, ( addr u -- )
  394:     \ allot the memory block HERE (do alignment yourself)
  395:     here over allot swap move ;
  396: 
  397: : ," ( "string"<"> -- )
  398:     [char] " parse s, ;
  399: 
  400: \ \ Header states						23feb93py
  401: 
  402: \ problematic only for big endian machines
  403: 
  404: : cset ( bmask c-addr -- )
  405:     tuck @ or swap ! ; 
  406: 
  407: : creset ( bmask c-addr -- )
  408:     tuck @ swap invert and swap ! ; 
  409: 
  410: : ctoggle ( bmask c-addr -- )
  411:     tuck @ xor swap ! ; 
  412: 
  413: : lastflags ( -- c-addr )
  414:     \ the address of the flags byte in the last header
  415:     \ aborts if the last defined word was headerless
  416:     latest dup 0= abort" last word was headerless" cell+ ;
  417: 
  418: : immediate ( -- ) \ core
  419:     \G Make the compilation semantics of a word be to @code{execute}
  420:     \G the execution semantics.
  421:     immediate-mask lastflags cset ;
  422: 
  423: : restrict ( -- ) \ gforth
  424:     \G A synonym for @code{compile-only}
  425:     restrict-mask lastflags cset ;
  426: 
  427: ' restrict alias compile-only ( -- ) \ gforth
  428: \G Remove the interpretation semantics of a word.
  429: 
  430: \ \ Create Variable User Constant                        	17mar93py
  431: 
  432: : Alias    ( xt "name" -- ) \ gforth
  433:     Header reveal
  434:     alias-mask lastflags creset
  435:     dup A, lastcfa ! ;
  436: 
  437: : Create ( "name" -- ) \ core
  438:     Header reveal dovar: cfa, ;
  439: 
  440: : buffer: ( u "name" -- ) \ core ext
  441:     Create allot ;
  442: 
  443: : Variable ( "name" -- ) \ core
  444:     Create 0 , ;
  445: 
  446: : AVariable ( "name" -- ) \ gforth
  447:     Create 0 A, ;
  448: 
  449: : 2Variable ( "name" -- ) \ double two-variable
  450:     Create 0 , 0 , ;
  451: 
  452: : uallot ( n -- ) \ gforth
  453:     udp @ swap udp +! ;
  454: 
  455: : User ( "name" -- ) \ gforth
  456:     Header reveal douser: cfa, cell uallot , ;
  457: 
  458: : AUser ( "name" -- ) \ gforth
  459:     User ;
  460: 
  461: : (Constant)  Header reveal docon: cfa, ;
  462: 
  463: : (Value)  Header reveal dovalue: cfa, ;
  464: 
  465: : Constant ( w "name" -- ) \ core
  466:     \G Define a constant @i{name} with value @i{w}.
  467:     \G  
  468:     \G @i{name} execution: @i{-- w}
  469:     (Constant) , ;
  470: 
  471: : AConstant ( addr "name" -- ) \ gforth
  472:     (Constant) A, ;
  473: 
  474: : Value ( w "name" -- ) \ core-ext
  475:     (Value) , ;
  476: 
  477: : AValue ( w "name" -- ) \ core-ext
  478:     (Value) A, ;
  479: 
  480: : 2Constant ( w1 w2 "name" -- ) \ double two-constant
  481:     Create ( w1 w2 "name" -- )
  482:         2,
  483:     DOES> ( -- w1 w2 )
  484:         2@ ;
  485: 
  486: : (Field)  Header reveal dofield: cfa, ;
  487: 
  488: \ \ interpret/compile:
  489: 
  490: struct
  491:     >body
  492:     cell% field interpret/compile-int
  493:     cell% field interpret/compile-comp
  494: end-struct interpret/compile-struct
  495: 
  496: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
  497:     Create immediate swap A, A,
  498: DOES>
  499:     abort" executed primary cfa of an interpret/compile: word" ;
  500: \    state @ IF  cell+  THEN  perform ;
  501: 
  502: \ IS Defer What's Defers TO                            24feb93py
  503: 
  504: defer defer-default ( -- )
  505: ' abort is defer-default
  506: \ default action for deferred words (overridden by a warning later)
  507:     
  508: : Defer ( "name" -- ) \ gforth
  509: \G Define a deferred word @i{name}; its execution semantics can be
  510: \G set with @code{defer!} or @code{is} (and they have to, before first
  511: \G executing @i{name}.
  512:     Header Reveal dodefer: cfa,
  513:     ['] defer-default A, ;
  514: 
  515: : defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
  516: \G @i{xt} represents the word currently associated with the deferred
  517: \G word @i{xt-deferred}.
  518:     >body @ ;
  519: 
  520: : Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
  521:     \G Compiles the present contents of the deferred word @i{name}
  522:     \G into the current definition.  I.e., this produces static
  523:     \G binding as if @i{name} was not deferred.
  524:     ' defer@ compile, ; immediate
  525: 
  526: : does>-like ( xt -- )
  527:     \ xt ( addr -- ) is !does or !;abi-code etc, addr is the address
  528:     \ that should be stored right after the code address.
  529:     >r ;-hook ?struc
  530:     exit-like
  531:     here [ has? peephole [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] cells +
  532:     postpone aliteral r> compile, [compile] exit
  533:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  534:     defstart ;
  535: 
  536: :noname
  537:     here !does ]
  538:     defstart :-hook ;
  539: :noname
  540:     ['] !does does>-like :-hook ;
  541: interpret/compile: DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core        does
  542: 
  543: : defer! ( xt xt-deferred -- ) \ gforth  defer-store
  544: \G Changes the @code{defer}red word @var{xt-deferred} to execute @var{xt}.
  545:     >body ! ;
  546:     
  547: : <IS> ( "name" xt -- ) \ gforth
  548:     \g Changes the @code{defer}red word @var{name} to execute @var{xt}.
  549:     record-name ' defer! ;
  550: 
  551: : [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
  552:     \g At run-time, changes the @code{defer}red word @var{name} to
  553:     \g execute @var{xt}.
  554:     record-name ' postpone ALiteral postpone defer! ; immediate restrict
  555: 
  556: ' <IS>
  557: ' [IS]
  558: interpret/compile: IS ( compilation/interpretation "name-deferred" -- ; run-time xt -- ) \ gforth
  559: \G Changes the @code{defer}red word @var{name} to execute @var{xt}.
  560: \G Its compilation semantics parses at compile time.
  561: 
  562: ' <IS>
  563: ' [IS]
  564: interpret/compile: TO ( w "name" -- ) \ core-ext
  565: 
  566: : interpret/compile? ( xt -- flag )
  567:     >does-code ['] DOES> >does-code = ;
  568: 
  569: \ \ : ;                                                  	24feb93py
  570: 
  571: defer :-hook ( sys1 -- sys2 )
  572: defer free-old-local-names ( -- )
  573: defer ;-hook ( sys2 -- sys1 )
  574: 
  575: 0 Constant defstart
  576: 
  577: : (:noname) ( -- colon-sys )
  578:     \ common factor of : and :noname
  579:     docol: cfa,
  580:     defstart ] :-hook ;
  581: 
  582: : : ( "name" -- colon-sys ) \ core	colon
  583:     free-old-local-names
  584:     Header (:noname) ;
  585: 
  586: : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
  587:     0 last !
  588:     cfalign here (:noname) ;
  589: 
  590: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
  591:     ;-hook ?struc [compile] exit
  592:     [ has? peephole [IF] ] finish-code [ [THEN] ]
  593:     reveal postpone [ ; immediate restrict
  594: 
  595: \ \ Search list handling: reveal words, recursive		23feb93py
  596: 
  597: : last?   ( -- false / nfa nfa )
  598:     latest ?dup ;
  599: 
  600: Variable warnings ( -- addr ) \ gforth
  601: G -1 warnings T !
  602: 
  603: : (reveal) ( nt wid -- )
  604:     wordlist-id dup >r
  605:     @ over ( name>link ) ! 
  606:     r> ! ;
  607: 
  608: \ make entry in wordlist-map
  609: ' (reveal) f83search reveal-method !
  610: 
  611: : check-shadow  ( addr count wid -- )
  612:     \G prints a warning if the string is already present in the wordlist
  613:     >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
  614: 	>stderr
  615: 	." redefined " name>string 2dup type
  616: 	str= 0= if
  617: 	    ."  with " type
  618: 	else
  619: 	    2drop
  620: 	then
  621: 	space space EXIT
  622:     then
  623:     2drop 2drop ;
  624: 
  625: : reveal ( -- ) \ gforth
  626:     last?
  627:     if \ the last word has a header
  628: 	dup ( name>link ) @ 1 and
  629: 	if \ it is still hidden
  630: 	    dup ( name>link ) @ 1 xor		( nt wid )
  631: 	    2dup >r name>string r> check-shadow ( nt wid )
  632: 	    dup wordlist-map @ reveal-method perform
  633: 	else
  634: 	    drop
  635: 	then
  636:     then ;
  637: 
  638: : rehash  ( wid -- )
  639:     dup wordlist-map @ rehash-method perform ;
  640: 
  641: ' reveal alias recursive ( compilation -- ; run-time -- ) \ gforth
  642: \g Make the current definition visible, enabling it to call itself
  643: \g recursively.
  644: 	immediate restrict

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