Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: filecomm.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 | \ filecomm.fth 2.21 02/11/19 | |
43 | \ Copyright 1985-1994 Bradley Forthware, Inc. | |
44 | \ copyright: Copyright 1994-2002 Sun Microsystems, Inc. All Rights Reserved | |
45 | \ Copyright Use is subject to license terms. | |
46 | ||
47 | decimal | |
48 | ||
49 | \ buffered i/o constants | |
50 | -1 constant eof | |
51 | ||
52 | \ field creates words which return their address within the structure | |
53 | \ pointed-to by the contents of file | |
54 | ||
55 | \ The file descriptor structure describes an open file. | |
56 | \ There is a pool of several of these structures. When a file is opened, | |
57 | \ a structure is allocated and initialized. While performing an io | |
58 | \ operation, the user variable "file" contains a pointer to the file | |
59 | \ on which the operation is being performed. | |
60 | ||
61 | headers | |
62 | struct ( file descriptor ) | |
63 | /n file-field bfbase \ starting address of the buffer for this file | |
64 | /n file-field bflimit \ ending address of the buffer for this file | |
65 | headerless | |
66 | /n file-field bftop \ address past last valid character in the buffer | |
67 | /n file-field bfend \ address past last place to write in the buffer | |
68 | /n file-field bfcurrent \ address of the current character in the buffer | |
69 | /n file-field bfdirty \ contains true if the buffer has been modified | |
70 | /n file-field fmode \ not-open, read, write, or modify | |
71 | /n 2* file-field fstart \ Position in file of the first byte in buffer | |
72 | /n file-field fid \ File handle for underlying operating system | |
73 | /n file-field seekop \ Points to system routine to set the file position | |
74 | /n file-field readop \ Points to system routine to read blocks | |
75 | /n file-field writeop \ Points to system routine to write blocks | |
76 | /n file-field closeop \ Points to system routine to close file | |
77 | /n file-field alignop \ Points to system routine to align to block boundary | |
78 | /n file-field sizeop \ Points to system routine to return the file size | |
79 | /n file-field (file-line) \ Number of line delims that read-line has consumed | |
80 | /c file-field line-delimiter \ The last delimiter at the end of each line | |
81 | /c file-field pre-delimiter \ The first line delimiter (if any) | |
82 | d# 128 file-field (file-name) \ The name of the file | |
83 | /n round-up | |
84 | headers | |
85 | constant /fd | |
86 | ||
87 | : set-name ( adr len -- ) | |
88 | \ If the name is too long, cut off initial characters (because the | |
89 | \ latter ones are more likely to be interesting), and replace the | |
90 | \ first character with "?". | |
91 | dup d# 127 - 0 max dup >r /string (file-name) place | |
92 | r> if ascii ? (file-name) 1+ c! then | |
93 | ; | |
94 | : file-name ( fd -- adr len ) | |
95 | file @ >r file ! (file-name) count r> file ! | |
96 | ; | |
97 | : file-line ( fd -- n ) file @ >r file ! (file-line) @ r> file ! ; | |
98 | : setupfd ( fid fmode sizeop alignop closeop seekop writeop readop -- ) | |
99 | readop ! writeop ! seekop ! closeop ! alignop ! sizeop ! | |
100 | fmode ! fid ! 0 (file-line) ! 0 0 set-name | |
101 | ; | |
102 | ||
103 | headerless | |
104 | \ values for mode field | |
105 | -1 constant not-open | |
106 | headers | |
107 | 0 constant read | |
108 | headerless | |
109 | 1 constant write | |
110 | headers | |
111 | 2 constant modify | |
112 | headerless | |
113 | modify constant read-write ( for old programs ) | |
114 | ||
115 | \ Stub routines for readop and writeop | |
116 | headers | |
117 | \ These return 0 for the number of bytes actually transferred. | |
118 | : nullwrite ( adr count fd -- 0 ) drop 2drop 0 ; | |
119 | : fakewrite ( adr count fd -- count ) drop nip ; | |
120 | : nullalign ( d.position fd -- d.position' ) drop ; | |
121 | : nullread ( adr count fd -- 0 ) drop 2drop 0 ; | |
122 | : nullseek ( d.byte# fd -- ) drop 2drop ; | |
123 | headerless | |
124 | \ This one pretends to have transferred the requested number of bytes | |
125 | : fakeread ( adr count fd -- count ) drop nip ; | |
126 | ||
127 | headers | |
128 | \ Initializes the current descriptor to use the buffer "bufstart,buflen" | |
129 | : initbuf ( bufstart buflen -- ) | |
130 | 0 0 fstart 2! over + bflimit ! ( bufstart ) | |
131 | dup bfbase ! dup bfcurrent ! dup bfend ! bftop ! | |
132 | bfdirty off | |
133 | ; | |
134 | ||
135 | \ "unallocate" a file descriptor | |
136 | : release-fd ( fd -- ) file @ >r file ! not-open fmode ! r> file ! ; | |
137 | headerless | |
138 | ||
139 | \ An implementation factor which returns true if the file descriptor fd | |
140 | \ is not currently in use | |
141 | : fdavail? ( fd -- f ) file @ >r file ! fmode @ not-open = r> file ! ; | |
142 | ||
143 | \ These are the words that a program uses to read and write to/from a file. | |
144 | ||
145 | \ An implementation factor which | |
146 | \ ensures that the bftop is >= the bfcurrent variable. bfcurrent | |
147 | \ can temporarily advance beyond bftop while a file is being extended. | |
148 | ||
149 | : bfsync ( -- ) \ if current > top, move up top | |
150 | bftop @ bfcurrent @ u< if bfcurrent @ bftop ! then | |
151 | ; | |
152 | ||
153 | \ If the current file's buffer is modified, write it out | |
154 | \ Need to better handle the case where the file can't be extended, | |
155 | \ for instance if the file is a memory array | |
156 | : ?flushbuf ( -- ) | |
157 | bfdirty @ if | |
158 | bfsync | |
159 | fstart 2@ fid @ seekop @ execute ( ) | |
160 | bftop @ bfbase @ - ( #bytes-to-write) | |
161 | bfbase @ over ( #bytes adr #bytes ) | |
162 | fid @ writeop @ execute ( #bytes-to-write #bytes-written ) | |
163 | u> ( -37 ) abort" Flushbuf error" | |
164 | bfdirty off | |
165 | bfbase @ dup bftop ! bfcurrent ! | |
166 | then | |
167 | ; | |
168 | ||
169 | \ An implementation factor which | |
170 | \ fills the buffer with a block from the current file. The block will | |
171 | \ be chosen so that the file address "d.byte#" is somewhere within that | |
172 | \ block. | |
173 | ||
174 | : fillbuf ( d.byte# -- ) | |
175 | fid @ alignop @ execute ( d.byte# ) \ Aligns position to a buffer boundary | |
176 | 2dup fstart 2! ( d.byte# ) | |
177 | fid @ seekop @ execute ( ) | |
178 | bfbase @ bflimit @ over - ( adr #bytes-to-read ) | |
179 | fid @ readop @ execute ( #bytes-read ) | |
180 | bfbase @ + bftop ! | |
181 | bflimit @ bfend ! | |
182 | ; | |
183 | ||
184 | \ An implementation factor which | |
185 | \ returns the address within the buffer corresponding to the | |
186 | \ selected position "d.byte#" within the current file. | |
187 | ||
188 | : >bufaddr ( d.byte# -- bufaddr ) fstart 2@ d- drop bfbase @ + ; | |
189 | ||
190 | \ An implementation factor which | |
191 | \ advances to the next block in the file. This is used when accesses | |
192 | \ to the file are sequential (the most common case). | |
193 | ||
194 | \ Assumes the byte is not already in the buffer! | |
195 | : shortseek ( bufaddr -- ) | |
196 | ?flushbuf ( bufaddr ) | |
197 | bfbase @ - s>d fstart 2@ d+ ( d.byte# ) | |
198 | 2dup fillbuf ( d.byte# ) | |
199 | >bufaddr bftop @ umin bfcurrent ! | |
200 | ; | |
201 | ||
202 | \ Buffer boundaries are transparant | |
203 | \ end-of-file conditions work correctly | |
204 | \ The actual delimiter encountered in stored in delimiter. | |
205 | ||
206 | headers | |
207 | \ input-file contains the file descriptor which defines the input stream. | |
208 | nuser input-file | |
209 | ||
210 | headerless | |
211 | ||
212 | \ ?fillbuf is called by the string scanning routines after skipbl, scanbl, | |
213 | \ skipto, or scanto has returned. ?fillbuf determines whether or not | |
214 | \ the end of a buffer has been reached. If so, the buffer is refilled and | |
215 | \ end? is set to false so that the skip/scan routine will be called again, | |
216 | \ (unless the end of the file is reached). | |
217 | ||
218 | : ?fillbuf ( endaddr [ adr ] delimiter -- endaddr' addr' end? ) | |
219 | dup delimiter ! eof = if ( endaddr ) | |
220 | shortseek | |
221 | bftop @ bfcurrent @ ( endaddr' addr' ) | |
222 | 2dup u<= ( endaddr' addr' end-of-file? ) | |
223 | else ( endaddr addr ) | |
224 | true \ True so we'll exit the loop | |
225 | then | |
226 | ; | |
227 | ||
228 | headers | |
229 | \ Closes the file. | |
230 | : fclose ( fd -- ) | |
231 | file @ >r file ! | |
232 | file @ fdavail? 0= if | |
233 | ?flushbuf fid @ closeop @ execute | |
234 | file @ release-fd | |
235 | then | |
236 | r> file ! | |
237 | ; | |
238 | ||
239 | headerless | |
240 | \ File descriptor allocation | |
241 | ||
242 | 8 constant #fds | |
243 | #fds /fd * constant /fds | |
244 | ||
245 | nuser fds | |
246 | ||
247 | \ Initialize pool of file descriptors | |
248 | chain: init ( -- ) | |
249 | /stringbuf alloc-mem is 'word | |
250 | /fds alloc-mem ( base-address ) fds ! | |
251 | fds @ /fds bounds do i release-fd /fd +loop | |
252 | ; | |
253 | ||
254 | \ Allocates a file descriptor if possible | |
255 | : (get-fd ( -- fd | 0 ) | |
256 | 0 | |
257 | fds @ /fds bounds ?do ( 0 ) | |
258 | i fdavail? if drop i leave then ( 0 ) | |
259 | /fd +loop ( fd | 0 ) | |
260 | ; | |
261 | ||
262 | : string-sizeop ( fhandle -- d.length ) drop bflimit @ bfbase @ - 0 ; | |
263 | ||
264 | : open-buffer ( adr len -- fd ior ) | |
265 | 2 ?enough | |
266 | \ XXX we need a "throw" code for "no more fds" | |
267 | (get-fd ?dup 0= if 0 true exit then ( adr len fd ) | |
268 | file ! | |
269 | 2dup ( adr len ) | |
270 | initbuf ( adr len ) | |
271 | bflimit @ dup bfend ! bftop ! ( adr len ) | |
272 | ||
273 | 0 modify | |
274 | ['] string-sizeop ['] drop ['] drop | |
275 | ['] nullseek ['] fakewrite ['] nullread setupfd ( adr len ) | |
276 | $set-line-delimiter | |
277 | ||
278 | \ Set the file name field to "<buffer@ADDRESS>" | |
279 | base @ >r hex | |
280 | bfbase @ <# ascii > hold u#s " <buffer@" hold$ u#> set-name | |
281 | r> base ! | |
282 | ||
283 | file @ false | |
284 | ; | |
285 | ||
286 | headerless | |
287 | : (.error#) ( error# -- ) | |
288 | dup d# -38 = if | |
289 | ." The file '" opened-filename 2@ type ." ' cannot be opened." | |
290 | else ." Error " . then | |
291 | ; | |
292 | ' (.error#) is .error# |