\ ========== 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
\ - 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
\ ========== Copyright Header End ============================================
id: @(#)forward.fth 2.12 03/12/08 13:22:32
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 "<something>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.
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
\ 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
: do-action ( ??? acf-s -- )
\ The default action of a newly-defined symbol (until it's over-written)
drop ." Unknown `is' action." cr
: $makesym ( adr len -- acf-s ) \ makes a new symbol entry
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 )
\ When a target symbol executes, it compiles itself into the
\ target dictionary by adding a reference to itself to the list.
." is immediate in the target system but it" cr
." is not defined in the metacompiler." cr abort
: makesym ( str -- acf-s ) count $makesym ; \ makes a new symbol entry
: resolved? ( acf-s -- flag ) \ true if already resolved
\ Words to manipulate the symbol table vocabulary at the end of compilation.
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 )
\ Print the addresses of all the places where this word is used
: where-used ( acf-s -- )
first-occurrence@ ( first-occurrence )
begin another-occurrence? while
\ 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 )
safe-parse-word rot $vfind 0= if type ." not found" abort then
\ Display all the target symbols
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.
['] symbols follow begin another? while ( anf )
dup resolution@ ( anf acf-s acf-t )
info@ dup 3 and ( anf info-type header-type )
2 of ." headerless: " endof
endcase ( anf info-type )
h# 80 and if ." immediate" then ( )
\ Display only the headerless: symbols with their offsets.
['] symbols follow begin another? while ( anf )
dup info@ ( anf acf-s info-type )
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 ( )
\ Display a cross-reference list
follow begin another? while name> cr show repeat
\ Display undefined forward references
follow begin another? while
dup name> resolved? 0= ( lfa f )
if .id space else drop then
\ Replace all the references with the resolution address
follow begin another? while
dup name> dup resolved? ( lfa acf f )
else drop .id ." not defined" cr then
variable warning-t \ warning for target
only forth also meta also definitions
\ Finds the acf-s of the symbol whose name is str, or makes it if it
: $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 )
where 2dup type ." isn't unique in target" cr
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
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
lastanf-s @ name>string xref-hide-hook
drop dup c@ h# 80 or swap c!
lastanf-s @ name>string ( str,len )
over dup c@ h# 80 invert and swap c! ( str,len )
xref-reveal-hook 2drop ( )
\ 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
projects / OpenSPARC-T2-SAM / blob