kmx git

\ ========== 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 
\    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: @(#)chains.fth 1.3 01/08/07
purpose: 
copyright: Copyright 2001 Sun Microsystems, Inc  All rights reserved

\ Provide 4 new compile methods:
\
\   chain: \ name
\	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.
\
\   tail-chain: \ name
\	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
\	code.
\
\   tail;
\	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.
\
\   overload: \ name
\	create a new routine, supressing warnings for the creation.
\	It is an error to declare a routine as 'overload'ed if it does not
\	already exist.
\	The new routine is headered or headerless depending upon the current
\	header state.
\
\
\ Usage examples:
\
\   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.
\
\   3	: xxx ." xxx" ;
\	: yyy xxx ." yyy" ;
\	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.
\
headers transient

variable chain-acf
h#  20 alloc-mem value chain-name
h# 200 alloc-mem value tail-chain-info

[ifnexist] headerless?
0 value headerless?
warning @ warning off
: headers 0 is headerless? headers ;
: headerless true is headerless? headerless ;
warning !
[then]

: (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: )
;

: chain: ( -- ) \ Name
   safe-parse-word  (headerless-chain:) (make-chain)
; immediate

: overload: ( -- ) \ Name
   safe-parse-word 2dup $find if	( str,len acf )
      drop (chain:)			( )
   else					( str,len )
      where ." Error: overload of " type  ."  not neccessary" cr
      abort				( )
   then
; immediate

[ifexist] file-name
: 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
   then
   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 )
   then						( str,len )
   2dup tail-chain-info $cat			( str,len )
   (headerless-chain:)				( )
; immediate

: tail; ( -- )  (make-chain) postpone ; 0 tail-chain-info c! ; immediate
[then]

resident headerless
openbios/openboot/obp/fm/lib/chains.fth

Commit

obp/fm/lib/chains.fth
