\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: chains.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: @(#)chains.fth 1.3 01/08/07
copyright: Copyright 2001 Sun Microsystems, Inc All rights reserved
\ Provide 4 new compile methods:
\ create a new headerless chain.
\ Add a call to 'name' before dropping into the new definition if it
\ exists. stand-init is an example of one such chain.
\ terminate with ';' as for a normal colon definition.
\ Note: a chained word will always be available in the forth vocabulary
\ at compile time regardless of what vocabulary it was defined under.
\ create a new headerless chain.
\ terminate with 'tail;' which will compile in a call to the previous
\ definition of 'name' before returning.
\ execute-buffer is an example of a tail-chain: where the routine
\ decides to call the previous routine *after* executing some internal
\ Part of 'tail-chain:' complete a tail-chain call.
\ It is an error to break a tail-chain by terminating without a 'tail;'
\ Detection will only happen upon the next tail-chain call.
\ create a new routine, supressing warnings for the creation.
\ It is an error to declare a routine as 'overload'ed if it does not
\ The new routine is headered or headerless depending upon the current
\ 1 chain: foo ." hello " ; \ foo1
\ chain: foo ." world" ; \ foo2
\ Executing foo will print 'hello world' because foo2 calls foo1 before
\ executing any internal code.
\ 2 tail-chain: bar ." world" tail; \ bar1
\ tail-chain: bar ." hello " tail; \ bar2
\ Executing bar will also print 'hello world' this time bar2 prints
\ " hello" and then when finished (tail;) calls bar1 which prints "world"
\ Useage of tail-chain: should be deprecated. Its easy to make mistakes
\ execute-buffer is a good use, others probably are not.
\ overload: xxx ['] xxx catch drop ;
\ yyy wants to call the raw routine xxx, but the official interface to
\ xxx is supposed to be catch protected, so xxx is intentionally
\ overloaded to pretect its callers from 'throw'.
\ However for this specific case renaming the first xxx to (xxx) would
\ have been a better choice and then no overload: is required.
\ Everything else is private DONT call it.
h# 20 alloc-mem value chain-name
h# 200 alloc-mem value tail-chain-info
: headers 0 is headerless? headers ;
: headerless true is headerless? headerless ;
: (make-chain) ( -- ) chain-acf @ ?dup if token, then chain-acf off ;
: (chain-header) ( -- ) chain-name count $header acf-align ;
: (chain:) ( str,len -- )
chain-name pack count $find 0= if 2drop false then chain-acf !
[ifndef] show-duplicates? warning @ >r warning off [then]
['] header behavior >r ['] (chain-header) is header : r> is header
[ifndef] show-duplicates? r> warning ! [then]
: (headerless-chain:) ( str,len -- )
get-current >r ['] forth set-current ( str, len) ( r: c-voc )
headerless? >r headerless (chain:) r> 0= if headers then ( ) ( r: c-voc )
r> set-current ( ) ( r: )
safe-parse-word (headerless-chain:) (make-chain)
: overload: ( -- ) \ Name
safe-parse-word 2dup $find if ( str,len acf )
where ." Error: overload of " type ." not neccessary" cr
: tail-chain: ( -- ) \ Name
safe-parse-word ( str,len )
tail-chain-info c@ if ( str,len )
tail-chain-info count type
0 tail-chain-info c! abort
source-id ?dup 0<> if ( str,len )
dup file-name tail-chain-info pack >r ( str,len id )
" :" r@ $cat file-line ( str,len id )
base @ >r decimal (.) r> base ! r@ $cat ( str,len )
" : Error: Broken tail call for " r> $cat ( str,len )
2dup tail-chain-info $cat ( str,len )
: tail; ( -- ) (make-chain) postpone ; 0 tail-chain-info c! ; immediate
projects / OpenSPARC-T2-SAM / blob