\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: compiler.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 ============================================
\ compiler.fth 2.22 01/05/18
\ Copyright 1985-1994 Bradley Forthware
\ Copyright 1994-2001 Sun Microsystems, Inc. All Rights Reserved.
nuser state \ compilation or interpretation
nuser dp \ dictionary pointer
\ This can't use token@ and token! because the dictionary pointer
\ needs to temporarily contain odd byte offset because of c,
: here (s -- addr ) dp @ ;
: unused ( -- #bytes ) limit here - ;
dup pad + d# 100 + limit u> if allot-error then
dup 0< if \ Clear relocation bitmap if alloting a negative amount
here swap negate clear-relocation-bits
\ Don't fix the target header because there isn't one!
\ lastacf-t @ 1- th 40 toggle-t \ fix target header
\ 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
lastacf-s @ >flags th 40 toggle \ fix symbol table
: allot-abort (s size -- size )
." Dictionary overflow - here " here . ." limit " limit . cr
: allot-abort (s size -- size )
." Dictionary overflow - here " here . ." limit " limit . cr
' allot-abort is allot-error
: , (s n -- ) here /n allot unaligned-! ;
: c, (s char -- ) here dup set-swap-bit /c allot c! ;
: w, (s w -- ) here /w allot w! ;
: l, (s l -- ) here /l allot unaligned-l! ;
64\ : x, (s x -- ) here /x allot unaligned-! ;
: d, (s d -- ) here 2 /n* allot unaligned-d! ;
: compile, (s cfa -- ) token, ;
: compile (s -- ) ip> dup ta1+ >ip token@ compile, ;
: ?pairs (s n1 n2 -- ) <> ( -22 ) abort" Control structure mismatch" ;
\ Compiler and state error checking
: ?comp (s -- ) state @ 0= ( -14 ) abort" Compilation Only " ;
: ?exec (s -- ) state @ ( -29 ) abort" Execution Only " ;
: $defined (s -- adr len 0 | xt +-1 ) safe-parse-word $find ;
: $?missing ( +-1 | adr len 0 -- +-1 )
dup 0= if drop .not-found ( -13 ) abort then
: 'i ( "name" -- xt +-1 ) $defined $?missing ;
\t16 dup -1 h# fffe between if
\t16 compile (wlit) 1+ w,
64\ \t32 dup -1 h# 0.ffff.fffe n->l between if
64\ \t32 compile (llit) 1+ l,
: lliteral (s l -- ) [compile] literal ; immediate
: dliteral (s l -- ) compile (dlit) d, ; immediate
: safe-parse-word ( -- adr len )
parse-word dup 0= ( -16 ) abort" Unexpected end-of-line"
: control \ char (s -- n )
char bl 1- and 1 do-literal
: ['] \ name (s -- ) ( Run time: -- acf )
+level ' compile (') compile, -level
: [compile] \ name (s -- )
: postpone \ name (s -- )
'i 0< if compile compile then compile,
: recurse (s -- ) lastacf compile, ; immediate
: abort" \ string" (s -- )
+level compile (abort") ," -level
h# 400 /token-t * constant /compile-buffer
: compile-buffer ( -- adr ) 'compile-buffer @ ;
level off /compile-buffer alloc-mem 'compile-buffer !
: reset-dp ( -- ) saved-dp @ dp ! saved-limit @ is limit ;
: 0level ( -- ) level @ if level off reset-dp then ;
state @ 0= if \ If interpreting, begin temporary compilation
1 level ! here saved-dp ! limit saved-limit !
compile-buffer dp ! compile-buffer /compile-buffer + is limit
state @ 0= ( -22 ) abort" Control structure mismatch"
\ If back to level 0, execute the temporary definition
[compile] [ compile-buffer >ip
: +>mark (s acf -- >mark ) +level compile, here 0 branch, ;
: +<mark (s -- <mark ) +level here ;
: ->resolve (s >mark -- ) here over - swap branch! -level ;
: -<resolve (s <mark acf -- ) compile, here - branch, -level ;
: but ( m1 m2 -- m2 m1 ) swap ;
: cs-pick ( mn .. m0 n -- mn .. m0 mn ) pick ;
: cs-roll ( mn .. m0 n -- mn-1 .. m0 mn ) roll ;
: begin ( -- <m ) +<mark ; immediate
: until ( <m -- ) ['] ?branch -<resolve ; immediate
: again ( <m -- ) ['] branch -<resolve ; immediate
: if ( -- >m ) ['] ?branch +>mark ; immediate
: ahead ( -- >m ) ['] branch +>mark ; immediate
: then ( >m -- ) ->resolve ; immediate
: repeat ( >m <m -- ) [compile] again [compile] then ; immediate
: else ( >m1 -- >m2 ) [compile] ahead but [compile] then ; immediate
: while ( <m -- >m <m ) [compile] if but ; immediate
: do ( -- >m <m ) ['] (do) +>mark +<mark ; immediate
: ?do ( -- >m <m ) ['] (?do) +>mark +<mark ; immediate
: loop ( >m <m -- ) ['] (loop) -<resolve ->resolve ; immediate
: +loop ( >m <m -- ) ['] (+loop) -<resolve ->resolve ; immediate
\ XXX According to ANS Forth, LEAVE and ?LEAVE no longer have to be immediate
: leave ( -- ) compile (leave) ; immediate
: ?leave ( -- ) compile (?leave) ; immediate
: >user (s pfa -- addr-of-user-var )
: user#, ( #bytes -- user-var-adr )
: .id (s anf -- ) name>string type space ;
: .name (s acf -- ) >name .id ;
nuser warning \ control of warning messages
\ Dr. Charles Eaker's case statement
\ 0 of ." It was 0" endof
\ 1 of ." It was 1" endof
\ 2 of ." It was 2" endof
\ ( selector) ." **** It was " dup u.
\ The default clause is optional.
\ When an of clause is executed, the selector is NOT on the stack
\ When a default clause is executed, the selector IS on the stack.
\ The default clause may use the selector, but must not remove it
\ from the stack (it will be automatically removed just before the endcase)
\ At run time, (of) tests the top of the stack against the selector.
\ If they are the same, the selector is dropped and the following
\ forth code is executed. If they are not the same, execution continues
\ at the point just following the the matching ENDOF
: case ( -- 0 ) +level 0 ; immediate
: of ( -- >m ) ['] (of) +>mark ; immediate
: endof ( >m -- ) ['] (endof) +>mark but ->resolve ; immediate
: endcase ( 0 [ >m ... ] -- )
begin ?dup while ->resolve repeat
projects / OpenSPARC-T2-SAM / blob