\ ========== Copyright Header Begin ========================================== \ \ Hypervisor Software File: brackif.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 ============================================ \ @(#)brackif.fth 1.8 02/05/02 \ Copyright 2001-2002 Sun Microsystems, Inc. All Rights Reserved \ Copyright Use is subject to license terms. \ \ rewrite to scan tokens properly skipping strings and comments \ \ are not forth words, they exist outside the forth environment. \ are forth words and exist in the dictionary. \ \ DO NOT POSTONE ANY OF THESE DIRECTIVES. \ \ DO NOT USE ANY OF THE INTERNAL ROUTINES, The list of useable directives is: \ \ [if], [else], [then] \ these three work much like the C pre-processor directives \ #if #else #endif. \ \ [ifdef] \ [ifndef] \ these three work much like the C pre-processor #ifdef, #ifndef \ versions, no surprise there \ \ [undef] \ Once a symbol is [undef]'d it is gone and no further directive \ will match it. \ \ [defined] \ is a little different, it returns the state of the \ on the stack suitable for using with [if]. \ an undefined symbol returns 0,0 \ a boolean symbol returns va,0 \ a symbol with a value returns va,len \ \ [set-symbol] ( data,len symb,len -- ) \ [get-symbol] ( symb,len -- data,len ) \ These both work as you would expect and all the directives \ above treat them indistinguishably from the -D command line \ form. \ \ [ifexist] \ [ifnexist] \ these both work to detect the existance of a forth word. \ \ Examples: \ \ forth -D FILENAME=foo.fth -D debug? -U slow-mode? \ \ [defined] FILENAME would return: va,7 (foo.fth), \ [defined] debug? would return: va,0 \ [defined] slow-mode? would return: 0,0 \ \ " foo.fth" " FILENAME" [set-symbol] \ is the equivalent of -D FILENAME=foo.fth on the command line. \ \ " FILENAME" [get-symbol] would return "foo.fth" \ \ 0 0 " slow-mode?" [set-symbol] \ is the equivalent of -D slow-mode? on the command line. \ \ [ifexist] dup ." YES" [then] \ would print the 'YES'. \ \ [ifndef] dup ." NO" [then] \ would print: \ do you mean [*exist]? dup \ NO \ because the forth defintion 'dup' is not the \ same as the definition. [ifexist] does not check \ the definitions. \ headerless 1 constant IF-IS-NOOP 2 constant ELSE-IS-NOOP 3 constant SKIP-TO-ELSE-THEN 4 constant SKIP-TO-THEN 5 constant SKIP-ALL create dangling-else ," Dangling [else]" create botched-else ," [then] must follow [else]" create dangling-then ," Dangling [then]" create missing-token ," missing token following [..] construct" create bad-symbol-name ," ! is not permitted in a symbol definition" variable brackif-state brackif-state off struct /n field >brackif-state /n field >brackif-else /n field >brackif-next constant /brackif variable do-brackif do-brackif off : [push-state] ( n -- ) 1 do-brackif +! brackif-state >r ( flag n ) /brackif alloc-mem tuck ( flag va n va ) >brackif-state ! ( flag va ) r@ @ over >brackif-next ! ( va ) r> ! ( ) ; : [set-state] ( state -- ) brackif-state @ ?dup if >brackif-state ! then ; : [get-state] ( -- state ) brackif-state @ ?dup if >brackif-state @ else 0 then ; : [pop-state] ( -- state ) brackif-state >r r@ @ if ( ) -1 do-brackif +! ( ) r@ @ dup >brackif-next @ ( va next ) r> ! ( va ) dup >brackif-state @ swap ( state va ) /brackif free-mem ( state ) else r> drop 0 then ; : [error] ( error -- ) ?dup if begin [pop-state] while repeat throw then ; : nprompt do-brackif @ . [get-state] case IF-IS-NOOP of ." [pending else/then] " endof SKIP-TO-ELSE-THEN of ." [skip to else/then] " endof SKIP-TO-THEN of ." [skip to then] " endof ELSE-IS-NOOP of ." [pending then] " endof SKIP-ALL of ." [skip all??] " endof dup ascii [ emit 0 .r ." ] " endcase ; \ ' nprompt is status : [skip-comment] ( c -- ) ascii \ = if postpone \ else long-comments dup @ over 2>r on postpone ( 2r> ! \ where ascii ) parse ." skipped: " type cr then ; : [skip-quoted?] ( adr,len -- adr,len,0 | true ) 2dup " "(22)" $= >r ( str len ) 2dup " .(" $= r> or >r ( str len ) 2dup " abort"(22)" $= r> or >r ( str len ) 2dup " ."(22)" $= r> or >r ( str len ) 2dup " ,"(22)" $= r> or if ( str len ) 2drop ascii " parse 2drop true ( ) else ( str len ) 2dup " :" $= if ( ) 2drop parse-word 2drop true ( true ) else ( str,len ) 2dup " [message]" $= if ( str,len ) 2drop -1 parse 2drop true ( true ) else ( str,len ) false ( str len 0 ) then ( str,len,0 | true ) then ( adr,len,0 | true ) then ( adr,len,0 | true ) ; : [continue-parse] ( adr,len -- level' ) [skip-quoted?] 0= if ( adr,len ) 2dup s" [if]" $= >r ( adr len ) 2dup s" [ifdef]" $= r> or >r ( adr len ) 2dup s" [ifndef]" $= r> or >r ( adr len ) 2dup s" [ifexist]" $= r> or >r ( adr len ) 2dup s" [ifnexist]" $= r> or if ( str len ) 2drop ( ) SKIP-ALL [push-state] ( ) else ( adr len ) 2dup s" [else]" $= if ( adr len ) 2drop ( ) [get-state] case ( ) SKIP-ALL of endof ( ) SKIP-TO-THEN of botched-else [error] endof SKIP-TO-ELSE-THEN of ELSE-IS-NOOP [set-state] endof ( ) ( ) ." [?? ELSE STATE] " nprompt cr endcase else ( adr len ) s" [then]" $= if ( ) [get-state] case ( ) SKIP-ALL of [pop-state] drop endof ( ) SKIP-TO-THEN of [pop-state] drop endof ( ) SKIP-TO-ELSE-THEN of [pop-state] drop endof ( ) ( ) ." [?? THEN STATE] " nprompt cr endcase then then ( ) then ( ) then ( ) ; : [skip-tokens] ( -- ) true begin ( flag ) [get-state] >r ( flag ) r@ 0<> IF-IS-NOOP r@ <> and ( flag f ) r> ELSE-IS-NOOP <> and ( flag f' ) over and ( flag f' ) while ( flag ) parse-word dup if ( flag str,len ) $canonical ( flag str,len ) 2dup " \" $= >r ( flag str,len ) 2dup " (" $= r> or if ( flag str,len ) drop c@ [skip-comment] ( flag ) else ( flag adr len ) [continue-parse] ( flag ) then ( flag ) else ( flag str,len ) 2drop refill 0= if ( flag ) where ." parse error" cr drop false ( flag ) then ( flag ) then ( flag ) repeat ( flag ) drop ; headers : [else] [get-state] 1 <> if dangling-else [error] then [pop-state] drop SKIP-TO-THEN [push-state] [skip-tokens] ; immediate : [if] ( -- ) if IF-IS-NOOP [push-state] else SKIP-TO-ELSE-THEN [push-state] [skip-tokens] then ; immediate : [then] ( -- ) [pop-state] dup IF-IS-NOOP <> swap ELSE-IS-NOOP <> and if dangling-then [error] then ; immediate headerless : (ifcommon) ( verify? -- str,len ) >r parse-word dup 0= if missing-token [error] then r> if over c@ ascii ! = if bad-symbol-name [error] then then ; base @ decimal \ These two will not match ANY symbol in the forth dictionary; \ they only match symbols [define]d or -D symbol to the wrapper. \ : (ndefined) ( -- str,len ) caps @ >r caps off ( ) parse-word 2dup $find if ( str,len acf ) drop where ( str,len ) ." do you mean [*exist]?, " 2dup type cr ( str,len ) else ( str,len str,len ) 2drop ( str,len ) then ( str,len ) 55 45 fsyscall ( va,len ) r> caps ! ( va,len ) ; headers : [set-symbol] ( data,len name,len -- ) true 53 45 fsyscall ; : [get-symbol] ( name,len -- data,len ) 55 45 fsyscall ; \ define a boolen symbol : [define] true (ifcommon) ( str,len ) 0 0 2swap ( 0 0 str,len ) true 53 45 fsyscall ( ) ; immediate \ takes a single arg : [undef] true (ifcommon) ( str,len ) 0 53 45 fsyscall ( ) ; immediate \ Snag the next arg from the line and return the definition status/value \ 0 0 means undefined, is the value. : [defined] false (ifcommon) [get-symbol] ; immediate : [ifdef] (ndefined) drop postpone [if] \ postpone [defined] drop postpone [if] ; immediate : [ifndef] (ndefined) = postpone [if] \ postpone [defined] = postpone [if] ; immediate hex \ These two are for scanning for defined words in the dictionary; \ they will not match any [define] symbol. \ : [ifexist] $defined nip dup 0= if nip then postpone [if] ; immediate : [ifnexist] $defined nip 0= dup if nip then postpone [if] ; immediate base !