\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: crosslis.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: @(#)crosslis.fth 1.5 04/02/23
purpose: Tokenizer macros - one word expands to several FCodes
copyright: Copyright 1996-2004 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ Cross-compiler equivalents for tokenizer system
\ "All accounted for" means that, for this section, all non-primitives
\ are named (and either defined, or at least mentioned.)
\ In order to prevent multi-token macros from being accepted as
\ targets of ['] or ' (so-called "tick-targets"), we check
\ for seeming-tokens that are actually colon-definitions or
\ the like. However, some single-token macros are valid
\ The operator valid-tick-target will qualify the last definition
\ as a valid tick-target.
\ --- IEEE 1275 and ANS Forth name changes ------------------------------
\ As it happens, all the v2-compat: definitions are valid "tick-targets"
\ but this need not be necessarily so. Therefore, I am not going to
\ include the v2-compat: defining-word in the list of word-types
\ that are valid "tick-targets", nor am I going to mark these words
\ individually with the valid-tick-target operator.
\ Instead, I will make v2-compat: do the checking and mark the new words
\ appropriately. I will merely append a v-t-t comment...
v2-compat: << lshift \ v-t-t
v2-compat: >> rshift \ v-t-t
v2-compat: attribute property \ v-t-t
v2-compat: delete-attribute delete-property \ v-t-t
v2-compat: get-inherited-attribute get-inherited-property \ v-t-t
v2-compat: get-my-attribute get-my-property \ v-t-t
v2-compat: get-package-attribute get-package-property \ v-t-t
v2-compat: /c* chars \ v-t-t
v2-compat: ca1+ char+ \ v-t-t
v2-compat: /n* cells \ v-t-t
v2-compat: na1+ cell+ \ v-t-t
v2-compat: decode-2int parse-2int \ v-t-t
v2-compat: eval evaluate \ v-t-t
v2-compat: flip wbflip \ v-t-t
v2-compat: lflips lwflips \ v-t-t
v2-compat: wflips wbflips \ v-t-t
v2-compat: map-sbus map-low \ v-t-t
v2-compat: not invert \ v-t-t
v2-compat: u*x um* \ v-t-t
v2-compat: xu/mod um/mod \ v-t-t
v2-compat: version fcode-revision \ v-t-t
v2-compat: xdr+ encode+ \ v-t-t
v2-compat: xdrbytes encode-bytes \ v-t-t
v2-compat: xdrint encode-int \ v-t-t
v2-compat: xdrphys encode-phys \ v-t-t
v2-compat: xdrstring encode-string \ v-t-t
v2-compat: xdrtostring decode-string \ v-t-t
v2-compat: xdrtoint decode-int \ v-t-t
v2-compat: cmove move \ v-t-t
v2-compat: cmove> move \ v-t-t
\ --- Stack operators - All accounted for -------------------------------
\ : clear ( ??? -- ) depth 0 ?do drop loop ; not supported
\ : 4dup ( a b c d -- a b c d a b c d ) 2over 2over ; not supported
: 3dup ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ;
: 3drop ( a b c -- ) drop 2drop ;
\ --- Memory operators - All accounted for ------------------------------
\ caps-comp not supported
: blank ( addr count -- ) bl fill ;
: erase ( addr count -- ) 0 fill ;
: allot ( #bytes -- ) 0 max 0 ?do 0 c, loop ;
\ --- Arithmetic - All accounted for ------------------------------------
\ : even aligned ; not supported
\ : lobyte h# ff and ; not supported
\ : ?negate ( n1 n2 -- n1 | -n1 ) 0< if negate then ; not supported
: <<a << ; valid-tick-target
: xu>l ( ux -- ul ) drop ; valid-tick-target \ 64 -> 32
: lu>x ( ul -- ux ) 0 ; valid-tick-target \ 32 -> 64
\ --- Stack operators - All accounted for -------------------------------
: false 0 ; valid-tick-target
: true -1 ; valid-tick-target
\ --- TextInput - Only a subset is supported ----------------------------
\ ( included in main program
\ \ included in main program
\ (s included in main program
: accept ( addr len1 -- len2 ) span @ -rot expect span @ swap span ! ;
\ --- Ascii - All accounted for -----------------------------------------
\ ascii included in main program
\ control included in main program
\ : printable? ( char -- flag ) not supported
\ dup bl h# 7f within swap h# 80 h# ff between or ;
: carret d# 13 emit-number ;
: linefeed d# 10 emit-number ;
: newline d# 10 emit-number ;
\ --- Numeric Input - All accounted for ---------------------------------
\ b# included in main program
\ d# included in main program
\ h# included in main program
\ o# included in main program
\ td included in main program
\ th included in main program
: m-binary ( -- ) 2 base ! ;
: m-decimal ( -- ) d# 10 emit-number base ! ;
: m-hex ( -- ) d# 16 emit-number base ! ;
: m-octal ( -- ) 8 emit-number base ! ;
\ --- Numeric Output - All accounted for --------------------------------
: (.) ( n -- addr len ) dup abs n->l <# u#s swap sign u#> ;
: (.d) ( n -- addr len ) base @ swap m-decimal (.) rot base ! ;
: (.h) ( n -- addr len ) base @ swap m-hex (.) rot base ! ;
: .d ( n -- ) base @ swap m-decimal . base ! ;
: .h ( n -- ) base @ swap m-hex . base ! ;
: s. ( n -- ) (.) type bl emit ;
: (u.) ( n -- addr len ) n->l <# u#s u#> ;
: .x .h ; \ Becoming obsolete
\ --- Pre IEEE-1275 use of #, #s, #> use single vs double stack value ---
\ --- General Output - All accounted for --------------------------------
\ : backspaces 0 max 0 ?do bs emit loop ; not supported
\ : beep bell emit ; not supported
\ error-output not supported
\ restore-output not supported
: spaces 0 max 0 ?do space loop ;
\ --- Formatted output - All accounted for ------------------------------
\ : ??cr ( -- ) #out @ if cr then ; not supported
\ --- Control - Most are in body of main program ------------------------
\ : perform @ execute ; not supported
\ --- Strings - Only a subset is supported ------------------------------
\ " included in main program
\ .( included in main program
\ ." included in main program
\ : lower ( addr len -- ) not supported
\ bounds ?do i dup c@ lcc swap c! loop ;
\ : upper ( addr len -- ) not supported
\ bounds ?do i dup c@ upc swap c! loop ;
\ : sindex ( addr1 len1 addr2 len2 -- n ) \ Find array1 within array2
\ >r over r> swap - ( addr1 len1 addr2 len2-len1 )
\ dup 0< if 2drop 2drop -1 else
\ -1 swap 1+ 0 do ( addr1 len1 start2 found# )
\ 2over 2over drop swap comp ( addr1 len1 start2 found# n )
\ 0= if drop i leave else swap 1+ swap then
\ loop ( addr1 len1 start2 found# )
\ : -trailing ( addr n1 -- addr n2 )
\ dup 0 do 2dup + 1- c@ bl <> ?leave 1- loop ;
\ --- 32-Bit compatibility - All accounted for --------------------------
\ 16\ included in main program not supported
\ : 16-bit abort" Not a 16-bit forth" ; not supported
\ : 32-bit ; not supported
\ : l+! +! ; not supported
\ : l->w h# ffff and ; not supported
\ : l0= 0= ; not supported
\ : l2/ 2/ ; not supported
\ : l2dup 2dup ; not supported
\ : l<< << ; not supported
\ : l<<a << ; not supported
\ : l<= <= ; not supported
\ : l>= >= ; not supported
\ : l>> >> ; not supported
\ : l>>a >>a ; not supported
\ : labs abs ; not supported
\ : land and ; not supported
\ : lbetween between ; not supported
\ lconstant not supported
\ : ldrop drop ; not supported
\ : ldup dup ; not supported
\ : lmax max ; not supported
\ : lmin min ; not supported
\ : lnegate negate ; not supported
\ : ?lnegate ?negate ; not supported
\ : lnot not ; not supported
\ : lnover over ; not supported
\ : lnswap swap ; not supported
\ : lor or ; not supported
\ : lswap swap ; not supported
\ lvariable not supported
\ : lwithin within ; not supported
\ : m/mod /mod ; not supported
\ : mu/mod u/mod ; not supported
\ : n->w l->w ; not supported
\ : nlover over ; not supported
\ : nlswap swap ; not supported
\ : um/mod u/mod ; not supported
\ wvariable not supported
: wflip lwsplit swap wljoin ;
: version1? ( -- flag ) \ True if version 1.x
version h# 20000 emit-number <
: version2? ( -- flag ) \ True if version 2
version h# 20000 emit-number >=
version h# 30000 emit-number < and
: version2.0? ( -- flag ) \ True if version 2.0
h# 20000 emit-number version =
: version2.1? ( -- flag ) \ True if version 2.1
version h# 20001 emit-number =
: version2.2? ( -- flag ) \ True if version 2.2
version h# 20002 emit-number =
: version2.3? ( -- flag ) \ True if version 2.3
version h# 20003 emit-number =
: version3? ( -- flag ) \ True if version 3
version h# 30000 emit-number =
projects / OpenSPARC-T2-SAM / blob