\ ========== 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 = ( next-kept-item 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 ;