The new I/O system.
1. Shall be based on objects. 2. Shall do all input and output using addr and len.
We have to decide what we are trying to to do. Lets take a file first
S" drive/file.name" mode Sopen
Or a port perhaps.
S" ethernet/tcp-ip/06" mode Sopen
This is what I want to do, lets not get too complex.
As application program should be able to CATCH a file operation ABORT and expect the task to be in good shape. For this reason an ABORT will return buffers, remove locks and close open files as required.
The modes are bits in a 32 bit word. First we define the bits from the OS point of view from these we derive the STANDARD words.
The basic block file system assumes READ-LINE is character base as you don't know where the line ends if the OS doesn't make assumptions about character encoding. READ-FILE is binary based and no assumptions are mode. However the standard has a BIN word and who knows what use the furture may bring.
Lets be honest here. This OS uses classes it does need a lot of the bits as the object address gives the details. The mode codes fall through but I have put no effort into using them.
\ file mode bits, taken from NFS
$000001 CONSTANT _#mode_world_ex
$000002 CONSTANT _#mode_world_write
$000004 CONSTANT _#mode_world_read
$000008 CONSTANT _#mode_group_ex
$000010 CONSTANT _#mode_group_write
$000020 CONSTANT _#mode_group_read
$000040 CONSTANT _#mode_user_ex
$000080 CONSTANT _#mode_user_write
$000100 CONSTANT _#mode_user_read
$000200 CONSTANT _#mode_save_swapped
$000400 CONSTANT _#mode_group_id_ex
$000800 CONSTANT _#mode_user_id_ex
$002000 CONSTANT _#mode_char_spec
$004000 CONSTANT _#mode_dir
$006000 CONSTANT _#mode_block_spec
$008000 CONSTANT _#mode_reg_file
$00A000 CONSTANT _#mode_sym_link
$00C000 CONSTANT _#mode_socket
\ these come about because of the forth standard
$100000 CONSTANT #fl_mode_write
$080000 CONSTANT #fl_mode_extend
$040000 CONSTANT #fl_mode_create
$020000 CONSTANT #fl_mode_read_stop
$010000 CONSTANT #fl_mode_binary
: character# ( --num) 'output_file @ :character# ;
: line# ( --num) 'output_file @ :line# ;
: page# ( --num) 'output_file @ :page# ;
: page! ( num --) 'output_file @ :page! ;
: line_max ( --addr) 'output_file @ :line_max ;
: character_max ( --addr) 'output_file @ :character_max ;
FILE
( fam1 -- fam2 )
Modify the implementation-defined file access method fam1 to additionally select a binary, i.e., not line oriented, file access method, giving access method fam2.
: BIN ( fam1 -- fam2)
#fl_mode_binary OR
;
r-o FILE
( -- fam )
fam is the implementation-defined value for selecting the read only file access method.
This is the default mode.
: R/O ( --fam)
zero
;
r-w FILE
( -- fam )
fam is the implementation-defined value for selecting the read/write file access method.
: R/W ( --fam)
[ #fl_mode_write
#fl_mode_extend OR ]T LITERAL
;
w-o FILE
( -- fam )
fam is the implementation-defined value for selecting the write only file access method.
: W/O ( --fam)
[ #fl_mode_write
#fl_mode_extend OR
#fl_mode_read_stop OR ]T LITERAL
;
Scan from the left looking for the character. If found split the string at the character. The right string contains the character.
: left_split { variable %addr variable %num variable %char --
( L-addr L-len R-addr R-len ) }
%num @ zero ?DO
%addr @ I CHARS + char@ %char @ = IF
%addr @ I
%addr @ I CHARS + %num @ I -
UNLOOP
EXIT
THEN
[ 1 CHARS ]T LITERAL +LOOP
%addr @ %num @
%addr @ %num @ + zero
;
: remove_leading ( addr num char -- addr num)
\ count of zero go.
OVER not IF
DROP EXIT
THEN
jump char@ = IF
1- SWAP 1 CHARS + SWAP
THEN
;
\ generic error
CREATE $file_not_found ," file not found"
Scan from the right looking for the character. If found split the string at the charcter. the right string is left with the split character.
: right_split { variable %addr variable %num variable %char --
( L-addr L-len R-addr R-len ) }
%addr @ DUP %num @ 1 - CHARS + ?DO
I char@ %char @ = IF
%addr @ I %addr @ - bytes>chars 1 + \ L-addr l-len (--
I 1 CHARS + OVER %num @ SWAP -
UNLOOP
EXIT
THEN
[ 1 CHARS NEGATE ]T LITERAL +LOOP
%addr @ %num @
%addr @ %num @ CHARS + zero
;
]
Some types of logical units ( terminals ) can only be used with particular physical unit types.
##### are these still needed
( logical unit types)
00 CONSTANT #physical
04 CONSTANT #ether_port
21 CONSTANT #pipe
30 CONSTANT #message_type
| 40 CONSTANT #mserial
| 50 CONSTANT #sserial
| 60 CONSTANT #ilan_master
| 70 CONSTANT #ilan_slave
( Physical unit numbers)
3F CONSTANT #message_pu
3E CONSTANT #master_pipe
3D CONSTANT #message_pipe
3C CONSTANT #print_pipe
The file words set. The standard word set is far from a useful set of words so a few non standard words are found here.
: close ( object --)
DUP :parent_instance
\ :destruct object and reclaim memory
SWAP heap_object_free
\
?DUP IF
RECURSE
THEN
;
FILE
( fileid -- ior )
Close the file identified by fileid. ior is the implementation-defined I/O result code.
: CLOSE-FILE ( fileid -- ior )
['] close CATCH DUP IF
NIP
THEN
;
\ Why do we have :Sopen ?
\ -----------------------
\ You need to ba able to open a file using the file name
\ relative to root, or ralative to a directory. construct opens the
\ root directory. You may change the directory using :!file_handle
\ before calling :Sopen. In fact you can skip the :Sopen stage if desired,
\ in which case the root directory is open.
\ Why do we have :Sopen ?
\ -----------------------
\ You need to ba able to open a file using the file name
\ relative to root, or ralative to a directory. construct opens the
\ root directory. You may change the directory using :!file_handle
\ before calling :Sopen. In fact you can skip the :Sopen stage if desired,
\ in which case the root directory is open.
\ after the working directory has been added if required
: (Sopen) { ( addr num ) variable %mode -- ( object) }{
variable %root_object
variable %driver_object }
\ If the allocation of an object aborts
\ the object is not allocated
root heap_object \ addr num root_handle(--
%root_object !
\ save root name
2DUP %root_object @ :!name
\ using our provided string we now have to
\ open the driver
\ addr num(--
[CHAR] / remove_leading
[CHAR] / left_split
\ driver_addr driver_len file_addr file_data (-
2SWAP
\ file_addr file_num driver_addr driver_num (--
\ OPEN THE DEVICE
\ ---------------
~drivers SEARCH-WORDLIST not IF
%root_object @ heap_object_free
TRUE ABORT" Driver lookup failed"
THEN
EXECUTE \ a driver is a class, returns a class address
%root_object @ \ addr num class parent_object
\ create the driver object
\ if this aborts there is no object
SWAP heap_object
\ addr num driver_object(--
%driver_object !
%mode @ %driver_object @
\ note we do a close so the drivers must take care to leave
\ the structure in a valid state for destruct.
['] :Sopen CATCH ?DUP IF
\ we are closing the driver object; which will destoy itself and the root object
%driver_object @ close
$ABORT
THEN
\ file_handle(--
%driver_object @ %root_object @ :root_!device
\ if not equal a file is involved as well
DUP %driver_object @ <> IF
DUP %root_object @ :root_!file
THEN
;
\ contains the base directory, task specific
#$buffer ufree_buffer $working_directory
\ if file name starts with ./ remove . and add wd
ram_variable %open_debug
: Sopen { ( addr n ) variable %mode ( --) }
2DUP
[CHAR] / left_split
\ addr num left_addr left_num right_addr right_num(--
2DROP
\ one character and char is .
01 = SWAP char@ [CHAR] . = AND
IF
#$buffer get_buffer
\ addr n --
\ remove the .
[CHAR] / left_split 2SWAP 2DROP
\ add in working directory
$working_directory COUNT >R buffer R@ MOVE
\ c-addr u (--
TUCK
\ u c-addr u (--
%open_debug @ IF
.S
THEN
\ check that the result will fit
DUP R@ + #$buffer > ABORT" file name too long"
buffer R@ + SWAP MOVE
R> + buffer SWAP
\ add n (--
%open_debug @ IF
2DUP TYPE
THEN
%mode @
['] (Sopen) CATCH
%open_debug @ IF
." about to kill file buffer"
THEN
kill_buffer
\ if catch value is zero this will not abort
$ABORT
ELSE
%mode @ (Sopen)
THEN
;
FILE
( c-addr u fam -- fileid ior )
Open the file named in the character string specified by c-addr u, with file access method indicated by fam. The meaning of values of fam is implementation defined.
If the file is successfully opened, ior is zero, fileid is its identifier, and the file has been positioned to the start of the file.
Otherwise, ior is the implementation-defined I/O result code and fileid is undefined.
COLDFORTH The error code is the address of a string describing the error.
: OPEN-FILE ( addr num mode -- fileid ior)
['] Sopen CATCH DUP IF
\ on error have to tidy up stack
>R 2DROP DROP
zero R>
THEN
;
: $open ( $ mode --handle)
SWAP COUNT ROT Sopen
;
: open ( mode "file" --handle)
BL (word) ROT Sopen
;
\ use the left portion of string to open directory, right portion as
\ a name of a file to add to the directory.
: Smkfile { ( addr n --) }{
variable %file_handle
}
[CHAR] / right_split \ addrl nl addr nr(--
2SWAP
\ opening a directory
zero Sopen
\ addr1 n1 handle (--
%file_handle !
%file_handle @ ['] :?directory CATCH ?DUP IF
%file_handle @ close
$ABORT
THEN
not IF
%file_handle @ close
TRUE ABORT" Not a directory"
THEN
\ addr n (--
%file_handle @ ['] :make_file CATCH
?DUP IF
%file_handle @ close
$ABORT
THEN
%file_handle @ close
;
: $mkfile ( $ --)
COUNT Smkfile
;
: file ( "name" --)
BL (word) Smkfile
;
: mkfile ( "name" --)
BL (word) Smkfile
;
\ support words
\ Remove the left portion of string
\ open file as a directory ( if possible)
\ and create a directory using right portion
\ e.g.
\ /red/bill
\ make directory bill in directory red
: Smkdir { ( add n --) }{
variable %file_handle
}
[CHAR] / right_split \ addrl nl addr nr(--
2SWAP
R/W Sopen \ addrr nr handle (--
%file_handle !
%file_handle @ ['] :?directory CATCH ?DUP IF
%file_handle @ close
$ABORT
THEN
not IF
%file_handle @ close
TRUE ABORT" Not a directory"
THEN
\ :make_directory makes the files, sets the file mode to directory
\ and adds the . and .. entries
\ addr n(--
%file_handle @ DUP ['] :make_directory CATCH
?DUP IF
%file_handle @ close
$ABORT
THEN
%file_handle @ close
;
: $mkdir ( $ --)
COUNT Smkdir
;
: mkdir ( --)
BL (word) Smkdir
;
: _print_dir_name { ( cookie) variable %handle -- }{
$20 CONSTANT #column_size }
#$buffer get_buffer
buffer #$buffer %handle @ ['] :get_directory_name CATCH
?DUP IF
kill_buffer
$ABORT
THEN
\ will it fit on current line.
DUP character# + character_max @ < not IF
CR
THEN
\ print the directory name.
buffer SWAP TYPE
kill_buffer
\ move to next colume
character#
#column_size /MOD 1 + #column_size *
character_max @ < not IF
DROP CR
ELSE
#column_size SWAP - SPACES
THEN
;
\ The handle is the object_instance for the dir file.
: _dir { variable %handle -- }
\ make sure directory remains stable for listing
%handle @ :facility grab
%handle @ :first_directory_cookie
BEGIN
\ cookie(--
DUP %handle @ ['] _print_dir_name CATCH ?DUP IF
%handle @ :facility release
$ABORT
THEN
%handle @ :next_directory_cookie
not UNTIL
%handle @ :facility release
;
: Sdir { ( addr len --) }
CR
R/O Sopen \ handle (--
>R
R@ ['] :?directory CATCH ?DUP IF
R> close
$ABORT
THEN
IF
R@ ['] _dir CATCH ?DUP IF
R> close
$ABORT
THEN
R> close
EXIT
ELSE
R> close
TRUE ABORT" Not a directory"
THEN
;
: $dir ( $ --)
COUNT Sdir
;
: dir ( "string" --)
BL (word) Sdir
;
: Sformat ( addr n --)
R/W Sopen \ handle(--
>R
I :facility grab
I :number_of_links 1 <> IF
I :facility release
I close
TRUE ABORT" Files open on device, can't format"
THEN
I ['] :format CATCH
?DUP IF
I :facility release
I close
$ABORT
THEN
I :facility release
R> close
;
: $format ( $ --)
COUNT Sformat
;
: format ( "string" --)
BL (word) Sformat
;
\ use the left portion of string to open directory, right portion as
\ a name of a file to remove from directory.
: Sremove { ( addr n --) }{
variable %file_handle
}
[CHAR] / right_split \ addrl nl addr nr(--
2SWAP
R/W Sopen \ addr nr handle (--
%file_handle !
%file_handle @ ['] :?directory CATCH ?DUP IF
%file_handle @ close
$ABORT
THEN
not IF
%file_handle @ close
TRUE ABORT" Not a directory"
THEN
\ addr n (--
%file_handle @ ['] :remove_file CATCH
?DUP IF
%file_handle @ close
$ABORT
THEN
%file_handle @ close
;
: $remove ( $ --)
COUNT Sremove
;
: remove ( "name" --)
BL (word) Sremove
;
\ the unix command
: rm ( "name" -- )
remove
;
FILE
( c-addr u -- ior )
Delete the file named in the character string specified by c-addr u. ior is the implementation-defined I/O result code.
: DELETE-FILE ( c-addr u -- ior )
['] Sremove CATCH DUP IF
NIP NIP
THEN
;
FILE
( c-addr u fam -- fileid ior )
Create the file named in the character string specified by c-addr and u, and open it with file access method fam. The meaning of values of fam is implementation defined. If a file with the same name already exists, recreate it as an empty file. If the file was successfully created and opened, ior is zero, fileid is its identifier, and the file has been positioned to the start of the file. Otherwise, ior is the implementation-defined I/O result code and fileid is undefined.
: CREATE-FILE { ( c-addr u ) variable %fam -- ( fileid ior ) }
\ ignore the remove error
\ it may be the file is not there it may be other.
\ If other it will happen on Smkfile and we will exit then.
2DUP ['] Sremove CATCH IF
\ if error is caught, stack will be as on entry
2DROP
THEN
2DUP ['] Smkfile CATCH DUP IF
>R 2DROP 2DROP zero R>
EXIT
THEN
\ OPEN-FILE has already caught the abort and set a ior.
%fam @ OPEN-FILE
;
\ add the same name as unix
: rm ( "name" -- ) remove ;
\ copy file, you end up with two versions of the file
: Scopy ( addr1 n1 addr2 n2--)
2SWAP R/O Sopen \ from file
>R
2DUP ['] Smkfile CATCH \ create the to file, this will abort if file exists
?DUP IF
R> close $ABORT
THEN
R/W ['] Sopen CATCH \ handle_from handle_to(--
?DUP IF
R> close
$ABORT
THEN
R> \ handle_to handle_from
\ copy a zone at a time gives resonable performance.
DUP :bytes_a_zone get_buffer
\ handle_too handle_from(--
BEGIN
buffer OVER :bytes_a_zone jump
['] :read CATCH
?DUP IF
kill_buffer
close
close
$ABORT
THEN
\ handle_too handle_from num(--
>R
OVER buffer R@ ROT
['] :write CATCH
?DUP IF
kill_buffer
close
close
$ABORT
THEN
R> OVER :bytes_a_zone <>
UNTIL
kill_buffer
close
close
;
: $copy ( $ $ --)
COUNT ROT COUNT 2SWAP Scopy
;
: copy ( "from" "to" --)
BL WORD #$buffer get_buffer
buffer #$buffer $move
buffer \ $from(--
BL WORD \ $from $to(--
['] $copy CATCH
?DUP IF
kill_buffer
$ABORT
THEN
kill_buffer
;
\ rename file add1 n1 as addr2 n2
\ Two case:
\ 1) Same device, use the :rename method
\ 2) Different devices, copy and remove old.
\ well that is the right way to do it.
\ The quick way copy and delete the original, and as we are running
\ out of time.
: Srename ( add1 n1 addr2 n2 --)
4dup
Scopy
2DROP
Sremove
;
: $rename ( $ $ --)
COUNT ROT COUNT 2SWAP Srename
;
: rename ( "from" "to" --)
BL WORD #$buffer get_buffer
buffer #$buffer $move
buffer \ $from(--
BL WORD \ $from $to(--
['] $rename CATCH
?DUP IF
kill_buffer
$ABORT
THEN
kill_buffer
;
FILE EXT
( c-addr1 u1 c-addr2 u2 -- ior )
Rename the file named by the character string c-addr1 u1 to the name in the character string c-addr2 u2. ior is the implementation-defined I/O result code.
: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior )
['] Srename CATCH DUP IF
>R 2DROP 2DROP R>
THEN
;
Following code allows you to create a large test file. Usefull for testing.
\ create a large file with every location written with an offset value.
: Stestfile { ( addr num --) }{
variable %handle }
2DUP Smkfile
R/W Sopen \ handle(--
%handle !
%handle @ :bytes_a_zone get_buffer
$8000 0 DO
%handle @ :bytes_a_zone zero DO
J I + buffer I + !
4 +LOOP
buffer %handle @ :bytes_a_zone %handle @ ['] :write CATCH
?DUP IF
kill_buffer
%handle @ close
$ABORT
THEN
%handle @ :bytes_a_zone +LOOP
kill_buffer
%handle @ close
;
: $tesetfile ( $ --)
COUNT Stestfile
;
: testfile ( "name" --)
BL (word) Stesetfile
;
When it comes to the ansi standard the definition of characters is a mess. To do basic I/O in any other units than a byte is a problem. Yet the file words are all specified in terms of characters. It is for this reason COLDFORTH defines char@ and char! for operations that must use characters and use a 8 bit bytes as the forth standard words. For the FILE words there has to be a clarification.
READ-LINE must understand the characters being read as it must understand the line terminating character. So:
READ-FILE deals with bytes. READ-LINE deals in characters.
Be under no illusion this is not how the standard will be sorted out, it is my quess a new set of file words will be introduced.
FILE
( c-addr u1 fileid -- u2 flag ior )
Read the next line from the file specified by fileid into memory at the address c-addr. At most u1 characters are read. Up to two implementation-defined line-terminating characters may be read into memory at the end of the line, but are not included in the count u2. The line buffer provided by c-addr should be at least u1+2 characters long.
If the operation succeeded, flag is true and ior is zero. If a line terminator was received before u1 characters were read, then u2 is the number of characters, not including the line terminator, actually read (0 <= u2 <= u1). When u1 = u2, the line terminator has yet to be reached.
If the operation is initiated when the value returned by FILE-POSITION is equal to the value returned by FILE-SIZE for the file identified by fileid, flag is false, ior is zero, and u2 is zero. If ior is non-zero, an exception occurred during the operation and ior is the implementation-defined I/O result code.
An ambiguous condition exists if the operation is initiated when the value returned by FILE-POSITION is greater than the value returned by FILE-SIZE for the file identified by fileid, or if the requested operation attempts to read portions of the file not written.
At the conclusion of the operation, FILE-POSITION returns the next file position after the last character read.
Specifically, if the last line in the file is non-empty, but has no terminator, an attempt to read that line will "succeed", returning the number of characters thus read, and flag will be true. The next read, assuming that no intervening REPOSITION-FILE occurs, will return u2=0, flag=false, ior=false.
Here is complete list of return value combinations and their meanings:
u2 flag ior Meaning
-- ---- --- -------
X X nonzero Something bad and unexpected happened
(end-of-file is not "unexpected")
0 false zero End-of-file; no characters were read
0 true zero A blank line was read
0 < u2 < u1 true zero The entire line was read
u1 true zero A partial line was read; the rest would
not fit in the buffer, and can be acquired
by additional calls to READ-LINE.
Considing how simple it is to turn an abort into a ior, asking for it is done in the kernel is a nonsence but so be it.
: READ-LINE ( c-addr u1 fileid -- u2 flag ior )
['] :read_line CATCH DUP IF
>R DROP 2DROP
zero zero R>
THEN
;
FILE
( c-addr u1 fileid -- u2 ior )
Read u1 consecutive characters to c-addr from the current position of the file identified by fileid.
If u1 characters are read without an exception, ior is zero and u2 is equal to u1.
If the end of the file is reached before u1 characters are read, ior is zero and u2 is the number of characters actually read.
If the operation is initiated when the value returned by FILE-POSITION is equal to the value returned by FILE-SIZE for the file identified by fileid, ior is zero and u2 is zero.
If an exception occurs, ior is the implementation-defined I/O result code, and u2 is the number of characters transferred to c-addr without an exception.
An ambiguous condition exists if the operation is initiated when the value returned by FILE-POSITION is greater than the value returned by FILE-SIZE for the file identified by fileid, or if the requested operation attempts to read portions of the file not written.
At the conclusion of the operation, FILE-POSITION returns the next file position after the last character read.
A typical sequential file-processing algorithm might look like:
BEGIN ( )
... READ-FILE THROW ( length )
?DUP WHILE ( length )
... ( )
REPEAT ( )
In this example, THROW is used to handle (unexpected) exception conditions, which are reported as non-zero values of the ior return value from READ-FILE. End-of-file is reported as a zero value of the length return value.
I don't know, you go to all the trouble to catch the error for the standard words and the example in the standard goes and throws it.
: READ-FILE ( c-addr u1 fileid -- u2 ior )
['] :read CATCH DUP IF
>R 2DROP zero R>
THEN
;
CORE EXT
( -- flag )
Attempt to fill the input buffer from the input source, returning a true flag if successful.
When the input source is the user input device, attempt to receive input into the terminal input buffer. If successful, make the result the input buffer, set >IN to zero, and return true. Receipt of a line containing no characters is considered successful. If there is no input available from the current input source, return false.
When the input source is a string from EVALUATE, return false and perform no other action.
: REFILL ( --flag )
SOURCE-ID @ -1 = IF
FALSE EXIT
THEN
SOURCE-ID @ IF
SOURCE-ID @
ELSE
'input_file @
THEN
TIB #$buffer ROT :read_line
SWAP #TIB !
zero >IN !
1 %line +!
;
Note that _interpret and _compile use local variables. This means return stack errors will be dealt with. I am not sure if this a good thing or a bad thing.
These are written to token date is left in the input stream.
: new_interpret { ( ? ) variable _%addr variable _%n -- ( ?) }
_%addr @ _%n @ sfind IF
EXECUTE
EXIT
THEN \ addr-c
_%addr @ _%n @ ['] Snumber CATCH IF
CR _%addr @ _%n @ TYPE
TRUE ?token
THEN
;
: new_compiler { variable _%addr variable _%n -- }
_%addr @ _%n @ sfind ?DUP IF
_#immediate = IF
EXECUTE
ELSE
\ we found the word so it must have a head
\ so we can use this version of compile.
_:compile,
THEN
ELSE
_%addr @ _%n @ ['] Snumber CATCH IF
CR _%addr @ _%n @ TYPE
TRUE ?token
THEN
THEN
;
: scan ( ? --? )
BEGIN
^C
BL (word) DUP
WHILE
\ add n (--
STATE @ IF
new_compiler
ELSE
new_interpret
THEN
[ #5407 [IF] ]T
cache_flush
[ [THEN] ]T
_?stack_empty
REPEAT
\ addr zero(--
2DROP
;
: save_stream ( --)
R>
>IN @ >R
#TIB @ >R
%line @ >R
%tib @ >R
SOURCE-ID @ >R
>R
;
: restore_stream ( --)
R>
R> SOURCE-ID !
R> %tib !
R> %line !
R> #TIB !
R> >IN !
>R
;
FILE
( i*x fileid -- j*x )
Remove fileid from the stack. Save the current input source specification, including the current value of SOURCE-ID. Store fileid in SOURCE-ID. Make the file specified by fileid the input source. Store zero in BLK. Other stack effects are due to the words included.
Repeat until end of file: read a line from the file, fill the input buffer from the contents of that line, set >IN to zero, and interpret.
Text interpretation begins at the file position where the next file read would occur.
When the end of the file is reached, close the file and restore the input source specification to its saved value.
An ambiguous condition exists if fileid is invalid, if there is an I/O exception reading fileid, or if an I/O exception occurs while closing fileid. When an ambiguous condition exists, the status (open or closed) of any files that were being interpreted is implementation-defined.
COLDFORTH In this sytem the file is left upon, it is up to the user to deal with it. See INCLUDED for an example of how.
: INCLUDE-FILE ( fileid --)
save_stream
SOURCE-ID !
#$buffer get_buffer
buffer %tib !
0 %line !
BEGIN
REFILL
WHILE
scan
REPEAT
kill_buffer
restore_stream
;
FILE
( i*x c-addr u -- j*x )
Remove c-addr u from the stack. Save the current input source specification, including the current value of SOURCE-ID. Open the file specified by c-addr u, store the resulting fileid in SOURCE-ID, and make it the input source. Store zero in BLK. Other stack effects are due to the words included.
Repeat until end of file: read a line from the file, fill the input buffer from the contents of that line, set >IN to zero, and interpret.
Text interpretation begins at the file position where the next file read would occur.
When the end of the file is reached, close the file and restore the input source specification to its saved value.
An ambiguous condition exists if the named file can not be opened, if an I/O exception occurs reading the file, or if an I/O exception occurs while closing the file. When an ambiguous condition exists, the status (open or closed) of any files that were being interpreted is implementation-defined.
COLDFORTH All files are closed the location of the error is saved in
$error_file
%error_line
%error_character
.error_position displays the information. error_edit can by used to open up the line editor
at the errors location.
\ included files are linked in here. These files are
\ closed on an abort. See _close_included_files
uvariable _%included_handles
: INCLUDED ( c-addr u --)
R/O Sopen \ handle(--
\ do it this way so stack errors do not cause failure
>R \ (--
_%included_handles R@ :link_cleanup
R@ INCLUDE-FILE
R@ :unlink_cleanup
R> close
;
FILE
( ud fileid -- ior )
Reposition the file identified by fileid to ud. ior is the implementation-defined I/O result code. An ambiguous condition exists if the file is positioned outside the file boundaries.
At the conclusion of the operation, FILE-POSITION returns the value ud.
: REPOSITION-FILE ( ud fileid -- ior )
>R D>S R> ['] :reposition_file CATCH DUP IF
>R 2DROP R>
THEN
;
When something goes wrong it is really nice if you know where. These words are used in abort to save off details of where a compile error occured. Even better you can use edit to open the file in line editor mode just like you could in the good old block days.
: _close_included_files ( --)
_%included_handles @ BEGIN
DUP
WHILE
\ get next link before we close the object
DUP @
SWAP cleanup>object
DUP :unlink_cleanup
close
REPEAT
DROP
;
\ used in the abort code which was defined in previous files.
' _close_included_files _(close_included_files) t!
.( _close_include_files)
The working directory is task specific. It is nothing more than a string that is added to the front of file names. Unlike unix the code has no . or .. concept. Both reduce the general nature of the file system.
\ set working directory
: $swd ( $ --)
$working_directory #$buffer $move
;
: swd ( "wd" --)
BL WORD $swd
;
: cd ( "wd" --)
swd
;
\ print working directory
: .wd ( --)
$working_directory $type
;
\ the unix token
: pwd ( --)
;
Well the standard words are all pretty nice but includeSinclude and $include are the wordset we need.
: Sinclude ( addr num --)
INCLUDED
;
: $include ( $ --)
COUNT INCLUDED
;
: include ( "name" --)
BL (word) INCLUDED
;
: ^ include ;
FILE
( fileid -- ud ior )
ud is the current file position for the file identified by fileid. ior is the implementation-defined I/O result code. ud is undefined if ior is non-zero.
: FILE-POSITION ( fileid -- ud ior )
['] :file_position CATCH DUP IF
>R DROP zero zero R>
ELSE
>R S>D R>
THEN
;
FILE
( fileid -- ud ior )
ud is the size, in characters, of the file identified by fileid ( a file object). ior is the implementation-defined I/O result code. This operation does not affect the value returned by FILE-POSITION ud is undefined if ior is non-zero.
: FILE-SIZE ( handle -- ud ior )
['] :@file_size CATCH DUP IF
>R DROP zero zero R>
ELSE
\ as the top of stack is zero and as S>D simple adds a
\ zero you could just add a zero to get the correct result
\ But it is better to say what you mean and mean what you say.
>R S>D R>
THEN
;
FILE
( ud fileid -- ior )
Set the size of the file identified by fileid to ud. ior is the implementation-defined I/O result code.
If the resultant file is larger than the file before the operation, the portion of the file added as a result of the operation might not have been written.
At the conclusion of the operation, FILE-SIZE returns the value ud and FILE-POSITION returns an unspecified value.
: RESIZE-FILE ( ud fileid -- ior )
>R D>S R> \ u fileid
['] :!file_size CATCH DUP IF
>R 2DROP R>
THEN
;
FILE
( c-addr u fileid -- ior )
Write u characters from c-addr to the file identified by fileid starting at its current position. ior is the implementation-defined I/O result code.
At the conclusion of the operation, FILE-POSITION returns the next file position after the last character written to the file, and FILE-SIZE returns a value greater than or equal to the value returned by FILE-POSITION
: WRITE-FILE ( c-addr u fileid -- ior )
['] :write CATCH DUP IF
>R DROP 2DROP R>
THEN
;
FILE
( c-addr u fileid -- ior )
Write u characters from c-addr followed by the implementation-dependent line terminator to the file identified by fileid starting at its current position. ior is the implementation-defined I/O result code.
At the conclusion of the operation, FILE-POSITION returns the next file position after the last character written to the file, and FILE-SIZE returns a value greater than or equal to the value returned by FILE-POSITION.
: WRITE-LINE ( c-addr u fileid -- ior )
['] :write_line CATCH DUP IF
>R DROP 2DROP R>
THEN
;
FILE EXT
( c-addr u -- x ior )
Return the status of the file identified by the character string c-addr u. If the file exists, ior is zero; otherwise ior is the implementation-defined I/O result code. x contains implementation-defined information about the file.
: FILE-STATUS ( c-addr u -- x ior )
OPEN-FILE ?DUP IF
\ zero error(--
EXIT
THEN
\ fileid(--
DUP :status
SWAP
CLOSE-FILE
\ ior(--
;
FILE EXT
( fileid -- ior )
Attempt to force any buffered information written to the file referred to by fileid to be written to mass storage, and the size information for the file to be recorded in the storage directory if changed. If the operation is successful, ior is zero. Otherwise, it is an implementation-defined I/O result code.
: FLUSH-FILE ( fileid -- ior)
['] :flush_file CATCH DUP IF
NIP
THEN
;
( c-addr u -- )
If u is greater than zero, display the character string specified by c-addr and u.
When passed a character in a character string whose character-defining bits have a value between hex 20 and 7E inclusive, the corresponding standard character, specified by 3.1.2.1 graphic characters, is displayed. Because different output devices can respond differently to control characters, programs that use control characters to perform specific functions have an environmental dependency.
: TYPE ( addr num--)
'output_file @ :type
;
' TYPE (_type_) t!
CORE
( c-addr +n1 -- +n2 )
Receive a string of at most +n1 characters. An ambiguous condition exists if +n1 is zero or greater than 32,767. Display graphic characters as they are received. A program that depends on the presence or absence of non-graphic characters in the string has an environmental dependency. The editing functions, if any, that the system performs in order to construct the string are implementation-defined.
Input terminates when an implementation-defined line terminator is received. When input terminates, nothing is appended to the string, and the display is maintained in an implementation-defined way.
+n2 is the length of the string stored at c-addr.
#### COLDFORTH discussion. The ANSI standard assumes that ACCEPT is line base and KEY is binary based. COLDFORTH supports terminal I/O though pipes. The remote task can set echo and binary modes, and use one expect and one type word. This could be changes so that the expect came with it's own method codes but it is too late. That is the trouble with this sort of thing once a standard for communication is set you have to stick to it. Just look at the mess that is the TCP/IP standard.
#### We will get a chance to change this when we move to the TELNET standard. The option that best matches that standard will be chosen.
: ACCEPT ( addr num -- num)
'input_file @ DUP :terminal_mode@ IF
:read_line DROP
ELSE
:read
THEN
;
CORE EXT
( c-addr +n -- )
Receive a string of at most +n characters. Display graphic characters as they are received. A program that depends on the presence or absence of non-graphic characters in the string has an environmental dependency. The editing functions, if any, that the system performs in order to construct the string of characters are implementation-defined.
Input terminates when an implementation-defined line terminator is received or when the string is +n characters long. When input terminates, nothing is appended to the string and the display is maintained in an implementation-defined way.
Store the string at c-addr and its length in SPAN.
Note: This word is obsolescent and is included as a concession to existing implementations. Its function is superseded by 6.1.0695 ACCEPT.
: EXPECT ( addr num --)
ACCEPT 'input_file @ :span !
;
' EXPECT (_expect_) t!
( -- char )
Receive one character char, a member of the implementation-defined character set. Keyboard events that do not correspond to such characters are discarded until a valid character is received, and those events are subsequently unavailable.
All standard characters can be received. Characters received by KEY are not displayed.
Any standard character returned by KEY has the numeric value specified in 3.1.2.1 Graphic characters. Programs that require the ability to receive control characters have an environmental dependency.
In COLDFORTH you turn echo on and off with echo_on and echo_off. To change this reduces the usefullness of ACCEPT and KEY
The handleing of binary mode may be altered when TELNET is implemented.
: KEY ( --char)
keybuffer 'input_file @ DUP :terminal_mode@ IF
\ in line mode room has to be left for the termination code
two SWAP :read_line 2DROP keybuffer C@
ELSE
one SWAP :read DROP keybuffer C@
THEN
;
Words to print data using 'file_xxx contents as a pointer to the device driver.
c-r CORE
( -- )
Cause subsequent output to appear at the beginning of the next line.
: CR 'output_file @ :cr ;
' CR (_cr_) t!
\ The idea behind these words. When using a terminal it is pretty frustrating
\ when the previous page just goes. If true the output is supposed to wait for
\ input.
: page_free ( --) FALSE 'output_file @ :!?page ;
: page_hold ( --) TRUE 'output_file @ :!?page ;
: ?page ( --) 'output_file @ :?page ;
: MARK 'output_file @ :mark ;
FACILITY
( -- )
Move to another page for output. Actual function depends on the output device. On a terminal, PAGE clears the screen and resets the cursor position to the upper left corner. On a printer, PAGE performs a form feed.
: PAGE 'output_file @ :page ;
: TAB 'output_file @ :tab ;
: >| 'output_file @ :>| ;
: |> 'output_file @ :|> ;
: |I 'output_file @ :|i ;
: |O 'output_file @ :|o ;
: |V 'output_file @ :|v ;
: |H 'output_file @ :|h ;
: |N 'output_file @ :|n ;
: |TL 'output_file @ :|tl ;
: |TR 'output_file @ :|tr ;
: |BL 'output_file @ :|bl ;
: |BR 'output_file @ :|br ;
: .BOX 'output_file @ :box ;
: .ELEMENT 'output_file @ :element ;
: .LINE 'output_file @ :line ;
: .ZED 'output_file @ :zed ;
: normal 'output_file @ :normal ;
: rev 'output_file @ :rev ;
: blink 'output_file @ :blink ;
: dim 'output_file @ :dim ;
: udl 'output_file @ :udl ;
: dim&blink 'output_file @ :dim&blink ;
: rev&blink 'output_file @ :rev&blink ;
: rev&dim 'output_file @ :rev&dim ;
: rev&udl 'output_file @ :rev&udl ;
: rev&dim&blink 'output_file @ :rev&dim&blink ;
: rev&dim&udl 'output_file @ :rev&dim&udl ;
: LABELS 'output_file @ :labels ;
: SHIFT_LABELS 'output_file @ :shift_labels ;
: CURSOR 'output_file @ :cursor ;
: NO_CURSOR 'output_file @ :no_cursor ;
: MESSAGE 'output_file @ :message ;
: NO_MESSAGE 'output_file @ :no_message ;
: foreground 'output_file @ :foreground ;
: background 'output_file @ :background ;
: BORDER 'output_file @ :border ;
: A4 'output_file @ :a4 ;
: QUARTO 'output_file @ :quarto ;
: EOJ 'output_file @ :eoj ;
key-question FACILITY
( -- flag )
If a character is available, return true. Otherwise, return false. If non-character keyboard events are available before the first valid character, they are discarded and are subsequently unavailable. The character shall be returned by the next execution of KEY.
After KEY? returns with a value of true, subsequent executions of KEY? prior to the execution of KEY or EKEY also return true, without discarding keyboard events.
: KEY? ( -- flag) 'input_file @ :key? ;
: clear ( --) 'input_file @ :clear ;
CORE EXT
( -- a-addr )
a-addr is the address of a cell containing the count of characters stored by the last execution of EXPECT.
Note: This word is obsolescent and is included as a concession to existing implementations.
: SPAN ( --addr) 'input_file @ :span ;
: !control ( 16b --) 'output_file @ :!control ;
: !device ( n --) 'output_file @ :!device ;
: !eot ( addr--) 'output_file @ :!eot ;
: !timeout ( n --) 'output_file @ :!timeout ;
: baud ( n --) 'output_file @ :baud ;
: send 'output_file @ :flush_file ;
' send (_send_) t!
: ?send ( num --) 'output_file @ :?send ;
\ convert invisible characters to ~ and underline.
: ~MARK ( addr num --)
DUP IF
$buffer
TUCK
buffer visible
buffer SWAP
MARK
kill_buffer
ELSE
2DROP
xpause
THEN
;
Code to deal with the printing of errors.
#$buffer ufree_buffer $error_file
uvariable %error_line
uvariable %error_character
uvariable %error_source
: _save_off_source ( --)
SOURCE-ID @ DUP %error_source !
0> IF
SOURCE-ID @ :@root #$buffer MIN
$error_file $make
%line @ %error_line !
>IN @ %error_character !
THEN
;
: .error_position
%error_source @ 0> IF
CR
$error_file $type SPACE
." Line: " %error_line @ .d
." Character: " %error_character @ .d
THEN
;
\ has to be used before error file is closed
8 CONSTANT _#list_lines
4 CONSTANT _#back_lines
: list_error ( --)
\ error source is set to -1 if error was in EVALUATE
%error_source @ 0> IF
_#back_lines %error_line @ 1 - MIN %error_source @ :previous_line \ file_position flag(--
IF \ can get previous line position
S>D %error_source @ REPOSITION-FILE IF
\ we are dealing with an abort don't abort on this
\ error just tidy up and exit
EXIT
THEN
%error_line @
_#back_lines %error_line @ 1 - MIN - \ line_listed zero base(--
\ saved error line is one based
#$buffer get_buffer
CR CR
_#list_lines 0 DO
buffer #$buffer %error_source @ READ-LINE
IF
\ dealing with error just tidy up and exit
kill_buffer
2DROP \ return values
DROP \ line being listed
UNLOOP
EXIT
THEN
\ line count flag(--
\ end of file
not IF
kill_buffer
2DROP
UNLOOP
EXIT
THEN
\ line_being_listed count(--
BASE @ >R
DECIMAL
OVER 5 .R SPACE
R> BASE !
OVER %error_line @ = IF
buffer %error_character @ TYPE
buffer %error_character @ + SWAP %error_character @ -
zero MAX MARK
ELSE
buffer SWAP TYPE
THEN
CR
send
1+
LOOP
DROP
kill_buffer
THEN
THEN
;
: _error_position ( --)
_save_off_source
.error_position
list_error
;
\ used in the abort code which was been defined already.
' _error_position (error_position) t!
forth : device-set
HOST
(CREATE) HOST tw, DOES>
!device
;
01 device-set PARITY_ODD
02 device-set PARITY_EVEN
03 device-set PARITY_OFF
04 device-set SBIT1
05 device-set SBIT1.5
06 device-set SBIT2
07 device-set BITS7
08 device-set BITS8
\ CONSTANT returns the value stored at xcompile time, CREATE returns the address
forth : unit-set
HOST
CREATE t,
DOES>
@ !control
;
( Generic words for terminal setup) HEX
01 unit-set echo_on
02 unit-set echo_off
\ transmit an XOFF if rotating buffer becomes full
03 unit-set RXON_ON
04 unit-set RXON_OFF
\ look at input and if a XOFF is received stop the transmission.
05 unit-set SXON_ON
06 unit-set SXON_OFF
\ If binary is on the del key is not looked at, and the 8th bit is not
\ played with.
07 unit-set binary_on
08 unit-set binary_off
CORE EXT
( -- xn ... x1 n )
x1 through xn describe the current state of the input source specification for later use by RESTORE-INPUT.
SAVE-INPUT and RESTORE-INPUT allow the same degree of input source repositioning within a text file as is available with BLOCK input. SAVE-INPUT and RESTORE-INPUT hide the details of the operations necessary to accomplish this repositioning, and are used the same way with all input sources. This makes it easier for programs to reposition the input source, because they do not have to inspect several variables and take different action depending on the values of those variables.
SAVE-INPUT and RESTORE-INPUT are intended for repositioning within a single input source; for example, the following scenario is NOT allowed for a Standard Program:
: XX
SAVE-INPUT CREATE
S" RESTORE-INPUT" EVALUATE
ABORT" couldn't restore input"
;
This is incorrect because, at the time RESTORE-INPUT is executed, the input source is the string via EVALUATE, which is not the same input source that was in effect when SAVE-INPUT was executed.
The following code is allowed:
: XX
SAVE-INPUT CREATE
S" .( Hello)" EVALUATE
RESTORE-INPUT ABORT" couldn't restore input"
;
After EVALUATE returns, the input source specification is restored to its previous state, thus SAVE-INPUT and RESTORE-INPUT are called with the same input source in effect.
In the above examples, the EVALUATE phrase could have been replaced by a phrase involving INCLUDE-FILE and the same rules would apply.
The Standard does not specify what happens if a program violates the above rules. A Standard System might check for the violation and return an exception indication from RESTORE-INPUT, or it might fail in an unpredictable way.
The return value from RESTORE-INPUT is primarily intended to report the case where the program attempts to restore the position of an input source whose position cannot be restored. The keyboard might be such an input source.
Nesting of SAVE-INPUT and RESTORE-INPUT is allowed. For example, the following situation works as expected:
: XX
SAVE-INPUT
S" f1" INCLUDED \ The file "f1" includes:
\ ... SAVE-INPUT ... RESTORE-INPUT ...
\ End of file "f1"
RESTORE-INPUT ABORT" couldn't restore input"
;
In principle, RESTORE-INPUT could be implemented to always fail, e.g.:
: RESTORE-INPUT ( x1 ... xn n -- flag )
0 ?DO DROP LOOP TRUE
;
Such an implementation would not be useful in most cases. It would be preferable for a system to leave SAVE-INPUT and RESTORE-INPUT undefined, rather than to create a useless implementation. In the absence of the words, the application programmer could choose whether or not to create dummy implementations or to work-around the problem in some other way.
Examples of how an implementation might use the return values from SAVE-INPUT to accomplish the save/restore function:
: SAVE-INPUT ( -- x1 x2 x3 x4 x5 x6 6 )
>IN @
#TIB @
%line @
%tib @
SOURCE-ID @
\ we ignore error if we can't get the file position then it is not relevent
DUP FILE-POSITION ( fileid -- ud ior )
DROP
6
;
CORE EXT
( xn ... x1 n -- flag )
Attempt to restore the input source specification to the state described by x1 through xn. flag is true if the input source specification cannot be so restored.
An ambiguous condition exists if the input source represented by the arguments is not the same as the current input source.
: RESTORE-INPUT ( x1 x2 x3 x4 x5 x6 6--flag)
6 <> IF
TRUE EXIT
THEN
OVER REPOSITION-FILE DROP
SOURCE-ID !
%tib !
%line !
#TIB !
>IN !
FALSE
;