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

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: readline.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 ============================================
\ readline.fth 1.7 01/05/18
\ Copyright 1994 FirmWorks  All Rights Reserved
\ Copyright 1994-2001 Sun Microsystems, Inc.  All Rights Reserved

headers
0 constant r/o
1 constant w/o
2 constant r/w
4 constant bin
8 constant create-flag

headerless
2 /n-t * ualloc-t user opened-filename
headers

: open-file  ( adr len mode -- fd ior )
   >r 2dup opened-filename 2! cstrbuf pack r@ fopen   ( fd )  ( r: mode )

   \ Bail out now if the open failed
   dup  0=  if  mark-error d# -38  r> drop  exit  then

   \ But first, initialize the delimiters to the default values for the
   \ underlying operating system, in case the file is initially empty.
   newline-string  case
      1 of  c@         0        endof
      2 of  dup 1+ c@  swap c@  endof
      ( default )  linefeed carret rot
   endcase   pre-delimiter c!  line-delimiter c!

   \ If the mode is neither "w/o" nor "binary", and the file isn't
   \ being newly created, establish the line delimiter(s) by looking
   \ for the first carriage return or line feed

   dup  r@ bin create-flag or  and 0=  and  r> w/o <> and  if
      dup set-line-delimiter
   then                                           ( fd )
   0                                              ( fd ior )
;
: close-file  ( fd -- ior )
   ?dup  0=  if  0  exit  then
   dup -1 =  if  drop 0  exit  then
   ['] fclose catch  ?dup  if  nip  else  0  then
;

: left-parse-string  ( adr len delim -- tail$ head$ )
   split-string  dup if  1 /string  then  2swap
;

: remaining$  ( -- adr len )  bfcurrent @  bftop @ over -  ;

: $set-line-delimiter  ( adr len -- )
   carret split-string  dup  if           ( head-adr,len tail-adr,len )
      carret line-delimiter c!            ( head-adr,len tail-adr,len )
      1 >  if                             ( head-adr,len tail-adr )
         dup 1+ c@ linefeed  =  if        ( head-adr,len tail-adr )
            carret pre-delimiter c!       ( head-adr,len tail-adr )
            linefeed line-delimiter c!    ( head-adr,len tail-adr )
         then                             ( head-adr,len tail-adr )
      then                                ( head-adr,len tail-adr )
   else                                   ( adr,len tail-adr,0 )
      2drop  linefeed split-string  if    ( head-adr,len tail-adr )
         0 pre-delimiter c!               ( head-adr,len tail-adr )
         linefeed line-delimiter c!       ( head-adr,len tail-adr )
      then                                ( head-adr,len tail-adr )
   then                                   ( head-adr,len tail-adr )
   3drop                                  ( )
;
: set-line-delimiter  ( fd -- )
   file @ >r  file !  0 0 fillbuf  remaining$  $set-line-delimiter  r> file !
;
: -pre-delimiter  ( adr len -- adr' len' )
   pre-delimiter c@  if
      dup  if
         2dup + 1- c@  pre-delimiter c@  =  if
            1-
         then
      then
   then
;

: parse-line-piece  ( adr len #so-far -- actual retry? )
   >r  2>r  ( r: #so-far adr len )

   remaining$                          ( fbuf$ )
   line-delimiter c@ split-string      ( head$ tail$ )  ( r: # adr len )

   2swap -pre-delimiter                ( tail$ head$')  ( r: # adr len )

   dup r@  u>=  if                     ( tail$ head$ )  ( r: # adr len )
      \ The parsed line doesn't fit into the buffer, so we consume
      \ from the file buffer only the portion that we copy into the
      \ buffer.
      over r@ +  bfcurrent !           ( tail$ head$ )
      drop nip nip                     ( head-adr )  ( r: # adr len )
      2r> dup >r  move                 ( )           ( r: # len )
      2r> + false                      ( actual don't-retry )
      exit
   then                                ( tail$ head$ )  ( r: # adr len )

   \ The parsed line fits into the buffer, so we copy it all in
   tuck  2r> drop  swap  move          ( tail$ head-len )  ( r: # )
   r> +  -rot                          ( actual tail$ )

   \ Consume the parsed line from the file buffer, including the
   \ delimiter if one was found (as indicated by nonzero tail-len)
   tuck  if  1+  then  bfcurrent !     ( actual tail-len )

   \ If a delimiter was found, increment the line number the next time.
   dup if  1 (file-line) +!  then

   \ If a delimiter was found, we need not retry.
   0=                                  ( actual retry? )
;
: read-line  ( adr len fd -- actual not-eof? error? )
   file @ >r  file !
   0
   begin  >r 2dup r>  parse-line-piece  while   ( adr len actual )

      \ The end of the file buffer was reached without filling the
      \ argument buffer, so we refill the file buffer and try again.

      bftop @  ['] shortseek catch  ?dup  if  ( adr len actual x error-code )
         \ A file read error (more serious than end-of-file) occurred
         drop 2swap 2drop  false swap         ( actual false ior )
	 r> file !  exit
      then                                    ( adr len actual )
      remaining$  nip 0=  if                  ( adr len actual )

         \ Shortseek did not put any more characters into the file buffer,
         \ so we return the number of characters that were copied into the
	 \ argument buffer before shortseek was called and a flag.
         \ If no characters were copied into the argument buffer, the
         \ flag is false, indicating end-of-file

         nip  nip  dup 0<>  0                ( #copied not-eof? 0 )
         r> file !  exit
      then                                   ( adr len #copied )
      \ There are more characters in the file buffer, so we update
      \ adr len to reflect the portion of the buffer that has
      \ already been filled.
      dup >r /string r>                     ( adr' len' actual' )
   repeat                                   ( adr len actual )
   nip nip true 0                           ( actual true 0 )
   r> file !
;
\ Some more ANS Forth versions of file operations
: reposition-file  ( d.position fd -- ior )
   ['] dfseek catch  dup  if  nip nip nip  then
;
: file-size  ( fd -- d.size ior )
   ['] dfsize catch  dup if  0 0 rot  then
;
: read-file  ( adr len fd -- actual ior )
   ['] fgets catch  dup  if  >r 3drop 0 r>  then
;
: write-file  ( adr len fd -- actual ior )
   over >r  ['] fputs catch  dup  if   ( x x x ior )  ( r: len )
      r> drop  >r 3drop 0 r>           ( 0 ior )
   else                                ( ior )        ( r: len )
      r> swap                          ( len ior )
   then                                ( actual ior )
;
: flush-file  ( fd -- ior )  ['] fflush  catch  dup  if  nip  then  ;
: write-line  ( adr len fd -- ior )
   dup >r ['] fputs catch  ?dup  if  nip nip nip  r> drop exit  then  ( )
   pre-delimiter c@  if
      pre-delimiter c@  r@  ['] fputc catch  ?dup  if  ( x x ior )
         nip nip  r> drop exit
      then                                             ( )
   then
   line-delimiter c@  r>  ['] fputc catch  dup  if     ( x x ior )
      nip nip exit
   then                                                ( ior )
;
\ Missing: file-status, create-file, delete-file, resize-file, rename-file
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: readline.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	\ readline.fth 1.7 01/05/18
	43	\ Copyright 1994 FirmWorks All Rights Reserved
	44	\ Copyright 1994-2001 Sun Microsystems, Inc. All Rights Reserved
	45
	46	headers
	47	0 constant r/o
	48	1 constant w/o
	49	2 constant r/w
	50	4 constant bin
	51	8 constant create-flag
	52
	53	headerless
	54	2 /n-t * ualloc-t user opened-filename
	55	headers
	56
	57	: open-file ( adr len mode -- fd ior )
	58	>r 2dup opened-filename 2! cstrbuf pack r@ fopen ( fd ) ( r: mode )
	59
	60	\ Bail out now if the open failed
	61	dup 0= if mark-error d# -38 r> drop exit then
	62
	63	\ But first, initialize the delimiters to the default values for the
	64	\ underlying operating system, in case the file is initially empty.
65	newline-string case
66	1 of c@ 0 endof
67	2 of dup 1+ c@ swap c@ endof
68	( default ) linefeed carret rot
69	endcase pre-delimiter c! line-delimiter c!
70
71	\ If the mode is neither "w/o" nor "binary", and the file isn't
72	\ being newly created, establish the line delimiter(s) by looking
73	\ for the first carriage return or line feed
74
75	dup r@ bin create-flag or and 0= and r> w/o <> and if
76	dup set-line-delimiter
77	then ( fd )
78	0 ( fd ior )
79	;
80	: close-file ( fd -- ior )
81	?dup 0= if 0 exit then
82	dup -1 = if drop 0 exit then
83	['] fclose catch ?dup if nip else 0 then
84	;
85
86	: left-parse-string ( adr len delim -- tail$ head$ )
87	split-string dup if 1 /string then 2swap
88	;
89
90	: remaining$ ( -- adr len ) bfcurrent @ bftop @ over - ;
91
92	: $set-line-delimiter ( adr len -- )
93	carret split-string dup if ( head-adr,len tail-adr,len )
94	carret line-delimiter c! ( head-adr,len tail-adr,len )
95	1 > if ( head-adr,len tail-adr )
96	dup 1+ c@ linefeed = if ( head-adr,len tail-adr )
97	carret pre-delimiter c! ( head-adr,len tail-adr )
98	linefeed line-delimiter c! ( head-adr,len tail-adr )
99	then ( head-adr,len tail-adr )
100	then ( head-adr,len tail-adr )
101	else ( adr,len tail-adr,0 )
102	2drop linefeed split-string if ( head-adr,len tail-adr )
103	0 pre-delimiter c! ( head-adr,len tail-adr )
104	linefeed line-delimiter c! ( head-adr,len tail-adr )
105	then ( head-adr,len tail-adr )
106	then ( head-adr,len tail-adr )
107	3drop ( )
108	;
109	: set-line-delimiter ( fd -- )
110	file @ >r file ! 0 0 fillbuf remaining$ $set-line-delimiter r> file !
111	;
112	: -pre-delimiter ( adr len -- adr' len' )
113	pre-delimiter c@ if
114	dup if
115	2dup + 1- c@ pre-delimiter c@ = if
116	1-
117	then
118	then
119	then
120	;
121
122	: parse-line-piece ( adr len #so-far -- actual retry? )
123	>r 2>r ( r: #so-far adr len )
124
125	remaining$ ( fbuf$ )
126	line-delimiter c@ split-string ( head$ tail$ ) ( r: # adr len )
127
128	2swap -pre-delimiter ( tail$ head$') ( r: # adr len )
129
130	dup r@ u>= if ( tail$ head$ ) ( r: # adr len )
131	\ The parsed line doesn't fit into the buffer, so we consume
132	\ from the file buffer only the portion that we copy into the
133	\ buffer.
134	over r@ + bfcurrent ! ( tail$ head$ )
135	drop nip nip ( head-adr ) ( r: # adr len )
136	2r> dup >r move ( ) ( r: # len )
137	2r> + false ( actual don't-retry )
138	exit
139	then ( tail$ head$ ) ( r: # adr len )
140
141	\ The parsed line fits into the buffer, so we copy it all in
142	tuck 2r> drop swap move ( tail$ head-len ) ( r: # )
143	r> + -rot ( actual tail$ )
144
145	\ Consume the parsed line from the file buffer, including the
146	\ delimiter if one was found (as indicated by nonzero tail-len)
147	tuck if 1+ then bfcurrent ! ( actual tail-len )
148
149	\ If a delimiter was found, increment the line number the next time.
150	dup if 1 (file-line) +! then
151
152	\ If a delimiter was found, we need not retry.
153	0= ( actual retry? )
154	;
155	: read-line ( adr len fd -- actual not-eof? error? )
156	file @ >r file !
157	0
158	begin >r 2dup r> parse-line-piece while ( adr len actual )
159
160	\ The end of the file buffer was reached without filling the
161	\ argument buffer, so we refill the file buffer and try again.
162
163	bftop @ ['] shortseek catch ?dup if ( adr len actual x error-code )
164	\ A file read error (more serious than end-of-file) occurred
165	drop 2swap 2drop false swap ( actual false ior )
166	r> file ! exit
167	then ( adr len actual )
168	remaining$ nip 0= if ( adr len actual )
169
170	\ Shortseek did not put any more characters into the file buffer,
171	\ so we return the number of characters that were copied into the
172	\ argument buffer before shortseek was called and a flag.
173	\ If no characters were copied into the argument buffer, the
174	\ flag is false, indicating end-of-file
175
176	nip nip dup 0<> 0 ( #copied not-eof? 0 )
177	r> file ! exit
178	then ( adr len #copied )
179	\ There are more characters in the file buffer, so we update
180	\ adr len to reflect the portion of the buffer that has
181	\ already been filled.
182	dup >r /string r> ( adr' len' actual' )
183	repeat ( adr len actual )
184	nip nip true 0 ( actual true 0 )
185	r> file !
186	;
187	\ Some more ANS Forth versions of file operations
188	: reposition-file ( d.position fd -- ior )
189	['] dfseek catch dup if nip nip nip then
190	;
191	: file-size ( fd -- d.size ior )
192	['] dfsize catch dup if 0 0 rot then
193	;
194	: read-file ( adr len fd -- actual ior )
195	['] fgets catch dup if >r 3drop 0 r> then
196	;
197	: write-file ( adr len fd -- actual ior )
198	over >r ['] fputs catch dup if ( x x x ior ) ( r: len )
199	r> drop >r 3drop 0 r> ( 0 ior )
200	else ( ior ) ( r: len )
201	r> swap ( len ior )
202	then ( actual ior )
203	;
204	: flush-file ( fd -- ior ) ['] fflush catch dup if nip then ;
205	: write-line ( adr len fd -- ior )
206	dup >r ['] fputs catch ?dup if nip nip nip r> drop exit then ( )
207	pre-delimiter c@ if
208	pre-delimiter c@ r@ ['] fputc catch ?dup if ( x x ior )
209	nip nip r> drop exit
210	then ( )
211	then
212	line-delimiter c@ r> ['] fputc catch dup if ( x x ior )
213	nip nip exit
214	then ( ior )
215	;
216	\ Missing: file-status, create-file, delete-file, resize-file, rename-file