\ ========== Copyright Header Begin ========================================== \ \ Hypervisor Software File: forward.fth \ \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. \ \ - Do no alter or remove copyright notices \ \ - Redistribution and use of this software in source and binary forms, with \ or without modification, are permitted provided that the following \ conditions are met: \ \ - Redistribution of source code must retain the above copyright notice, \ this list of conditions and the following disclaimer. \ \ - Redistribution in binary form must reproduce the above copyright notice, \ this list of conditions and the following disclaimer in the \ documentation and/or other materials provided with the distribution. \ \ Neither the name of Sun Microsystems, Inc. or the names of contributors \ may be used to endorse or promote products derived from this software \ without specific prior written permission. \ \ This software is provided "AS IS," without a warranty of any kind. \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. \ \ You acknowledge that this software is not designed, licensed or \ intended for use in the design, construction, operation or maintenance of \ any nuclear facility. \ \ ========== Copyright Header End ============================================ id: @(#)forward.fth 2.12 03/12/08 13:22:32 purpose: copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved copyright: Use is subject to license terms. \ Copyright 1985-1990 Bradley Forthware \ Metacompiler forward referencing code, target-independent only forth also meta also forth definitions \ Symbol entries in "symbols" vocabulary: \ The "first-occurrence" field is the head of a linked list \ its value is a pointer to an occurrence of this word in the \ target dictionary. Each node in the list is one 16-bit word. \ The last node contains 0. If there are no occurrences, the \ first-occurrence field contains 0. \ The "resadd" field contains the compilation address of the \ word, or 0 if the word hasn't been defined yet. \ Symbols are "does>" words, but historically hadn't been. \ It is important to keep in mind the distinction between the ACF of the \ named word as it occurs in the symbols vocabulary and as it occurs \ in the target-space. In stack diagrams, the former will be notated \ acf-s and the latter, acf-t . The notation of just-plain acf will \ be used to designate an ACF in the metacompilation host, as in what \ gets "set" in the setaction function. \ The PF of words in the symbols vocabulary consists of four fields: \ : >first-occurrence ( acf-s -- first-occurrence-add ) >body ; : >resolution ( acf-s -- resolution-add ) >first-occurrence /a-t + ; : >action ( acf-s -- action-add ) >resolution /token-t + ; : >info ( acf-s -- info-addr ) >action /token + ; \ \ Note: The order of these fields is closely linked with the sequence \ of "comma" events in the definition of $makesym : first-occurrence@ ( acf-s -- first-occurrence ) >first-occurrence rlink-t@ ; : first-occurrence! ( first-occurrence acf-s -- ) >first-occurrence rlink-t! ; : resolution@ ( acf-s -- resolution ) >resolution token-t@ ; : resolution! ( resolution acf-s -- ) >resolution token-t! ; : action@ ( acf-s -- acf ) >action token@ ; : action! ( acf acf-s -- ) >action token! ; : info@ ( acf-s -- info ) >info c@ ; : info! ( info acf-s -- ) >info c! ; \ Add a new occurrence of word to the linked-list of occurrences. \ The "first-occurrence" field is the head of the list. If the list \ is empty, it contains 0. If the list isn't empty, it contains the \ non-relocated target address of the most-recent \ occurrence of the word. That location, in turn, points to the \ previous occurrence. The last one in the list contains 0. : addlink ( acf-s -- ) here-t over first-occurrence@ ( acf-s occurrence old-first-link ) over rlink!-t ( acf-s occurrence ) \ link old list to occurrence swap first-occurrence! ( ) \ link occurrence to head-of-list-node /token-t allot-t ; variable lastacf-s variable lastanf-s \ Establish the action to be performed by the most recently \ defined symbol when it is the target of "is" : setaction ( acf -- ) lastacf-s @ action! ; \ Perform the established action when the target-word \ is the target of "is" : do-action ( ??? acf-s -- ) action@ execute ; \ The default action of a newly-defined symbol (until it's over-written) : isunknown ( n??? -- ) drop ." Unknown `is' action." cr ; : $makesym ( adr len -- acf-s ) \ makes a new symbol entry ['] symbols $vcreate here body> \ leave acf-s for downstream code 0 a-t, \ initialize first-occurrence 0 token-t, \ initialize resolution ['] isunknown token, \ initialize action 0 c, \ info ( headers/headerless & immediate ) does> \ When a target symbol executes, it compiles itself into the \ target dictionary by adding a reference to itself to the list. body> ( acf ) dup immediate? if .name ." is immediate in the target system but it" cr ." is not defined in the metacompiler." cr abort else addlink then ; : makesym ( str -- acf-s ) count $makesym ; \ makes a new symbol entry : resolved? ( acf-s -- flag ) \ true if already resolved resolution@ origin-t u> ; \ Words to manipulate the symbol table vocabulary at the end of compilation. : .x ( -- ) depth 30 u< if push-hex .s pop-base else ." Underflow" then ; \ Is there another entry in this list of occurrences? : another-occurrence? ( current-occurrence -- [ current-occurrence ] flag ) dup origin-t u> if true else drop false then ; \ resolve is used to replace all the references chained to \ its argument acf-s with the associated referent variable debugflag debugflag off : resolve ( acf-s -- ) \ replace all links with the resolution dup resolution@ >r ( ) ( R: resol'n ) first-occurrence@ ( first-occ ) \ If there are no occurrences, \ the resolution is just put in \ the "first-occurrence" field, \ which doesn't hurt anything begin another-occurrence? while \ first grab link to next occurrence before clobbering it dup rlink@-t ( current-occ next-occ ) ( R: resol'n ) \ put the resolution value in the current-occ. r@ rot token!-t ( next-occurrence ) ( R: resol'n ) repeat r> drop ; \ Print the addresses of all the places where this word is used : where-used ( acf-s -- ) first-occurrence@ ( first-occurrence ) begin another-occurrence? while dup u. token@-t repeat ; \ For each target symbol, prints the name of the word, \ its compilation address, and all the places it's used. \ Basically a cross-reference listing for the word. : show ( acf-s -- ) \ name, resolution, occurrences dup .name dup resolution@ u. where-used ; \ Find the named target symbol : n' \ name ( voc-acf -- acf ) \ CROSS [compile] "" safe-parse-word rot $vfind 0= if type ." not found" abort then ; \ Display all the target symbols : nwords ( voc-cfa -- ) follow begin another? while .id 2 spaces repeat ; : .targ-acf ( acf-t -- ) ." h# " <# u# u# u# u# u# u# u#> type ; \ Display all the symbols, with their offsets and types, along with \ the header: / headerless: indication. : nheads ( -- ) push-hex ['] symbols follow begin another? while ( anf ) dup name> ( anf acf-s ) dup resolution@ ( anf acf-s acf-t ) .targ-acf ( anf acf-s ) info@ dup 3 and ( anf info-type header-type ) over ." ( type " . ." )" case ( anf info-type ) 0 of ." header: " endof 1 of ." header: " endof 2 of ." headerless: " endof 3 of ." header: " endof endcase ( anf info-type ) swap .id ( info-type ) h# 80 and if ." immediate" then ( ) cr repeat pop-base ; \ Display only the headerless: symbols with their offsets. : nheadless ( -- ) push-hex ['] symbols follow begin another? while ( anf ) dup name> ( anf acf-s ) dup info@ ( anf acf-s info-type ) dup 3 and 2 <> if 3drop else -rot ( info-type anf acf-s ) resolution@ ( info-type anf acf-t ) .targ-acf ( info-type anf ) ." headerless: " .id ( info-type ) h# 80 and if ." immediate" then ( ) cr then repeat pop-base ; \ Display a cross-reference list : cref ( voc-cfa -- ) follow begin another? while name> cr show repeat ; \ Display undefined forward references : undef ( voc-cfa -- ) follow begin another? while dup name> resolved? 0= ( lfa f ) if .id space else drop then repeat ; \ Replace all the references with the resolution address : fixall ( voc-cfa -- ) follow begin another? while dup name> dup resolved? ( lfa acf f ) if resolve drop else drop .id ." not defined" cr then repeat ; variable warning-t \ warning for target warning-t off only forth also meta also definitions \ Finds the acf-s of the symbol whose name is str, or makes it if it \ doesn't already exist. : $findsymbol ( str -- acf-s ) $sfind 0= if $makesym then ; \ Defines a new target symbol with name str. \ If a symbol with the same name exists and has already been resolved, \ a new one is created and a warning message is printed. \ If a symbol of the same name exists but is unresolved (a forward reference), \ a new one is not created. : $create-s ( str -- acf-s ) 2dup $findsymbol ( str acf-s ) dup resolved? if ( str acf-s ) drop ( str ) warning-t @ if ( str ) where 2dup type ." isn't unique in target" cr then $makesym ( acf-s ) else nip nip ( acf-s ) then ( acf-s ) dup lastacf-s ! >name lastanf-s ! ; \ Set the precedence bit on the most-recently-resolved symbol. \ We can't do this with immediate-h because the symbol we need to make \ immediate isn't necessarily the last one for which a header was \ created. It could have been a forward reference, with the header \ created long ago. : immediate-s ( -- ) lastanf-s @ n>flags h# 40 toggle \ fix symbol table lastacf-s @ dup info@ h# 80 or swap info! ; \ hide-t temporarily prevents the most-recently-created word from being \ found. It is used when creating a colon definition, so that a colon \ definition may refer to a previous word with the same name as itself, \ without resulting in recursion. \ \ reveal-t is the inverse of hide-t, allowing the most-recently-created \ word to be found again. \ \ In the normal Forth kernel, hide is implemented by unhooking the most \ recent word from the dictionary. That implementation doesn't work in \ the metacompiler, because due to forward referencing, the current colon \ definition is not necessarily the most-recently-created symbol. \ Instead, we use a technique similar to the old FIG-Forth "smudge", where \ the name is altered to make it unrecognizable. "Smudge" was a toggle, \ which suffered from the problem that sometimes "smudge" would inadvertantly \ be executed one too many times, thus leaving the word hidden when it \ should have been visible. To eliminate this, we use separate words \ hide and reveal. : hide-t ( -- ) lastanf-s @ name>string xref-hide-hook drop dup c@ h# 80 or swap c! ; : reveal-t ( -- ) lastanf-s @ name>string ( str,len ) over dup c@ h# 80 invert and swap c! ( str,len ) xref-reveal-hook 2drop ( ) ; : .lastname ( -- ) \ This hack gets around the fact that symbol headers are "smudged" lastanf-s @ ?dup if name>string h# 1f and bounds ?do i c@ h# 7f and emit loop then ; \ compile,-t takes an acf-s and compiles it into \ the current definition in the target-space. : compile,-t ( acf-s -- ) addlink ; \ $compile-t takes a string and compiles a reference to that word in the \ target dictionary. In the case of a forward reference, this may \ involve creating an entry in the symbol vocabulary. Even if the \ word has already been defined, we don't emplace the compilation address \ yet. Instead, we just add this location to a linked list of references \ to the word. For what it's worth, this makes generating a \ cross-reference list easy at the end of the metacompilation. : $compile-t ( adr len -- ) $findsymbol ( acf-s ) addlink ; \ compile-t is used inside a definition. It takes an in-line string \ argument and stores the string somewhere in the definition. When the \ definition executes, that string is $compile-t'd. This allows \ immediate words to compile run-time words, even if the run-time \ word hasn't yet been defined in the target system. \ example : foo compile-t bar ; \ when foo executes, it will then search for the word bar and \ compile a reference to it. The STRING bar is stored within foo : compile-t \ name ( -- ) [compile] [""] compile count compile $compile-t ; immediate