[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / compiler.fth

\ ========== 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 
\    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 ============================================
\ compiler.fth 2.22 01/05/18
\ Copyright 1985-1994 Bradley Forthware
\ Copyright 1994-2001 Sun Microsystems, Inc.  All Rights Reserved.

hex

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 @  ;

fffffffc value limit
: unused  ( -- #bytes )  limit here -  ;

defer allot-error
: allot  (s n -- )
   dup pad + d# 100 + limit  u>  if  allot-error  then
   dup  dp +!   ( n )
   dup 0<  if	\ Clear relocation bitmap if alloting a negative amount
      here swap negate clear-relocation-bits
   else
      drop
   then
;

[ifdef] run-time

:-h immediate ( -- )
\ 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
   \ created long ago.
   lastacf-s @ >flags  th 40 toggle        \ fix symbol table
;-h

: allot-abort  (s size -- size )
   ." Dictionary overflow - here "  here .  ." limit " limit .  cr
   ( -8 ) abort
;

[else]

: allot-abort  (s size -- size )
   ." Dictionary overflow - here "  here .  ." limit " limit .  cr
   ( -8 ) abort
;

[then]

' 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" ;

[ifndef] run-time

\ 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  ;
: literal     (s n -- )
\t16   dup -1  h# fffe  between  if
\t16      compile (wlit) 1+ w,
\t16   else
\t16      compile  (lit)  ,
\t16   then

64\ \t32   dup -1 h# 0.ffff.fffe n->l between  if
64\ \t32      compile (llit) 1+ l,
64\ \t32   else
    \t32      compile (lit) ,
64\ \t32   then
;  immediate
: 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"
;
: char  \ char (s -- n )
   safe-parse-word drop c@
;
: [char]  \ char  (s -- )
   char  1 do-literal
; immediate
: ascii  \ char (s -- n )
   char  1 do-literal
; immediate
: control  \ char  (s -- n )
   char  bl 1- and  1 do-literal
; immediate

: '   \ name  (s -- cfa )
   'i drop
;
: [']  \ name  (s -- )  ( Run time: -- acf )
   +level ' compile (') compile, -level
; immediate
: [compile]  \ name  (s -- )
   ' compile,
; immediate
: postpone  \ name  (s -- )
   'i  0<  if  compile compile  then  compile,
; immediate

: recurse  (s -- )  lastacf compile,  ; immediate

\ : dumpx  \ name  (s -- )
\   blword 10 dump
\ ;

: abort"  \ string"  (s -- )
   +level  compile (abort")  ,"  -level
; immediate

[then]

\ Control Structures

decimal
headerless
nuser saved-dp
nuser saved-limit
nuser level
headers
[ifdef] run-time
: +level  ( -- )  ;
: -level  ( -- )  ;
[else]
headerless
h# 400 /token-t * constant /compile-buffer
nuser 'compile-buffer
: compile-buffer  ( -- adr )  'compile-buffer @  ;

chain: init  ( -- )
   level off   /compile-buffer alloc-mem 'compile-buffer !
;
: reset-dp  ( -- )  saved-dp @ dp !  saved-limit @ is limit  ;

headers
: 0level  ( -- )  level @  if  level off  reset-dp  then  ;

: +level  ( -- )
   level @  if
      1 level +!
   else
      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
	 ]
      then
   then
;
: -level  ( -- )
   state @ 0= ( -22 ) abort" Control structure mismatch"
   level @  if
      -1 level +!
      level @ 0=  if
         \ If back to level 0, execute the temporary definition
         compile unnest  reset-dp
         [compile] [  compile-buffer >ip
      then
   then
;
[then]

headerless
: +>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  ;
headers

: but      ( m1 m2 -- m2 m1 )  swap  ;
: yet      ( m -- m m )  dup  ;
: 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

[ifnexist] >user
: >user  (s pfa -- addr-of-user-var )
\t32 l@
\t16 w@
   up@ +
;
[then]

: user#,  ( #bytes -- user-var-adr )
   here swap ualloc
\t32   l,
\t16   w,
   >user
;

[ifndef] run-time
: .id     (s anf -- )  name>string type space  ;
: .name   (s acf -- )  >name .id  ;
[then]

nuser warning      \ control of warning messages
-1       is warning

[ifndef] run-time

\ Dr. Charles Eaker's case statement
\ Example of use:
\ : foo ( selector -- )
\   case
\     0  of  ." It was 0"   endof
\     1  of  ." It was 1"   endof
\     2  of  ." It was 2"   endof
\     ( selector) ." **** It was " dup u.
\   endcase
\ ;
\ 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 ... ] -- )
   compile (endcase)
   begin  ?dup  while  ->resolve  repeat
   -level
; immediate

[then]
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: compiler.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	\ compiler.fth 2.22 01/05/18
	43	\ Copyright 1985-1994 Bradley Forthware
	44	\ Copyright 1994-2001 Sun Microsystems, Inc. All Rights Reserved.
	45
	46	hex
	47
	48	nuser state \ compilation or interpretation
	49	nuser dp \ dictionary pointer
	50
	51	\ This can't use token@ and token! because the dictionary pointer
	52	\ needs to temporarily contain odd byte offset because of c,
	53	: here (s -- addr ) dp @ ;
	54
	55	fffffffc value limit
	56	: unused ( -- #bytes ) limit here - ;
	57
	58	defer allot-error
	59	: allot (s n -- )
	60	dup pad + d# 100 + limit u> if allot-error then
	61	dup dp +! ( n )
	62	dup 0< if \ Clear relocation bitmap if alloting a negative amount
	63	here swap negate clear-relocation-bits
	64	else
65	drop
66	then
67	;
68
69	[ifdef] run-time
70
71	:-h immediate ( -- )
72	\ Don't fix the target header because there isn't one!
73	\ lastacf-t @ 1- th 40 toggle-t \ fix target header
74	\ We can't do this with immediate-h because the symbol we need to make
75	\ immediate isn't necessarily the last one for which a header was
76	\ created. It could have been a forward reference, with the header
77	\ created long ago.
78	lastacf-s @ >flags th 40 toggle \ fix symbol table
79	;-h
80
81	: allot-abort (s size -- size )
82	." Dictionary overflow - here " here . ." limit " limit . cr
83	( -8 ) abort
84	;
85
86	[else]
87
88	: allot-abort (s size -- size )
89	." Dictionary overflow - here " here . ." limit " limit . cr
90	( -8 ) abort
91	;
92
93	[then]
94
95	' allot-abort is allot-error
96
97	: , (s n -- ) here /n allot unaligned-! ;
98	: c, (s char -- ) here dup set-swap-bit /c allot c! ;
99	: w, (s w -- ) here /w allot w! ;
100	: l, (s l -- ) here /l allot unaligned-l! ;
101	64\ : x, (s x -- ) here /x allot unaligned-! ;
102	: d, (s d -- ) here 2 /n* allot unaligned-d! ;
103
104	: compile, (s cfa -- ) token, ;
105	: compile (s -- ) ip> dup ta1+ >ip token@ compile, ;
106
107	: ?pairs (s n1 n2 -- ) <> ( -22 ) abort" Control structure mismatch" ;
108
109	[ifndef] run-time
110
111	\ Compiler and state error checking
112	: ?comp (s -- ) state @ 0= ( -14 ) abort" Compilation Only " ;
113	: ?exec (s -- ) state @ ( -29 ) abort" Execution Only " ;
114
115	: $defined (s -- adr len 0 \| xt +-1 ) safe-parse-word $find ;
116	: $?missing ( +-1 \| adr len 0 -- +-1 )
117	dup 0= if drop .not-found ( -13 ) abort then
118	;
119	: 'i ( "name" -- xt +-1 ) $defined $?missing ;
120	: literal (s n -- )
121	\t16 dup -1 h# fffe between if
122	\t16 compile (wlit) 1+ w,
123	\t16 else
124	\t16 compile (lit) ,
125	\t16 then
126
127	64\ \t32 dup -1 h# 0.ffff.fffe n->l between if
128	64\ \t32 compile (llit) 1+ l,
129	64\ \t32 else
130	\t32 compile (lit) ,
131	64\ \t32 then
132	; immediate
133	: lliteral (s l -- ) [compile] literal ; immediate
134	: dliteral (s l -- ) compile (dlit) d, ; immediate
135
136	: safe-parse-word ( -- adr len )
137	parse-word dup 0= ( -16 ) abort" Unexpected end-of-line"
138	;
139	: char \ char (s -- n )
140	safe-parse-word drop c@
141	;
142	: [char] \ char (s -- )
143	char 1 do-literal
144	; immediate
145	: ascii \ char (s -- n )
146	char 1 do-literal
147	; immediate
148	: control \ char (s -- n )
149	char bl 1- and 1 do-literal
150	; immediate
151
152	: ' \ name (s -- cfa )
153	'i drop
154	;
155	: ['] \ name (s -- ) ( Run time: -- acf )
156	+level ' compile (') compile, -level
157	; immediate
158	: [compile] \ name (s -- )
159	' compile,
160	; immediate
161	: postpone \ name (s -- )
162	'i 0< if compile compile then compile,
163	; immediate
164
165	: recurse (s -- ) lastacf compile, ; immediate
166
167	\ : dumpx \ name (s -- )
168	\ blword 10 dump
169	\ ;
170
171	: abort" \ string" (s -- )
172	+level compile (abort") ," -level
173	; immediate
174
175	[then]
176
177	\ Control Structures
178
179	decimal
180	headerless
181	nuser saved-dp
182	nuser saved-limit
183	nuser level
184	headers
185	[ifdef] run-time
186	: +level ( -- ) ;
187	: -level ( -- ) ;
188	[else]
189	headerless
190	h# 400 /token-t * constant /compile-buffer
191	nuser 'compile-buffer
192	: compile-buffer ( -- adr ) 'compile-buffer @ ;
193
194	chain: init ( -- )
195	level off /compile-buffer alloc-mem 'compile-buffer !
196	;
197	: reset-dp ( -- ) saved-dp @ dp ! saved-limit @ is limit ;
198
199	headers
200	: 0level ( -- ) level @ if level off reset-dp then ;
201
202	: +level ( -- )
203	level @ if
204	1 level +!
205	else
206	state @ 0= if \ If interpreting, begin temporary compilation
207	1 level ! here saved-dp ! limit saved-limit !
208	compile-buffer dp ! compile-buffer /compile-buffer + is limit
209	]
210	then
211	then
212	;
213	: -level ( -- )
214	state @ 0= ( -22 ) abort" Control structure mismatch"
215	level @ if
216	-1 level +!
217	level @ 0= if
218	\ If back to level 0, execute the temporary definition
219	compile unnest reset-dp
220	[compile] [ compile-buffer >ip
221	then
222	then
223	;
224	[then]
225
226	headerless
227	: +>mark (s acf -- >mark ) +level compile, here 0 branch, ;
228	: +<mark (s -- <mark ) +level here ;
229	: ->resolve (s >mark -- ) here over - swap branch! -level ;
230	: -<resolve (s <mark acf -- ) compile, here - branch, -level ;
231	headers
232
233	: but ( m1 m2 -- m2 m1 ) swap ;
234	: yet ( m -- m m ) dup ;
235	: cs-pick ( mn .. m0 n -- mn .. m0 mn ) pick ;
236	: cs-roll ( mn .. m0 n -- mn-1 .. m0 mn ) roll ;
237
238	: begin ( -- <m ) +<mark ; immediate
239	: until ( <m -- ) ['] ?branch -<resolve ; immediate
240	: again ( <m -- ) ['] branch -<resolve ; immediate
241
242	: if ( -- >m ) ['] ?branch +>mark ; immediate
243	: ahead ( -- >m ) ['] branch +>mark ; immediate
244	: then ( >m -- ) ->resolve ; immediate
245
246	: repeat ( >m <m -- ) [compile] again [compile] then ; immediate
247	: else ( >m1 -- >m2 ) [compile] ahead but [compile] then ; immediate
248	: while ( <m -- >m <m ) [compile] if but ; immediate
249
250	: do ( -- >m <m ) ['] (do) +>mark +<mark ; immediate
251	: ?do ( -- >m <m ) ['] (?do) +>mark +<mark ; immediate
252	: loop ( >m <m -- ) ['] (loop) -<resolve ->resolve ; immediate
253	: +loop ( >m <m -- ) ['] (+loop) -<resolve ->resolve ; immediate
254
255	\ XXX According to ANS Forth, LEAVE and ?LEAVE no longer have to be immediate
256	: leave ( -- ) compile (leave) ; immediate
257	: ?leave ( -- ) compile (?leave) ; immediate
258
259	[ifnexist] >user
260	: >user (s pfa -- addr-of-user-var )
261	\t32 l@
262	\t16 w@
263	up@ +
264	;
265	[then]
266
267	: user#, ( #bytes -- user-var-adr )
268	here swap ualloc
269	\t32 l,
270	\t16 w,
271	>user
272	;
273
274	[ifndef] run-time
275	: .id (s anf -- ) name>string type space ;
276	: .name (s acf -- ) >name .id ;
277	[then]
278
279	nuser warning \ control of warning messages
280	-1 is warning
281
282	[ifndef] run-time
283
284	\ Dr. Charles Eaker's case statement
285	\ Example of use:
286	\ : foo ( selector -- )
287	\ case
288	\ 0 of ." It was 0" endof
289	\ 1 of ." It was 1" endof
290	\ 2 of ." It was 2" endof
291	\ ( selector) ." **** It was " dup u.
292	\ endcase
293	\ ;
294	\ The default clause is optional.
295	\ When an of clause is executed, the selector is NOT on the stack
296	\ When a default clause is executed, the selector IS on the stack.
297	\ The default clause may use the selector, but must not remove it
298	\ from the stack (it will be automatically removed just before the endcase)
299
300	\ At run time, (of) tests the top of the stack against the selector.
301	\ If they are the same, the selector is dropped and the following
302	\ forth code is executed. If they are not the same, execution continues
303	\ at the point just following the the matching ENDOF
304
305	: case ( -- 0 ) +level 0 ; immediate
306	: of ( -- >m ) ['] (of) +>mark ; immediate
307	: endof ( >m -- ) ['] (endof) +>mark but ->resolve ; immediate
308
309	: endcase ( 0 [ >m ... ] -- )
310	compile (endcase)
311	begin ?dup while ->resolve repeat
312	-level
313	; immediate
314
315	[then]