[OpenSPARC-T2-SAM] / obp / obp / fm / lib / dispose.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: dispose.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 ============================================
\ dispose.fth 3.5 99/05/04
\ Copyright 1985-1990 Bradley Forthware

\ Transient vocabulary disposal
\
\ This file (and also headless.fth) may be compiled within 'transient'
\ in order to save space.  If this is done, however, only ONE 'dispose'
\ is possible.
\
\ Multiple 'start-module' - 'end-module' cycles are still allowed.
\ Nested modules are allowed.
\
\ dispose   ( -- )	Throw away the transient dictionary and
\	reclaim its space.  Names are saved in the 'headers' file.
\
\ start-module  ( -- )	Mark the start of a module.
\
\ end-module  ( -- )	The end of a module.  The heads of all
\	headerless words within the module are immediately tossed.

decimal

\ File output primitives
variable header:?   \ If true, output 'header:' else output 'headerless:'
: ftype  ( adr len -- )  ofd @ fputs  ;
: f.acf  ( anf acf  -- )
   " h# " ftype
   origin-  (.)   ( adr len )
   5 over - 0 ?do  ascii 0 ofd @ fputc loop  ( adr len )
   ftype
   header:? @  if  "  header: "  else  "  headerless: "  then
   ftype
;
\ : fspace  ( -- )  bl  ofd @ fputc  ;
: fcr  ( -- )  linefeed ofd @ fputc  ;

: open-headerfile  ( -- )  " headers" $append-open  ;
: close-headerfile ( -- )  fcr fcr ofd @ fclose  ;

: alias?  ( anf -- alias? )  n>flags c@  32 and  ;
: new-name>  ( anf -- acf )     \ Handles alias properly
   dup name>  swap   ( acf anf )
   alias?  if  token@  then
;

: f.immediate ( anf -- )  n>flags c@  64 and  if  "  immediate" ftype  then  ;

: f.name  ( anf acf -- )  fcr  f.acf  dup name>string ftype f.immediate  ;

: word.  ( alf -- )
   l>name      ( anf )
   dup alias?  if  dup new-name> f.name  else  drop  then
;
: ..name  ( acf -- )  \ Print acf and name
   dup >name swap  f.name
;

: buffer:.  ( acf -- )  \ buffer: pfa = user#, size, link-to-prev-buffer:
   ..name  "  ( buffer: )" ftype
;

: vocab.  ( voclink -- )  \ vocab pfa = user#, link-to-prev-vocab
   ..name   "  ( vocabulary )" ftype
;
defer link.  ( link -- )  \ Different links are printed differently

\ variable tosscount
variable showit?   showit? on
: showit  ( alf -- )
   showit? @ if
      link.
\       1 tosscount +!
\       #out @ 65 >  if  cr  2 spaces  then
   else
      drop
   then
;


defer item@  ( this-item -- next-item )
defer item!  ( data-item addr-item -- )
\ ITEMS are alf's for word (thread searches)
\ ITEMS are links for buffer: and vocab
\ ITEMS are acf's for (cold

0 value resboundary   \ Lower boundary of region to dispose
0 value tranboundary
: relink  ( first-link -- )  \ Removes transients from any linked list
   begin       ( good-link )
      \ Skip over all consecutive words in the transient vocabulary
      dup
      begin   ( prev-item this-item )
         item@  dup tranboundary >=  ( prev-item next-item tran? )
         dup if  over showit  then
      0= until       ( prev-item next-kept-item )
      \ Link the next non-transient word to the previous non-transient one
      dup rot  item!           ( next-kept-item )
      dup resboundary <        ( next-kept-item <resboundary? )
      over transtart >=   ( next-kept-item <resboundary? safe-transient? )
      or
   until   drop
;

: relink-voc  ( voc-acf -- )  \ Follow and relink threads in this vocab.
   >threads  #threads /link *  bounds  do  i relink  /link +loop
;

: .word-link ( alf1 alf2 -- alf1 alf2 )  showit? @ if  ??cr ." WL " 2dup . . then  ;
: word-link@ ( alf -- alf' )  link@ >link  ;
: word-link! ( alf1 alf2 -- ) ( .word-link ) swap link> swap link!  ;
: do-word-link    ( -- )  ['] word-link@ is item@   ['] word-link! is item!  ;

: relink-words  ( -- )
   \ showit? @  if  cr ." Words: "  then
   ['] word.    is link.   do-word-link
   voc-link  begin  another-link?   while  dup voc> relink-voc >voc-link repeat
;

: .buffer-link ( a1 a2 -- a1 a2 )  showit? @  if  ??cr ." BL " 2dup . .  then  ;
: buf-link! ( link adr -- ) ( .buffer-link ) >buffer-link link!  ;
: buf-link@ ( adr -- link )  >buffer-link link@  ;
: do-buf-link ( -- )  ['] buf-link@ is item@   ['] buf-link! is item!  ;
: relink-buffer:s  ( -- )
   \ showit? @  if  cr ." Buffer:s "  then
   ['] buffer:. is link.   do-buf-link  buffer-link link@  relink
;

: .voc-link ( a1 a2 -- a1 a2 )  showit? @  if  ??cr ." VL " 2dup . .  then  ;
: voc-link! ( link adr -- )  ( .voc-link ) >voc-link link!  ;
: voc-link@ ( adr -- link )  >voc-link link@  ;
: do-voc-link ( -- )  ['] voc-link! is item! ['] voc-link@ is item@  ;
: relink-voc-list  ( -- )
   \ showit? @  if  cr ." Vocabularies: "  then
   ['] vocab.   is link.   do-voc-link   voc-link link@  relink
;

: (cold.  ( acf -- )  \ (cold pfa = prev-(cold-cfa, content-cfa, ...
\    ."  initialization word containing: "  >body  /token +  token@  ..name
\    dup ..name  "  ( containing: " ftype
\    >body  /token +  token@  ..name  "  )" ftype
   ..name
;
: cold@  ( acf -- next-acf )  >body token@  ;
: cold!  ( next-acf acf -- )  >body token!  ;

: relink-init-chain  ( str -- )  $find  if  relink  else  2drop  then  ;
: relink-init-chains  ( -- )
   \ cr ." Initialization chains: "
   ['] (cold. is link.   ['] cold@ is item@   ['] cold! is item!
   " init"              relink-init-chain
\  " unix-init"         relink-init-chain
\  " unix-init-io"      relink-init-chain
\  " stand-init"        relink-init-chain
\  " stand-init-io"     relink-init-chain
   " (cold-hook"        relink-init-chain
;

defer relink-hook  ' noop is relink-hook

: unlink-all  ( resboundary tranboundary -- )
   is tranboundary   is resboundary
   header:? off      \ Dump using 'headerless:', not 'header:'
   resident    \ Just to be sure

   base @ >r hex
   open-headerfile
   relink-buffer:s
   relink-voc-list
   relink-init-chains
   relink-words
   relink-hook
   close-headerfile
   r> base !
   tranboundary is there
;

: dispose  ( -- )  \ Dispose transient, and save names of words tossed
\  showit? @  if  ." DISPOSING ..."  then
\    tosscount off
\ Lower res. bound is start of 'transien.fth' package
   ['] there transtart unlink-all
\    cr ." Number of headers disposed: " tosscount @ .
\    cr ." Transient start: " transtart .
\    cr ." Transient end:   " there .
\    cr
;

hex fe1f constant magic#
decimal

: start-module  ( -- here there magic# )
   here there magic#
;

: end-module  ( oldhere oldthere magic# -- )
   base @ >r decimal
   magic# <> abort" illegal stack for end-module"

   ( oldhere oldthere )

   \ ." here=" here .  ." there=" there . cr
   \ ." transtart=" transtart . ." transize=" transize . cr
   \ ." oldhere=" over .  ." oldthere=" dup .  cr

   ( oldhere oldthere ) unlink-all

   \ ??cr ." here=" here .  ." there=" there . cr
   \ ." transtart=" transtart . ." transize=" transize . cr
   \ ??cr ." EM " .s cr

   r> base !
;

"" headers _delete  drop
: start-module ;
: end-module ;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: dispose.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	\ dispose.fth 3.5 99/05/04
	43	\ Copyright 1985-1990 Bradley Forthware
	44
	45	\ Transient vocabulary disposal
	46	\
	47	\ This file (and also headless.fth) may be compiled within 'transient'
	48	\ in order to save space. If this is done, however, only ONE 'dispose'
	49	\ is possible.
	50	\
	51	\ Multiple 'start-module' - 'end-module' cycles are still allowed.
	52	\ Nested modules are allowed.
	53	\
	54	\ dispose ( -- ) Throw away the transient dictionary and
	55	\ reclaim its space. Names are saved in the 'headers' file.
	56	\
	57	\ start-module ( -- ) Mark the start of a module.
	58	\
	59	\ end-module ( -- ) The end of a module. The heads of all
	60	\ headerless words within the module are immediately tossed.
	61
	62	decimal
	63
	64	\ File output primitives
65	variable header:? \ If true, output 'header:' else output 'headerless:'
66	: ftype ( adr len -- ) ofd @ fputs ;
67	: f.acf ( anf acf -- )
68	" h# " ftype
69	origin- (.) ( adr len )
70	5 over - 0 ?do ascii 0 ofd @ fputc loop ( adr len )
71	ftype
72	header:? @ if " header: " else " headerless: " then
73	ftype
74	;
75	\ : fspace ( -- ) bl ofd @ fputc ;
76	: fcr ( -- ) linefeed ofd @ fputc ;
77
78	: open-headerfile ( -- ) " headers" $append-open ;
79	: close-headerfile ( -- ) fcr fcr ofd @ fclose ;
80
81	: alias? ( anf -- alias? ) n>flags c@ 32 and ;
82	: new-name> ( anf -- acf ) \ Handles alias properly
83	dup name> swap ( acf anf )
84	alias? if token@ then
85	;
86
87	: f.immediate ( anf -- ) n>flags c@ 64 and if " immediate" ftype then ;
88
89	: f.name ( anf acf -- ) fcr f.acf dup name>string ftype f.immediate ;
90
91	: word. ( alf -- )
92	l>name ( anf )
93	dup alias? if dup new-name> f.name else drop then
94	;
95	: ..name ( acf -- ) \ Print acf and name
96	dup >name swap f.name
97	;
98
99	: buffer:. ( acf -- ) \ buffer: pfa = user#, size, link-to-prev-buffer:
100	..name " ( buffer: )" ftype
101	;
102
103	: vocab. ( voclink -- ) \ vocab pfa = user#, link-to-prev-vocab
104	..name " ( vocabulary )" ftype
105	;
106	defer link. ( link -- ) \ Different links are printed differently
107
108	\ variable tosscount
109	variable showit? showit? on
110	: showit ( alf -- )
111	showit? @ if
112	link.
113	\ 1 tosscount +!
114	\ #out @ 65 > if cr 2 spaces then
115	else
116	drop
117	then
118	;
119
120
121	defer item@ ( this-item -- next-item )
122	defer item! ( data-item addr-item -- )
123	\ ITEMS are alf's for word (thread searches)
124	\ ITEMS are links for buffer: and vocab
125	\ ITEMS are acf's for (cold
126
127	0 value resboundary \ Lower boundary of region to dispose
128	0 value tranboundary
129	: relink ( first-link -- ) \ Removes transients from any linked list
130	begin ( good-link )
131	\ Skip over all consecutive words in the transient vocabulary
132	dup
133	begin ( prev-item this-item )
134	item@ dup tranboundary >= ( prev-item next-item tran? )
135	dup if over showit then
136	0= until ( prev-item next-kept-item )
137	\ Link the next non-transient word to the previous non-transient one
138	dup rot item! ( next-kept-item )
139	dup resboundary < ( next-kept-item <resboundary? )
140	over transtart >= ( next-kept-item <resboundary? safe-transient? )
141	or
142	until drop
143	;
144
145	: relink-voc ( voc-acf -- ) \ Follow and relink threads in this vocab.
146	>threads #threads /link * bounds do i relink /link +loop
147	;
148
149	: .word-link ( alf1 alf2 -- alf1 alf2 ) showit? @ if ??cr ." WL " 2dup . . then ;
150	: word-link@ ( alf -- alf' ) link@ >link ;
151	: word-link! ( alf1 alf2 -- ) ( .word-link ) swap link> swap link! ;
152	: do-word-link ( -- ) ['] word-link@ is item@ ['] word-link! is item! ;
153
154	: relink-words ( -- )
155	\ showit? @ if cr ." Words: " then
156	['] word. is link. do-word-link
157	voc-link begin another-link? while dup voc> relink-voc >voc-link repeat
158	;
159
160	: .buffer-link ( a1 a2 -- a1 a2 ) showit? @ if ??cr ." BL " 2dup . . then ;
161	: buf-link! ( link adr -- ) ( .buffer-link ) >buffer-link link! ;
162	: buf-link@ ( adr -- link ) >buffer-link link@ ;
163	: do-buf-link ( -- ) ['] buf-link@ is item@ ['] buf-link! is item! ;
164	: relink-buffer:s ( -- )
165	\ showit? @ if cr ." Buffer:s " then
166	['] buffer:. is link. do-buf-link buffer-link link@ relink
167	;
168
169	: .voc-link ( a1 a2 -- a1 a2 ) showit? @ if ??cr ." VL " 2dup . . then ;
170	: voc-link! ( link adr -- ) ( .voc-link ) >voc-link link! ;
171	: voc-link@ ( adr -- link ) >voc-link link@ ;
172	: do-voc-link ( -- ) ['] voc-link! is item! ['] voc-link@ is item@ ;
173	: relink-voc-list ( -- )
174	\ showit? @ if cr ." Vocabularies: " then
175	['] vocab. is link. do-voc-link voc-link link@ relink
176	;
177
178	: (cold. ( acf -- ) \ (cold pfa = prev-(cold-cfa, content-cfa, ...
179	\ ." initialization word containing: " >body /token + token@ ..name
180	\ dup ..name " ( containing: " ftype
181	\ >body /token + token@ ..name " )" ftype
182	..name
183	;
184	: cold@ ( acf -- next-acf ) >body token@ ;
185	: cold! ( next-acf acf -- ) >body token! ;
186
187	: relink-init-chain ( str -- ) $find if relink else 2drop then ;
188	: relink-init-chains ( -- )
189	\ cr ." Initialization chains: "
190	['] (cold. is link. ['] cold@ is item@ ['] cold! is item!
191	" init" relink-init-chain
192	\ " unix-init" relink-init-chain
193	\ " unix-init-io" relink-init-chain
194	\ " stand-init" relink-init-chain
195	\ " stand-init-io" relink-init-chain
196	" (cold-hook" relink-init-chain
197	;
198
199	defer relink-hook ' noop is relink-hook
200
201	: unlink-all ( resboundary tranboundary -- )
202	is tranboundary is resboundary
203	header:? off \ Dump using 'headerless:', not 'header:'
204	resident \ Just to be sure
205
206	base @ >r hex
207	open-headerfile
208	relink-buffer:s
209	relink-voc-list
210	relink-init-chains
211	relink-words
212	relink-hook
213	close-headerfile
214	r> base !
215	tranboundary is there
216	;
217
218	: dispose ( -- ) \ Dispose transient, and save names of words tossed
219	\ showit? @ if ." DISPOSING ..." then
220	\ tosscount off
221	\ Lower res. bound is start of 'transien.fth' package
222	['] there transtart unlink-all
223	\ cr ." Number of headers disposed: " tosscount @ .
224	\ cr ." Transient start: " transtart .
225	\ cr ." Transient end: " there .
226	\ cr
227	;
228
229	hex fe1f constant magic#
230	decimal
231
232	: start-module ( -- here there magic# )
233	here there magic#
234	;
235
236	: end-module ( oldhere oldthere magic# -- )
237	base @ >r decimal
238	magic# <> abort" illegal stack for end-module"
239
240	( oldhere oldthere )
241
242	\ ." here=" here . ." there=" there . cr
243	\ ." transtart=" transtart . ." transize=" transize . cr
244	\ ." oldhere=" over . ." oldthere=" dup . cr
245
246	( oldhere oldthere ) unlink-all
247
248	\ ??cr ." here=" here . ." there=" there . cr
249	\ ." transtart=" transtart . ." transize=" transize . cr
250	\ ??cr ." EM " .s cr
251
252	r> base !
253	;
254
255	"" headers _delete drop
256	: start-module ;
257	: end-module ;