\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: definers.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: @(#)definers.fth 3.11 03/12/08 13:21:59
copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved
copyright: Copyright 1985-1994 Bradley Forthware
copyright: Use is subject to license terms.
\ Extensible Layer Defining Words
defer header \ Create a new word
: $create ( adr len -- ) $header create-cf ;
nuser csp \ for stack position error checking
: !csp ( -- ) sp@ csp ! ;
: ?csp ( -- ) sp@ csp @ <> ( -22 ) abort" Stack Changed " ;
: (;code) ( -- ) ip> aligned acf-aligned used ;
: (does>) ( -- ) ip> acf-aligned used ;
header code-cf !csp do-entercode
: c; ( -- ) next end-code ;
?csp compile (;code) align acf-align place-;code
[compile] [ reveal do-entercode
here aligned acf-aligned used !csp not-hidden ]
align acf-align place-does
: : ( -- ) ?exec !csp header hide ] colon-cf ;
: :noname ( -- ) ?exec !csp not-hidden ] colon-cf ;
?comp ?csp compile unnest reveal [compile] [
: recursive ( -- ) reveal ; immediate
: constant \ name ( n -- )
: user \ name ( user# -- )
: value \ name ( value -- )
header value-cf /n user#, !
\ In-dictionary variables are a leftover from the earliest FORTH
\ implementations. They have no place in a ROMable target-system
\ and we are deprecating support for them; but Just In Case you
\ ever want to restore support for them, define the command-line
\ symbol: in-dictionary-variables
[ifdef] in-dictionary-variables
: wvariable \ name ( -- )
: lvariable \ name ( -- )
: wvariable \ name ( -- )
: lvariable \ name ( -- )
\ Also known as execution vectors.
\ : foo ." Hello" ; ' foo is bar
\ Alternatively: ' foo ' bar (is
\ Since the execution of an execution vector doesn't leave around
\ information about which deferred word was used, we have to try
\ to find it by looking on the return stack
\ if the vector was EXECUTE'd, we don't know what it was. This
\ will be the case if the deferred word was interpreted from the
: crash ( -- ) \ unitialized execution vector routine
\ The following line may not always work right for token-threaded code
\ with variable-length tokens
ip@ /token - token@ \ use the return stack to see who called us
dup ['] execute = if 'word count type space else .name then
." <--deferred word not initialized" abort
\ Allocates a user area location to hold the vector
['] crash /token user#, token! \ Allocate user location
: 2constant \ name ( d# -- )
header 2constant-cf swap , ,
\ buffer: \ name ( size -- )
\ Defines a word that returns the address of a buffer of the
\ requested size. The buffer is allocated at initialization
\ time from free memory, not from the dictionary.
\ The parameter field contains three items as follows:
\ -- Location Name ( Size )
\ pfa: user# ( /user# , which is either /l )
\ ( or, in the \t16 model, /w )
\ pfa+/user#: buffer-size ( /n , which is way too large!)
\ pfa+/user#+/n: buffer-link ( /a , which is either /l )
\ ( or, in the \t16 model, /w )
\ When the buffer is defined, a single cell is allocated in user space,
\ which holds the address of the allocated block of memory.
: make-buffer ( size -- )
0 /n user#, ! ( size ) \ Cell in user space; initlz to zero.
lastacf buffer-link link!
\ Return the buffer-size field of the buffer whose PFA is on the stack
: /buffer ( buff-pfa -- size )
: init-buffer ( pfa usr-adr -- buff-adr )
>r ( apf ) ( R: usr-adr )
/buffer ( size ) ( R: usr-adr )
dup alloc-mem ( size buff-adr ) ( R: usr-adr )
tuck tuck r> ! ( buff-adr buff-adr size )
: do-buffer ( pfa -- buff-adr )
dup >user dup @ ?dup if ( apf usr-adr [ buff-adr ] )
create-cf make-buffer does> do-buffer
: buffer: \ name ( size -- )
: >buffer-link ( acf -- link-adr ) >body /user# + na1+ ;
buffer-link ( next-buffer-word )
begin another-link? while ( acf )
dup >body >user off ( acf )
>buffer-link ( prev-buffer:-acf )
chain: init ( -- ) clear-buffer:s ;