\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: ansio.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
\ - 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
\ ========== Copyright Header End ============================================
\ ansio.fth 1.11 05/01/04
\ Copyright 1994 FirmWorks All Rights Reserved
\ Copyright 1994-2002, 2004 Sun Microsystems, Inc. All Rights Reserved
\ Copyright Use is subject to license terms.
: allocate ( size -- adr ior ) alloc-mem dup 0= ;
\ Assumes free-mem doesn't really need the size parameter; usually true
: free ( adr -- ior ) 0 free-mem 0 ;
\ XXX check for EOF on keyboard stream
: more-input? ( -- flag ) insane off true ;
defer ?block-valid ( -- flag ) ' false is ?block-valid
: source-id ( -- fid ) 'source-id @ ;
: source-adr ( -- adr ) 'source @ ;
: source ( -- adr len ) source-adr #source @ ;
: set-source ( adr len -- ) #source ! 'source ! ;
: save-input ( -- source-adr source-len source-id >in blk 5 )
source source-id >in @ blk @ 5
: restore-input ( source-adr source-len source-id >in blk 5 -- flag )
blk ! >in ! 'source-id ! set-source
: set-input ( source-adr source-len source-id -- )
: skipwhite ( adr1 len1 -- adr2 len2 )
begin dup 0> while ( adr len )
over c@ bl > if exit then
\ Adr2 points to the delimiter or to the end of the buffer
\ Adr3 points to the character after the delimiter or to the end of the buffer
: scantowhite ( adr1 len1 -- adr1 adr2 adr3 )
over swap ( adr1 adr1 len1 )
begin dup 0> while ( adr1 adr len )
over c@ bl <= if drop dup 1+ exit then
1 /string ( adr1 adr' len' )
drop dup ( adr1 adr2 adr2 )
: skipchar ( adr1 len1 delim -- adr2 len2 )
>r ( adr1 len1 ) ( r: delim )
begin dup 0> while ( adr len )
over c@ r@ <> if ( adr len )
r> drop exit ( adr2 len2 )
\ Adr2 points to the delimiter or to the end of the buffer
\ Adr3 points to the character after the delimiter or to the end of the buffer
: scantochar ( adr1 len1 char -- adr1 adr2 adr3 )
>r ( adr1 len1 ) ( r: delim )
over swap ( adr1 adr1 len1 )
begin dup 0> while ( adr1 adr len )
over c@ r@ = if ( adr1 adr len )
r> 2drop dup 1+ exit ( adr1 adr2 adr3 )
1 /string ( adr1 adr' len' )
r> 2drop dup ( adr1 adr2 adr2 )
: parse-word ( -- adr len )
source >in @ /string over >r ( adr1 len1 ) ( r: adr1 )
scantowhite ( adr2 adr3 adr4 )
r> - >in +! ( adr2 adr3 ) ( r: )
: parse ( delim -- adr len )
source >in @ /string rot ( adr len delim )
-1 over = if ( adr len delim )
drop parse-line 2drop ( adr' len' )
over >r ( delim adr1 len1 ) ( r: adr1 )
rot scantochar ( adr1 adr2 adr3 ) ( r: adr1 )
r> - >in +! ( adr1 adr2 ) ( r: )
source >in @ /string over >r ( delim adr1 len1 ) ( r: adr1 )
rot >r r@ skipchar ( adr2 len2 ) ( r: adr1 delim )
r> scantochar ( adr2 adr3 adr4 ) ( r: adr1 )
r> - >in +! ( adr2 adr3 ) ( r: )
dup h# 255 > ( -18 ) abort" Parsed string overflow"
defer refill-line ( adr fd -- actual not-eof? error? )
: simple-refill-line ( adr fd -- actual not-eof? error? )
\ The ANS Forth standard does not mention the possibility
\ that ACCEPT might not be able to deliver any more input,
\ but in this implementation, the `keyboard' can be redirected
\ to a file via the command line, so it is indeed possible for
\ ACCEPT to have no more characters to deliver. Furthermore,
\ we also provide a "finished" flag that can be set to force an
\ exit from the interpreter loop.
/tib accept insane off ( cnt )
dup if true else more-input? then ( cnt more? )
' simple-refill-line is refill-line
blk @ if 1 blk +! ?block-valid exit then
source-id -1 = if false exit then
source-adr source-id refill-line ( adr )
swap #source ! 0 >in ! ( more? )
interactive? if \ Suppress prompt if input is redirected to a file
level @ ?dup if 1 .r else ." " then ." ] "
depth 0< if ." Stack Underflow" cr clear then
sp@ sp0 @ ps-size - u< if ." Stack Overflow" cr clear then
['] interpret catch ??cr ?dup if
\ ANS Forth sort of requires the following "clear", but it's a
\ real pain and doesn't affect programs, so we don't do it
exit-interact? until then
2r> 2r> 2r> restore-input throw
\ XXX We really should clean up any open input files here...
: (evaluate) ( adr len -- ) -1 set-input interpret ;
: evaluate ( adr len -- )
save-input 2>r 2>r 2>r ( adr len )
['] (evaluate) catch dup if nip nip then ( error# )
2r> 2r> 2r> restore-input throw ( error# )
projects / OpenSPARC-T2-SAM / blob