\ ========== Copyright Header Begin ========================================== \ \ Hypervisor Software File: order.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 ============================================ id: @(#)order.fth 2.13 03/12/11 09:22:49 purpose: copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved copyright: Use is subject to license terms. \ Copyright 1985-1990 Bradley Forthware \ Search order. Maintains the list of vocabularies that are \ searched while interpreting Forth code. decimal 16 equ nvocs nvocs constant #vocs \ The # of vocabularies that can be in the search path nvocs /token-t * ualloc-t user context \ vocabulary searched first tuser current \ vocabulary which gets new definitions #vocs /token * constant /context : context-bounds ( -- end start ) context /context bounds ; headerless : shuffle-down ( adr -- finished? ) \ The loop goes from the next location after adr to the end of the \ context array. context-bounds drop over /token + ?do ( adr ) \ Look for a non-null entry, replace the current entry with that one, \ and replace that one with null i get-token? if ( adr acf ) over token! i !null-token leave ( adr ) then ( adr ) /token +loop drop ; headers : clear-context ( -- ) context-bounds ?do i !null-token /token +loop ; headerless : compact-search-order ( -- ) context-bounds ?do i get-token? 0= if i shuffle-down else drop then /token +loop ; headers : (except ( voc-acf -- ) \ Remove a vocabulary from the search order context-bounds ?do dup i token@ = if i !null-token then /token +loop drop compact-search-order ; nuser prior \ used for dictionary searches : $find ( adr len -- xt +-1 | adr len 0 ) 2dup 2>r $canonical ( adr' len' ) prior off ( adr len ) false ( adr len found? ) context-bounds ?do drop i get-token? if ( adr len voc ) \ Don't search the vocabulary again if we just searched it. dup prior @ over prior ! = if ( adr len voc ) drop false ( adr len false ) else ( adr len voc ) $find-word dup ?leave ( adr len false ) then ( adr len false ) else ( adr len voc ) false ( adr len false ) then ( adr len false ) /token +loop ( adr len false | xt +-1 ) ?dup if 2r> 2drop else 2drop 2r> false then ; : find ( pstr -- pstr false | xt +-1 ) dup >r count $find dup 0= if nip nip r> swap else r> drop then ; \ The also/only vocabulary search order scheme decimal : >voc ( n -- adr ) /token * context + ; vocabulary root root definitions-t : also ( -- ) context 1 >voc #vocs 2- /token * cmove> ; : (min-search) root also re-heads also ; defer minimum-search-order ' (min-search) is minimum-search-order : forth-wordlist ( -- wid ) ['] forth ; : get-current ( -- ) current token@ ; : set-current ( -- ) current token! ; : get-order ( -- vocn .. voc1 n ) 0 0 #vocs 1- do i >voc token@ non-null? if swap 1+ then -1 +loop ; : set-order ( vocn .. voc1 n -- ) dup #vocs > abort" Too many vocabularies in requested search order" clear-context 0 ?do i >voc token! loop ; : only ( -- ) clear-context \ ['] root #vocs 1- >voc token! minimum-search-order ; : except \ vocabulary-name ( -- ) ' (except ; : seal ( -- ) ['] root (except ; : previous ( -- ) 1 >voc context #vocs 2- /token * cmove #vocs 2- >voc !null-token ; : definitions ( -- ) context token@ set-current ; : order ( -- ) ." context: " get-order 0 ?do .name loop 4 spaces ." current: " get-current .name ; : vocs ( -- ) voc-link begin another-link? while ( link ) #out @ 64 > if cr then dup voc> .name >voc-link repeat ; vocabulary forth forth definitions-t \ only forth also definitions \ : (cold-hook ( -- ) (cold-hook only forth also definitions ; \ headers chain: init ( -- ) only forth also definitions ; \ "Hidden" is a vocabulary that can be used to contain implementation words \ that shouldn't appear in the forth dictionary. It was popular before we \ had the option to compile such words headerless (and also save space). \ Headerless words made the decompiler less useful, so we added a way for \ developers to restore headerful behavior vocabulary hidden hidden definitions-t \ "Re-heads" is the vocabulary that will hold restored headers and make them \ searchable to the decompiler. It will be somewhat of a while before we \ actually use it, but we need it defined now so that we can get it into the \ search-order early on in the game. vocabulary re-heads forth definitions-t