[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / ansio.fth

\ ========== 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 
\    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 ============================================
\ 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.

headers
: 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  ;

nuser insane
0 value exit-interact?

\ XXX check for EOF on keyboard stream
: more-input?  ( -- flag )  insane off  true  ;

d# 1024 constant /tib

variable blk
defer ?block-valid  ( -- flag )  ' false is ?block-valid

variable >in
variable #tib
nuser 'source-id
: source-id  ( -- fid )  'source-id @  ;

nuser 'source
nuser #source
: 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 )
   drop
   blk !  >in !  'source-id !  set-source
   false
;
: set-input  ( source-adr source-len source-id -- )
   0 0 5 restore-input drop
;
headerless
: skipwhite  ( adr1 len1 -- adr2 len2  )
   begin  dup 0>  while       ( adr len )
      over c@  bl >  if  exit  then
      1 /string
   repeat                     ( adr' 0 )
;

\ 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' )
   repeat                          ( adr1 adr2 0 )
   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 )
      then                    ( adr len )
      1 /string               ( adr' len' )
   repeat                     ( adr' 0 )
   r> drop                    ( adr2 0 )
;

\ 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 )
      then                         ( adr1 adr len )
      1 /string                    ( adr1 adr' len' )
   repeat                          ( adr1 adr2 0 )
   r> 2drop dup                    ( adr1 adr2 adr2 )
;
headers
: parse-word  ( -- adr len )
   source >in @ /string  over >r   ( adr1 len1 )  ( r: adr1 )
   skipwhite                       ( adr2 len2 )
   scantowhite                     ( adr2 adr3 adr4 )
   r> - >in +!                     ( adr2 adr3 ) ( r: )
   over -                          ( adr1 len )
;
: parse  ( delim -- adr len )
   source >in @ /string rot	   ( adr len delim )
   -1 over = if			   ( adr len delim )
      \ CRLF..
      drop parse-line 2drop	   ( adr' len' )
      dup >in +!		   ( adr' len' )
      exit			   ( adr' len' )
   else				   ( adr len delim )
      -rot			   ( delim adr len )
   then				   ( delim adr1 len1 )
   over >r			   ( delim adr1 len1 )  ( r: adr1 )
   rot scantochar                  ( adr1 adr2 adr3 )  ( r: adr1 )
   r> - >in +!                     ( adr1 adr2 ) ( r: )
   over -                          ( adr1 len )
;
: word  ( delim -- pstr )
   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: )
   over -                          ( adr1 len )
   dup h# 255 >  ( -18 ) abort" Parsed string overflow"
   'word pack                      ( pstr )
;

defer refill-line ( adr fd -- actual not-eof? error? )

: simple-refill-line ( adr fd -- actual not-eof? error? )
   drop						( adr )
   \ 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

: refill  ( -- more? )
   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? )
;

: (prompt)  ( -- )
   interactive?  if	\ Suppress prompt if input is redirected to a file
      ??cr status
      state @  if
         level @  ?dup if  1 .r  else  ."  "  then  ." ] "
      else
         (ok)
      then
      mark-output
   then
;
' (prompt) is prompt

: (interact)  ( -- )
   tib /tib 0 set-input
   [compile] [
   begin
      depth 0<  if  ." Stack Underflow" cr  clear  then
      sp@  sp0 @  ps-size -  u<  if  ." Stack Overflow" cr  clear  then
      do-prompt
   refill  while
      ['] interpret catch  ??cr  ?dup if
	 [compile] [  .error
	 \ 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
	 \ clear
      then
   exit-interact? until then
   false is exit-interact?
;
: interact  ( -- )
   save-input  2>r 2>r 2>r
   (interact)
   2r> 2r> 2r> restore-input  throw
;
: (quit)  ( -- )
   \ XXX We really should clean up any open input files here...
   reset-checkpts
   0 level !  ]
   rp0 @ rp!
   interact
   bye
;
' (quit) is quit

: (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# )
   throw
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: ansio.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	\ ansio.fth 1.11 05/01/04
	43	\ Copyright 1994 FirmWorks All Rights Reserved
	44	\ Copyright 1994-2002, 2004 Sun Microsystems, Inc. All Rights Reserved
	45	\ Copyright Use is subject to license terms.
	46
	47	headers
	48	: allocate ( size -- adr ior ) alloc-mem dup 0= ;
	49
	50	\ Assumes free-mem doesn't really need the size parameter; usually true
	51	: free ( adr -- ior ) 0 free-mem 0 ;
	52
	53	nuser insane
	54	0 value exit-interact?
	55
	56	\ XXX check for EOF on keyboard stream
	57	: more-input? ( -- flag ) insane off true ;
	58
	59	d# 1024 constant /tib
	60
	61	variable blk
	62	defer ?block-valid ( -- flag ) ' false is ?block-valid
	63
	64	variable >in
65	variable #tib
66	nuser 'source-id
67	: source-id ( -- fid ) 'source-id @ ;
68
69	nuser 'source
70	nuser #source
71	: source-adr ( -- adr ) 'source @ ;
72	: source ( -- adr len ) source-adr #source @ ;
73	: set-source ( adr len -- ) #source ! 'source ! ;
74
75	: save-input ( -- source-adr source-len source-id >in blk 5 )
76	source source-id >in @ blk @ 5
77	;
78	: restore-input ( source-adr source-len source-id >in blk 5 -- flag )
79	drop
80	blk ! >in ! 'source-id ! set-source
81	false
82	;
83	: set-input ( source-adr source-len source-id -- )
84	0 0 5 restore-input drop
85	;
86	headerless
87	: skipwhite ( adr1 len1 -- adr2 len2 )
88	begin dup 0> while ( adr len )
89	over c@ bl > if exit then
90	1 /string
91	repeat ( adr' 0 )
92	;
93
94	\ Adr2 points to the delimiter or to the end of the buffer
95	\ Adr3 points to the character after the delimiter or to the end of the buffer
96	: scantowhite ( adr1 len1 -- adr1 adr2 adr3 )
97	over swap ( adr1 adr1 len1 )
98	begin dup 0> while ( adr1 adr len )
99	over c@ bl <= if drop dup 1+ exit then
100	1 /string ( adr1 adr' len' )
101	repeat ( adr1 adr2 0 )
102	drop dup ( adr1 adr2 adr2 )
103	;
104
105	: skipchar ( adr1 len1 delim -- adr2 len2 )
106	>r ( adr1 len1 ) ( r: delim )
107	begin dup 0> while ( adr len )
108	over c@ r@ <> if ( adr len )
109	r> drop exit ( adr2 len2 )
110	then ( adr len )
111	1 /string ( adr' len' )
112	repeat ( adr' 0 )
113	r> drop ( adr2 0 )
114	;
115
116	\ Adr2 points to the delimiter or to the end of the buffer
117	\ Adr3 points to the character after the delimiter or to the end of the buffer
118	: scantochar ( adr1 len1 char -- adr1 adr2 adr3 )
119	>r ( adr1 len1 ) ( r: delim )
120	over swap ( adr1 adr1 len1 )
121	begin dup 0> while ( adr1 adr len )
122	over c@ r@ = if ( adr1 adr len )
123	r> 2drop dup 1+ exit ( adr1 adr2 adr3 )
124	then ( adr1 adr len )
125	1 /string ( adr1 adr' len' )
126	repeat ( adr1 adr2 0 )
127	r> 2drop dup ( adr1 adr2 adr2 )
128	;
129	headers
130	: parse-word ( -- adr len )
131	source >in @ /string over >r ( adr1 len1 ) ( r: adr1 )
132	skipwhite ( adr2 len2 )
133	scantowhite ( adr2 adr3 adr4 )
134	r> - >in +! ( adr2 adr3 ) ( r: )
135	over - ( adr1 len )
136	;
137	: parse ( delim -- adr len )
138	source >in @ /string rot ( adr len delim )
139	-1 over = if ( adr len delim )
140	\ CRLF..
141	drop parse-line 2drop ( adr' len' )
142	dup >in +! ( adr' len' )
143	exit ( adr' len' )
144	else ( adr len delim )
145	-rot ( delim adr len )
146	then ( delim adr1 len1 )
147	over >r ( delim adr1 len1 ) ( r: adr1 )
148	rot scantochar ( adr1 adr2 adr3 ) ( r: adr1 )
149	r> - >in +! ( adr1 adr2 ) ( r: )
150	over - ( adr1 len )
151	;
152	: word ( delim -- pstr )
153	source >in @ /string over >r ( delim adr1 len1 ) ( r: adr1 )
154	rot >r r@ skipchar ( adr2 len2 ) ( r: adr1 delim )
155	r> scantochar ( adr2 adr3 adr4 ) ( r: adr1 )
156	r> - >in +! ( adr2 adr3 ) ( r: )
157	over - ( adr1 len )
158	dup h# 255 > ( -18 ) abort" Parsed string overflow"
159	'word pack ( pstr )
160	;
161
162	defer refill-line ( adr fd -- actual not-eof? error? )
163
164	: simple-refill-line ( adr fd -- actual not-eof? error? )
165	drop ( adr )
166	\ The ANS Forth standard does not mention the possibility
167	\ that ACCEPT might not be able to deliver any more input,
168	\ but in this implementation, the `keyboard' can be redirected
169	\ to a file via the command line, so it is indeed possible for
170	\ ACCEPT to have no more characters to deliver. Furthermore,
171	\ we also provide a "finished" flag that can be set to force an
172	\ exit from the interpreter loop.
173	/tib accept insane off ( cnt )
174	dup if true else more-input? then ( cnt more? )
175	;
176	' simple-refill-line is refill-line
177
178	: refill ( -- more? )
179	blk @ if 1 blk +! ?block-valid exit then
180
181	source-id -1 = if false exit then
182	source-adr source-id refill-line ( adr )
183	swap #source ! 0 >in ! ( more? )
184	;
185
186	: (prompt) ( -- )
187	interactive? if \ Suppress prompt if input is redirected to a file
188	??cr status
189	state @ if
190	level @ ?dup if 1 .r else ." " then ." ] "
191	else
192	(ok)
193	then
194	mark-output
195	then
196	;
197	' (prompt) is prompt
198
199	: (interact) ( -- )
200	tib /tib 0 set-input
201	[compile] [
202	begin
203	depth 0< if ." Stack Underflow" cr clear then
204	sp@ sp0 @ ps-size - u< if ." Stack Overflow" cr clear then
205	do-prompt
206	refill while
207	['] interpret catch ??cr ?dup if
208	[compile] [ .error
209	\ ANS Forth sort of requires the following "clear", but it's a
210	\ real pain and doesn't affect programs, so we don't do it
211	\ clear
212	then
213	exit-interact? until then
214	false is exit-interact?
215	;
216	: interact ( -- )
217	save-input 2>r 2>r 2>r
218	(interact)
219	2r> 2r> 2r> restore-input throw
220	;
221	: (quit) ( -- )
222	\ XXX We really should clean up any open input files here...
223	reset-checkpts
224	0 level ! ]
225	rp0 @ rp!
226	interact
227	bye
228	;
229	' (quit) is quit
230
231	: (evaluate) ( adr len -- ) -1 set-input interpret ;
232
233	: evaluate ( adr len -- )
234	save-input 2>r 2>r 2>r ( adr len )
235	['] (evaluate) catch dup if nip nip then ( error# )
236	2r> 2r> 2r> restore-input throw ( error# )
237	throw
238	;