\ ========== 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
\ - 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 ============================================
\ readline.fth 1.7 01/05/18
\ Copyright 1994 FirmWorks All Rights Reserved
\ Copyright 1994-2001 Sun Microsystems, Inc. All Rights Reserved
2 /n-t * ualloc-t user opened-filename
: 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.
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
: close-file ( fd -- ior )
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 )
: set-line-delimiter ( fd -- )
file @ >r file ! 0 0 fillbuf remaining$ $set-line-delimiter r> file !
: -pre-delimiter ( adr len -- adr' len' )
2dup + 1- c@ pre-delimiter c@ = if
: parse-line-piece ( adr len #so-far -- actual retry? )
>r 2>r ( r: #so-far adr len )
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
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 )
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.
: read-line ( adr len fd -- actual not-eof? error? )
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 )
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 )
\ There are more characters in the file buffer, so we update
\ adr len to reflect the portion of the buffer that has
dup >r /string r> ( adr' len' actual' )
repeat ( adr len actual )
nip nip true 0 ( actual true 0 )
\ 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 )
: 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@ r@ ['] fputc catch ?dup if ( x x ior )
line-delimiter c@ r> ['] fputc catch dup if ( x x ior )
\ Missing: file-status, create-file, delete-file, resize-file, rename-file
projects / OpenSPARC-T2-SAM / blob