1 /*
2 * Streams for CLISP
3 * Bruno Haible 1990-2008, 2016-2018
4 * Sam Steingold 1998-2011, 2016-2017
5 * Generic Streams: Marcus Daniels 8.4.1994
6 * SCREEN package for Win32: Arseny Slobodjuck 2001-02-14
7 * German comments translated into English: Stefan Kain 2001-11-02
8 */
9
10 #include "lispbibl.c"
11 #include "arilev0.c" /* for R_sign */
12
13 #if 0
14 #define DEBUG_OUT(x) do { printf x; fflush(stdout); } while(0)
15 #else
16 #define DEBUG_OUT(x)
17 #endif
18
19 #ifdef GNU_READLINE
20 #include <readline/readline.h>
21 #include <readline/history.h>
22 #endif
23
24 /* off_t is a signed type, defined in <sys/types.h> and <fcntl.h>, denoting
25 a file descriptor's position. Here we also need the unsigned equivalent. */
26 #if SIZEOF_OFF_T > 4
27 typedef uint64 uoff_t;
28 #else
29 typedef uint32 uoff_t;
30 #endif
31
32 /* Converts an uoff_t value into an Integer >=0.
33 uoff_t_to_I(value)
34 > value: value in the range of uoff_t
35 < result: Integer with that value.
36 can trigger GC */
37 #if SIZEOF_OFF_T > 4
38 #define uoff_to_I UQ_to_I
39 #else
40 #define uoff_to_I UL_to_I
41 #endif
42
43 /* Converts an Integer >=0 into an uoff_t value.
44 I_to_uoff_t(obj)
45 > obj: an object, should be an Integer >=0, <= ~(uoff_t)0
46 < result: the Integer's value as an uoff_t */
47 #if SIZEOF_OFF_T > 4
48 #define I_to_uoff_t I_to_UQ
49 #else
50 #define I_to_uoff_t I_to_UL
51 #endif
52
53 /* Test for an Integer that fits into an uoff_t.
54 uoff_t_p(obj)
55 > obj: an object
56 < result: true if it's an integer >=0, <= ~(uoff_t)0 */
57 #if SIZEOF_OFF_T > 4
58 #define uoff_t_p uint64_p
59 #else
60 #define uoff_t_p uint32_p
61 #endif
62
63 /* once again the structure of Streams:
64 strmflags = Flags
65 Bits in the Flags:
66 define strmflags_open_bit_B 0 - set, if the Stream is open
67 define strmflags_immut_bit_B 1 - set if read literals are immutable
68 define strmflags_fasl_bit_B 2 - Read-Eval is allowed, \r=#\Return */
69 #define strmflags_unread_bit_B 3 /* set while strm_rd_ch_last is back */
70 /* define strmflags_rd_by_bit_B 4 - set if READ-BYTE is possible
71 define strmflags_wr_by_bit_B 5 - set if WRITE-BYTE is possible
72 define strmflags_rd_ch_bit_B 6 - set if READ-CHAR is possible
73 define strmflags_wr_ch_bit_B 7 - set if WRITE-CHAR is possible
74 Bitmasks in the Flags:
75 define strmflags_open_B bit(strmflags_open_bit_B) */
76 #define strmflags_immut_B bit(strmflags_immut_bit_B)
77 #define strmflags_fasl_B bit(strmflags_fasl_bit_B)
78 #define strmflags_unread_B bit(strmflags_unread_bit_B)
79 /* define strmflags_rd_by_B bit(strmflags_rd_by_bit_B)
80 define strmflags_wr_by_B bit(strmflags_wr_by_bit_B)
81 define strmflags_rd_ch_B bit(strmflags_rd_ch_bit_B)
82 define strmflags_wr_ch_B bit(strmflags_wr_ch_bit_B)
83 define strmflags_rd_B (strmflags_rd_by_B | strmflags_rd_ch_B)
84 define strmflags_wr_B (strmflags_wr_by_B | strmflags_wr_ch_B) */
85 #define strmflags_by_B (strmflags_rd_by_B | strmflags_wr_by_B)
86 #define strmflags_ch_B (strmflags_rd_ch_B | strmflags_wr_ch_B)
87 #define strmflags_rdwr_B (strmflags_rd_B | strmflags_wr_B)
88 /* strmtype = further Typinfo. See LISPBIBL.D. */
89
90 /* individual fields:
91 strm_rd_by pseudofunction for READ-BYTE
92 strm_rd_by_array pseudofunction for READ-BYTE-SEQUENCE
93 strm_wr_by pseudofunction for WRITE-BYTE
94 strm_wr_by_array pseudofunction for WRITE-BYTE-SEQUENCE
95 strm_rd_ch pseudofunction for READ-CHAR
96 strm_pk_ch pseudofunction for PEEK-CHAR
97 strm_rd_ch_array pseudofunction for READ-CHAR-SEQUENCE
98 strm_rd_ch_last last character read by READ-CHAR, NIL if none has been
99 read upto now, eof_value after EOF has been seen.
100 After UNREAD-CHAR, additionally the bit
101 strmflags_unread_bit_B is set.
102 strm_wr_ch pseudofunction for WRITE-CHAR
103 strm_wr_ch_array pseudofunction for WRITE-CHAR-SEQUENCE
104 strm_wr_ch_npnl pseudofunction for WRITE-CHAR, when
105 no pending newline
106 strm_wr_ch_array_npnl pseudofunction for WRITE-CHAR-SEQUENCE, when
107 no pending newline
108 strm_wr_ch_lpos line-position in the current line after last WRITE-CHAR,
109 a fixnum >=0
110 further (type-specific) components:
111 See in LISPBIBL.D and at the Stream-Types.
112
113 =============================================================================
114 S T R E A M S
115
116 Since MAKE-TWO-WAY-STREAM possibly can return a Stream that is, e.g.,
117 Character-Input and Byte-Output, and therewith in particular all
118 READ-/WRITE-Operations must run efficiently, Streams are built up
119 as follows:
120 - Type of the Stream,
121 - Components for READ-BYTE, READ-BYTE-SEQUENCE,
122 - Components for WRITE-BYTE, WRITE-BYTE-SEQUENCE,
123 - Components for READ-CHAR, READ-CHAR-SEQUENCE,
124 - Components for WRITE-CHAR, WRITE-CHAR-SEQUENCE,
125 - Components, depending on the Type of the Stream.
126
127 Specification of the nine Types of Pseudo-Functions:
128
129 Specification for READ-BYTE - Pseudo-Function:
130 fun(stream)
131 > stream: Stream
132 < result: read Integer (eof_value at EOF)
133 can trigger GC */
134 typedef maygc object (* rd_by_Pseudofun) (object stream);
135
136 /* Specification for READ-BYTE-ARRAY - Pseudo-Function:
137 fun(&stream,&bytearray,start,len,persev)
138 > stream: stream
139 > object bytearray: simple-8bit-vector
140 > uintL start: start index of byte sequence to be filled
141 > uintL len: length of byte sequence to be filled, >0
142 > perseverance_t persev: how to react on incomplete I/O
143 < uintL result: number of bytes that have been filled
144 can trigger GC */
145 typedef maygc uintL (* rd_by_array_Pseudofun) (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);
146
147 /* Specification for WRITE-BYTE - Pseudo-Function:
148 fun(stream,obj)
149 > stream: Stream
150 > obj: Integer to be written
151 can trigger GC */
152 typedef maygc void (* wr_by_Pseudofun) (object stream, object obj);
153
154 /* Specification for WRITE-BYTE-ARRAY - Pseudo-Function:
155 fun(&stream,&bytearray,start,len,persev)
156 > stream: stream
157 > object bytearray: simple-8bit-vector
158 > uintL start: start index of byte sequence to be written
159 > uintL len: length of byte sequence to be written, >0
160 > perseverance_t persev: how to react on incomplete I/O
161 can trigger GC */
162 typedef maygc uintL (* wr_by_array_Pseudofun) (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);
163
164 /* Specification for READ-CHAR - Pseudo-Function:
165 fun(&stream)
166 > stream: Stream
167 < stream: Stream
168 < result: read Character (eof_value at EOF)
169 can trigger GC */
170 typedef maygc object (* rd_ch_Pseudofun) (const gcv_object_t* stream_);
171
172 /* Specification for PEEK-CHAR - Pseudo-Function:
173 fun(&stream)
174 Like READ-CHAR with sequencing UNREAD-CHAR. Only side-effects up
175 to the next real READ-CHAR are retarded (if possible).
176 > stream: Stream (with strmflags_unread_bit_B deleted)
177 < stream: Stream
178 < result: read Character (eof_value at EOF)
179 can trigger GC */
180 typedef maygc object (* pk_ch_Pseudofun) (const gcv_object_t* stream_);
181
182 /* Specification for READ-CHAR-ARRAY - Pseudo-Function:
183 fun(&stream,&chararray,start,len)
184 > stream: stream
185 > object chararray: a mutable string that is or was simple
186 > uintL start: start index of character sequence to be filled
187 > uintL len: length of character sequence to be filled, >0
188 < uintL result: number of characters that have been filled
189 can trigger GC */
190 typedef maygc uintL (* rd_ch_array_Pseudofun) (const gcv_object_t* stream_, const gcv_object_t* chararray_, uintL start, uintL len);
191
192 /* Specification for WRITE-CHAR - Pseudo-Function:
193 fun(&stream,obj)
194 > stream: Stream
195 < stream: Stream
196 > obj: Character to be written
197 can trigger GC */
198 typedef maygc void (* wr_ch_Pseudofun) (const gcv_object_t* stream_, object obj);
199
200 /* Specification for WRITE-CHAR-ARRAY - Pseudo-Function:
201 fun(&stream,&chararray,start,len)
202 > stream: stream
203 > object chararray: not-reallocated simple-string
204 > uintL start: start index of character sequence to be written
205 > uintL len: length of character sequence to be written, >0 */
206 typedef maygc void (* wr_ch_array_Pseudofun) (const gcv_object_t* stream_, const gcv_object_t* chararray_, uintL start, uintL len);
207
208 /* extract Pseudo-Functions out of a Stream: */
209 #define rd_by(strm) \
210 (*(rd_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_by)))
211 #define rd_by_array(strm) \
212 (*(rd_by_array_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_by_array)))
213 #define wr_by(strm) \
214 (*(wr_by_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_by)))
215 #define wr_by_array(strm) \
216 (*(wr_by_array_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_by_array)))
217 #define rd_ch(strm) \
218 (*(rd_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_ch)))
219 #define pk_ch(strm) \
220 (*(pk_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_pk_ch)))
221 #define rd_ch_array(strm) \
222 (*(rd_ch_array_Pseudofun)(ThePseudofun(TheStream(strm)->strm_rd_ch_array)))
223 #define wr_ch(strm) \
224 (*(wr_ch_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ch)))
225 #define wr_ch_array(strm) \
226 (*(wr_ch_array_Pseudofun)(ThePseudofun(TheStream(strm)->strm_wr_ch_array)))
227
228 /*Possible Types of Streams Additional Components
229 ------------------------- ---------------------
230 Synonym-Stream Symbol
231 Broadcast-(Output-)Stream list of streams
232 Concatenated-(Input-)Stream list of streams
233 Two-Way-Stream Stream for Input, Stream for Output
234 Echo-Stream Stream for Input, Stream for Output
235 String-Input-Stream total string, character counter
236 String-Output-Stream Buffer (Semi-Simple-String)
237 String-Push-Stream String with Fill-Pointer
238 Pretty-Printer-Helper-Stream List of Buffers, Mode
239 Buffered-Input-Stream fun, mode, String, character counter
240 Buffered-Output-Stream fun, Buffer (Semi-Simple-String)
241 #ifdef GENERIC_STREAMS
242 Generic-Stream Private Controller Object
243 #endif
244 Keyboard-Stream
245 Interactive Terminal Stream input-buffer, character counter
246 File-Stream Handle, Pathname, File-Position,
247 (Input, Output, I/O, Closed=Probe) Buffer, [Bit-Buffer]
248 Window-Stream ---
249 #ifdef PRINTER
250 Printer-Stream
251 #endif
252 File-Handle-Stream Handle, Pathname
253 #ifdef PIPES
254 Pipe-Input-Stream Pid, Handle
255 Pipe-Output-Stream Pid, Handle
256 #endif
257 #ifdef X11SOCKETS
258 X11-Socket-Stream Info, Handle
259 #endif
260 #ifdef SOCKET_STREAMS
261 Socket-Stream Host, Port
262 #endif
263
264 Additionally a list of all open File-Streams is maintained (for safety). */
265
266 /* error-message, if a Stream-Operation on a Stream is not allowed.
267 error_illegal_streamop(caller,stream);
268 > caller: Caller (a Symbol)
269 > stream: Stream */
error_illegal_streamop(object caller,object stream)270 global _Noreturn void error_illegal_streamop (object caller, object stream) {
271 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
272 pushSTACK(stream);
273 pushSTACK(caller);
274 error(stream_error,GETTEXT("~S on ~S is illegal"));
275 }
276
277 /* Dummy-Pseudo-Functions, that signal errors: */
rd_by_error(object stream)278 local object rd_by_error (object stream)
279 { error_illegal_streamop(S(read_byte),stream); }
280
rd_by_array_error(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)281 local uintL rd_by_array_error (const gcv_object_t* stream_,
282 const gcv_object_t* bytearray_,
283 uintL start, uintL len, perseverance_t persev)
284 {
285 unused(bytearray_); unused(start); unused(len); unused(persev);
286 error_illegal_streamop(S(read_byte),*stream_);
287 }
288
rd_by_array_dummy(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)289 local maygc uintL rd_by_array_dummy (const gcv_object_t* stream_,
290 const gcv_object_t* bytearray_,
291 uintL start, uintL len,
292 perseverance_t persev) {
293 var uintL end = start + len;
294 var uintL index = start;
295 do {
296 var object stream = *stream_;
297 if ((persev == persev_immediate || persev == persev_bonus)
298 && LISTEN_AVAIL != listen_byte(stream))
299 break;
300 var object obj = rd_by(stream)(stream);
301 if (eq(obj,eof_value))
302 break;
303 obj = check_uint8(obj);
304 TheSbvector(*bytearray_)->data[index] =
305 (uintB)(as_oint(obj) >> oint_data_shift);
306 index++;
307 if (persev == persev_partial)
308 persev = persev_bonus;
309 } while (index < end);
310 return index - start;
311 }
312
wr_by_error(object stream,object obj)313 local void wr_by_error (object stream, object obj)
314 {
315 unused(obj);
316 error_illegal_streamop(S(write_byte),stream);
317 }
318
wr_by_array_error(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)319 local void wr_by_array_error (const gcv_object_t* stream_,
320 const gcv_object_t* bytearray_,
321 uintL start, uintL len, perseverance_t persev)
322 {
323 unused(bytearray_); unused(start); unused(len); unused(persev);
324 error_illegal_streamop(S(write_byte),*stream_);
325 }
326
wr_by_array_dummy(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)327 local uintL wr_by_array_dummy (const gcv_object_t* stream_,
328 const gcv_object_t* bytearray_,
329 uintL start, uintL len, perseverance_t persev) {
330 var uintL end = start + len;
331 var uintL index = start;
332 if (persev != persev_full) /* FIXME: need write_byte_will_hang_p() */
333 error_illegal_streamop(S(write_byte_sequence),*stream_);
334 do {
335 var object stream = *stream_;
336 wr_by(stream)(stream,fixnum(TheSbvector(*bytearray_)->data[index]));
337 index++;
338 } while (index < end);
339 return len;
340 }
341
rd_ch_error(const gcv_object_t * stream_)342 local object rd_ch_error (const gcv_object_t* stream_)
343 { error_illegal_streamop(S(read_char),*stream_); }
344
pk_ch_dummy(const gcv_object_t * stream_)345 local object pk_ch_dummy (const gcv_object_t* stream_) {
346 var object newch = rd_ch(*stream_)(stream_);
347 TheStream(*stream_)->strm_rd_ch_last = newch;
348 if (!eq(newch,eof_value))
349 TheStream(*stream_)->strmflags |= strmflags_unread_B;
350 return newch;
351 }
352
rd_ch_array_error(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)353 local uintL rd_ch_array_error (const gcv_object_t* stream_,
354 const gcv_object_t* chararray_,
355 uintL start, uintL len)
356 {
357 unused(chararray_); unused(start); unused(len);
358 error_illegal_streamop(S(read_char),*stream_);
359 }
360
rd_ch_array_dummy(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)361 local uintL rd_ch_array_dummy (const gcv_object_t* stream_,
362 const gcv_object_t* chararray_,
363 uintL start, uintL len) {
364 var uintL end = start + len;
365 var uintL index = start;
366 do {
367 var object obj = rd_ch(*stream_)(stream_);
368 if (eq(obj,eof_value))
369 break;
370 if (!charp(obj))
371 error_char(obj);
372 sstring_store(*chararray_,index,char_code(obj));
373 index++;
374 } while (index < end);
375 return index - start;
376 }
377
wr_ch_error(const gcv_object_t * stream_,object obj)378 local void wr_ch_error (const gcv_object_t* stream_, object obj)
379 {
380 unused(obj);
381 error_illegal_streamop(S(write_char),*stream_);
382 }
383
wr_ch_array_error(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)384 local void wr_ch_array_error (const gcv_object_t* stream_,
385 const gcv_object_t* chararray_,
386 uintL start, uintL len)
387 {
388 unused(chararray_); unused(start); unused(len);
389 error_illegal_streamop(S(write_char),*stream_);
390 }
391
wr_ch_array_dummy(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)392 local maygc void wr_ch_array_dummy (const gcv_object_t* stream_,
393 const gcv_object_t* chararray_,
394 uintL start, uintL len) {
395 var uintL end = start + len;
396 var uintL index = start;
397 SstringDispatch(*chararray_,X, {
398 do {
399 write_char(stream_,code_char(as_chart(((SstringX)TheVarobject(*chararray_))->data[index])));
400 index++;
401 } while (index < end);
402 });
403 }
404
405 /* check whether the stream is a terminal stream */
terminal_stream_p(object stream)406 global bool terminal_stream_p (object stream) {
407 if (!streamp(stream)) return false;
408 if (eq(stream,Symbol_value(S(terminal_read_stream)))) return true;
409 if (!builtin_stream_p(stream)) return false;
410 if (TheStream(stream)->strmtype == strmtype_terminal) return true;
411 if (TheStream(stream)->strmtype == strmtype_synonym)
412 return terminal_stream_p(Symbol_value /* get_synonym_stream */
413 (TheStream(stream)->strm_synonym_symbol));
414 #if 0
415 if (TheStream(stream)->strmtype == strmtype_concat) {
416 /* this is a gross hack for the CLISP kludge
417 of reading the first line with READ-LINE for *KEY-BINDINGS*
418 and then concatenating the line with the terminal stream */
419 var object list = TheStream(stream)->strm_concat_list;
420 while (consp(list)) {
421 if (terminal_stream_p(Car(list)))
422 return true;
423 list = Cdr(list);
424 }
425 return false;
426 }
427 #endif
428 return false;
429 }
430
431 /* At the end of a wr_ch_array, update the Line-Position:
432 wr_ss_lpos(stream,ptr,len);
433 > stream: Builtin-Stream, not the Terminal-Stream
434 > ptr: Pointer to the End(!) of the already written characters to the Stream
435 > len: number of characters, >0
436 < result: true, if a NL is among the characters, else false */
wr_ss_lpos(object stream,const chart * ptr,uintL len)437 local bool wr_ss_lpos (object stream, const chart* ptr, uintL len) {
438 #ifdef TERMINAL_USES_KEYBOARD
439 if (TheStream(stream)->strmtype == strmtype_terminal)
440 return false; /* On the Atari wr_ch_terminal() would do this. */
441 #endif
442 /* Add together the widths of the characters since the last NL: */
443 var bool result;
444 var uintV pos = 0;
445 var uintL count;
446 dotimespL(count,len, {
447 if (chareq(*--ptr,ascii(NL)))
448 goto found_NL;
449 pos++;
450 });
451 if (false) {
452 found_NL: /* pos characters since the last NL */
453 ptr++; len = pos; pos = 0; result = true;
454 } else { /* pos==len */
455 pos = posfixnum_to_V(TheStream(stream)->strm_wr_ch_lpos); result = false;
456 }
457 /* There were len characters starting from ptr, pos is the Position there. */
458 #ifdef TERMINAL_USES_KEYBOARD
459 pos += len;
460 #else
461 if (len > 0) {
462 if (TheStream(stream)->strmtype == strmtype_terminal) {
463 dotimespL(count,len, {
464 var chart c = *ptr++;
465 /* How do the control characters effect at that Position? */
466 if (chareq(c,ascii(BS))) {
467 /* Backspace ==> decrement Line Position, if possible: */
468 if (pos > 0)
469 pos--;
470 } else if (chareq(c,ascii(TAB))) {
471 /* Tabs have width 8 in Unix culture. */
472 pos = (pos | (8 - 1)) + 1;
473 } else
474 pos += char_width(c);
475 });
476 } else {
477 dotimespL(count,len, {
478 var chart c = *ptr++;
479 if (chareq(c,ascii(TAB))) {
480 /* Tabs have width 8 in Unix culture. */
481 pos = (pos | (8 - 1)) + 1;
482 } else
483 pos += char_width(c);
484 });
485 }
486 }
487 #endif
488 TheStream(stream)->strm_wr_ch_lpos = fixnum(pos);
489 return result;
490 }
491
492 /* Function: Returns the last character read (and not yet unread) from a stream.
493 stream_get_lastchar(stream)
494 > stream: a stream
495 < result: the last character read, or NIL
496 can trigger GC */
stream_get_lastchar(object stream)497 global maygc object stream_get_lastchar (object stream) {
498 if (builtin_stream_p(stream)) {
499 return TheStream(stream)->strm_rd_ch_last;
500 } else {
501 /* (SLOT-VALUE stream '$lastchar): */
502 var object stream_forwarded = stream;
503 instance_un_realloc(stream_forwarded);
504 instance_update(stream,stream_forwarded);
505 var object cv = TheInstance(stream_forwarded)->inst_class_version;
506 var object clas = TheClassVersion(cv)->cv_class;
507 var object slotinfo = gethash(S(lastchar),TheClass(clas)->slot_location_table,false);
508 if (!eq(slotinfo,nullobj))
509 return TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)];
510 else
511 return NIL;
512 }
513 }
514
515 /* Function: Sets the last character read (and not yet unread) of a stream.
516 stream_set_lastchar(stream,ch);
517 > stream: a non-builtin stream
518 > ch: an object (usually a character or NIL)
519 can trigger GC */
stream_set_lastchar(object stream,object ch)520 local maygc void stream_set_lastchar (object stream, object ch) {
521 ASSERT(!builtin_stream_p(stream));
522 /* (SETF (SLOT-VALUE stream '$lastchar) ch): */
523 pushSTACK(ch);
524 var object stream_forwarded = stream;
525 instance_un_realloc(stream_forwarded);
526 instance_update(stream,stream_forwarded);
527 var object cv = TheInstance(stream_forwarded)->inst_class_version;
528 var object clas = TheClassVersion(cv)->cv_class;
529 var object slotinfo = gethash(S(lastchar),TheClass(clas)->slot_location_table,false);
530 ch = popSTACK();
531 if (!eq(slotinfo,nullobj))
532 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = ch;
533 }
534
535 /* Reads a Byte from a Stream.
536 read_byte(stream)
537 > stream: Stream
538 < result: read Integer (eof_value at EOF)
539 can trigger GC */
read_byte(object stream)540 global maygc object read_byte (object stream) {
541 if (builtin_stream_p(stream)) {
542 if (TheStream(stream)->strmflags & strmflags_unread_B) {
543 /* UNREAD-CHAR was followed by a (SETF STREAM-ELEMENT-TYPE)
544 thus we _know_ that the stream element type is ([UN]SIGNED-BYTE 8) */
545 #ifdef ENABLE_UNICODE
546 var object enc = TheStream(stream)->strm_encoding;
547 var chart ch = char_code(TheStream(stream)->strm_rd_ch_last);
548 var uintB buf[4]; /* are there characters longer than 4 bytes?! */
549 var uintL char_len = cslen(enc,&ch,1);
550 ASSERT(char_len <= sizeof(buf));
551 if (char_len == 0) { /* the char corresponds to no bytes at all */
552 TheStream(stream)->strmflags &= ~strmflags_unread_B;
553 TheStream(stream)->strm_rd_ch_last = NIL;
554 goto do_read_byte;
555 }
556 cstombs(enc,&ch,1,buf,char_len);
557 var uint8 code = buf[0];
558 if (char_len == 1) { /* the char was just one byte */
559 TheStream(stream)->strmflags &= ~strmflags_unread_B;
560 TheStream(stream)->strm_rd_ch_last = NIL;
561 } else { /* encode the rest */
562 var const uintB* cbuf = buf+1; /* skip the first byte */
563 var chart* cptr = &ch;
564 Encoding_mbstowcs(enc)(enc,stream,&cbuf,buf+char_len,&cptr,cptr+1);
565 TheStream(stream)->strm_rd_ch_last = code_char(*cptr);
566 }
567 #else /* no ENABLE_UNICODE */
568 var uint8 code = as_cint(char_code(TheStream(stream)->strm_rd_ch_last));
569 TheStream(stream)->strmflags &= ~strmflags_unread_B;
570 TheStream(stream)->strm_rd_ch_last = NIL;
571 #endif
572 var object eltype = TheStream(stream)->strm_eltype;
573 if (eq(eltype,S(signed_byte))
574 || (mconsp(eltype) && eq(Car(eltype),S(signed_byte))))
575 return sfixnum((sint8)code);
576 else
577 return fixnum((uint8)code);
578 } else {
579 do_read_byte:
580 return rd_by(stream)(stream);
581 }
582 } else {
583 /* Call the generic function (STREAM-READ-BYTE stream): */
584 pushSTACK(stream); funcall(S(stream_read_byte),1);
585 var object result = value1;
586 if (eq(result,S(Keof)))
587 return eof_value;
588 else
589 return result;
590 }
591 }
592
593 /* UP: check that the return value of STREAM-READ-BYTE-SEQUENCE et al
594 > value: the value to be checked
595 > caller: the function which returned the value
596 > minval, maxval: the permissible range
597 < an integer in [minval;maxval]
598 can trigger GC */
check_value_range(object value,object caller,uintL minval,uintL maxval)599 local maygc uintL check_value_range (object value, object caller,
600 uintL minval, uintL maxval) {
601 var uintV result;
602 if (posfixnump(value)
603 && (result = posfixnum_to_V(value),
604 result >= minval && result <= maxval))
605 return result;
606 /* should we make this continuable? continue == return maxval */
607 pushSTACK(fixnum(maxval));
608 pushSTACK(fixnum(minval));
609 pushSTACK(caller);
610 pushSTACK(value);
611 error(error_condition,GETTEXT("Return value ~S of call to ~S should be an integer between ~S and ~S."));
612 }
613
614 /* Function: Reads several bytes from a stream.
615 read_byte_array(&stream,&bytearray,start,len,persev)
616 > stream: stream (on the STACK)
617 > object bytearray: simple-8bit-vector (on the STACK)
618 > uintL start: start index of byte sequence to be filled
619 > uintL len: length of byte sequence to be filled
620 > perseverance_t persev: how to react on incomplete I/O
621 < uintL result: number of bytes that have been filled
622 can trigger GC */
read_byte_array(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)623 modexp maygc uintL read_byte_array
624 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
625 uintL start, uintL len, perseverance_t persev) {
626 if (len==0)
627 return 0;
628 var object stream = *stream_;
629 if (builtin_stream_p(stream)) {
630 return rd_by_array(stream)(stream_,bytearray_,start,len,persev);
631 } else {
632 /* Call the generic function
633 (STREAM-READ-BYTE-SEQUENCE stream bytearray start start+len no-hang interactive): */
634 pushSTACK(stream); pushSTACK(*bytearray_);
635 pushSTACK(fixnum(start)); pushSTACK(fixnum(start+len));
636 pushSTACK(persev == persev_immediate || persev == persev_bonus ? T : NIL);
637 pushSTACK(persev == persev_partial ? T : NIL);
638 funcall(S(stream_read_byte_sequence),6);
639 return check_value_range(value1,S(stream_read_byte_sequence),
640 start,start+len) - start;
641 }
642 }
643
644 /* Writes a Byte to a Stream.
645 write_byte(stream,byte);
646 > stream: Stream
647 > byte: Integer to be written
648 can trigger GC */
write_byte(object stream,object byte)649 global maygc void write_byte (object stream, object byte) {
650 if (builtin_stream_p(stream)) {
651 wr_by(stream)(stream,byte);
652 } else {
653 /* Call the generic function (STREAM-WRITE-BYTE stream byte): */
654 pushSTACK(stream); pushSTACK(byte); funcall(S(stream_write_byte),2);
655 }
656 }
657
658 /* Function: Writes several bytes to a stream.
659 write_byte_array(&stream,&bytearray,start,len,persev)
660 > stream: Stream (on the STACK)
661 > object bytearray: simple-8bit-vector (on the STACK)
662 > uintL start: start index of byte sequence to be written
663 > uintL len: length of byte sequence to be written
664 > perseverance_t persev: how to react on incomplete I/O
665 < uintL result: number of bytes that have been written
666 can trigger GC */
write_byte_array(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)667 modexp maygc uintL write_byte_array
668 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
669 uintL start, uintL len, perseverance_t persev) {
670 if (len==0)
671 return 0;
672 var object stream = *stream_;
673 if (builtin_stream_p(stream)) {
674 return wr_by_array(stream)(stream_,bytearray_,start,len,persev);
675 } else {
676 /* Call the generic function
677 (STREAM-WRITE-BYTE-SEQUENCE stream bytearray start start+len no-hang interactive): */
678 pushSTACK(stream); pushSTACK(*bytearray_);
679 pushSTACK(fixnum(start)); pushSTACK(fixnum(start+len));
680 pushSTACK(persev == persev_immediate || persev == persev_bonus ? T : NIL);
681 pushSTACK(persev == persev_partial ? T : NIL);
682 funcall(S(stream_write_byte_sequence),6);
683 if (mv_count >= 2)
684 /* second return value is index of first unwritten byte
685 have to change that here into #bytes written */
686 return check_value_range(value2,S(stream_write_byte_sequence),
687 start,start+len) - start;
688 else
689 return len;
690 }
691 }
692
693 /* Reads a Character from a Stream.
694 read_char(&stream)
695 > stream: Stream
696 < stream: Stream
697 < result: read Character (eof_value at EOF)
698 can trigger GC */
read_char(const gcv_object_t * stream_)699 global maygc object read_char (const gcv_object_t* stream_) {
700 var object stream = *stream_;
701 if (builtin_stream_p(stream)) {
702 if (!(TheStream(stream)->strmflags & strmflags_unread_B)) { /* Char after UNREAD ? */
703 /* no -> fetch next character: */
704 var object newch = rd_ch(stream)(stream_);
705 stream = *stream_;
706 TheStream(stream)->strm_rd_ch_last = newch; /* and store */
707 TheStream(stream)->strmflags &= ~strmflags_unread_B;
708 return newch;
709 } else {
710 /* yes -> deleteFlagbit and fetch last character: */
711 var object ret = TheStream(stream)->strm_rd_ch_last; /* immediate */
712 TheStream(stream)->strmflags &= ~strmflags_unread_B;
713 switch (TheStream(stream)->strmtype) {
714 case strmtype_concat:
715 /* presence of rd_ch_last indicates that concat_list is non-NIL */
716 stream = Car(TheStream(stream)->strm_concat_list);
717 goto read_char_recurse;
718 case strmtype_echo:
719 case strmtype_twoway:
720 stream = TheStream(stream)->strm_twoway_input;
721 read_char_recurse:
722 pushSTACK(stream);
723 var object new_ch = read_char(&STACK_0);
724 ASSERT(eq(new_ch,ret));
725 skipSTACK(1);
726 }
727 return ret;
728 }
729 } else {
730 pushSTACK(stream);
731 /* Call the generic function (STREAM-READ-CHAR stream): */
732 pushSTACK(stream); funcall(S(stream_read_char),1);
733 var object result = value1;
734 if (eq(result,S(Keof)))
735 result = eof_value;
736 /* Store the result as slot $lastchar: */
737 stream = STACK_0; STACK_0 = result;
738 stream_set_lastchar(stream,result);
739 return popSTACK();
740 }
741 }
742
743 /* pushes the last read Character back to the Stream.
744 unread_char(&stream,ch);
745 > ch: last read Character
746 > stream: Stream
747 < stream: Stream
748 can trigger GC */
unread_char(const gcv_object_t * stream_,object ch)749 global maygc void unread_char (const gcv_object_t* stream_, object ch) {
750 var object stream = *stream_;
751 if (builtin_stream_p(stream)) {
752 if (eq(TheStream(stream)->strm_rd_ch_last,ch)
753 && !(TheStream(stream)->strmflags & strmflags_unread_B)) {
754 /* composite streams operate on their constituent streams */
755 switch (TheStream(stream)->strmtype) {
756 case strmtype_concat:
757 /* presence of rd_ch_last indicates that concat_list is non-NIL */
758 pushSTACK(Car(TheStream(stream)->strm_concat_list));
759 goto unread_char_recurse;
760 case strmtype_echo:
761 case strmtype_twoway:
762 pushSTACK(TheStream(stream)->strm_twoway_input);
763 unread_char_recurse:
764 unread_char(&STACK_0,ch);
765 skipSTACK(1);
766 stream = *stream_;
767 /*FALLTHROUGH*/
768 default:
769 TheStream(stream)->strmflags |= strmflags_unread_B; /* set Flagbit */
770 }
771 } else {
772 if (!nullp(TheStream(stream)->strm_rd_ch_last)
773 && !(TheStream(stream)->strmflags & strmflags_unread_B)) {
774 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
775 pushSTACK(ch);
776 pushSTACK(stream);
777 pushSTACK(S(unread_char));
778 error(stream_error,GETTEXT("~S: the last character read from ~S was not ~S"));
779 } else {
780 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
781 pushSTACK(S(read_char));
782 pushSTACK(stream);
783 pushSTACK(S(unread_char));
784 error(stream_error,GETTEXT("~S from ~S without ~S before it"));
785 }
786 }
787 } else {
788 pushSTACK(stream);
789 /* Call the generic function (STREAM-UNREAD-CHAR stream ch): */
790 pushSTACK(stream); pushSTACK(ch); funcall(S(stream_unread_char),2);
791 /* Set $lastchar := NIL: */
792 stream_set_lastchar(popSTACK(),NIL);
793 }
794 }
795
796 /* Reads a Character from a Stream, without consuming it.
797 peek_char(&stream)
798 > stream: Stream
799 < stream: Stream
800 < result: read Character (eof_value at EOF)
801 can trigger GC */
peek_char(const gcv_object_t * stream_)802 global maygc object peek_char (const gcv_object_t* stream_) {
803 var object stream = *stream_;
804 if (builtin_stream_p(stream)) {
805 if (!(TheStream(stream)->strmflags & strmflags_unread_B)) /* Char after UNREAD ? */
806 /* no -> fetch new character: */
807 return pk_ch(stream)(stream_);
808 else
809 /* yes -> fetch last character: */
810 return TheStream(stream)->strm_rd_ch_last;
811 } else {
812 /* Call the generic function (STREAM-PEEK-CHAR stream): */
813 pushSTACK(stream); funcall(S(stream_peek_char),1);
814 var object result = value1;
815 if (eq(result,S(Keof)))
816 return eof_value;
817 else
818 return result;
819 }
820 }
821
822 /* Function: Reads several characters from a stream.
823 read_char_array(&stream,&chararray,start,len)
824 > stream: stream (on the STACK)
825 > object chararray: a mutable string that is or was simple (on the STACK)
826 > uintL start: start index of character sequence to be filled
827 > uintL len: length of character sequence to be filled
828 < uintL result: number of characters that have been filled
829 can trigger GC */
read_char_array(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)830 global maygc uintL read_char_array (const gcv_object_t* stream_,
831 const gcv_object_t* chararray_,
832 uintL start, uintL len) {
833 if (len==0)
834 return 0;
835 var object stream = *stream_;
836 if (builtin_stream_p(stream)) {
837 var object lastchar = TheStream(stream)->strm_rd_ch_last;
838 if (eq(lastchar,eof_value)) /* EOF ? */
839 return 0;
840 var uintL index = start;
841 if (TheStream(stream)->strmflags & strmflags_unread_B) {
842 if (!charp(lastchar))
843 error_char(lastchar);
844 sstring_store(*chararray_,index++,char_code(lastchar));
845 stream = *stream_;
846 len--;
847 if (len==0) {
848 TheStream(stream)->strmflags &= ~strmflags_unread_B;
849 return 1;
850 }
851 }
852 var uintL count = rd_ch_array(stream)(stream_,chararray_,index,len);
853 index += count;
854 stream = *stream_;
855 if (count == len) {
856 var object chararray = *chararray_;
857 sstring_un_realloc(chararray);
858 var chart last_ch = schar(chararray,index-1);
859 TheStream(stream)->strm_rd_ch_last = code_char(last_ch);
860 } else
861 TheStream(stream)->strm_rd_ch_last = eof_value;
862 TheStream(stream)->strmflags &= ~strmflags_unread_B;
863 return index - start;
864 } else {
865 pushSTACK(stream);
866 /* Call the generic function
867 (STREAM-READ-CHAR-SEQUENCE stream chararray start start+len): */
868 pushSTACK(stream); pushSTACK(*chararray_);
869 pushSTACK(fixnum(start)); pushSTACK(fixnum(start+len));
870 funcall(S(stream_read_char_sequence),4);
871 var uintV result =
872 check_value_range(value1,S(stream_read_char_sequence),start,start+len);
873 /* Set the stream's $lastchar := last char or #<EOF>: */
874 var object lastchar;
875 if (result-start == len) {
876 var object chararray = *chararray_;
877 sstring_un_realloc(chararray);
878 lastchar = code_char(schar(chararray,result-1));
879 } else
880 lastchar = eof_value;
881 stream_set_lastchar(popSTACK(),lastchar);
882 return result-start;
883 }
884 }
885
886 /* Function that handles the pending newline before doing the real job. */
wr_ch_pending_newline(const gcv_object_t * stream_,object obj)887 local maygc void wr_ch_pending_newline (const gcv_object_t* stream_, object obj)
888 {
889 var object stream = *stream_;
890 TheStream(stream)->strm_wr_ch = TheStream(stream)->strm_wr_ch_npnl;
891 TheStream(stream)->strm_wr_ch_array = TheStream(stream)->strm_wr_ch_array_npnl;
892 if (!eq(obj,ascii_char(NL))) {
893 pushSTACK(obj);
894 write_char(stream_,ascii_char(NL));
895 obj = popSTACK();
896 }
897 write_char(stream_,obj);
898 }
899
900 /* writes a Character to a Stream.
901 write_char(&stream,ch);
902 > ch: Character to be written
903 > stream: Stream
904 < stream: Stream
905 can trigger GC */
write_char(const gcv_object_t * stream_,object ch)906 global maygc void write_char (const gcv_object_t* stream_, object ch) {
907 var object stream = *stream_;
908 if (builtin_stream_p(stream)) {
909 var chart c = char_code(ch);
910 /* write Char: */
911 wr_ch(stream)(stream_,ch);
912 /* update Line Position: */
913 var object stream = *stream_;
914 if (!(TheStream(stream)->strmtype == strmtype_terminal)) {
915 /* not the Terminal-Stream */
916 if (chareq(c,ascii(NL))) /* After Newline: Line Position := 0 */
917 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
918 else if (chareq(c,ascii(TAB))) /* Tab width is 8 in Unix culture. */
919 TheStream(stream)->strm_wr_ch_lpos =
920 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,
921 8 - fixnum_to_V(TheStream(stream)->strm_wr_ch_lpos) % 8);
922 else /* increment line position */
923 TheStream(stream)->strm_wr_ch_lpos =
924 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,char_width(c));
925 } else { /* it is the Terminal-Stream */
926 #ifdef TERMINAL_USES_KEYBOARD
927 /* On the Atari, wr_ch_terminal() would do this. */
928 #else
929 /* How do the control-characters effect in that Position? */
930 if (chareq(c,ascii(NL))) { /* Newline -> Line Position := 0 */
931 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
932 } else if (chareq(c,ascii(BS))) {
933 /* Backspace -> Line Position, if possible, decrement: */
934 if (!eq(TheStream(stream)->strm_wr_ch_lpos,Fixnum_0))
935 TheStream(stream)->strm_wr_ch_lpos =
936 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,-1);
937 } else if (chareq(c,ascii(TAB))) /* Tab width is 8 in Unix culture. */
938 TheStream(stream)->strm_wr_ch_lpos =
939 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,
940 8 - fixnum_to_V(TheStream(stream)->strm_wr_ch_lpos) % 8);
941 else /* increment line position */
942 TheStream(stream)->strm_wr_ch_lpos =
943 fixnum_inc(TheStream(stream)->strm_wr_ch_lpos,char_width(c));
944 #endif
945 }
946 } else {
947 pushSTACK(stream); pushSTACK(ch);
948 /* Test (SLOT-VALUE stream '$penl): */
949 var object stream_forwarded = stream;
950 instance_un_realloc(stream_forwarded);
951 instance_update(stream,stream_forwarded);
952 var object cv = TheInstance(stream_forwarded)->inst_class_version;
953 var object clas = TheClassVersion(cv)->cv_class;
954 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
955 if (!nullp(TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)])) {
956 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = NIL;
957 if (!eq(STACK_0,ascii_char(NL))) {
958 /* Call the generic function (STREAM-WRITE-CHAR stream #\Newline): */
959 pushSTACK(STACK_1); pushSTACK(ascii_char(NL));
960 funcall(S(stream_write_char),2);
961 }
962 }
963 /* Call the generic function (STREAM-WRITE-CHAR stream ch): */
964 funcall(S(stream_write_char),2);
965 }
966 }
967
968 /* Function that handles the pending newline before doing the real job. */
wr_ch_array_pending_newline(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)969 local maygc void wr_ch_array_pending_newline (const gcv_object_t* stream_,
970 const gcv_object_t* chararray_,
971 uintL start, uintL len) {
972 var object stream = *stream_;
973 TheStream(stream)->strm_wr_ch = TheStream(stream)->strm_wr_ch_npnl;
974 TheStream(stream)->strm_wr_ch_array = TheStream(stream)->strm_wr_ch_array_npnl;
975 var bool next_is_NL;
976 SstringDispatch(*chararray_,X, {
977 next_is_NL = chareq(as_chart(((SstringX)TheVarobject(*chararray_))->data[start]),ascii(NL));
978 });
979 if (!next_is_NL)
980 write_char(stream_,ascii_char(NL));
981 write_char_array(stream_,chararray_,start,len);
982 }
983
984 /* Function: Writes several characters to a stream.
985 write_char_array(&stream,&chararray,start,len)
986 > stream: stream (on the STACK)
987 > object chararray: not-reallocated simple-string (on the STACK)
988 > uintL start: start index of character sequence to be written
989 > uintL len: length of character sequence to be written
990 can trigger GC */
write_char_array(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)991 global maygc void write_char_array (const gcv_object_t* stream_,
992 const gcv_object_t* chararray_,
993 uintL start, uintL len) {
994 if (len==0)
995 return;
996 var object stream = *stream_;
997 if (builtin_stream_p(stream)) {
998 wr_ch_array(stream)(stream_,chararray_,start,len);
999 } else {
1000 /* Test (SLOT-VALUE stream '$penl): */
1001 var object stream_forwarded = stream;
1002 instance_un_realloc(stream_forwarded);
1003 instance_update(stream,stream_forwarded);
1004 var object cv = TheInstance(stream_forwarded)->inst_class_version;
1005 var object clas = TheClassVersion(cv)->cv_class;
1006 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
1007 if (!nullp(TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)])) {
1008 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = NIL;
1009 var bool next_is_NL;
1010 SstringDispatch(*chararray_,X, {
1011 next_is_NL = chareq(as_chart(((SstringX)TheVarobject(*chararray_))->data[start]),ascii(NL));
1012 });
1013 if (!next_is_NL) {
1014 /* Call the generic function (STREAM-WRITE-CHAR stream #\Newline): */
1015 pushSTACK(*stream_); pushSTACK(ascii_char(NL));
1016 funcall(S(stream_write_char),2);
1017 }
1018 }
1019 /* Call the generic function
1020 (STREAM-WRITE-CHAR-SEQUENCE stream chararray start start+len): */
1021 pushSTACK(*stream_); pushSTACK(*chararray_);
1022 pushSTACK(fixnum(start)); pushSTACK(fixnum(start+len));
1023 funcall(S(stream_write_char_sequence),4);
1024 }
1025 }
1026
1027 /* Outputs a real newline if an elastic newline is pending on the stream.
1028 harden_elastic_newline(&stream);
1029 > stream: Stream
1030 < stream: Stream
1031 can trigger GC */
harden_elastic_newline(const gcv_object_t * stream_)1032 local maygc void harden_elastic_newline (const gcv_object_t* stream_) {
1033 var object stream = *stream_;
1034 if (builtin_stream_p(stream)) {
1035 if (eq(TheStream(stream)->strm_wr_ch,P(wr_ch_pending_newline))) {
1036 TheStream(stream)->strm_wr_ch = TheStream(stream)->strm_wr_ch_npnl;
1037 TheStream(stream)->strm_wr_ch_array = TheStream(stream)->strm_wr_ch_array_npnl;
1038 write_char(stream_,ascii_char(NL));
1039 }
1040 } else {
1041 /* Test (SLOT-VALUE stream '$penl): */
1042 var object stream_forwarded = stream;
1043 instance_un_realloc(stream_forwarded);
1044 instance_update(stream,stream_forwarded);
1045 var object cv = TheInstance(stream_forwarded)->inst_class_version;
1046 var object clas = TheClassVersion(cv)->cv_class;
1047 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
1048 if (!nullp(TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)])) {
1049 /* (SETF (SLOT-VALUE stream '$penl) NIL): */
1050 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = NIL;
1051 write_char(stream_,ascii_char(NL));
1052 }
1053 }
1054 }
1055
1056 /* UP: when closing, fill the stream with the dummy pseudo-functions
1057 and remove the capability flags
1058 close_dummys(stream);
1059 > stream: Stream */
1060 #define close_dummys(s) \
1061 stream_dummy_fill(s); \
1062 /* delete capability flags */\
1063 TheStream(s)->strmflags &= ~(strmflags_open_B|strmflags_unread_B)
1064
1065 /* fill the stream with dummy pseudo-functions */
stream_dummy_fill(object stream)1066 local void stream_dummy_fill (object stream) {
1067 var Stream s = TheStream(stream);
1068 s->strm_rd_by = P(rd_by_error);
1069 s->strm_rd_by_array = P(rd_by_array_error);
1070 s->strm_wr_by = P(wr_by_error);
1071 s->strm_wr_by_array = P(wr_by_array_error);
1072 s->strm_rd_ch = P(rd_ch_error);
1073 s->strm_pk_ch = P(pk_ch_dummy);
1074 s->strm_rd_ch_array = P(rd_ch_array_error);
1075 s->strm_rd_ch_last = NIL; /* Lastchar := NIL */
1076 s->strm_wr_ch_lpos = Fixnum_0;
1077 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_error);
1078 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_error);
1079 }
1080
1081 /* returns error-message, if the value of the Symbol sym is not a Stream. */
1082 local _Noreturn void error_value_stream (object sym);
1083 /* see below */
1084
1085 /* UP: Returns the Stream, that is the value of a Variable.
1086 var_stream(sym,streamflags)
1087 > sym: Variable (Symbol)
1088 > streamflags: set of Operations, that are to be possible on the Stream
1089 < result: Stream */
var_stream(object sym,uintB streamflags)1090 global object var_stream (object sym, uintB streamflags) {
1091 var object stream;
1092 recurse:
1093 stream = Symbol_value(sym);
1094 if (builtin_stream_p(stream)) {
1095 if ((streamflags | strmflags_open_B) & ~ TheStream(stream)->strmflags)
1096 error_value_stream(sym);
1097 if (TheStream(stream)->strmtype == strmtype_synonym) {
1098 sym = TheStream(stream)->strm_synonym_symbol;
1099 goto recurse;
1100 }
1101 } else if (instanceof(stream,O(class_fundamental_stream))) {
1102 /* Among instances of FUNDAMENTAL-STREAM:
1103 Only instances of FUNDAMENTAL-INPUT-STREAM can do input.
1104 Only instances of FUNDAMENTAL-OUTPUT-STREAM can do output. */
1105 if (((streamflags & strmflags_rd_B)
1106 && !instanceof(stream,O(class_fundamental_input_stream)))
1107 || ((streamflags & strmflags_wr_B)
1108 && !instanceof(stream,O(class_fundamental_output_stream))))
1109 error_value_stream(sym);
1110 } else
1111 error_value_stream(sym);
1112 return stream;
1113 }
1114
1115 /* (SYSTEM::SYMBOL-STREAM symbol [direction])
1116 returns the Stream, that is the value of the Symbol, and checks, if it is an
1117 open Stream with Direction direction (:PROBE, :INPUT, :OUTPUT or :IO) . */
1118 LISPFUN(symbol_stream,seclass_read,1,1,norest,nokey,0,NIL) {
1119 var object symbol = check_symbol(STACK_1);
1120 var object direction = STACK_0; skipSTACK(2);
1121 VALUES1(var_stream(symbol,(uintB)(
1122 eq(direction,S(Kinput)) ? strmflags_rd_ch_B : /* :INPUT */
1123 eq(direction,S(Koutput)) ? strmflags_wr_ch_B : /* :OUTPUT */
1124 eq(direction,S(Kio)) ?
1125 strmflags_rd_ch_B | strmflags_wr_ch_B : /* :IO */
1126 0))); /* :PROBE or not given */
1127 }
1128
1129 /* signal an error if for some obscure reason a WRITE should not work: */
error_unwritable(object caller,object stream)1130 local _Noreturn void error_unwritable (object caller, object stream)
1131 {
1132 pushSTACK(stream); /* FILE-ERROR slot PATHNAME */
1133 pushSTACK(stream);
1134 pushSTACK(caller);
1135 error(file_error,GETTEXT("~S: cannot output to ~S"));
1136 }
1137
1138 /* signal an error if an Object is not the needed type:
1139 error_write(stream,obj,type); */
error_write(object stream,object obj,object type)1140 local _Noreturn void error_write (object stream, object obj, object type) {
1141 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1142 pushSTACK(type); /* TYPE-ERROR slot EXPECTED-TYPE */
1143 pushSTACK(type); pushSTACK(stream); pushSTACK(obj);
1144 pushSTACK(TheSubr(subr_self)->name);
1145 error(type_error,GETTEXT("~S: cannot output ~S into ~S, not of type ~S"));
1146 }
1147
1148 /* WRITE-CHAR pseudo-function for output streams of element type NIL */
wr_ch_forbidden(const gcv_object_t * stream_,object ch)1149 local maygc void wr_ch_forbidden (const gcv_object_t* stream_, object ch)
1150 {
1151 error_write(*stream_,ch,NIL);
1152 }
1153
1154 /* WRITE-CHAR-ARRAY pseudo-function for output streams of element type NIL */
wr_ch_array_forbidden(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)1155 local maygc void wr_ch_array_forbidden (const gcv_object_t* stream_,
1156 const gcv_object_t* chararray_,
1157 uintL start, uintL len)
1158 {
1159 unused start;
1160 unused len;
1161 error_write(*stream_,*chararray_,NIL);
1162 }
1163
1164 #define check_wr_char(s,c) if(!charp(c)) error_write(s,c,S(character))
1165
1166 /* signal an error if an Integer is out of range:
1167 error_bad_integer(stream,obj); */
error_bad_integer(object stream,object obj)1168 local _Noreturn void error_bad_integer (object stream, object obj) {
1169 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
1170 pushSTACK(stream); pushSTACK(obj);
1171 error(stream_error,GETTEXT("integer ~S is out of range, cannot be output onto ~S"));
1172 }
1173
1174 /* Error message and get a replacement for an argument
1175 which isn't a stream of the requested stream-type:
1176 get_streamtype_replacement(obj,type);
1177 > obj: the faulty argument
1178 > type: requested stream-type
1179 can trigger GC */
get_streamtype_replacement(object obj,object type)1180 local maygc object get_streamtype_replacement (object obj, object type) {
1181 pushSTACK(NIL); /* no PLACE */
1182 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
1183 pushSTACK(type); /* TYPE-ERROR slot EXPECTED-TYPE */
1184 pushSTACK(type); pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
1185 check_value(type_error,GETTEXT("~S: argument ~S is not a stream of type ~S"));
1186 return value1;
1187 }
1188
1189 /* barf if the object is not a stream of the specific type */
1190 #define CHECK_streamtype(obj,type,test) \
1191 while(!(test)) obj = get_streamtype_replacement(obj,type)
1192 /* barf if the object is not a built-in stream */
1193 #define CHECK_builtin_stream(obj) \
1194 CHECK_streamtype(obj,O(type_builtin_stream),(builtin_stream_p(obj)))
1195 /* barf of the object is not an integer */
1196 #define ASSERT_wr_int(stream,obj) \
1197 if (!integerp(obj)) error_write(stream,obj,S(integer))
1198
1199 /* UP: checks, if Arguments are Streams.
1200 check_stream_args(args_pointer,argcount);
1201 > args_pointer: Pointer to the Arguments
1202 > argcount: number of Arguments
1203 can trigger GC */
check_stream_args(gcv_object_t * args_pointer,uintC argcount)1204 local maygc void check_stream_args (gcv_object_t* args_pointer, uintC argcount) {
1205 while (argcount--) {
1206 var gcv_object_t *next_arg_ptr = &NEXT(args_pointer);
1207 *next_arg_ptr = check_stream(*next_arg_ptr);
1208 };
1209 }
1210
1211 /* forward declaration */
1212 local object resolve_synonym_stream (object stream);
1213
1214 /* Function: Tests whether an object is an input-stream.
1215 input_stream_p(stream)
1216 > stream: object */
input_stream_p(object stream)1217 local bool input_stream_p (object stream) {
1218 stream = resolve_synonym_stream(stream);
1219 return (builtin_stream_p(stream) ?
1220 (TheStream(stream)->strmflags & strmflags_rd_B) != 0
1221 : instanceof(stream,O(class_fundamental_input_stream)));
1222 }
1223
1224 /* Function: Tests whether an object is an output-stream.
1225 output_stream_p(stream)
1226 > stream: object */
output_stream_p(object stream)1227 local bool output_stream_p (object stream) {
1228 stream = resolve_synonym_stream(stream);
1229 return (builtin_stream_p(stream) ?
1230 (TheStream(stream)->strmflags & strmflags_wr_B) != 0
1231 : instanceof(stream,O(class_fundamental_output_stream)));
1232 }
1233
1234 /* UP: checks an Input-Stream.
1235 test_input_stream(stream);
1236 > stream: Stream */
1237 #define test_input_stream(stream) \
1238 if (!input_stream_p(stream)) error_input_stream(stream);
error_input_stream(object stream)1239 local _Noreturn void error_input_stream (object stream) {
1240 pushSTACK(stream); /* TYPE-ERROR slot DATUM */
1241 pushSTACK(O(type_input_stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
1242 pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name);
1243 error(type_error,GETTEXT("~S: argument ~S should be an input stream"));
1244 }
1245
1246 /* UP: checks an Output-Stream.
1247 test_output_stream(stream);
1248 > stream: Stream */
1249 #define test_output_stream(stream) \
1250 if (!output_stream_p(stream)) error_output_stream(stream);
error_output_stream(object stream)1251 local _Noreturn void error_output_stream (object stream) {
1252 pushSTACK(stream); /* TYPE-ERROR slot DATUM */
1253 pushSTACK(O(type_output_stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
1254 pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name);
1255 error(type_error,GETTEXT("~S: argument ~S should be an output stream"));
1256 }
1257
1258 /* UP: checks, if Arguments are Input-Streams.
1259 test_input_stream_args(args_pointer,argcount);
1260 > args_pointer: Pointer to the Arguments
1261 > argcount: number of Arguments */
1262 #define test_input_stream_args(args_pointer,argcount) \
1263 if (argcount > 0) { \
1264 var gcv_object_t* pointer = (args_pointer); \
1265 var uintC count; \
1266 dotimespC(count,argcount, { \
1267 var object arg = Next(pointer); \
1268 NEXT(pointer) = arg = check_stream(arg); \
1269 test_input_stream(arg); \
1270 }); \
1271 }
1272
1273 /* UP: checks, if Arguments are Output-Streams.
1274 test_output_stream_args(args_pointer,argcount);
1275 > args_pointer: Pointer to the Arguments
1276 > argcount: number of Arguments */
1277 #define test_output_stream_args(args_pointer,argcount) \
1278 if (argcount > 0) { \
1279 var gcv_object_t* pointer = (args_pointer); \
1280 var uintC count; \
1281 dotimespC(count,argcount, { \
1282 var object arg = Next(pointer); \
1283 NEXT(pointer) = arg = check_stream(arg); \
1284 test_output_stream(arg); \
1285 }); \
1286 }
1287
1288
1289 /* Synonym-Stream
1290 ==============
1291
1292 Additional Components:
1293 define strm_synonym_symbol strm_other[0] - Symbol, whose value is referred to
1294
1295 Macro: Returns the value of a Symbol, a Stream.
1296 get_synonym_stream(sym)
1297 > sym: Symbol, a variable
1298 < result: its value, a Stream */
1299 #define get_synonym_stream(sym) \
1300 (!streamp(Symbol_value(sym)) \
1301 ? (error_value_stream(sym), unbound) \
1302 : (object)Symbol_value(sym))
1303
1304 /* Macro: resolve the synonym stream */
1305 #define resolve_as_synonym(stream) \
1306 do { object symbol = TheStream(stream)->strm_synonym_symbol; \
1307 stream = get_synonym_stream(symbol); } while (0)
1308
1309 /* Function: resolve the synonym stream */
resolve_synonym_stream(object stream)1310 local object resolve_synonym_stream (object stream) {
1311 while (builtin_stream_p(stream)
1312 && TheStream(stream)->strmtype == strmtype_synonym) {
1313 var object symbol = TheStream(stream)->strm_synonym_symbol;
1314 stream = get_synonym_stream(symbol);
1315 }
1316 return stream;
1317 }
1318
1319 /* READ-BYTE - Pseudo-Function for Synonym-Streams: */
rd_by_synonym(object stream)1320 local maygc object rd_by_synonym (object stream) {
1321 check_SP();
1322 var object symbol = TheStream(stream)->strm_synonym_symbol;
1323 return read_byte(get_synonym_stream(symbol));
1324 }
1325
1326 /* READ-BYTE-ARRAY - Pseudo-Function for Synonym-Streams: */
rd_by_array_synonym(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)1327 local maygc uintL rd_by_array_synonym (const gcv_object_t* stream_,
1328 const gcv_object_t* bytearray_,
1329 uintL start, uintL len,
1330 perseverance_t persev) {
1331 check_SP(); check_STACK();
1332 var object symbol = TheStream(*stream_)->strm_synonym_symbol;
1333 pushSTACK(get_synonym_stream(symbol));
1334 var uintL result = read_byte_array(&STACK_0,bytearray_,start,len,persev);
1335 skipSTACK(1);
1336 return result;
1337 }
1338
1339 /* WRITE-BYTE - Pseudo-Function for Synonym-Streams: */
wr_by_synonym(object stream,object obj)1340 local maygc void wr_by_synonym (object stream, object obj) {
1341 check_SP();
1342 var object symbol = TheStream(stream)->strm_synonym_symbol;
1343 write_byte(get_synonym_stream(symbol),obj);
1344 }
1345
1346 /* WRITE-BYTE-ARRAY - Pseudo-Function for Synonym-Streams: */
wr_by_array_synonym(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)1347 local maygc uintL wr_by_array_synonym (const gcv_object_t* stream_,
1348 const gcv_object_t* bytearray_,
1349 uintL start, uintL len,
1350 perseverance_t persev) {
1351 check_SP(); check_STACK();
1352 var object symbol = TheStream(*stream_)->strm_synonym_symbol;
1353 pushSTACK(get_synonym_stream(symbol));
1354 var uintL result = write_byte_array(&STACK_0,bytearray_,start,len,persev);
1355 skipSTACK(1);
1356 return result;
1357 }
1358
1359 /* READ-CHAR - Pseudo-Function for Synonym-Streams: */
rd_ch_synonym(const gcv_object_t * stream_)1360 local maygc object rd_ch_synonym (const gcv_object_t* stream_) {
1361 check_SP(); check_STACK();
1362 var object stream = *stream_;
1363 var object symbol = TheStream(stream)->strm_synonym_symbol;
1364 pushSTACK(get_synonym_stream(symbol));
1365 var object result = read_char(&STACK_0);
1366 skipSTACK(1);
1367 return result;
1368 }
1369
1370 /* PEEK-CHAR - Pseudo-Function for Synonym-Streams: */
pk_ch_synonym(const gcv_object_t * stream_)1371 local maygc object pk_ch_synonym (const gcv_object_t* stream_) {
1372 check_SP(); check_STACK();
1373 var object stream = *stream_;
1374 var object symbol = TheStream(stream)->strm_synonym_symbol;
1375 pushSTACK(get_synonym_stream(symbol));
1376 var object result = peek_char(&STACK_0);
1377 skipSTACK(1);
1378 return result;
1379 }
1380
1381 /* READ-CHAR-ARRAY - Pseudo-Function for Synonym-Streams: */
rd_ch_array_synonym(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)1382 local maygc uintL rd_ch_array_synonym (const gcv_object_t* stream_,
1383 const gcv_object_t* chararray_,
1384 uintL start, uintL len) {
1385 check_SP(); check_STACK();
1386 var object symbol = TheStream(*stream_)->strm_synonym_symbol;
1387 pushSTACK(get_synonym_stream(symbol));
1388 var uintL result = read_char_array(&STACK_0,chararray_,start,len);
1389 skipSTACK(1);
1390 return result;
1391 }
1392
1393 /* WRITE-CHAR - Pseudo-Function for Synonym-Streams: */
wr_ch_synonym(const gcv_object_t * stream_,object obj)1394 local maygc void wr_ch_synonym (const gcv_object_t* stream_, object obj) {
1395 check_SP(); check_STACK();
1396 var object stream = *stream_;
1397 var object symbol = TheStream(stream)->strm_synonym_symbol;
1398 pushSTACK(get_synonym_stream(symbol));
1399 write_char(&STACK_0,obj);
1400 skipSTACK(1);
1401 }
1402
1403 /* WRITE-CHAR-ARRAY - Pseudo-Function for Synonym-Streams: */
wr_ch_array_synonym(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)1404 local maygc void wr_ch_array_synonym (const gcv_object_t* stream_,
1405 const gcv_object_t* chararray_,
1406 uintL start, uintL len) {
1407 check_SP(); check_STACK();
1408 var object symbol = TheStream(*stream_)->strm_synonym_symbol;
1409 pushSTACK(get_synonym_stream(symbol));
1410 write_char_array(&STACK_0,chararray_,start,len);
1411 skipSTACK(1);
1412 /* No need to update wr_ch_lpos here. (See get_line_position().) */
1413 }
1414
1415 /* Closes a Synonym-Stream.
1416 close_synonym(stream, abort);
1417 > stream : Synonym-Stream
1418 > abort: flag: non-0 => ignore errors */
1419 #ifdef X3J13_014
1420 #define close_synonym(stream,abort)
1421 #else
close_synonym(object stream,uintB abort)1422 local maygc void close_synonym (object stream, uintB abort) {
1423 check_SP(); check_STACK();
1424 var object symbol = TheStream(stream)->strm_synonym_symbol;
1425 var int argcount = 1;
1426 pushSTACK(get_synonym_stream(symbol));
1427 if (abort) { pushSTACK(S(Kabort)); pushSTACK(T); argcount=3; }
1428 funcall(S(closeL),argcount);
1429 }
1430 #endif
1431
1432 /* Reads a line of characters from a synonym-stream.
1433 read_line_synonym(stream,&buffer)
1434 > stream: synonym-stream
1435 > buffer: a semi-simple string
1436 < buffer: contains the read characters, excluding the terminating #\Newline
1437 < result: true if EOF was seen before newline, else false
1438 can trigger GC */
read_line_synonym(object stream,const gcv_object_t * buffer_)1439 local maygc bool read_line_synonym (object stream, const gcv_object_t* buffer_)
1440 {
1441 check_SP(); check_STACK();
1442 var object symbol = TheStream(stream)->strm_synonym_symbol;
1443 pushSTACK(get_synonym_stream(symbol));
1444 var bool eofp = read_line(&STACK_0,buffer_);
1445 skipSTACK(1);
1446 return eofp;
1447 }
1448
1449 /* Determines, if a character is available on the Synonym-Stream.
1450 listen_char_synonym(stream)
1451 > stream : Synonym-Stream
1452 < result: input availability
1453 can trigger GC */
listen_char_synonym(object stream)1454 local maygc listen_t listen_char_synonym (object stream) {
1455 check_SP();
1456 var object symbol = TheStream(stream)->strm_synonym_symbol;
1457 return listen_char(get_synonym_stream(symbol));
1458 }
1459
1460 /* UP: Deletes already entered interactive Input from a Synonym-Stream.
1461 clear_input_synonym(stream)
1462 > stream: Synonym-Stream
1463 < result: true if Input was deleted
1464 can trigger GC */
clear_input_synonym(object stream)1465 local maygc bool clear_input_synonym (object stream) {
1466 check_SP();
1467 var object symbol = TheStream(stream)->strm_synonym_symbol;
1468 return clear_input(get_synonym_stream(symbol));
1469 }
1470
1471 /* Determines, if a Byte is available on a Synonym-Stream.
1472 listen_byte_synonym(stream)
1473 > stream : Synonym-Stream
1474 < result: input availability
1475 can trigger GC */
listen_byte_synonym(object stream)1476 local maygc listen_t listen_byte_synonym (object stream) {
1477 check_SP();
1478 var object symbol = TheStream(stream)->strm_synonym_symbol;
1479 return listen_byte(get_synonym_stream(symbol));
1480 }
1481
1482 /* UP: bring pending Output of a Synonym-Stream to the destination.
1483 finish_output_synonym(stream);
1484 > stream: Synonym-Stream
1485 can trigger GC */
finish_output_synonym(object stream)1486 local maygc void finish_output_synonym (object stream) {
1487 check_SP();
1488 var object symbol = TheStream(stream)->strm_synonym_symbol;
1489 finish_output(get_synonym_stream(symbol));
1490 }
1491
1492 /* UP: bring pending Output of a Synonym-Stream to the destination.
1493 force_output_synonym(stream);
1494 > stream: Synonym-Stream
1495 can trigger GC */
force_output_synonym(object stream)1496 local maygc void force_output_synonym (object stream) {
1497 check_SP();
1498 var object symbol = TheStream(stream)->strm_synonym_symbol;
1499 force_output(get_synonym_stream(symbol));
1500 }
1501
1502 /* UP: delete the pending Output of a Synonym-Stream.
1503 clear_output_synonym(stream);
1504 > stream: Synonym-Stream
1505 can trigger GC */
clear_output_synonym(object stream)1506 local maygc void clear_output_synonym (object stream) {
1507 check_SP();
1508 var object symbol = TheStream(stream)->strm_synonym_symbol;
1509 clear_output(get_synonym_stream(symbol));
1510 }
1511
1512 /* Returns a Synonym-Stream for a Symbol.
1513 make_synonym_stream(symbol)
1514 > symbol : Symbol
1515 < result : new Synonym-Stream
1516 can trigger GC */
make_synonym_stream(object symbol)1517 local maygc object make_synonym_stream (object symbol) {
1518 pushSTACK(symbol); /* save Symbol */
1519 var object stream = /* new Stream, all Operations permitted */
1520 allocate_stream(strmflags_rdwr_B,strmtype_synonym,strm_len+1,0);
1521 TheStream(stream)->strm_rd_by = P(rd_by_synonym);
1522 TheStream(stream)->strm_rd_by_array = P(rd_by_array_synonym);
1523 TheStream(stream)->strm_wr_by = P(wr_by_synonym);
1524 TheStream(stream)->strm_wr_by_array = P(wr_by_array_synonym);
1525 TheStream(stream)->strm_rd_ch = P(rd_ch_synonym);
1526 TheStream(stream)->strm_pk_ch = P(pk_ch_synonym);
1527 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_synonym);
1528 TheStream(stream)->strm_rd_ch_last = NIL;
1529 TheStream(stream)->strm_wr_ch =
1530 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_synonym);
1531 TheStream(stream)->strm_wr_ch_array =
1532 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_synonym);
1533 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
1534 TheStream(stream)->strm_synonym_symbol = popSTACK();
1535 return stream;
1536 }
1537
1538 LISPFUNNR(make_synonym_stream,1)
1539 { /* (MAKE-SYNONYM-STREAM symbol), CLTL p. 329 */
1540 var object arg = popSTACK();
1541 if (!symbolp(arg)) {
1542 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
1543 pushSTACK(S(symbol)); /* TYPE-ERROR slot EXPECTED-TYPE */
1544 pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
1545 error(type_error,GETTEXT("~S: argument should be a symbol, not ~S"));
1546 }
1547 VALUES1(make_synonym_stream(arg));
1548 }
1549
1550 LISPFUNNF(synonym_stream_p,1)
1551 { /* (SYS::SYNONYM-STREAM-P stream) == (TYPEP stream 'SYNONYM-STREAM) */
1552 var object arg = popSTACK();
1553 VALUES_IF(builtin_stream_p(arg)
1554 && (TheStream(arg)->strmtype == strmtype_synonym));
1555 }
1556
1557 LISPFUNNR(synonym_stream_symbol,1)
1558 { /* (SYNONYM-STREAM-SYMBOL stream), CLtL2 p. 507 */
1559 var object stream = popSTACK();
1560 CHECK_streamtype(stream,S(synonym_stream),
1561 (builtin_stream_p(stream)
1562 && (TheStream(stream)->strmtype == strmtype_synonym)));
1563 VALUES1(TheStream(stream)->strm_synonym_symbol);
1564 }
1565
1566
1567 /* Broadcast-Stream
1568 ================
1569
1570 Additional Components:
1571 define strm_broad_list strm_other[0] - list of streams
1572
1573 WRITE-BYTE - Pseudo-Function for Broadcast-Streams: */
wr_by_broad(object stream,object obj)1574 local maygc void wr_by_broad (object stream, object obj) {
1575 check_SP(); check_STACK();
1576 pushSTACK(obj);
1577 { /* list of streams */
1578 var object streamlist = TheStream(stream)->strm_broad_list;
1579 /* write obj to each Stream on the List: */
1580 while (consp(streamlist)) {
1581 pushSTACK(Cdr(streamlist)); /* remaining Streams */
1582 write_byte(Car(streamlist),STACK_1); /* write obj */
1583 streamlist = popSTACK();
1584 }
1585 }
1586 skipSTACK(1);
1587 }
1588
1589 /* WRITE-BYTE-ARRAY - Pseudo-Function for Broadcast-Streams: */
wr_by_array_broad(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)1590 local maygc uintL wr_by_array_broad (const gcv_object_t* stream_,
1591 const gcv_object_t* bytearray_,
1592 uintL start, uintL len,
1593 perseverance_t persev) {
1594 /* what happens if different streams write different amounts?
1595 Only persev_full is supported for broadcast streams. */
1596 if (persev != persev_full) {
1597 error_illegal_streamop(S(write_byte_sequence),*stream_);
1598 }
1599 check_SP(); check_STACK();
1600 pushSTACK(TheStream(*stream_)->strm_broad_list); /* list of streams */
1601 var object streamlist;
1602 while (streamlist = STACK_0, consp(streamlist)) {
1603 STACK_0 = Cdr(streamlist);
1604 pushSTACK(Car(streamlist));
1605 write_byte_array(&STACK_0,bytearray_,start,len,persev);
1606 skipSTACK(1);
1607 }
1608 skipSTACK(1);
1609 return len;
1610 }
1611
1612 /* WRITE-CHAR - Pseudo-Function for Broadcast-Streams: */
wr_ch_broad(const gcv_object_t * stream_,object obj)1613 local maygc void wr_ch_broad (const gcv_object_t* stream_, object obj) {
1614 check_SP(); check_STACK();
1615 pushSTACK(obj);
1616 pushSTACK(NIL); /* dummy */
1617 pushSTACK(TheStream(*stream_)->strm_broad_list); /* list of streams */
1618 /* write obj to each Stream on the List: */
1619 while (mconsp(STACK_0)) {
1620 /* Stack Layout: obj, dummy, streamlistr. */
1621 STACK_1 = Car(STACK_0); /* a Stream from the Liste */
1622 write_char(&STACK_1,STACK_2); /* write obj */
1623 STACK_0 = Cdr(STACK_0);
1624 }
1625 skipSTACK(3);
1626 }
1627
1628 /* WRITE-CHAR-ARRAY - Pseudo-Function for Broadcast-Streams: */
wr_ch_array_broad(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)1629 local maygc void wr_ch_array_broad (const gcv_object_t* stream_,
1630 const gcv_object_t* chararray_,
1631 uintL start, uintL len) {
1632 check_SP(); check_STACK();
1633 pushSTACK(TheStream(*stream_)->strm_broad_list); /* list of streams */
1634 pushSTACK(NIL); /* dummy */
1635 var object streamlist;
1636 while (streamlist = STACK_1, consp(streamlist)) {
1637 STACK_1 = Cdr(streamlist);
1638 STACK_0 = Car(streamlist);
1639 write_char_array(&STACK_0,chararray_,start,len);
1640 }
1641 skipSTACK(2);
1642 /* No need to update wr_ch_lpos here. (See get_line_position().) */
1643 }
1644
1645 /* UP: Moves the pending Output of a Broadcast-Stream to the destination.
1646 finish_output_broad(stream);
1647 > stream: Broadcast-Stream
1648 can trigger GC */
finish_output_broad(object stream)1649 local maygc void finish_output_broad (object stream) {
1650 check_SP(); check_STACK();
1651 var object streamlist = TheStream(stream)->strm_broad_list;
1652 /* treat each Stream from the List separately: */
1653 while (consp(streamlist)) {
1654 pushSTACK(Cdr(streamlist)); /* remaining Streams */
1655 finish_output(Car(streamlist));
1656 streamlist = popSTACK();
1657 }
1658 }
1659
1660 /* UP: Moves the pending Output of a Broadcast-Stream to the destination.
1661 force_output_broad(stream);
1662 > stream: Broadcast-Stream
1663 can trigger GC */
force_output_broad(object stream)1664 local maygc void force_output_broad (object stream) {
1665 check_SP(); check_STACK();
1666 var object streamlist = TheStream(stream)->strm_broad_list;
1667 /* treat each Stream from the List separately: */
1668 while (consp(streamlist)) {
1669 pushSTACK(Cdr(streamlist)); /* remaining Streams */
1670 force_output(Car(streamlist));
1671 streamlist = popSTACK();
1672 }
1673 }
1674
1675 /* UP: Deletes the pending Output of a Broadcast-Stream.
1676 clear_output_broad(stream);
1677 > stream: Broadcast-Stream
1678 can trigger GC */
clear_output_broad(object stream)1679 local maygc void clear_output_broad (object stream) {
1680 check_SP(); check_STACK();
1681 var object streamlist = TheStream(stream)->strm_broad_list;
1682 /* treat each Stream from the List separately: */
1683 while (consp(streamlist)) {
1684 pushSTACK(Cdr(streamlist)); /* remaining Streams */
1685 clear_output(Car(streamlist));
1686 streamlist = popSTACK();
1687 }
1688 }
1689
1690 /* Returns a Broadcast-Stream for a list of Streams.
1691 make_broadcast_stream(list)
1692 > list : list of streams
1693 < result : Broadcast-Stream
1694 Thereby the List list is destroyed.
1695 can trigger GC */
make_broadcast_stream(object list)1696 local maygc object make_broadcast_stream (object list) {
1697 pushSTACK(list); /* save list */
1698 var object stream = /* new Stream, only WRITEs allowed */
1699 allocate_stream(strmflags_wr_B,strmtype_broad,strm_len+1,0);
1700 list = popSTACK();
1701 stream_dummy_fill(stream);
1702 TheStream(stream)->strm_wr_by = P(wr_by_broad);
1703 TheStream(stream)->strm_wr_by_array = P(wr_by_array_broad);
1704 TheStream(stream)->strm_wr_ch =
1705 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_broad);
1706 TheStream(stream)->strm_wr_ch_array =
1707 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_broad);
1708 TheStream(stream)->strm_broad_list = list;
1709 return stream;
1710 }
1711
1712 /* returns a Broadcast-Stream for Stream stream.
1713 make_broadcast1_stream(stream)
1714 > stream : Stream
1715 < result : Broadcast-Stream
1716 can trigger GC */
make_broadcast1_stream(object oldstream)1717 global maygc object make_broadcast1_stream (object oldstream) {
1718 pushSTACK(oldstream);
1719 /* pack oldstream in a one-element List: */
1720 var object new_cons = allocate_cons();
1721 Car(new_cons) = STACK_0;
1722 var object stream = make_broadcast_stream(new_cons); /* new Stream */
1723 oldstream = popSTACK();
1724 /* take over Line-Position: */
1725 TheStream(stream)->strm_wr_ch_lpos = TheStream(oldstream)->strm_wr_ch_lpos;
1726 return stream;
1727 }
1728
1729 LISPFUN(make_broadcast_stream,seclass_read,0,0,rest,nokey,0,NIL)
1730 { /* (MAKE-BROADCAST-STREAM {stream}), CLTL p. 329 */
1731 /* check that all Arguments are Streams: */
1732 test_output_stream_args(rest_args_pointer,argcount);
1733 /* collect to one List: */
1734 var object list = listof(argcount);
1735 /* build Stream: */
1736 VALUES1(make_broadcast_stream(list));
1737 }
1738
1739 LISPFUNNF(broadcast_stream_p,1)
1740 { /* (SYS::BROADCAST-STREAM-P stream) == (TYPEP stream 'BROADCAST-STREAM) */
1741 var object arg = popSTACK();
1742 VALUES_IF(builtin_stream_p(arg)
1743 && (TheStream(arg)->strmtype == strmtype_broad));
1744 }
1745
1746 LISPFUNNR(broadcast_stream_streams,1)
1747 { /* (BROADCAST-STREAM-STREAMS stream), CLtL2 p. 507 */
1748 var object stream = popSTACK();
1749 CHECK_streamtype(stream,S(broadcast_stream),
1750 (builtin_stream_p(stream)
1751 && (TheStream(stream)->strmtype == strmtype_broad)));
1752 /* copy List of Streams as a precaution */
1753 VALUES1(copy_list(TheStream(stream)->strm_broad_list));
1754 }
1755
1756 /* (car (last (broadcast_stream stream)))
1757 this is necessary for issue 021
1758 <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Issues/iss021.html> */
broadcast_stream_last(object stream)1759 local object broadcast_stream_last (object stream)
1760 {
1761 var object stream_list = TheStream(stream)->strm_broad_list;
1762 if (consp(stream_list)) {
1763 do { stream = Car(stream_list);
1764 stream_list = Cdr(stream_list);
1765 } while (consp(stream_list));
1766 return stream;
1767 } else return nullobj;
1768 }
1769
1770 /* Concatenated-Stream
1771 ===================
1772
1773 Additional Components:
1774 define strm_concat_list strm_other[0] - list of not exhausted streams */
1775 #define strm_concat_totallist strm_other[1] /* list of all streams */
1776
1777 /* READ-BYTE - Pseudo-Function for Concatenated-Streams: */
rd_by_concat(object stream)1778 local maygc object rd_by_concat (object stream) {
1779 check_SP(); check_STACK();
1780 pushSTACK(stream);
1781 var object streamlist = TheStream(stream)->strm_concat_list;
1782 var object result;
1783 while (consp(streamlist)) {
1784 result = read_byte(Car(streamlist)); /* read Integer */
1785 if (!eq(result,eof_value)) /* not EOF ? */
1786 goto OK;
1787 /* EOF reached -> remove emptied Stream from the List: */
1788 stream = STACK_0;
1789 streamlist = TheStream(stream)->strm_concat_list =
1790 Cdr(TheStream(stream)->strm_concat_list);
1791 }
1792 /* all Streams emptied -> return EOF: */
1793 { result = eof_value; }
1794 OK:
1795 skipSTACK(1);
1796 return result;
1797 }
1798
1799 /* READ-BYTE-ARRAY - Pseudo-Function for Concatenated-Streams: */
rd_by_array_concat(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)1800 local maygc uintL rd_by_array_concat (const gcv_object_t* stream_,
1801 const gcv_object_t* bytearray_,
1802 uintL start, uintL len,
1803 perseverance_t persev) {
1804 check_SP(); check_STACK();
1805 var uintL result = 0;
1806 var object stream = *stream_;
1807 var object streamlist = TheStream(stream)->strm_concat_list;
1808 while (consp(streamlist)) {
1809 pushSTACK(Car(streamlist));
1810 var uintL count = read_byte_array(&STACK_0,bytearray_,start,len,persev);
1811 skipSTACK(1);
1812 result += count;
1813 start += count; len -= count;
1814 if (len == 0)
1815 break;
1816 /* EOF reached -> remove emptied stream from the list: */
1817 stream = *stream_;
1818 streamlist = TheStream(stream)->strm_concat_list =
1819 Cdr(TheStream(stream)->strm_concat_list);
1820 if (persev == persev_partial && result > 0)
1821 persev = persev_bonus;
1822 }
1823 return result;
1824 }
1825
1826 /* READ-CHAR - Pseudo-Function for Concatenated-Streams: */
rd_ch_concat(const gcv_object_t * stream_)1827 local maygc object rd_ch_concat (const gcv_object_t* stream_) {
1828 check_SP(); check_STACK();
1829 var object streamlist = TheStream(*stream_)->strm_concat_list;
1830 while (consp(streamlist)) {
1831 pushSTACK(Car(streamlist));
1832 var object result = read_char(&STACK_0); /* read Character */
1833 skipSTACK(1);
1834 if (!eq(result,eof_value))
1835 return result;
1836 /* EOF reached -> remove emptied stream from the list: */
1837 var object stream = *stream_;
1838 streamlist = TheStream(stream)->strm_concat_list =
1839 Cdr(TheStream(stream)->strm_concat_list);
1840 }
1841 /* all Streams emptied -> return EOF: */
1842 return eof_value;
1843 }
1844
1845 /* PEEK-CHAR - Pseudo-Function for Concatenated-Streams: */
pk_ch_concat(const gcv_object_t * stream_)1846 local maygc object pk_ch_concat (const gcv_object_t* stream_) {
1847 check_SP(); check_STACK();
1848 var object streamlist = TheStream(*stream_)->strm_concat_list;
1849 while (consp(streamlist)) {
1850 pushSTACK(Car(streamlist));
1851 var object result = peek_char(&STACK_0); /* read Character */
1852 skipSTACK(1);
1853 if (!eq(result,eof_value))
1854 return result;
1855 /* EOF reached -> remove emptied stream from the list: */
1856 var object stream = *stream_;
1857 streamlist = TheStream(stream)->strm_concat_list =
1858 Cdr(TheStream(stream)->strm_concat_list);
1859 }
1860 /* all Streams emptied -> return EOF: */
1861 return eof_value;
1862 }
1863
1864 /* READ-CHAR-ARRAY - Pseudo-Function for Concatenated-Streams: */
rd_ch_array_concat(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)1865 local maygc uintL rd_ch_array_concat (const gcv_object_t* stream_,
1866 const gcv_object_t* chararray_,
1867 uintL start, uintL len) {
1868 check_SP(); check_STACK();
1869 var uintL result = 0;
1870 var object stream = *stream_;
1871 var object streamlist = TheStream(stream)->strm_concat_list;
1872 while (consp(streamlist)) {
1873 pushSTACK(Car(streamlist));
1874 var uintL count = read_char_array(&STACK_0,chararray_,start,len);
1875 skipSTACK(1);
1876 result += count;
1877 start += count; len -= count;
1878 if (len == 0)
1879 break;
1880 /* EOF reached -> remove emptied stream from the list: */
1881 stream = *stream_;
1882 streamlist = TheStream(stream)->strm_concat_list =
1883 Cdr(TheStream(stream)->strm_concat_list);
1884 }
1885 return result;
1886 }
1887
1888 /* Determines, if a character is available on the Concatenated-Stream.
1889 listen_char_concat(stream)
1890 > stream : Concatenated-Stream
1891 < result: input availability
1892 can trigger GC */
listen_char_concat(object stream)1893 local maygc listen_t listen_char_concat (object stream) {
1894 pushSTACK(stream);
1895 var object streamlist = TheStream(stream)->strm_concat_list;
1896 var listen_t result;
1897 while (consp(streamlist)) {
1898 result = listen_char(Car(streamlist));
1899 if (result != LISTEN_EOF) /* not EOF ? */
1900 goto OK;
1901 /* EOF reached -> remove emptied stream from the list: */
1902 stream = STACK_0;
1903 streamlist = TheStream(stream)->strm_concat_list =
1904 Cdr(TheStream(stream)->strm_concat_list);
1905 }
1906 /* all Streams emptied -> return EOF: */
1907 result = LISTEN_EOF;
1908 OK:
1909 skipSTACK(1);
1910 return result;
1911 }
1912
1913 /* UP: Deletes already entered interactive Input from a
1914 Concatenated-Stream.
1915 clear_input_concat(stream)
1916 > stream: Concatenated-Stream
1917 < result: true if Input was deleted
1918 can trigger GC */
clear_input_concat(object stream)1919 local maygc bool clear_input_concat (object stream) {
1920 var bool result = false; /* no Input deleted yet */
1921 /* treat all Streams separately: */
1922 var object streamlist = TheStream(stream)->strm_concat_list;
1923 while (consp(streamlist)) {
1924 pushSTACK(Cdr(streamlist)); /* remaining list ofStreams */
1925 result |= clear_input(Car(streamlist)); /* delete all Input of the sub-streams */
1926 streamlist = popSTACK();
1927 }
1928 return result;
1929 }
1930
1931 /* Determines, if a Byte is available on the Concatenated-Stream.
1932 listen_byte_concat(stream)
1933 > stream : Concatenated-Stream
1934 < result: input availability
1935 can trigger GC */
listen_byte_concat(object stream)1936 local maygc listen_t listen_byte_concat (object stream) {
1937 pushSTACK(stream);
1938 var object streamlist = TheStream(stream)->strm_concat_list;
1939 var listen_t result;
1940 while (consp(streamlist)) {
1941 result = listen_byte(Car(streamlist));
1942 if (result != LISTEN_EOF) /* not EOF ? */
1943 goto OK;
1944 /* EOF reached -> remove emptied stream from the list: */
1945 stream = STACK_0;
1946 streamlist = TheStream(stream)->strm_concat_list =
1947 Cdr(TheStream(stream)->strm_concat_list);
1948 }
1949 /* all Streams emptied -> return EOF: */
1950 result = LISTEN_EOF;
1951 OK:
1952 skipSTACK(1);
1953 return result;
1954 }
1955
1956 /* Returns a Concatenated-Stream for a list of Stream.
1957 make_concatenated_stream(list)
1958 > list : list of streams
1959 < result : Concatenated-Stream
1960 Thereby the List list is destroyed.
1961 can trigger GC */
make_concatenated_stream(object list)1962 local maygc object make_concatenated_stream (object list) {
1963 pushSTACK(list); /* save list */
1964 var object stream = /* new Stream, only READs allowed */
1965 allocate_stream(strmflags_rd_B,strmtype_concat,strm_len+2,0);
1966 stream_dummy_fill(stream);
1967 TheStream(stream)->strm_rd_by = P(rd_by_concat);
1968 TheStream(stream)->strm_rd_by_array = P(rd_by_array_concat);
1969 TheStream(stream)->strm_rd_ch = P(rd_ch_concat);
1970 TheStream(stream)->strm_pk_ch = P(pk_ch_concat);
1971 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_concat);
1972 TheStream(stream)->strm_concat_list =
1973 TheStream(stream)->strm_concat_totallist = popSTACK();
1974 return stream;
1975 }
1976
1977 LISPFUN(make_concatenated_stream,seclass_read,0,0,rest,nokey,0,NIL)
1978 { /* (MAKE-CONCATENATED-STREAM {stream}), CLTL p. 329 */
1979 /* check that all Arguments are Streams: */
1980 test_input_stream_args(rest_args_pointer,argcount);
1981 /* collect to one List: */
1982 var object list = listof(argcount);
1983 /* build Stream: */
1984 VALUES1(make_concatenated_stream(list));
1985 }
1986
1987 LISPFUNNF(concatenated_stream_p,1)
1988 { /* (SYS::CONCATENATED-STREAM-P stream)
1989 == (TYPEP stream 'CONCATENATED-STREAM) */
1990 var object arg = popSTACK();
1991 VALUES_IF(builtin_stream_p(arg)
1992 && (TheStream(arg)->strmtype == strmtype_concat));
1993 }
1994
1995 LISPFUNNR(concatenated_stream_streams,1)
1996 { /* (CONCATENATED-STREAM-STREAMS stream), CLtL2 p. 507 */
1997 var object stream = popSTACK();
1998 CHECK_streamtype(stream,S(concatenated_stream),
1999 (builtin_stream_p(stream)
2000 && (TheStream(stream)->strmtype == strmtype_concat)));
2001 /* copy List of Streams as a precaution */
2002 VALUES1(copy_list(TheStream(stream)->strm_concat_list));
2003 }
2004
2005
2006 /* Two-Way-Stream, Echo-Stream
2007 ===========================
2008
2009 Additional Components:
2010 define strm_twoway_input strm_other[0] - Stream for Input
2011 define strm_twoway_output strm_other[1] - Stream for Output
2012
2013 WRITE-BYTE - Pseudo-Function for Two-Way- and Echo-Streams: */
wr_by_twoway(object stream,object obj)2014 local maygc void wr_by_twoway (object stream, object obj) {
2015 check_SP();
2016 write_byte(TheStream(stream)->strm_twoway_output,obj);
2017 }
2018
2019 /* WRITE-BYTE-ARRAY - Pseudo-Function for Two-Way- and Echo-Streams: */
wr_by_array_twoway(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)2020 local maygc uintL wr_by_array_twoway (const gcv_object_t* stream_,
2021 const gcv_object_t* bytearray_,
2022 uintL start, uintL len,
2023 perseverance_t persev) {
2024 check_SP(); check_STACK();
2025 pushSTACK(TheStream(*stream_)->strm_twoway_output);
2026 var uintL result = write_byte_array(&STACK_0,bytearray_,start,len,persev);
2027 skipSTACK(1);
2028 return result;
2029 }
2030
2031 /* WRITE-CHAR - Pseudo-Function for Two-Way- and Echo-Streams: */
wr_ch_twoway(const gcv_object_t * stream_,object obj)2032 local maygc void wr_ch_twoway (const gcv_object_t* stream_, object obj) {
2033 check_SP(); check_STACK();
2034 pushSTACK(TheStream(*stream_)->strm_twoway_output);
2035 write_char(&STACK_0,obj);
2036 skipSTACK(1);
2037 }
2038
2039 /* WRITE-CHAR-ARRAY - Pseudo-Function for Two-Way- and Echo-Streams: */
wr_ch_array_twoway(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2040 local maygc void wr_ch_array_twoway (const gcv_object_t* stream_,
2041 const gcv_object_t* chararray_,
2042 uintL start, uintL len) {
2043 check_SP(); check_STACK();
2044 pushSTACK(TheStream(*stream_)->strm_twoway_output);
2045 write_char_array(&STACK_0,chararray_,start,len);
2046 skipSTACK(1);
2047 /* No need to update wr_ch_lpos here. (See get_line_position().) */
2048 }
2049
2050 /* Determines, if a Character is available on a Two-Way- or Echo-Stream.
2051 listen_char_twoway(stream)
2052 > stream : Two-Way- or Echo-Stream
2053 < result: input availability
2054 can trigger GC */
listen_char_twoway(object stream)2055 local maygc listen_t listen_char_twoway (object stream) {
2056 check_SP();
2057 return listen_char(TheStream(stream)->strm_twoway_input);
2058 }
2059
2060 /* UP: Deletes already entered interactive Input from a Two-Way-
2061 or Echo-Stream.
2062 clear_input_twoway(stream)
2063 > stream: Two-Way- or Echo-Stream
2064 < result: true if Input was deleted
2065 can trigger GC */
clear_input_twoway(object stream)2066 local maygc bool clear_input_twoway (object stream) {
2067 check_SP();
2068 return clear_input(TheStream(stream)->strm_twoway_input);
2069 }
2070
2071 /* Determines, if a Byte is available on a Two-Way- or Echo-Stream.
2072 listen_byte_twoway(stream)
2073 > stream : Two-Way- or Echo-Stream
2074 < result: input availability
2075 can trigger GC */
listen_byte_twoway(object stream)2076 local maygc listen_t listen_byte_twoway (object stream) {
2077 check_SP();
2078 return listen_byte(TheStream(stream)->strm_twoway_input);
2079 }
2080
2081 /* UP: Moves the pending Output of a Two-Way- or Echo-Stream to the destination.
2082 finish_output_twoway(stream);
2083 > stream: Two-Way- or Echo-Stream
2084 can trigger GC */
finish_output_twoway(object stream)2085 local maygc void finish_output_twoway (object stream) {
2086 check_SP();
2087 finish_output(TheStream(stream)->strm_twoway_output);
2088 }
2089
2090 /* UP: Moves the pending Output of a Two-Way- or Echo-Stream to the destination.
2091 force_output_twoway(stream);
2092 > stream: Two-Way- or Echo-Stream
2093 can trigger GC */
force_output_twoway(object stream)2094 local maygc void force_output_twoway (object stream) {
2095 check_SP();
2096 force_output(TheStream(stream)->strm_twoway_output);
2097 }
2098
2099 /* UP: Deletes the pending Output of a Two-Way- or Echo-Stream.
2100 clear_output_twoway(stream);
2101 > stream: Two-Way- or Echo-Stream
2102 can trigger GC */
clear_output_twoway(object stream)2103 local maygc void clear_output_twoway (object stream) {
2104 check_SP();
2105 clear_output(TheStream(stream)->strm_twoway_output);
2106 }
2107
2108 /* Two-Way-Stream
2109 ==============
2110
2111 READ-BYTE - Pseudo-Function for Two-Way-Streams: */
rd_by_twoway(object stream)2112 local maygc object rd_by_twoway (object stream) {
2113 check_SP();
2114 return read_byte(TheStream(stream)->strm_twoway_input);
2115 }
2116
2117 /* READ-BYTE-ARRAY - Pseudo-Function for Two-Way-Streams: */
rd_by_array_twoway(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)2118 local maygc uintL rd_by_array_twoway (const gcv_object_t* stream_,
2119 const gcv_object_t* bytearray_,
2120 uintL start, uintL len,
2121 perseverance_t persev) {
2122 check_SP(); check_STACK();
2123 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2124 var uintL result = read_byte_array(&STACK_0,bytearray_,start,len,persev);
2125 skipSTACK(1);
2126 return result;
2127 }
2128
2129 /* READ-CHAR - Pseudo-Function for Two-Way-Streams: */
rd_ch_twoway(const gcv_object_t * stream_)2130 local maygc object rd_ch_twoway (const gcv_object_t* stream_) {
2131 check_SP(); check_STACK();
2132 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2133 var object result = read_char(&STACK_0);
2134 skipSTACK(1);
2135 return result;
2136 }
2137
2138 /* PEEK-CHAR - Pseudo-Function for Two-Way-Streams: */
pk_ch_twoway(const gcv_object_t * stream_)2139 local maygc object pk_ch_twoway (const gcv_object_t* stream_) {
2140 check_SP(); check_STACK();
2141 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2142 var object result = peek_char(&STACK_0);
2143 skipSTACK(1);
2144 return result;
2145 }
2146
2147 /* READ-CHAR-ARRAY - Pseudo-Function for Two-Way-Streams: */
rd_ch_array_twoway(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2148 local maygc uintL rd_ch_array_twoway (const gcv_object_t* stream_,
2149 const gcv_object_t* chararray_,
2150 uintL start, uintL len) {
2151 check_SP(); check_STACK();
2152 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2153 var uintL result = read_char_array(&STACK_0,chararray_,start,len);
2154 skipSTACK(1);
2155 return result;
2156 }
2157
2158 /* Reads a line of characters from a two-way-stream.
2159 read_line_twoway(stream,&buffer)
2160 > stream: two-way-stream
2161 > buffer: a semi-simple string
2162 < buffer: contains the read characters, excluding the terminating #\Newline
2163 < result: true if EOF was seen before newline, else false
2164 can trigger GC */
read_line_twoway(object stream,const gcv_object_t * buffer_)2165 local maygc bool read_line_twoway (object stream, const gcv_object_t* buffer_) {
2166 check_SP(); check_STACK();
2167 pushSTACK(TheStream(stream)->strm_twoway_input);
2168 var bool eofp = read_line(&STACK_0,buffer_);
2169 skipSTACK(1);
2170 return eofp;
2171 }
2172
2173 /* Returns a Two-Way-Stream for an Input-Stream and an Output-Stream.
2174 make_twoway_stream(input_stream,output_stream)
2175 > input_stream : Input-Stream
2176 > output_stream : Output-Stream
2177 < result : Two-Way-Stream
2178 can trigger GC */
make_twoway_stream(object input_stream,object output_stream)2179 global maygc object make_twoway_stream (object input_stream,
2180 object output_stream) {
2181 pushSTACK(input_stream); pushSTACK(output_stream); /* save Streams */
2182 var uintB flags = strmflags_rdwr_B
2183 | (TheStream(input_stream)->strmflags & strmflags_immut_B);
2184 var object stream = /* new Stream, all Operations allowed */
2185 allocate_stream(flags,strmtype_twoway,strm_len+2,0);
2186 TheStream(stream)->strm_rd_by = P(rd_by_twoway);
2187 TheStream(stream)->strm_rd_by_array = P(rd_by_array_twoway);
2188 TheStream(stream)->strm_wr_by = P(wr_by_twoway);
2189 TheStream(stream)->strm_wr_by_array = P(wr_by_array_twoway);
2190 TheStream(stream)->strm_rd_ch = P(rd_ch_twoway);
2191 TheStream(stream)->strm_pk_ch = P(pk_ch_twoway);
2192 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_twoway);
2193 TheStream(stream)->strm_rd_ch_last = NIL;
2194 TheStream(stream)->strm_wr_ch =
2195 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_twoway);
2196 TheStream(stream)->strm_wr_ch_array =
2197 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_twoway);
2198 output_stream = popSTACK(); input_stream = popSTACK(); /* put back Streams */
2199 TheStream(stream)->strm_wr_ch_lpos =
2200 TheStream(output_stream)->strm_wr_ch_lpos;
2201 TheStream(stream)->strm_twoway_input = input_stream;
2202 TheStream(stream)->strm_twoway_output = output_stream;
2203 return stream;
2204 }
2205
2206 LISPFUNNR(make_two_way_stream,2)
2207 { /* (MAKE-TWO-WAY-STREAM input-stream output-stream), CLTL p. 329 */
2208 /* check that both are Streams: */
2209 check_stream_args(args_end_pointer STACKop 2, 2);
2210 var object output_stream = popSTACK();
2211 var object input_stream = popSTACK();
2212 test_input_stream(input_stream);
2213 test_output_stream(output_stream);
2214 /* build Stream: */
2215 VALUES1(make_twoway_stream(input_stream,output_stream));
2216 }
2217
2218 /* check whether the stream S is a two-way-stream */
2219 #define stream_twoway_p(s) \
2220 (builtin_stream_p(s) && (TheStream(s)->strmtype == strmtype_twoway))
2221
2222 LISPFUNNF(two_way_stream_p,1)
2223 { /* (SYS::TWO-WAY-STREAM-P stream) == (TYPEP stream 'TWO-WAY-STREAM) */
2224 var object arg = popSTACK();
2225 VALUES_IF(stream_twoway_p(arg));
2226 }
2227
2228 LISPFUNNR(two_way_stream_input_stream,1)
2229 { /* (TWO-WAY-STREAM-INPUT-STREAM stream), CLtL2 p. 507 */
2230 var object stream = popSTACK();
2231 CHECK_streamtype(stream,S(two_way_stream),stream_twoway_p(stream));
2232 VALUES1(TheStream(stream)->strm_twoway_input);
2233 }
2234
2235 LISPFUNNR(two_way_stream_output_stream,1)
2236 { /* (TWO-WAY-STREAM-OUTPUT-STREAM stream), CLtL2 p. 507 */
2237 var object stream = popSTACK();
2238 CHECK_streamtype(stream,S(two_way_stream),stream_twoway_p(stream));
2239 VALUES1(TheStream(stream)->strm_twoway_output);
2240 }
2241
2242
2243 /* Echo-Stream
2244 ===========
2245
2246 READ-BYTE - Pseudo-Function for Echo-Streams: */
rd_by_echo(object stream)2247 local maygc object rd_by_echo (object stream) {
2248 check_SP(); check_STACK();
2249 pushSTACK(stream);
2250 var object obj = read_byte(TheStream(stream)->strm_twoway_input);
2251 stream = popSTACK();
2252 if (!eq(obj,eof_value)) {
2253 pushSTACK(obj);
2254 write_byte(TheStream(stream)->strm_twoway_output,obj);
2255 obj = popSTACK();
2256 }
2257 return obj;
2258 }
2259
2260 /* READ-BYTE-ARRAY - Pseudo-Function for Echo-Streams: */
rd_by_array_echo(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)2261 local maygc uintL rd_by_array_echo (const gcv_object_t* stream_,
2262 const gcv_object_t* bytearray_,
2263 uintL start, uintL len,
2264 perseverance_t persev) {
2265 check_SP(); check_STACK();
2266 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2267 var uintL result = read_byte_array(&STACK_0,bytearray_,start,len,persev);
2268 STACK_0 = TheStream(*stream_)->strm_twoway_output;
2269 write_byte_array(&STACK_0,bytearray_,start,result,persev_full);
2270 skipSTACK(1);
2271 return result;
2272 }
2273
2274 /* READ-CHAR - Pseudo-Function for Echo-Streams: */
rd_ch_echo(const gcv_object_t * stream_)2275 local maygc object rd_ch_echo (const gcv_object_t* stream_) {
2276 check_SP(); check_STACK();
2277 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2278 var object obj = read_char(&STACK_0);
2279 if (!eq(obj,eof_value)) {
2280 STACK_0 = TheStream(*stream_)->strm_twoway_output;
2281 pushSTACK(obj);
2282 write_char(&STACK_1,obj);
2283 obj = popSTACK();
2284 }
2285 skipSTACK(1);
2286 return obj;
2287 }
2288
2289 /* READ-CHAR-ARRAY - Pseudo-Function for Echo-Streams: */
rd_ch_array_echo(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2290 local maygc uintL rd_ch_array_echo (const gcv_object_t* stream_,
2291 const gcv_object_t* chararray_,
2292 uintL start, uintL len) {
2293 check_SP(); check_STACK();
2294 pushSTACK(TheStream(*stream_)->strm_twoway_input);
2295 var uintL result = read_char_array(&STACK_0,chararray_,start,len);
2296 STACK_0 = TheStream(*stream_)->strm_twoway_output;
2297 write_char_array(&STACK_0,chararray_,start,result);
2298 skipSTACK(1);
2299 return result;
2300 }
2301
2302 /* returns an Echo-Stream for an Input-Stream and an Output-Stream.
2303 make_echo_stream(input_stream,output_stream)
2304 > input_stream : Input-Stream
2305 > output_stream : Output-Stream
2306 < result : Echo-Stream
2307 can trigger GC */
make_echo_stream(object input_stream,object output_stream)2308 local maygc object make_echo_stream (object input_stream, object output_stream)
2309 {
2310 pushSTACK(input_stream); pushSTACK(output_stream); /* save Streams */
2311 var uintB flags = strmflags_rdwr_B
2312 | (TheStream(input_stream)->strmflags & strmflags_immut_B);
2313 var object stream = /* new Stream, all Operations allowed */
2314 allocate_stream(flags,strmtype_echo,strm_len+2,0);
2315 TheStream(stream)->strm_rd_by = P(rd_by_echo);
2316 TheStream(stream)->strm_rd_by_array = P(rd_by_array_echo);
2317 TheStream(stream)->strm_wr_by = P(wr_by_twoway);
2318 TheStream(stream)->strm_wr_by_array = P(wr_by_array_twoway);
2319 TheStream(stream)->strm_rd_ch = P(rd_ch_echo);
2320 TheStream(stream)->strm_pk_ch = P(pk_ch_twoway);
2321 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_echo);
2322 TheStream(stream)->strm_rd_ch_last = NIL;
2323 TheStream(stream)->strm_wr_ch =
2324 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_twoway);
2325 TheStream(stream)->strm_wr_ch_array =
2326 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_twoway);
2327 output_stream = popSTACK(); input_stream = popSTACK(); /* put back Streams */
2328 TheStream(stream)->strm_wr_ch_lpos =
2329 TheStream(output_stream)->strm_wr_ch_lpos;
2330 TheStream(stream)->strm_twoway_input = input_stream;
2331 TheStream(stream)->strm_twoway_output = output_stream;
2332 return stream;
2333 }
2334
2335 LISPFUNNR(make_echo_stream,2)
2336 { /* (MAKE-ECHO-STREAM input-stream output-stream), CLTL p. 330 */
2337 /* check that both are Streams: */
2338 check_stream_args(args_end_pointer STACKop 2, 2);
2339 var object output_stream = popSTACK();
2340 var object input_stream = popSTACK();
2341 test_input_stream(input_stream);
2342 test_output_stream(output_stream);
2343 /* build Stream: */
2344 VALUES1(make_echo_stream(input_stream,output_stream));
2345 }
2346
2347 /* check whether the stream S is a two-way-stream */
2348 #define stream_echo_p(s) \
2349 (builtin_stream_p(s) && (TheStream(s)->strmtype == strmtype_echo))
2350
2351 LISPFUNNF(echo_stream_p,1)
2352 { /* (SYS::ECHO-STREAM-P stream) == (TYPEP stream 'ECHO-STREAM) */
2353 var object arg = popSTACK();
2354 VALUES_IF(stream_echo_p(arg));
2355 }
2356
2357 LISPFUNNR(echo_stream_input_stream,1)
2358 { /* (ECHO-STREAM-INPUT-STREAM stream), CLtL2 p. 507 */
2359 var object stream = popSTACK();
2360 CHECK_streamtype(stream,S(echo_stream),stream_echo_p(stream));
2361 VALUES1(TheStream(stream)->strm_twoway_input);
2362 }
2363
2364 LISPFUNNR(echo_stream_output_stream,1)
2365 { /* (ECHO-STREAM-OUTPUT-STREAM stream), CLtL2 p. 507 */
2366 var object stream = popSTACK();
2367 CHECK_streamtype(stream,S(echo_stream),stream_echo_p(stream));
2368 VALUES1(TheStream(stream)->strm_twoway_output);
2369 }
2370
2371
2372 /* String-Input-Stream
2373 ===================
2374
2375 Additional Components: */
2376 #define strm_str_in_string strm_other[0] /* String for Input */
2377 #define strm_str_in_index strm_other[1] /* Index in the String (Fixnum>=0)*/
2378 #define strm_str_in_begindex strm_other[2] /* Begindex (Fixnum >= index >=0) */
2379 #define strm_str_in_endindex strm_other[3] /* Endindex (Fixnum >= index >=0) */
2380
2381 /* error-message, if index >= length(string):
2382 error_str_in_adjusted(stream);
2383 > stream: problematic String-Input-Stream */
error_str_in_adjusted(object stream)2384 local _Noreturn void error_str_in_adjusted (object stream) {
2385 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
2386 pushSTACK(TheStream(stream)->strm_str_in_string);
2387 pushSTACK(stream);
2388 error(stream_error,GETTEXT("~S is beyond the end because the string ~S has been adjusted"));
2389 }
2390
2391 /* READ-CHAR - Pseudo-Function for String-Input-Streams: */
rd_ch_str_in(const gcv_object_t * stream_)2392 local maygc object rd_ch_str_in (const gcv_object_t* stream_) {
2393 var object stream = *stream_;
2394 var uintV index = posfixnum_to_V(TheStream(stream)->strm_str_in_index);
2395 var uintV endindex = posfixnum_to_V(TheStream(stream)->strm_str_in_endindex);
2396 if (index >= endindex) {
2397 return eof_value; /* EOF reached */
2398 } else { /* index < endvalid */
2399 var uintL len;
2400 var uintL offset;
2401 var object string =
2402 unpack_string_ro(TheStream(stream)->strm_str_in_string,&len,&offset);
2403 if (index >= len) /* Index too big? */
2404 error_str_in_adjusted(stream);
2405 /* fetch character from String */
2406 var object ch = code_char(schar(string,offset+index));
2407 /* increase Index: */
2408 TheStream(stream)->strm_str_in_index =
2409 fixnum_inc(TheStream(stream)->strm_str_in_index,1);
2410 return ch;
2411 }
2412 }
2413
2414 /* READ-CHAR-ARRAY - Pseudo-Function for String-Input-Streams: */
rd_ch_array_str_in(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2415 local maygc uintL rd_ch_array_str_in (const gcv_object_t* stream_,
2416 const gcv_object_t* chararray_,
2417 uintL start, uintL len) {
2418 var object stream = *stream_;
2419 var uintV index = posfixnum_to_V(TheStream(stream)->strm_str_in_index);
2420 var uintV endindex = posfixnum_to_V(TheStream(stream)->strm_str_in_endindex);
2421 if (index < endindex) {
2422 var uintL srclen;
2423 var uintL srcoffset;
2424 var object string = unpack_string_ro(TheStream(stream)->strm_str_in_string,
2425 &srclen,&srcoffset);
2426 if (srclen < endindex)
2427 error_str_in_adjusted(stream);
2428 var uintL count = endindex - index;
2429 if (count > len)
2430 count = len;
2431 /* count = min(len,endindex-index) > 0. */
2432 var object chararray = *chararray_;
2433 sstring_un_realloc(chararray);
2434 elt_copy(string,srcoffset+index,chararray,start,count);
2435 stream = *stream_;
2436 TheStream(stream)->strm_str_in_index =
2437 fixnum_inc(TheStream(stream)->strm_str_in_index,count);
2438 return count;
2439 } else {
2440 return 0;
2441 }
2442 }
2443
2444 /* Closes a String-Input-Stream.
2445 close_str_in(stream, abort);
2446 > stream : String-Input-Stream */
close_str_in(object stream)2447 local maygc void close_str_in (object stream) {
2448 TheStream(stream)->strm_str_in_string = NIL; /* String := NIL */
2449 }
2450
2451 /* Determines, if a character is available on a String-Input-Stream.
2452 listen_char_str_in(stream)
2453 > stream : String-Input-Stream
2454 < result: input availability
2455 can trigger GC */
listen_char_str_in(object stream)2456 local maygc listen_t listen_char_str_in (object stream) {
2457 var uintV index = posfixnum_to_V(TheStream(stream)->strm_str_in_index);
2458 var uintV endindex = posfixnum_to_V(TheStream(stream)->strm_str_in_endindex);
2459 if (index >= endindex)
2460 return LISTEN_EOF; /* EOF reached */
2461 else
2462 return LISTEN_AVAIL;
2463 }
2464
2465 LISPFUN(make_string_input_stream,seclass_read,1,2,norest,nokey,0,NIL)
2466 { /* (MAKE-STRING-INPUT-STREAM string [start [end]]), CLTL p. 330 */
2467 /* fetch String and check range: */
2468 var stringarg arg;
2469 var object string = test_string_limits_ro(&arg);
2470 var object start_arg = fixnum(arg.index); /* start-Argument (Fixnum >=0) */
2471 var object end_arg = fixnum_inc(start_arg,arg.len); /* end-Argument (Fixnum >=0) */
2472 pushSTACK(string); /* save String */
2473 var object stream = /* new Stream, only READ-CHAR allowed */
2474 allocate_stream(strmflags_rd_ch_B,strmtype_str_in,strm_len+4,0);
2475 stream_dummy_fill(stream);
2476 TheStream(stream)->strm_rd_ch = P(rd_ch_str_in);
2477 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_str_in);
2478 TheStream(stream)->strm_str_in_string = popSTACK();
2479 TheStream(stream)->strm_str_in_index = /* (Beg)Index := start-Argument */
2480 TheStream(stream)->strm_str_in_begindex = start_arg;
2481 TheStream(stream)->strm_str_in_endindex = end_arg; /* Endindex := end-Argument */
2482 VALUES1(stream); /* stream as value */
2483 }
2484
error_string_stream(object stream,const char * message)2485 local _Noreturn void error_string_stream (object stream, const char *message) {
2486 pushSTACK(stream); /* TYPE-ERROR slot DATUM */
2487 pushSTACK(S(string_stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
2488 pushSTACK(stream);
2489 pushSTACK(TheSubr(subr_self)->name);
2490 error(type_error,message);
2491 }
2492
2493 LISPFUNNR(string_input_stream_index,1)
2494 { /* (SYSTEM::STRING-INPUT-STREAM-INDEX string-input-stream) ==> Index */
2495 var object stream = popSTACK(); /* Argument */
2496 /* must be a String-Input-Stream: */
2497 if (!(builtin_stream_p(stream)
2498 && (TheStream(stream)->strmtype == strmtype_str_in)))
2499 error_string_stream(stream,GETTEXT("~S: ~S is not a string input stream"));
2500 var object index = TheStream(stream)->strm_str_in_index;
2501 /* if a Character was pushed back with UNREAD-CHAR,
2502 use (1- index), a Fixnum >=0, as value: */
2503 if (TheStream(stream)->strmflags & strmflags_unread_B)
2504 index = fixnum_inc(index,-1);
2505 VALUES1(index);
2506 }
2507
2508
2509 /* String-Output-Stream
2510 ====================
2511
2512 Additional Components: */
2513 #define strm_str_out_string strm_other[0] /* Semi-Simple-String for Output */
2514
2515 /* WRITE-CHAR - Pseudo-Function for String-Output-Streams: */
wr_ch_str_out(const gcv_object_t * stream_,object ch)2516 local maygc void wr_ch_str_out (const gcv_object_t* stream_, object ch) {
2517 var object stream = *stream_;
2518 check_wr_char(stream,ch);
2519 /* push Character in the String: */
2520 ssstring_push_extend(TheStream(stream)->strm_str_out_string,char_code(ch));
2521 }
2522
2523 /* WRITE-CHAR-ARRAY - Pseudo-Function for String-Output-Streams: */
wr_ch_array_str_out(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2524 local maygc void wr_ch_array_str_out (const gcv_object_t* stream_,
2525 const gcv_object_t* chararray_,
2526 uintL start, uintL len) {
2527 var object ssstring = TheStream(*stream_)->strm_str_out_string; /* Semi-Simple-String */
2528 ssstring = ssstring_append_extend(ssstring,*chararray_,start,len);
2529 wr_ss_lpos(*stream_,&TheSnstring(TheIarray(ssstring)->data)->data[TheIarray(ssstring)->dims[1]],len); /* update Line-Position */
2530 }
2531
2532 /* Returns a String-Output-Stream.
2533 make_string_output_stream()
2534 can trigger GC */
make_string_output_stream(void)2535 global maygc object make_string_output_stream (void) {
2536 pushSTACK(make_ssstring(SEMI_SIMPLE_DEFAULT_SIZE));
2537 var object stream = /* new Stream, only WRITE-CHAR allowed */
2538 allocate_stream(strmflags_wr_ch_B,strmtype_str_out,strm_len+1,0);
2539 stream_dummy_fill(stream);
2540 TheStream(stream)->strm_wr_ch =
2541 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_str_out);
2542 TheStream(stream)->strm_wr_ch_array =
2543 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_str_out);
2544 TheStream(stream)->strm_str_out_string = popSTACK(); /* enter the String */
2545 return stream;
2546 }
2547
2548 LISPFUN(make_string_output_stream,seclass_read,0,0,norest,key,2,
2549 (kw(element_type),kw(line_position)))
2550 { /* (MAKE-STRING-OUTPUT-STREAM [:element-type] [:line-position]) */
2551 /* check line-position: */
2552 if (missingp(STACK_0)) {
2553 STACK_0 = Fixnum_0; /* Default value 0 */
2554 } else /* line-position specified, should be a Fixnum >=0 : */
2555 STACK_0 = check_posfixnum(STACK_0);
2556 /* check element-type: */
2557 if (boundp(STACK_1) && !nullp(STACK_1) && !eq(STACK_1,S(character))) {
2558 var object eltype = STACK_1;
2559 restart_check_eltype:
2560 /* Verify (SUBTYPEP eltype 'CHARACTER): */
2561 pushSTACK(eltype); pushSTACK(S(character)); funcall(S(subtypep),2);
2562 if (nullp(value1)) {
2563 pushSTACK(NIL); /* no PLACE */
2564 pushSTACK(STACK_2); /* TYPE-ERROR slot DATUM - eltype */
2565 pushSTACK(S(character)); /* TYPE-ERROR slot EXPECTED-TYPE */
2566 pushSTACK(STACK_1); /* eltype */
2567 pushSTACK(S(character)); /* CHARACTER */
2568 pushSTACK(S(Kelement_type)); /* :ELEMENT-TYPE */
2569 pushSTACK(S(make_string_output_stream));
2570 check_value(type_error,
2571 GETTEXT("~S: ~S argument must be a subtype of ~S, not ~S"));
2572 eltype = STACK_1 = value1;
2573 goto restart_check_eltype;
2574 }
2575 }
2576 var object stream;
2577 if (nullp(STACK_1)) {
2578 /* A string-output-stream with element type NIL is a handicapped guy:
2579 You cannot feed him with any character... */
2580 /* Call (MAKE-ARRAY 0 :ELEMENT-TYPE NIL :FILL-POINTER 0): */
2581 pushSTACK(fixnum(0));
2582 pushSTACK(S(Kelement_type)); pushSTACK(NIL);
2583 pushSTACK(S(Kfill_pointer)); pushSTACK(Fixnum_0);
2584 funcall(L(make_array),5); pushSTACK(value1);
2585 stream = allocate_stream(strmflags_wr_ch_B,strmtype_str_out,strm_len+1,0);
2586 stream_dummy_fill(stream);
2587 TheStream(stream)->strm_wr_ch =
2588 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_forbidden);
2589 TheStream(stream)->strm_wr_ch_array =
2590 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_forbidden);
2591 TheStream(stream)->strm_str_out_string = popSTACK();
2592 } else
2593 stream = make_string_output_stream(); /* normal String-Output-Stream */
2594 TheStream(stream)->strm_wr_ch_lpos = popSTACK(); /* enter Line Position */
2595 VALUES1(stream); /* return stream */
2596 skipSTACK(1);
2597 }
2598
2599 /* UP: Returns the collected stuff from a String-Output-Stream.
2600 get_output_stream_string(&stream)
2601 > stream: String-Output-Stream
2602 < stream: emptied Stream
2603 < result: collected stuff, a Simple-String
2604 can trigger GC */
get_output_stream_string(const gcv_object_t * stream_)2605 global maygc object get_output_stream_string (const gcv_object_t* stream_) {
2606 harden_elastic_newline(stream_);
2607 var object string = TheStream(*stream_)->strm_str_out_string; /* old String */
2608 if ((Iarray_flags(string) & arrayflags_atype_mask) == Atype_NIL) {
2609 /* Return the encapsulated (VECTOR NIL). It is an immutable object, since
2610 it is not adjustable and its fill-pointer is constrained to remain 0.
2611 Therefore no need to copy it into a string without fill-pointer. */
2612 } else {
2613 string = coerce_ss(string); /* convert to Simple-String (enforces copying) */
2614 /* empty old String by Fill-Pointer:=0 : */
2615 TheIarray(TheStream(*stream_)->strm_str_out_string)->dims[1] = 0;
2616 }
2617 return string;
2618 }
2619
2620 LISPFUNN(get_output_stream_string,1)
2621 { /* (GET-OUTPUT-STREAM-STRING string-output-stream), CLTL p. 330 */
2622 var object stream = STACK_0; /* Argument */
2623 /* must be a String-Output-Stream: */
2624 if (!(builtin_stream_p(stream)
2625 && (TheStream(stream)->strmtype == strmtype_str_out)))
2626 error_string_stream(stream,GETTEXT("~S: ~S is not a string output stream"));
2627 /* the collected stuff is the value */
2628 VALUES1(get_output_stream_string(&STACK_0));
2629 skipSTACK(1);
2630 }
2631
2632
2633 /* String-Push-Stream
2634 ==================
2635
2636 Additional Components: */
2637 #define strm_str_push_string strm_other[0] /* String with Fill-Pointer for Output */
2638
2639 /* WRITE-CHAR - Pseudo-Function for String-Push-Streams: */
wr_ch_str_push(const gcv_object_t * stream_,object ch)2640 local maygc void wr_ch_str_push (const gcv_object_t* stream_, object ch) {
2641 var object stream = *stream_;
2642 check_wr_char(stream,ch);
2643 /* push Character in the String: */
2644 pushSTACK(ch); pushSTACK(TheStream(stream)->strm_str_push_string);
2645 funcall(L(vector_push_extend),2); /* (VECTOR-PUSH-EXTEND ch string) */
2646 }
2647
2648 /* (SYSTEM::MAKE-STRING-PUSH-STREAM string) returns a Stream, whose
2649 WRITE-CHAR operation is equivalent to a VECTOR-PUSH-EXTEND
2650 on the given String. */
2651 LISPFUNNR(make_string_push_stream,1) {
2652 {
2653 var object arg = STACK_0; /* Argument */
2654 /* must be a String with Fill-Pointer: */
2655 if (!(stringp(arg) && array_has_fill_pointer_p(arg))) {
2656 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
2657 pushSTACK(O(type_string_with_fill_pointer)); /* TYPE-ERROR slot EXPECTED-TYPE */
2658 pushSTACK(arg); pushSTACK(S(with_output_to_string));
2659 error(type_error,
2660 GETTEXT("~S: argument ~S should be a string with fill pointer"));
2661 }
2662 }
2663 var object stream = /* new Stream, only WRITE-CHAR allowed */
2664 allocate_stream(strmflags_wr_ch_B,strmtype_str_push,strm_len+1,0);
2665 stream_dummy_fill(stream);
2666 TheStream(stream)->strm_wr_ch =
2667 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_str_push);
2668 TheStream(stream)->strm_wr_ch_array =
2669 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_dummy);
2670 TheStream(stream)->strm_str_push_string = popSTACK(); /* enter String */
2671 VALUES1(stream); /* return stream */
2672 }
2673
2674
2675 /* String-Stream in general
2676 ======================= */
2677
2678 LISPFUNNF(string_stream_p,1)
2679 { /* (SYS::STRING-STREAM-P stream) == (TYPEP stream 'STRING-STREAM) */
2680 var object arg = popSTACK();
2681 if (builtin_stream_p(arg)) {
2682 switch (TheStream(arg)->strmtype) {
2683 case strmtype_str_in: /* String-Input-Stream */
2684 case strmtype_str_out: /* String-Output-Stream */
2685 case strmtype_str_push: /* String-Push-Stream */
2686 VALUES1(T); break;
2687 default:
2688 VALUES1(NIL); break;
2689 }
2690 } else
2691 VALUES1(NIL);
2692 }
2693
2694 LISPFUNNR(string_stream_string,1)
2695 { /* (SYSTEM::STRING-STREAM-STRING string-stream) ==> String [beg end] */
2696 var object stream = popSTACK();
2697 if (builtin_stream_p(stream))
2698 switch (TheStream(stream)->strmtype) {
2699 case strmtype_str_in: /* String-Input-Stream */
2700 VALUES3(TheStream(stream)->strm_str_in_string,
2701 TheStream(stream)->strm_str_in_begindex,
2702 TheStream(stream)->strm_str_in_endindex);
2703 return;
2704 case strmtype_str_out: /* String-Output-Stream */
2705 VALUES1(TheStream(stream)->strm_str_out_string);
2706 return;
2707 case strmtype_str_push: /* String-Push-Stream */
2708 VALUES1(TheStream(stream)->strm_str_push_string);
2709 return;
2710 }
2711 error_string_stream(stream,GETTEXT("~S: ~S is not a string stream"));
2712 }
2713
2714
2715 /* Pretty-Printer-Help-Stream
2716 ==========================
2717
2718 Additional Components:
2719 define strm_pphelp_strings strm_other[0] - Semi-Simple-Strings for Output
2720 define strm_pphelp_modus strm_other[1] - Mode (NIL=single-liner, T=multi-liner)
2721
2722 WRITE-CHAR - Pseudo-Function for Pretty-Printer-Auxiliary-Streams: */
wr_ch_pphelp(const gcv_object_t * stream_,object ch)2723 local maygc void wr_ch_pphelp (const gcv_object_t* stream_, object ch) {
2724 var object stream = *stream_;
2725 check_wr_char(stream,ch);
2726 var chart c = char_code(ch); /* Character */
2727 /* At NL: Now Mode := Multi-liner */
2728 if (chareq(c,ascii(NL))) {
2729 TheStream(stream)->strm_pphelp_modus = T;
2730 cons_ssstring(stream_,NIL);
2731 } else if ((chareq(c,ascii(' ')) || chareq(c,ascii('\t')))
2732 && !nullpSv(print_pretty_fill)) {
2733 var object list = TheStream(stream)->strm_pphelp_strings;
2734 if (!(vector_length(Car(list)) == 0 && mconsp(Cdr(list))
2735 && mconsp(Car(Cdr(list))) && eq(S(Kfill),Car(Car(Cdr(list)))))) {
2736 ssstring_push_extend(Car(list),c);
2737 /* spaces right after a :FILL newline or multiple spaces are ignored */
2738 cons_ssstring(stream_,S(Kfill));
2739 }
2740 } else
2741 /* push Character in the first String: */
2742 ssstring_push_extend(Car(TheStream(stream)->strm_pphelp_strings),c);
2743 }
2744
2745 /* WRITE-CHAR-ARRAY - Pseudo-Function for Pretty-Printer-Auxiliary-Streams: */
wr_ch_array_pphelp(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)2746 local maygc void wr_ch_array_pphelp (const gcv_object_t* stream_,
2747 const gcv_object_t* chararray_,
2748 uintL start, uintL len) {
2749 var bool filling = !nullpSv(print_pretty_fill);
2750 var uintL beg = start;
2751 DEBUG_OUT(("s=%d l=%d",start,len));
2752 while (1) {
2753 var uintL end = beg;
2754 var object nl_type = NIL;
2755 DEBUG_OUT((" [%d/",beg));
2756 while (end < start+len) {
2757 var chart ch = schar(*chararray_,end);
2758 if (chareq(ch,ascii(NL))) { DEBUG_OUT(("%d=NL",end)); break; }
2759 if (filling && (chareq(ch,ascii(' ')) || chareq(ch,ascii('\t')))) {
2760 DEBUG_OUT(("%d=SPC",end));
2761 end++; /* include the space */
2762 nl_type = S(Kfill);
2763 break;
2764 }
2765 end++;
2766 }
2767 DEBUG_OUT(("/%d]",end));
2768 if (beg != end) {
2769 var uintL count = end-beg;
2770 var object ssstring = Car(TheStream(*stream_)->strm_pphelp_strings); /* Semi-Simple-String */
2771 ssstring = ssstring_append_extend(ssstring,*chararray_,beg,count);
2772 if (wr_ss_lpos(*stream_,&TheSnstring(TheIarray(ssstring)->data)->data[TheIarray(ssstring)->dims[1]],count)) /* update Line-Position */
2773 TheStream(*stream_)->strm_pphelp_modus = T; /* After NL: Mode := multi-liner */
2774 }
2775 if (end == start+len)
2776 break;
2777 if (nullp(nl_type))
2778 TheStream(*stream_)->strm_pphelp_modus = T;
2779 cons_ssstring(stream_,nl_type);
2780 beg = end;
2781 if (nullp(nl_type))
2782 beg++; /* skip the newline */
2783 }
2784 DEBUG_OUT(("\n"));
2785 }
2786
2787 /* UP: Returns a Pretty-Printer-Auxiliary-Stream.
2788 make_pphelp_stream()
2789 can trigger GC */
make_pphelp_stream(void)2790 global maygc object make_pphelp_stream (void) {
2791 pushSTACK(cons_ssstring(NULL,NIL));
2792 var object stream = /* new Stream, only WRITE-CHAR allowed */
2793 allocate_stream(strmflags_wr_ch_B,strmtype_pphelp,strm_len+2,0);
2794 stream_dummy_fill(stream);
2795 TheStream(stream)->strm_wr_ch =
2796 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_pphelp);
2797 TheStream(stream)->strm_wr_ch_array =
2798 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_pphelp);
2799 TheStream(stream)->strm_pphelp_strings = popSTACK(); /* enter String-List */
2800 TheStream(stream)->strm_pphelp_modus = NIL; /* Mode := single-liner */
2801 return stream;
2802 }
2803
2804
2805 /* Buffered-Input-Stream
2806 =====================
2807
2808 Element-Type: character
2809 Directions: only input
2810 (make-buffered-input-stream fun mode) returns a Buffered-Input-Stream.
2811 fun is a Function of 0 Arguments, that returns upon call
2812 either NIL (stands for EOF) or up to three values string, start, end.
2813 Functionality: (read-char ...) returns one after another the characters
2814 of the current String; if it is consumed, fun is called, and if the returning
2815 value is a String, the new current String is given by
2816 (multiple-value-bind (str start end) (funcall fun)
2817 (subseq str (or start 0) (or end 'NIL))
2818 )
2819 The String returned by fun should not be changed.
2820 (Otherwise fun should copy the String with COPY-SEQ beforehand.)
2821 mode determines, how the Stream acts regarding to LISTEN.
2822 mode = NIL: Stream acts like a File-Stream, i.e. on LISTEN
2823 and empty current String fun is called.
2824 mode = T: Stream acts like an interactive Stream without EOF,
2825 i.e. one can assume, that always further characters will
2826 arrive, without calling fun.
2827 mode a Function: This Function tells, upon call, if
2828 further non-empty Strings are to be expected.
2829 (clear-input ...) finishes the processing of the current String.
2830
2831 Additional Components:
2832 define strm_buff_in_fun strm_other[0] - Read-Function */
2833 #define strm_buff_in_mode strm_other[1] /* Mode or Listen-Function */
2834 #define strm_buff_in_string strm_other[2] /* current String for Input */
2835 #define strm_buff_in_index strm_other[3] /* Index in the String (Fixnum >=0) */
2836 #define strm_buff_in_endindex strm_other[4] /* Endindex (Fixnum >= index >=0) */
2837
2838 /* READ-CHAR - Pseudo-Function for Buffered-Input-Streams: */
rd_ch_buff_in(const gcv_object_t * stream_)2839 local maygc object rd_ch_buff_in (const gcv_object_t* stream_) {
2840 var object stream = *stream_;
2841 var uintV index = posfixnum_to_V(TheStream(stream)->strm_buff_in_index);
2842 var uintV endindex =
2843 posfixnum_to_V(TheStream(stream)->strm_buff_in_endindex);
2844 while (index >= endindex) { /* string end reached */
2845 /* call fun: */
2846 funcall(TheStream(stream)->strm_buff_in_fun,0);
2847 if (!stringp(value1))
2848 return eof_value; /* EOF reached */
2849 /* fetch new String and check ranges: */
2850 pushSTACK(value1); /* String */
2851 pushSTACK(mv_count >= 2 ? value2 : unbound); /* start */
2852 pushSTACK(mv_count >= 3 ? value3 : unbound); /* end */
2853 var stringarg val;
2854 var object string = test_string_limits_ro(&val);
2855 stream = *stream_;
2856 index = val.index; /* val.offset==0 since the buffer is simple! */
2857 endindex = index+val.len;
2858 TheStream(stream)->strm_buff_in_string = string;
2859 TheStream(stream)->strm_buff_in_index = fixnum(index);
2860 TheStream(stream)->strm_buff_in_endindex = fixnum(endindex);
2861 }
2862 /* index < endvalid */
2863 var uintL len;
2864 var uintL offset;
2865 var object string = unpack_string_ro(TheStream(stream)->strm_buff_in_string,&len,&offset);
2866 if (index >= len) { /* Index too big ? */
2867 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
2868 pushSTACK(TheStream(stream)->strm_buff_in_string);
2869 pushSTACK(stream);
2870 error(stream_error,GETTEXT("~S is beyond the end because the string ~S has been adjusted"));
2871 }
2872 /* fetch character from String */
2873 var object ch = code_char(schar(string,offset+index));
2874 /* increase Index: */
2875 TheStream(stream)->strm_buff_in_index = fixnum_inc(TheStream(stream)->strm_buff_in_index,1);
2876 return ch;
2877 }
2878
2879 /* Closes a Buffered-Input-Stream.
2880 close_buff_in(stream, abort);
2881 > stream : Buffered-Input-Stream */
close_buff_in(object stream)2882 local maygc void close_buff_in (object stream) {
2883 TheStream(stream)->strm_buff_in_fun = NIL; /* Function := NIL */
2884 TheStream(stream)->strm_buff_in_mode = NIL; /* Mode := NIL */
2885 TheStream(stream)->strm_buff_in_string = NIL; /* String := NIL */
2886 }
2887
2888 /* Determines, if a character is available on a Buffered-Input-Stream.
2889 listen_char_buff_in(stream)
2890 > stream : Buffered-Input-Stream
2891 < result: input availability
2892 can trigger GC */
listen_char_buff_in(object stream)2893 local maygc listen_t listen_char_buff_in (object stream) {
2894 var uintV index = posfixnum_to_V(TheStream(stream)->strm_buff_in_index);
2895 var uintV endindex = posfixnum_to_V(TheStream(stream)->strm_buff_in_endindex);
2896 if (index < endindex)
2897 return LISTEN_AVAIL;
2898 var object mode = TheStream(stream)->strm_buff_in_mode;
2899 if (eq(mode,S(nil))) {
2900 pushSTACK(stream);
2901 mode = peek_char(&STACK_0); /* peek_char makes read_char, calls fun */
2902 skipSTACK(1);
2903 if (eq(mode,eof_value))
2904 return LISTEN_EOF; /* EOF reached */
2905 else
2906 return LISTEN_AVAIL;
2907 } else if (eq(mode,S(t))) {
2908 return LISTEN_AVAIL;
2909 } else {
2910 funcall(mode,0); /* call mode */
2911 if (nullp(value1)) /* no more Strings to be expected? */
2912 return LISTEN_EOF; /* yes -> EOF reached */
2913 else
2914 return LISTEN_AVAIL;
2915 }
2916 }
2917
2918 /* UP: Deletes already entered interactive Input from a Buffered-Input-Stream.
2919 clear_input_buff_in(stream)
2920 > stream: Buffered-Input-Stream
2921 < result: true if Input was deleted
2922 can trigger GC */
clear_input_buff_in(object stream)2923 local maygc bool clear_input_buff_in (object stream) {
2924 /* end processing of the current String: */
2925 var object index = TheStream(stream)->strm_buff_in_index;
2926 var object endindex = TheStream(stream)->strm_buff_in_endindex;
2927 TheStream(stream)->strm_buff_in_index = endindex; /* index := endindex */
2928 if (eq(index,endindex))
2929 return false;
2930 else
2931 return true;
2932 }
2933
2934 LISPFUNNR(make_buffered_input_stream,2)
2935 { /* (MAKE-BUFFERED-INPUT-STREAM fun mode) */
2936 var object stream = /* new Stream, only READ-CHAR allowed */
2937 allocate_stream(strmflags_rd_ch_B,strmtype_buff_in,strm_len+5,0);
2938 stream_dummy_fill(stream);
2939 TheStream(stream)->strm_rd_ch = P(rd_ch_buff_in);
2940 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_dummy);
2941 TheStream(stream)->strm_buff_in_mode = popSTACK();
2942 TheStream(stream)->strm_buff_in_fun = popSTACK();
2943 TheStream(stream)->strm_buff_in_string = O(empty_string); /* String := "" */
2944 TheStream(stream)->strm_buff_in_index = Fixnum_0; /* Index := 0 */
2945 TheStream(stream)->strm_buff_in_endindex = Fixnum_0; /* Endindex := 0 */
2946 VALUES1(stream); /* return stream */
2947 }
2948
2949 LISPFUNNR(buffered_input_stream_index,1)
2950 { /* (SYS::BUFFERED-INPUT-STREAM-INDEX buffered-input-stream)
2951 returns the Index */
2952 var object stream = popSTACK(); /* Argument */
2953 /* must be a Buffered-Input-Stream: */
2954 if (!(builtin_stream_p(stream)
2955 && (TheStream(stream)->strmtype == strmtype_buff_in))) {
2956 pushSTACK(stream);
2957 pushSTACK(TheSubr(subr_self)->name);
2958 error(error_condition,GETTEXT("~S: ~S is not a buffered input stream"));
2959 }
2960 var object index = TheStream(stream)->strm_buff_in_index;
2961 /* if a Character was pushed back with UNREAD-CHAR,
2962 use (1- index), a Fixnum >=0, as value: */
2963 if (TheStream(stream)->strmflags & strmflags_unread_B)
2964 index = fixnum_inc(index,-1);
2965 VALUES1(index);
2966 }
2967
2968 /* handling of (close :abort): ignore the error and proceed to close FDs */
2969 #if !defined(MULTITHREAD)
2970 /* should be per thread - moved to clisp_thread_t in MT */
2971 local bool running_handle_close_errors = false;
2972 #endif
handle_close_errors(void * sp,gcv_object_t * frame,object label,object condition)2973 local void handle_close_errors (void* sp, gcv_object_t* frame, object label,
2974 object condition) {
2975 unused(sp); unused(label); unused(condition);
2976 if (running_handle_close_errors) return;
2977 else running_handle_close_errors = true;
2978 unwind_upto(frame);
2979 }
2980 #define MAYBE_IGNORE_ERRORS(abort,code) \
2981 { var sp_jmp_buf returner; /* return point */ \
2982 if (abort) { \
2983 running_handle_close_errors = false; \
2984 make_C_HANDLER_entry_frame(O(handler_for_error), handle_close_errors, \
2985 returner, goto end_ignore_errors; ); \
2986 } \
2987 code; \
2988 if (abort) running_handle_close_errors = false; \
2989 end_ignore_errors: \
2990 if (abort) { unwind_C_HANDLER_frame(); } \
2991 }
2992
2993
2994 /* Buffered-Output-Stream
2995 ======================
2996
2997 Element-Type: character
2998 Directions: only output
2999 (make-buffered-output-stream fun) returns a Buffered-Output-Stream.
3000 fun is a Function expecting one Argument, a Simple-String.
3001 Functionality: (write-char ...) gathers the written characters in
3002 a String, until a #\Newline or a FORCE-/FINISH-OUTPUT-
3003 request arrives. Then it calls fun with a Simple-String as Argument,
3004 that contains the so far collected stuff.
3005 (clear-output ...) dicards the so far collected characters.
3006
3007 Additional Components:
3008 define strm_buff_out_fun strm_other[0] - Output-Function */
3009 #define strm_buff_out_string strm_other[1] /* Semi-Simple-String for Output */
3010
3011 /* UP: Moves the pending Output of a Buffered-Output-Stream to the destination.
3012 finish_output_buff_out(stream);
3013 > stream: Buffered-Output-Stream
3014 can trigger GC */
finish_output_buff_out(object stream)3015 local maygc void finish_output_buff_out (object stream) {
3016 pushSTACK(stream);
3017 var object string = TheStream(stream)->strm_buff_out_string; /* String */
3018 string = coerce_ss(string); /* convert to Simple-String (enforces copying) */
3019 stream = STACK_0; STACK_0 = string;
3020 /* empty String by Fill-Pointer:=0 : */
3021 TheIarray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0;
3022 funcall(TheStream(stream)->strm_buff_out_fun,1); /* call Function */
3023 }
3024
3025 /* UP: Moves the pending Output of a Buffered-Output-Stream to the destination.
3026 force_output_buff_out(stream);
3027 > stream: Buffered-Output-Stream
3028 can trigger GC */
3029 #define force_output_buff_out finish_output_buff_out
3030
3031 /* UP: Deletes the pending Output of a Buffered-Output-Stream.
3032 clear_output_buff_out(stream);
3033 > stream: Buffered-Output-Stream
3034 can trigger GC */
clear_output_buff_out(object stream)3035 local maygc void clear_output_buff_out (object stream) {
3036 /* empty String by Fill-Pointer:=0 : */
3037 TheIarray(TheStream(stream)->strm_buff_out_string)->dims[1] = 0;
3038 /* leave Line-Position unchanged?? */
3039 }
3040
3041 /* WRITE-CHAR - Pseudo-Function for Buffered-Output-Streams: */
wr_ch_buff_out(const gcv_object_t * stream_,object ch)3042 local maygc void wr_ch_buff_out (const gcv_object_t* stream_, object ch) {
3043 var object stream = *stream_;
3044 check_wr_char(stream,ch);
3045 /* push Character in the String: */
3046 ssstring_push_extend(TheStream(stream)->strm_buff_out_string,char_code(ch));
3047 /* After #\Newline pass on Buffer: */
3048 if (chareq(char_code(ch),ascii(NL)))
3049 force_output_buff_out(*stream_);
3050 }
3051
3052 /* Closes a Buffered-Output-Stream.
3053 close_buff_out(stream, abort);
3054 > stream : Buffered-Output-Stream
3055 > abort: flag: non-0 => ignore errors
3056 can trigger GC */
close_buff_out(object stream,uintB abort)3057 local maygc void close_buff_out (object stream, uintB abort) {
3058 pushSTACK(stream); /* save stream */
3059 MAYBE_IGNORE_ERRORS(abort,finish_output_buff_out(stream));
3060 stream = popSTACK(); /* restore stream */
3061 TheStream(stream)->strm_buff_out_fun = NIL; /* Function := NIL */
3062 TheStream(stream)->strm_buff_out_string = NIL; /* String := NIL */
3063 }
3064
3065 /* (MAKE-BUFFERED-OUTPUT-STREAM fun [line-position]) */
3066 LISPFUN(make_buffered_output_stream,seclass_read,1,1,norest,nokey,0,NIL) {
3067 /* check line-position: */
3068 if (!boundp(STACK_0)) {
3069 STACK_0 = Fixnum_0; /* default value 0 */
3070 } else { /* line-position specified, should be a Fixnum >=0 : */
3071 if (!posfixnump(STACK_0))
3072 error_posfixnum(STACK_0);
3073 }
3074 /* allocate small Semi-Simple-String of Length 50 : */
3075 pushSTACK(make_ssstring(SEMI_SIMPLE_DEFAULT_SIZE));
3076 var object stream = /* new Stream, only WRITE-CHAR allowed */
3077 allocate_stream(strmflags_wr_ch_B,strmtype_buff_out,strm_len+2,0);
3078 stream_dummy_fill(stream);
3079 TheStream(stream)->strm_wr_ch =
3080 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_buff_out);
3081 TheStream(stream)->strm_wr_ch_array =
3082 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_dummy);
3083 TheStream(stream)->strm_buff_out_string = popSTACK(); /* enter String */
3084 TheStream(stream)->strm_wr_ch_lpos = popSTACK(); /* enter Line Position */
3085 TheStream(stream)->strm_buff_out_fun = popSTACK(); /* enter Function */
3086 VALUES1(stream); /* return stream */
3087 }
3088
3089
3090 #ifdef GENERIC_STREAMS
3091
3092 /* Generic Streams
3093 ===============
3094
3095 Contains a "controller object".
3096 define strm_controller_object strm_other[0] - see lispbibl.d
3097
3098 The function GENERIC-STREAM-CONTROLLER will return some
3099 object c associated with the stream s.
3100
3101 (GENERIC-STREAM-READ-CHAR c) --> character or NIL
3102 (GENERIC-STREAM-PEEK-CHAR c) --> character or NIL
3103 (GENERIC-STREAM-READ-CHAR-WILL-HANG-P c) --> {T,NIL}
3104 (GENERIC-STREAM-CLEAR-INPUT c) --> {T,NIL}
3105 (GENERIC-STREAM-WRITE-CHAR c ch) -->
3106 (GENERIC-STREAM-WRITE-STRING c string start len) -->
3107 (GENERIC-STREAM-FINISH-OUTPUT c) -->
3108 (GENERIC-STREAM-FORCE-OUTPUT c) -->
3109 (GENERIC-STREAM-CLEAR-OUTPUT c) -->
3110 (GENERIC-STREAM-READ-BYTE c) --> integer or NIL
3111 (GENERIC-STREAM-WRITE-BYTE c i) -->
3112 (GENERIC-STREAM-CLOSE c) -->
3113
3114 (READ-CHAR s) == (GENERIC-STREAM-READ-CHAR c) */
rd_ch_generic(const gcv_object_t * stream_)3115 local maygc object rd_ch_generic (const gcv_object_t* stream_) {
3116 pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
3117 pushSTACK(value1); funcall(S(generic_stream_rdch),1);
3118 return nullp(value1) ? eof_value : value1;
3119 }
3120
3121 /* (PEEK-CHAR s) == (GENERIC-STREAM-PEEK-CHAR c) */
pk_ch_generic(const gcv_object_t * stream_)3122 local maygc object pk_ch_generic (const gcv_object_t* stream_) {
3123 pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
3124 pushSTACK(value1); funcall(S(generic_stream_pkch),1);
3125 if (nullp(value1))
3126 value1 = eof_value;
3127 if ((mv_count >= 2) && !nullp(value2)) {
3128 /* READ-CHAR already executed -> must execute an implicit UNREAD-CHAR
3129 (i.e. save the result for the next READ-CHAR/PEEK-CHAR). */
3130 TheStream(*stream_)->strm_rd_ch_last = value1;
3131 if (!eq(value1,eof_value))
3132 TheStream(*stream_)->strmflags |= strmflags_unread_B;
3133 }
3134 return value1;
3135 }
3136
3137 /* (LISTEN s) ==
3138 (IF (GENERIC-STREAM-READ-CHAR-WILL-HANG-P c)
3139 :WAIT
3140 (IF (GENERIC-STREAM-PEEK-CHAR c)
3141 :INPUT-AVAILABLE
3142 :EOF)) */
listen_char_generic(object stream)3143 local maygc listen_t listen_char_generic (object stream) {
3144 pushSTACK(stream);
3145 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3146 pushSTACK(value1); funcall(S(generic_stream_read_char_will_hang_p),1);
3147 if (!nullp(value1)) {
3148 skipSTACK(1); return LISTEN_WAIT;
3149 }
3150 var object nextchar = pk_ch_generic(&STACK_0);
3151 skipSTACK(1);
3152 if (eq(nextchar,eof_value))
3153 return LISTEN_EOF;
3154 else
3155 return LISTEN_AVAIL;
3156 }
3157
3158 /* (CLEAR-INPUT s) == (GENERIC-STREAM-CLEAR-INPUT c) */
clear_input_generic(object stream)3159 local maygc bool clear_input_generic (object stream) {
3160 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3161 pushSTACK(value1); funcall(S(generic_stream_clear_input),1);
3162 return !nullp(value1);
3163 }
3164
3165 /* (WRITE-CHAR ch s) == (GENERIC-STREAM-WRITE-CHAR c ch) */
wr_ch_generic(const gcv_object_t * stream_,object ch)3166 local maygc void wr_ch_generic (const gcv_object_t* stream_, object ch) {
3167 /* ch is a character, need not save it */
3168 pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
3169 pushSTACK(value1); pushSTACK(ch); funcall(S(generic_stream_wrch),2);
3170 }
3171
3172 /* (WRITE-CHAR-ARRAY s string start len) ==
3173 (GENERIC-STREAM-WRITE-STRING c string start len) */
wr_ch_array_generic(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)3174 local maygc void wr_ch_array_generic (const gcv_object_t* stream_,
3175 const gcv_object_t* chararray_,
3176 uintL start, uintL len) {
3177 pushSTACK(*stream_); funcall(L(generic_stream_controller),1);
3178 pushSTACK(value1); pushSTACK(*chararray_);
3179 pushSTACK(UL_to_I(start)); pushSTACK(UL_to_I(len));
3180 funcall(S(generic_stream_wrss),4);
3181 var const chart* charptr;
3182 unpack_sstring_alloca(*chararray_,len,start, charptr=);
3183 wr_ss_lpos(*stream_,&charptr[len],len);
3184 }
3185
3186 /* (FINISH-OUTPUT s) == (GENERIC-STREAM-FINISH-OUTPUT c) */
finish_output_generic(object stream)3187 local maygc void finish_output_generic (object stream) {
3188 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3189 pushSTACK(value1); funcall(S(generic_stream_finish_output),1);
3190 }
3191
3192 /* (FORCE-OUTPUT s) == (GENERIC-STREAM-FORCE-OUTPUT c) */
force_output_generic(object stream)3193 local maygc void force_output_generic (object stream) {
3194 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3195 pushSTACK(value1); funcall(S(generic_stream_force_output),1);
3196 }
3197
3198 /* (CLEAR-OUTPUT s) == (GENERIC-STREAM-CLEAR-OUTPUT c) */
clear_output_generic(object stream)3199 local maygc void clear_output_generic (object stream) {
3200 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3201 pushSTACK(value1); funcall(S(generic_stream_clear_output),1);
3202 }
3203
3204 /* (READ-BYTE s) == (GENERIC-STREAM-READ-BYTE c) */
rd_by_generic(object stream)3205 local maygc object rd_by_generic (object stream) {
3206 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3207 pushSTACK(value1); funcall(S(generic_stream_rdby),1);
3208 return (nullp(value1) ? eof_value : value1);
3209 }
3210
3211 /* (WRITE-BYTE s i) == (GENERIC-STREAM-WRITE-BYTE c i) */
wr_by_generic(object stream,object obj)3212 local maygc void wr_by_generic (object stream, object obj) {
3213 pushSTACK(obj); /* save obj */
3214 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3215 obj = STACK_0;
3216 STACK_0 = value1; pushSTACK(obj); funcall(S(generic_stream_wrby),2);
3217 }
3218
3219 /* (CLOSE s) == (GENERIC-STREAM-CLOSE c) */
close_generic(object stream,uintB abort)3220 local maygc void close_generic (object stream, uintB abort) {
3221 MAYBE_IGNORE_ERRORS(abort, {
3222 pushSTACK(stream); funcall(L(generic_stream_controller),1);
3223 pushSTACK(value1); funcall(S(generic_stream_close),1);
3224 });
3225 }
3226
3227 LISPFUNN(generic_stream_controller,1) {
3228 var object stream = popSTACK();
3229 CHECK_streamtype(stream,S(generic_stream),
3230 (builtin_stream_p(stream)
3231 && eq(TheStream(stream)->strm_rd_by,P(rd_by_generic))
3232 && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic))));
3233 VALUES1(TheStream(stream)->strm_controller_object);
3234 }
3235
3236 LISPFUNN(make_generic_stream,1) {
3237 var object stream =
3238 allocate_stream(strmflags_rdwr_B,strmtype_generic,strm_len+1,0);
3239 TheStream(stream)->strm_rd_by = P(rd_by_generic);
3240 TheStream(stream)->strm_rd_by_array = P(rd_by_array_dummy);
3241 TheStream(stream)->strm_wr_by = P(wr_by_generic);
3242 TheStream(stream)->strm_wr_by_array = P(wr_by_array_dummy);
3243 TheStream(stream)->strm_rd_ch = P(rd_ch_generic);
3244 TheStream(stream)->strm_pk_ch = P(pk_ch_generic);
3245 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_dummy);
3246 TheStream(stream)->strm_rd_ch_last = NIL;
3247 TheStream(stream)->strm_wr_ch =
3248 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_generic);
3249 TheStream(stream)->strm_wr_ch_array =
3250 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_generic);
3251 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
3252 TheStream(stream)->strm_controller_object = popSTACK();
3253 VALUES1(stream); /* return stream */
3254 }
3255
3256 LISPFUNN(generic_stream_p,1) {
3257 var object stream = check_stream(popSTACK());
3258 VALUES_IF(builtin_stream_p(stream)
3259 && eq(TheStream(stream)->strm_rd_by,P(rd_by_generic))
3260 && eq(TheStream(stream)->strm_wr_by,P(wr_by_generic)));
3261 }
3262
3263 #endif
3264
3265
3266 /* Streams communicating with the exterior world, based on bytes
3267 =============================================================
3268
3269 They can be classified in three ways:
3270 According to strmtype:
3271
3272 file ---- strmtype_file
3273 /
3274 handle
3275 / \ / strmtype_pipe_in
3276 channel pipe ----- strmtype_pipe_out
3277 \
3278 socket ----- strmtype_x11socket
3279 \ strmtype_socket
3280
3281 According to buffering:
3282
3283 unbuffered
3284 /
3285 channel
3286 \
3287 buffered
3288
3289 According to element type:
3290
3291 CHARACTER or ([UN]SIGNED-BYTE n), n a multiple of 8 (setfable!)
3292 /
3293 channel
3294 \
3295 ([UN]SIGNED-BYTE n), n not a multiple of 8 (only if buffered)
3296
3297
3298 UP: Check a :BUFFERED argument.
3299 test_buffered_arg(arg)
3300 > object arg: argument
3301 < buffered_t: +1 for T, -1 for NIL, 0 for :DEFAULT */
3302 typedef enum { BUFFERED_T, BUFFERED_NIL, BUFFERED_DEFAULT } buffered_t;
test_buffered_arg(object arg)3303 local buffered_t test_buffered_arg (object arg) {
3304 if (!boundp(arg) || eq(arg,S(Kdefault)))
3305 return BUFFERED_DEFAULT;
3306 if (nullp(arg))
3307 return BUFFERED_NIL;
3308 if (eq(arg,T))
3309 return BUFFERED_T;
3310 error_illegal_arg(arg,O(type_buffered_arg),S(Kbuffered));
3311 }
3312
3313 /* Classification of possible :ELEMENT-TYPEs. */
3314 typedef enum {
3315 eltype_ch, /* CHARACTER */
3316 eltype_iu, /* (UNSIGNED-BYTE n) */
3317 eltype_is /* (SIGNED-BYTE n) */
3318 } eltype_kind;
3319
3320 /* An analyzed :ELEMENT-TYPE argument. */
3321 typedef struct {
3322 eltype_kind kind;
3323 uintL size; /* the n in ([UN]SIGNED-BYTE n), */
3324 /* >0, <intDsize*uintWC_max,
3325 but 0 for eltype_ch */
3326 } decoded_el_t;
3327
3328 /* UP: Check a :ELEMENT-TYPE argument.
3329 test_eltype_arg(&eltype,&decoded);
3330 > object eltype: argument (in the STACK)
3331 < decoded: decoded eltype
3332 can trigger GC */
test_eltype_arg(gcv_object_t * eltype_,decoded_el_t * decoded)3333 local maygc void test_eltype_arg (gcv_object_t* eltype_, decoded_el_t* decoded)
3334 {
3335 var object arg = *eltype_;
3336 if (!boundp(arg) || eq(arg,S(character)) || eq(arg,S(string_char))
3337 || eq(arg,S(Kdefault))) { /* CHARACTER, STRING-CHAR, :DEFAULT */
3338 decoded->kind = eltype_ch; decoded->size = 0; return;
3339 }
3340 if (eq(arg,S(bit))) { /* BIT */
3341 decoded->kind = eltype_iu; decoded->size = 1; return;
3342 }
3343 if (eq(arg,S(unsigned_byte))) { /* UNSIGNED-BYTE */
3344 decoded->kind = eltype_iu; decoded->size = 8; return;
3345 }
3346 if (eq(arg,S(signed_byte))) { /* SIGNED-BYTE */
3347 decoded->kind = eltype_is; decoded->size = 8; return;
3348 }
3349 var object eltype_size;
3350 if (consp(arg) && mconsp(Cdr(arg)) && nullp(Cdr(Cdr(arg)))) { /* two-element List */
3351 var object h = Car(arg);
3352 if (eq(h,S(mod))) { /* (MOD n) */
3353 decoded->kind = eltype_iu;
3354 h = Car(Cdr(arg)); /* n */
3355 /* must be an Integer >0 : */
3356 if (!(integerp(h) && positivep(h) && !eq(h,Fixnum_0)))
3357 goto bad_eltype;
3358 /* build eltype_size := (integer-length (1- n)) : */
3359 pushSTACK(h); funcall(L(minus_one),1); /* (1- n) */
3360 pushSTACK(value1); funcall(L(integer_length),1); /* (integer-length (1- n)) */
3361 eltype_size = value1;
3362 goto eltype_integer;
3363 }
3364 if (eq(h,S(unsigned_byte))) { /* (UNSIGNED-BYTE n) */
3365 decoded->kind = eltype_iu;
3366 eltype_size = Car(Cdr(arg));
3367 goto eltype_integer;
3368 }
3369 if (eq(h,S(signed_byte))) { /* (SIGNED-BYTE n) */
3370 decoded->kind = eltype_is;
3371 eltype_size = Car(Cdr(arg));
3372 goto eltype_integer;
3373 }
3374 }
3375 { /* First of all canonicalize a little bit (therewith the different
3376 SUBTYPEP will not have to do the same three times): */
3377 pushSTACK(arg); funcall(S(canonicalize_type),1); /* (SYS::CANONICALIZE-TYPE arg) */
3378 pushSTACK(value1); /* save canon-arg */
3379 pushSTACK(STACK_0); pushSTACK(S(character)); funcall(S(subtypep),2); /* (SUBTYPEP canon-arg 'CHARACTER) */
3380 if (!nullp(value1)) {
3381 skipSTACK(1);
3382 decoded->kind = eltype_ch; decoded->size = 0;
3383 return;
3384 }
3385 funcall(S(subtype_integer),1); /* (SYS::SUBTYPE-INTEGER canon-arg) */
3386 }
3387 if (!((mv_count>1) && integerp(value1) && integerp(value2)))
3388 goto bad_eltype;
3389 {
3390 /* arg is a subtype of `(INTEGER ,low ,high) and
3391 value1 = low, value2 = high. */
3392 var uintL l;
3393 if (positivep(value1)) {
3394 l = I_integer_length(value2); /* (INTEGER-LENGTH high) */
3395 decoded->kind = eltype_iu;
3396 } else {
3397 var uintL l1 = I_integer_length(value1); /* (INTEGER-LENGTH low) */
3398 var uintL l2 = I_integer_length(value2); /* (INTEGER-LENGTH high) */
3399 l = (l1>l2 ? l1 : l2) + 1;
3400 decoded->kind = eltype_is;
3401 }
3402 eltype_size = fixnum(l);
3403 }
3404 eltype_integer:
3405 /* check eltype_size: */
3406 if (!(posfixnump(eltype_size) && !eq(eltype_size,Fixnum_0)
3407 && ((oint_data_len < log2_intDsize+intWCsize)
3408 /* [when oint_data_len <= log2(intDsize)+intWCsize-1 always
3409 eltype_size < 2^oint_data_len < intDsize*(2^intWCsize-1) ] */
3410 || (as_oint(eltype_size) <
3411 as_oint(fixnum(intDsize*(uintV)(vbitm(intWCsize)-1)))))))
3412 goto bad_eltype;
3413 decoded->size = posfixnum_to_V(eltype_size);
3414 return;
3415 bad_eltype:
3416 error_illegal_arg(*eltype_,nullobj,S(Kelement_type));
3417 }
3418
3419 /* evaluate the appropriate forms */
3420 #define ELTYPE_DISPATCH(decoded,ch,iu,is) \
3421 switch (decoded->kind) { \
3422 case eltype_ch: /*CHARACTER*/ ch; break; \
3423 case eltype_iu: /*(UNSIGNED-BYTE bitsize)*/ iu; break; \
3424 case eltype_is: /*(SIGNED-BYTE bitsize)*/ is; break; \
3425 default: NOTREACHED; \
3426 }
3427
3428 /* UP: Returns a canonical representation for a :ELEMENT-TYPE.
3429 canon_eltype(&decoded)
3430 > decoded: decoded eltype
3431 < result: either CHARACTER or ([UN]SIGNED-BYTE n)
3432 can trigger GC */
canon_eltype(const decoded_el_t * decoded)3433 local maygc object canon_eltype (const decoded_el_t* decoded) {
3434 ELTYPE_DISPATCH(decoded,{
3435 return S(character);
3436 },{
3437 pushSTACK(S(unsigned_byte));
3438 pushSTACK(fixnum(decoded->size));
3439 return listof(2);
3440 },{
3441 pushSTACK(S(signed_byte));
3442 pushSTACK(fixnum(decoded->size));
3443 return listof(2);
3444 });
3445 }
3446
3447 /* UP: Check an :EXTERNAL-FORMAT argument.
3448 test_external_format_arg(arg)
3449 > arg: argument
3450 < result: an encoding
3451 can trigger GC */
3452 #define test_external_format_arg(arg) \
3453 check_encoding(arg,&O(default_file_encoding),true)
3454
3455 /* Tells whether this process is running in Microsoft WSL
3456 (Windows Subsystem for Linux). */
3457 #if defined(UNIX_LINUX) && defined(AMD64)
3458 local bool is_wsl;
3459 #else
3460 #define is_wsl false
3461 #endif
3462
3463 /* UP: Initializes the OS dependencies for streams.
3464 init_stream_osdeps(); */
init_stream_osdeps(void)3465 global void init_stream_osdeps (void) {
3466 #if defined(UNIX_LINUX) && defined(AMD64)
3467 struct utsname buf;
3468 is_wsl = (uname(&buf) >= 0
3469 && (strstr(buf.release,"Microsoft") != NULL
3470 || strstr(buf.version, "Microsoft") != NULL));
3471 #endif
3472 }
3473
3474 #ifdef UNIX
3475
3476 /* UP: Deletes already entered interactive Input from a Handle. */
clear_tty_input(Handle handle)3477 local void clear_tty_input (Handle handle) {
3478 /* Method: tcflush TCIFLUSH, see TERMIOS(3V) */
3479 begin_system_call();
3480 #ifdef UNIX_TERM_TERMIOS
3481 /* On AIX, when a clisp process is run through 'nohup ... &' and the user
3482 logs out, the tty device /dev/pts/N is deallocated, that is, becomes owned
3483 by root, with permissions rw-rw-rw- (as opposed to rw--w--w- when it is
3484 allocated). The tcflush TCIFLUSH call can then trigger a SIGHUP signal,
3485 which would make the process terminate. Avoid this. */
3486 #ifdef UNIX_AIX
3487 var signal_handler_t prev_handler = install_signal_handler(SIGHUP,SIG_IGN);
3488 #endif
3489 var int ret = TCFLUSH(handle,TCIFLUSH);
3490 #ifdef UNIX_AIX
3491 var int saved_errno = errno;
3492 install_signal_handler(SIGHUP,prev_handler);
3493 errno = saved_errno;
3494 #endif
3495 if (!(ret==0)) {
3496 if (!((errno==ENOTTY)||(errno==EINVAL))) { /* no TTY: OK */
3497 local bool flag = false;
3498 /* report other Error, but only once */
3499 if (!flag) { flag = true; OS_error(); }
3500 }
3501 }
3502 #endif
3503 end_system_call();
3504 }
3505
3506 #if defined(UNIX_LINUX)
3507 #define IS_EINVAL_EXTRA (is_wsl&&(errno==EIO))
3508 #elif defined(UNIX_CYGWIN) /* for Windows95 and xterm/rxvt, and WindowsXP /dev/null */
3509 #define IS_EINVAL_EXTRA ((errno==EBADF)||(errno==EACCES)||(errno==EBADRQC))
3510 #elif defined(UNIX_MACOSX) || defined(UNIX_FREEBSD) || defined(UNIX_NETBSD) || defined(UNIX_OPENBSD)
3511 #if !defined(ENOTSUP) /* OpenBSD */
3512 #define ENOTSUP EOPNOTSUPP
3513 #endif
3514 #define IS_EINVAL_EXTRA ((errno==EOPNOTSUPP)||(errno==ENOTSUP)||(errno==ENODEV))
3515 #elif defined(UNIX_SUNOS5)
3516 #define IS_EINVAL_EXTRA ((errno==ENXIO))
3517 #elif defined(UNIX_AIX)
3518 /* ioctl() on /dev/null produces ENODEV. */
3519 #define IS_EINVAL_EXTRA ((errno==ENODEV))
3520 #elif defined(UNIX_IRIX)
3521 /* ioctl() on stdout, when it is a pipe, produces ENOSYS. */
3522 #define IS_EINVAL_EXTRA ((errno==ENOSYS))
3523 #elif defined(UNIX_HAIKU)
3524 /* ioctl() on /dev/null produces EPERM. */
3525 #define IS_EINVAL_EXTRA ((errno==EPERM))
3526 #else
3527 #define IS_EINVAL_EXTRA 0
3528 #endif
3529 #define IS_EINVAL ((errno==EINVAL)||IS_EINVAL_EXTRA)
3530
3531 /* UP: Move the pending Output of a Handle to the destination. */
finish_tty_output(Handle handle)3532 local void finish_tty_output (Handle handle) {
3533 /* Method 1: fsync, see fsync(2)
3534 Method 2: tcdrain, see termios(3V)
3535 poss. Method 3: ioctl TCGETS/TCSETSW, see termio(4) or tty_ioctl(4)
3536 or (almost equivalent) ioctl TIOCGETP/TIOCSETP, see TTCOMPAT(4) */
3537 begin_system_call();
3538 #if !(defined(UNIX) && !defined(HAVE_FSYNC))
3539 if (!( fsync(handle) ==0)) {
3540 #ifndef UNIX_BEOS /* BeOS 5 apparently does not set errno */
3541 if (!IS_EINVAL)
3542 { OS_error(); }
3543 #endif
3544 } else goto ok;
3545 #endif
3546 #ifdef UNIX_TERM_TERMIOS
3547 if (!( TCDRAIN(handle) ==0)) {
3548 if (!((errno==ENOTTY)||IS_EINVAL))
3549 { OS_error(); } /* no TTY: OK, report other Error */
3550 } else goto ok;
3551 #endif
3552 #if defined(UNIX_TERM_TERMIOS) && defined(TCGETS) && defined(TCSETSW)
3553 {
3554 var struct termios term_parameters;
3555 if (!( ( ioctl(handle,TCGETS,&term_parameters) ==0)
3556 && ( ioctl(handle,TCSETSW,&term_parameters) ==0))) {
3557 if (!((errno==ENOTTY)||IS_EINVAL))
3558 { OS_error(); } /* no TTY: OK, report other Error */
3559 } else goto ok;
3560 }
3561 #endif
3562 #if 0 /* Caution: This should cause FINISH-OUTPUT and CLEAR-INPUT! */
3563 {
3564 var struct sgttyb tty_parameters;
3565 if (!( ( ioctl(handle,TIOCGETP,&tty_parameters) ==0)
3566 && ( ioctl(handle,TIOCSETP,&tty_parameters) ==0))) {
3567 if (!(errno==ENOTTY)) { OS_error(); }
3568 } else goto ok;
3569 }
3570 #endif
3571 ok:
3572 end_system_call();
3573 }
3574
3575 /* UP: Move the pending Output of a Handle to the destination. */
3576 local void force_tty_output (Handle handle);
3577 #if !(defined(UNIX) && !defined(HAVE_FSYNC))
force_tty_output(Handle handle)3578 local void force_tty_output (Handle handle) {
3579 /* Method: fsync, see FSYNC(2) */
3580 begin_system_call();
3581 if (!( fsync(handle) ==0)) {
3582 #ifndef UNIX_BEOS /* BeOS 5 apparently does not set errno */
3583 if (!IS_EINVAL)
3584 OS_error();
3585 #endif
3586 }
3587 end_system_call();
3588 }
3589 #else
3590 #define force_tty_output(handle)
3591 #endif
3592
3593 /* UP: Deletes the pending Output of a Handle. */
clear_tty_output(Handle handle)3594 local void clear_tty_output (Handle handle) {
3595 /* Method: tcflush TCOFLUSH, see TERMIOS(3V) */
3596 begin_system_call();
3597 #ifdef UNIX_TERM_TERMIOS
3598 if (!( TCFLUSH(handle,TCOFLUSH) ==0)) {
3599 if (!((errno==ENOTTY)||IS_EINVAL))
3600 { OS_error(); } /* no TTY: OK, report other Error */
3601 }
3602 #endif
3603 end_system_call();
3604 }
3605
3606 #endif /* UNIX */
3607
3608 #if defined(WIN32_NATIVE)
3609
3610 /* signal OS_error unless the error is cause by invalid arguments */
error_unless_invalid(void)3611 local void error_unless_invalid (void) {
3612 switch (GetLastError()) {
3613 case ERROR_INVALID_HANDLE: case ERROR_INVALID_PARAMETER:
3614 case ERROR_INVALID_FUNCTION: break;
3615 default: OS_error();
3616 }
3617 }
3618
3619 /* UP: Deletes already entered interactive Input from a Handle. */
clear_tty_input(Handle handle)3620 local void clear_tty_input (Handle handle) {
3621 begin_system_call();
3622 /* Maybe it's a serial communication. */
3623 if (!PurgeComm(handle,PURGE_RXABORT|PURGE_RXCLEAR))
3624 error_unless_invalid();
3625 /* Maybe it's a console. */
3626 if (!FlushConsoleInputBuffer(handle))
3627 error_unless_invalid();
3628 end_system_call();
3629 }
3630
3631 /* UP: Move the pending Output of a Handle to the destination. */
3632 local void finish_tty_output (Handle handle);
3633 /* Maybe call WaitCommEvent with argument EV_TXEMPTY ? */
3634 #define finish_tty_output(handle)
3635
3636 /* UP: Move the pending Output of a Handle to the destination. */
3637 local void force_tty_output (Handle handle);
3638 #define force_tty_output(handle) finish_tty_output(handle)
3639
3640 /* UP: Deletes the pending Output of a Handle. */
clear_tty_output(Handle handle)3641 local void clear_tty_output (Handle handle) {
3642 begin_system_call();
3643 /* Maybe it's a serial communication. */
3644 if (!PurgeComm(handle,PURGE_TXABORT|PURGE_TXCLEAR))
3645 error_unless_invalid();
3646 end_system_call();
3647 }
3648
3649
3650 #endif
3651
3652 /* UP: Return platform-specific file type
3653 handle_type(handle)
3654 > handle: open handle (file or pipe)
3655 < result: an integer, identifying the type */
3656 #if defined(UNIX)
3657 #define handle_type_t mode_t
handle_type(Handle handle)3658 local handle_type_t handle_type (Handle handle) {
3659 var struct stat statbuf;
3660 begin_system_call();
3661 if (!( fstat(handle,&statbuf) ==0)) {
3662 #if defined(UNIX_MACOSX)
3663 /* This happens with stdin_handle of a process launched through nohup,
3664 on Mac OS X 10.5. */
3665 if (errno == EBADF) { end_system_call(); return 0; }
3666 #endif
3667 OS_error();
3668 }
3669 end_system_call();
3670 return statbuf.st_mode;
3671 }
3672 #elif defined(WIN32_NATIVE)
3673 #define handle_type_t DWORD
handle_type(Handle handle)3674 local handle_type_t handle_type (Handle handle) {
3675 var DWORD filetype;
3676 begin_system_call();
3677 filetype = GetFileType(handle);
3678 end_system_call();
3679 return filetype;
3680 }
3681 #else
3682 #error handle_type() and handle_type_t are not defined
3683 #endif
3684
3685 /* UP: Determines, if a Handle refers to a (static) File.
3686 regular_handle_p(handle)
3687 > handle: Handle of the opened File
3688 < result: true if it is a (static) File */
regular_handle_type_p(handle_type_t mode)3689 local inline bool regular_handle_type_p (handle_type_t mode) {
3690 #if defined(UNIX)
3691 return S_ISREG(mode) || S_ISBLK(mode);
3692 #elif defined(WIN32_NATIVE)
3693 return mode == FILE_TYPE_DISK;
3694 #endif
3695 }
3696 #define regular_handle_p(h) regular_handle_type_p(handle_type(h))
3697
3698 /* UP: Determines, if a Handle refers to a pipe or a socket
3699 pipe_handle_p(handle)
3700 > handle: Handle of the opened File
3701 < result: true if it is a socket or a pipe */
pipe_handle_type_p(handle_type_t mode)3702 local inline bool pipe_handle_type_p (handle_type_t mode) {
3703 #if defined(UNIX)
3704 return S_ISFIFO(mode)
3705 #if defined(S_ISSOCK)
3706 || S_ISSOCK(mode)
3707 #endif
3708 ;
3709 #elif defined(WIN32_NATIVE)
3710 return mode == FILE_TYPE_PIPE;
3711 #endif
3712 }
3713 #define pipe_handle_p(h) pipe_handle_type_p(handle_type(h))
3714
3715 /* UP: Determines, if a Handle refers to a pipe, socket, file
3716 regular_or_pipe_handle_p(handle)
3717 > handle: Handle of the opened File
3718 < result: true if it is a socket/pipe/file */
regular_or_pipe_handle_p(Handle handle)3719 local inline bool regular_or_pipe_handle_p (Handle handle) {
3720 var handle_type_t mode = handle_type(handle);
3721 DEBUG_OUT(("\nregular_or_pipe_handle_p(%d): 0x%x\n",handle,mode));
3722 return regular_handle_type_p(mode) || pipe_handle_type_p(mode);
3723 }
3724
3725 /* UP: Determines if two Handle refer to the same file or device.
3726 same_handle_p(handle1,handle2)
3727 > handle1: Handle of the first open device
3728 > handle2: Handle of the second open device
3729 < result: true if handle1 and handle2 are exchangeable */
same_handle_p(Handle handle1,Handle handle2)3730 local bool same_handle_p (Handle handle1, Handle handle2) {
3731 #if defined(UNIX)
3732 var struct stat statbuf1;
3733 var struct stat statbuf2;
3734 begin_system_call();
3735 DEBUG_OUT(("\nsame_handle_p(%d,%d)\n",handle1,handle2));
3736 if (!( fstat(handle1,&statbuf1) ==0)) { OS_error(); }
3737 if (!( fstat(handle2,&statbuf2) ==0)) { OS_error(); }
3738 DEBUG_OUT(("dev: 0x%lx 0x%lx ino: 0x%lx 0x%lx mode: 0x%x 0x%x\n",
3739 statbuf1.st_dev,statbuf2.st_dev,statbuf1.st_ino,statbuf2.st_ino,
3740 statbuf1.st_mode,statbuf2.st_mode));
3741 if (statbuf1.st_dev == statbuf2.st_dev
3742 && statbuf1.st_ino == statbuf2.st_ino) {
3743 /* handle1 and handle2 point to the same inode. */
3744 if ((S_ISREG(statbuf1.st_mode) || S_ISBLK(statbuf1.st_mode))
3745 && (S_ISREG(statbuf2.st_mode) || S_ISBLK(statbuf2.st_mode))) {
3746 /* handle1 and handle2 are exchangeable only if they are positioned
3747 at the same file position. */
3748 var off_t pos1 = lseek(handle1,0,SEEK_CUR);
3749 DEBUG_OUT(("pos1: %ld\n",pos1));
3750 if (pos1 >= 0) {
3751 var off_t pos2 = lseek(handle2,0,SEEK_CUR);
3752 DEBUG_OUT(("pos2: %ld\n",pos2));
3753 if (pos2 >= 0) {
3754 end_system_call();
3755 return (pos1 == pos2);
3756 }
3757 }
3758 }
3759 end_system_call();
3760 return true;
3761 } else {
3762 end_system_call();
3763 return false;
3764 }
3765 #endif
3766 #if defined(WIN32_NATIVE)
3767 /* Same handle? */
3768 DEBUG_OUT(("\nsame_handle_p(0x%lx,0x%lx)\n",handle1,handle2));
3769 if (handle1 == handle2)
3770 return true;
3771 /* Same handle type? */
3772 begin_system_call();
3773 var DWORD filetype1;
3774 var DWORD filetype2;
3775 filetype1 = GetFileType(handle1);
3776 filetype2 = GetFileType(handle2);
3777 DEBUG_OUT(("GetFileType: 0x%lx 0x%lx\n",filetype1,filetype2));
3778 if (filetype1 == filetype2) {
3779 if (filetype1 == FILE_TYPE_DISK) {
3780 /* handle1 and handle2 are both files. */
3781 var BY_HANDLE_FILE_INFORMATION fileinfo1;
3782 var BY_HANDLE_FILE_INFORMATION fileinfo2;
3783 if (!GetFileInformationByHandle(handle1,&fileinfo1)) { OS_error(); }
3784 if (!GetFileInformationByHandle(handle2,&fileinfo2)) { OS_error(); }
3785 DEBUG_OUT(("GetFileInformationByHandle:\n vol: 0x%lx 0x%lx\n"
3786 " index: 0x%x,0x%x 0x%x,0x%x\n attr: 0x%lx 0x%lx\n"
3787 " size: 0x%x,0x%x 0x%x,0x%x\n",
3788 fileinfo1.dwVolumeSerialNumber,
3789 fileinfo2.dwVolumeSerialNumber,
3790 fileinfo1.nFileIndexHigh,fileinfo1.nFileIndexLow,
3791 fileinfo2.nFileIndexHigh,fileinfo2.nFileIndexLow,
3792 fileinfo1.dwFileAttributes,fileinfo2.dwFileAttributes,
3793 fileinfo1.nFileSizeHigh,fileinfo1.nFileSizeLow,
3794 fileinfo2.nFileSizeHigh,fileinfo2.nFileSizeLow));
3795 end_system_call();
3796 #define TIME_EQ(ft1,ft2) \
3797 ((ft1).dwLowDateTime == (ft2).dwLowDateTime \
3798 && (ft1).dwHighDateTime == (ft2).dwHighDateTime)
3799 return (fileinfo1.dwVolumeSerialNumber == fileinfo2.dwVolumeSerialNumber
3800 && fileinfo1.nFileIndexLow == fileinfo2.nFileIndexLow
3801 && fileinfo1.nFileIndexHigh == fileinfo2.nFileIndexHigh
3802 /* Comparing the other members of the BY_HANDLE_FILE_INFORMATION
3803 structure shouldn't be necessary, but doesn't hurt either. */
3804 && fileinfo1.dwFileAttributes == fileinfo2.dwFileAttributes
3805 && TIME_EQ(fileinfo1.ftCreationTime,fileinfo2.ftCreationTime)
3806 && TIME_EQ(fileinfo1.ftLastAccessTime,fileinfo2.ftLastAccessTime)
3807 && TIME_EQ(fileinfo1.ftLastWriteTime,fileinfo2.ftLastWriteTime)
3808 && fileinfo1.nFileSizeLow == fileinfo2.nFileSizeLow
3809 && fileinfo1.nFileSizeHigh == fileinfo2.nFileSizeHigh
3810 && fileinfo1.nNumberOfLinks == fileinfo2.nNumberOfLinks);
3811 #undef TIME_EQ
3812 } else if (filetype1 == FILE_TYPE_CHAR) {
3813 /* Same console? */
3814 var DWORD console_mode;
3815 DEBUG_OUT(("FILE_TYPE_CHAR\n"));
3816 if (GetConsoleMode(handle1,&console_mode)) {
3817 DEBUG_OUT(("console_mode1: 0x%lx\n",console_mode));
3818 if (GetConsoleMode(handle2,&console_mode)) {
3819 DEBUG_OUT(("console_mode2: 0x%lx\n",console_mode));
3820 end_system_call();
3821 return true;
3822 }
3823 }
3824 } else { DEBUG_OUT(("neither FILE_TYPE_CHAR nor FILE_TYPE_DISK\n")); }
3825 /* Cannot determine equality. Assume they are different. */
3826 }
3827 end_system_call();
3828 return false;
3829 #endif
3830 }
3831
3832
3833 /* Channel-Streams
3834 ===============
3835
3836 Channel streams are a common framework which perform their input/output
3837 via a channel from the operating system. Encompasses: terminal stream,
3838 file stream, pipe stream, socket stream.
3839
3840 Because the input side has some non-GCed fields, all channel streams must
3841 have the same number of GCed fields.
3842
3843 Fields used for both the input side and the output side:
3844
3845 define strm_eltype strm_other[0] - CHARACTER or ([UN]SIGNED-BYTE n)
3846 define strm_encoding strm_other[1] - Encoding (used iff eltype = CHARACTER) */
3847
3848 #define strm_bitbuffer strm_other[2] /* (used if eltype /= CHARACTER only) */
3849 #define strm_buffer strm_other[3] /* (used by buffered streams only) */
3850
3851 /* Fields used for the input side only: */
3852
3853 /* /=NIL or NIL, depending on whether the input channel is a tty
3854 handle and therefore needs special treatment in the
3855 low_listen function on some OSes (used by unbuffered streams only) */
3856 #define strm_isatty strm_other[3]
3857 #define strm_ichannel_position 4 /* ichannel index */
3858
3859 /* the input channel, an encapsulated handle, or, on WIN32_NATIVE,
3860 an encapsulated SOCKET */
3861 #define strm_ichannel strm_other[strm_ichannel_position]
3862
3863 /* Fields used for the output side only: */
3864 #define strm_ochannel_position 5 /* ochannel index */
3865 #define strm_ochannel strm_other[strm_ochannel_position] /* the output channel */
3866 /* an encapsulated handle, or, on WIN32_NATIVE, an encapsulated SOCKET */
3867
3868 /* Fields reserved for the specialized stream: */
3869 #define strm_field1 strm_other[6]
3870 #define strm_field2 strm_other[7]
3871
3872 /* Binary fields start here. */
3873 #define strm_channel_extrafields strm_other[8]
3874 #define strm_channel_len (strm_len+8)
3875
3876 /* Additional binary (not GCed) fields: */
3877 typedef struct strm_channel_extrafields_t {
3878 /*bool*/int buffered : 8; /* false for unbuffered streams,
3879 true for buffered streams */
3880 /*bool*/int regular : 8; /* whether the handle refers to a regular file */
3881 uintL bitsize; /* If the element-type is ([UN]SIGNED-BYTE n):
3882 n = number of bits per unit,
3883 >0, <intDsize*uintWC_max.
3884 If the element-type is CHARACTER: 0. */
3885 void (* low_close) (object stream, object handle, uintB abort);
3886 /* Fields used if the element-type is CHARACTER: */
3887 uintL lineno; /* line number during read, >0 */
3888 /* For general interoperability with Win32 systems, we recognize all possible
3889 line-terminators: LF, CR/LF and CR, independently of strm_encoding.
3890 This is because, when confronted with Unix-style text files (eol = LF),
3891 some Microsoft editors insert new lines with eol = CR/LF,
3892 while other Microsoft editors insert new lines with eol = CR.
3893 Java learned the lesson and understands all three line-terminators.
3894 So do we, see http://clisp.org/impnotes/clhs-newline.html
3895 See also http://www.unicode.org/reports/tr13/tr13-9.html */
3896 /*bool*/int ignore_next_LF : 8; /* true after reading a CR */
3897 struct file_id fid; /* unique file ID */
3898 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
3899 iconv_t iconvdesc; /* input conversion descriptor and state */
3900 iconv_t oconvdesc; /* output conversion descriptor and state */
3901 #endif
3902 } strm_channel_extrafields_t;
3903
3904 /* Accessors. */
3905 #define ChannelStream_eltype(stream) TheStream(stream)->strm_eltype
3906 #define ChannelStream_isatty(stream) TheStream(stream)->strm_isatty
3907 #define ChannelStream_ichannel(stream) TheStream(stream)->strm_ichannel
3908 #define ChannelStream_ochannel(stream) TheStream(stream)->strm_ochannel
3909 #define ChannelStream_buffered(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->buffered
3910 #define ChannelStream_regular(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->regular
3911 #define ChannelStream_bitsize(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->bitsize
3912 #define ChannelStreamLow_close(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_close
3913 #define ChannelStream_lineno(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->lineno
3914 #define ChannelStream_ignore_next_LF(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->ignore_next_LF
3915 #define ChannelStream_file_id(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->fid
3916 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
3917 #define ChannelStream_iconvdesc(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->iconvdesc
3918 #define ChannelStream_oconvdesc(stream) ((strm_channel_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->oconvdesc
3919 #endif
3920
3921 /* Additional binary (not GCed) fields, used by unbuffered streams only: */
3922 typedef struct strm_unbuffered_extrafields_t {
3923 strm_channel_extrafields_t _parent;
3924 /* The low_... operations operate on bytes only, and independently of the
3925 stream's element type. They cannot cause GC.
3926 Fields used for the input side only: */
3927 sintL (* low_read) (object stream);
3928 listen_t (* low_listen) (object stream);
3929 bool (* low_clear_input) (object stream);
3930 uintB* (* low_read_array) (object stream, uintB* byteptr,
3931 uintL len, perseverance_t persev);
3932 sintL status; /* -1 means EOF reached
3933 0 means unknown, bytebuf invalid
3934 >0 means the number of valid bytes in
3935 bytebuf, to be consumed */
3936 uintB bytebuf[max_bytes_per_chart]; /* the last bytes read but not yet consumed */
3937 /* Fields used for the output side only: */
3938 void (* low_write) (object stream, uintB b);
3939 const uintB* (* low_write_array) (object stream, const uintB* byteptr,
3940 uintL len, perseverance_t persev);
3941 void (* low_finish_output) (object stream);
3942 void (* low_force_output) (object stream);
3943 void (* low_clear_output) (object stream);
3944 } strm_unbuffered_extrafields_t;
3945
3946 /* Accessors. */
3947 #define UnbufferedStreamLow_read(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_read
3948 #define UnbufferedStreamLow_listen(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_listen
3949 #define UnbufferedStreamLow_clear_input(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_clear_input
3950 #define UnbufferedStreamLow_read_array(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_read_array
3951 #define UnbufferedStream_status(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->status
3952 #define UnbufferedStream_bytebuf(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->bytebuf
3953 #define UnbufferedStreamLow_write(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_write
3954 #define UnbufferedStreamLow_write_array(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_write_array
3955 #define UnbufferedStreamLow_finish_output(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_finish_output
3956 #define UnbufferedStreamLow_force_output(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_force_output
3957 #define UnbufferedStreamLow_clear_output(stream) ((strm_unbuffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_clear_output
3958
3959 /* Error message after user interrupt.
3960 error_interrupt(); */
error_interrupt(void)3961 local _Noreturn void error_interrupt (void) {
3962 pushSTACK(TheSubr(subr_self)->name);
3963 error(interrupt_condition,GETTEXT("~S: Ctrl-C: User break"));
3964 }
3965
3966 /* General Subroutines
3967 ===================
3968
3969 saving_errno(statement) -- execute a statement, but save the errno during it
3970 OS_error_saving_errno(statement) -- ... then signal the error */
3971 #ifdef WIN32
3972 #define saving_errno(statement) \
3973 do { var int _olderrno = GetLastError(); statement; SetLastError(_olderrno); } while(0)
3974 #define OS_error_saving_errno(statement) \
3975 do { var int _olderrno = GetLastError(); statement; SetLastError(_olderrno); OS_error(); } while(0)
3976 #else
3977 #define saving_errno(statement) \
3978 do { var int _olderrno = errno; statement; errno = _olderrno; } while(0)
3979 #define OS_error_saving_errno(statement) \
3980 do { var int _olderrno = errno; statement; errno = _olderrno; OS_error(); } while(0)
3981 #endif
3982
3983 /* iconv-based encodings
3984 ---------------------
3985
3986 Here enc_charset is a simple-string, not a symbol. The system decides
3987 which encodings are available, and there is no API for getting them all. */
3988
3989 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
3990
3991 /* Our internal encoding is UCS-4 with platform dependent endianness. */
3992 #ifdef GNU_LIBICONV
3993 #define CLISP_INTERNAL_CHARSET "UCS-4-INTERNAL"
3994 #else
3995 #if (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2))
3996 /* glibc >= 2.2 also has UCS-4BE, UCS-4LE but WCHAR_T is more efficient. */
3997 #define CLISP_INTERNAL_CHARSET "WCHAR_T"
3998 #elif defined(UNIX_HPUX) && BIG_ENDIAN_P
3999 #define CLISP_INTERNAL_CHARSET "ucs4"
4000 #else
4001 #if BIG_ENDIAN_P
4002 #define CLISP_INTERNAL_CHARSET "UCS-4"
4003 #else
4004 #define CLISP_INTERNAL_CHARSET "UCS-4" /* FIXME: This is probably wrong */
4005 #endif
4006 #endif
4007 #endif
4008
4009 /* min. bytes per character = 1
4010 max. bytes per character unknown, assume it's <= max_bytes_per_chart */
4011
4012 global uintL iconv_mblen (object encoding, const uintB* src, const uintB* srcend);
4013 global void iconv_mbstowcs (object encoding, object stream, const uintB* *srcp, const uintB* srcend, chart* *destp, chart* destend);
4014 global uintL iconv_wcslen (object encoding, const chart* src, const chart* srcend);
4015 global void iconv_wcstombs (object encoding, object stream, const chart* *srcp, const chart* srcend, uintB* *destp, uintB* destend);
4016 global object iconv_range (object encoding, uintL start, uintL end, uintL maxintervals);
4017
4018 /* Error, when a character cannot be converted to an encoding.
4019 error_unencodable(encoding); */
4020 extern _Noreturn void error_unencodable (object encoding, chart ch);
4021
4022 /* Avoid annoying warning caused by a wrongly standardized iconv() prototype. */
4023 #if defined(GNU_LIBICONV) && defined(iconv)
4024 #undef iconv
4025 #define iconv(cd,inbuf,inbytesleft,outbuf,outbytesleft) \
4026 libiconv(cd,(ICONV_CONST char **)(inbuf),inbytesleft,outbuf,outbytesleft)
4027 #else
4028 #define iconv(cd,inbuf,inbytesleft,outbuf,outbytesleft) \
4029 (iconv)(cd,(ICONV_CONST char **)(inbuf),inbytesleft,outbuf,outbytesleft)
4030 #endif
4031
4032 /* open the iconv conversion and signal errors when necessary
4033 skip error when CHARSET is NULLOBJ
4034 begin_system_call() must be called before this!!!
4035 end_system_call() must be called after this!!! */
open_iconv(const char * to_code,const char * from_code,object charset)4036 local iconv_t open_iconv (const char * to_code, const char * from_code,
4037 object charset) {
4038 var iconv_t cd = iconv_open(to_code,from_code);
4039 if ((cd == (iconv_t)(-1)) && (!eq(nullobj,charset))) {
4040 if (errno == EINVAL) {
4041 end_system_call();
4042 pushSTACK(charset);
4043 error(error_condition,GETTEXT("unknown character set ~S"));
4044 }
4045 ANSIC_error();
4046 }
4047 return cd;
4048 }
4049
4050 /* check whether the charset is valid
4051 when CHARSET is NULLOBJ, return false instead of signalling an error */
check_charset(const char * code,object charset)4052 global bool check_charset (const char * code, object charset) {
4053 begin_system_call();
4054 var iconv_t cd = open_iconv(CLISP_INTERNAL_CHARSET,code,charset);
4055 if (cd == (iconv_t)(-1)) return false;
4056 if (iconv_close(cd) < 0) {
4057 if (eq(nullobj,charset)) return false;
4058 ANSIC_error();
4059 }
4060 cd = open_iconv(code,CLISP_INTERNAL_CHARSET,charset);
4061 if (cd == (iconv_t)(-1)) return false;
4062 if (iconv_close(cd) < 0) {
4063 if (eq(nullobj,charset)) return false;
4064 ANSIC_error();
4065 }
4066 end_system_call();
4067 return true;
4068 }
4069
4070 /* Bytes to characters. */
4071
iconv_mblen(object encoding,const uintB * src,const uintB * srcend)4072 global uintL iconv_mblen (object encoding, const uintB* src,
4073 const uintB* srcend) {
4074 var uintL count = 0;
4075 #define tmpbufsize 4096
4076 var chart tmpbuf[tmpbufsize];
4077 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4078 charset_asciz, {
4079 begin_system_call();
4080 var iconv_t cd = open_iconv(CLISP_INTERNAL_CHARSET,charset_asciz,
4081 TheEncoding(encoding)->enc_charset);
4082 {
4083 var const char* inptr = (const char*)src;
4084 var size_t insize = srcend-src;
4085 while (insize > 0) {
4086 var char* outptr = (char*)tmpbuf;
4087 var size_t outsize = tmpbufsize*sizeof(chart);
4088 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4089 if (res == (size_t)(-1) && errno != E2BIG) {
4090 /* At the end of a delimited string, we treat
4091 EINVAL (incomplete input) like EILSEQ (conversion error) */
4092 if (errno == EILSEQ || errno == EINVAL) {
4093 ASSERT(insize > 0);
4094 var object action = TheEncoding(encoding)->enc_towcs_error;
4095 if (eq(action,S(Kignore))) {
4096 inptr++; insize--;
4097 } else if (eq(action,S(Kerror))) {
4098 iconv_close(cd); errno = EILSEQ; ANSIC_error();
4099 } else {
4100 outptr += sizeof(chart);
4101 inptr++; insize--;
4102 }
4103 } else {
4104 var int saved_errno = errno;
4105 iconv_close(cd);
4106 errno = saved_errno;
4107 ANSIC_error();
4108 }
4109 }
4110 count += (outptr-(char*)tmpbuf);
4111 }
4112 }
4113 if (iconv_close(cd) < 0) { ANSIC_error(); }
4114 end_system_call();
4115 });
4116 #undef tmpbufsize
4117 return count/sizeof(chart);
4118 }
4119
iconv_mbstowcs(object encoding,object stream,const uintB ** srcp,const uintB * srcend,chart ** destp,chart * destend)4120 global void iconv_mbstowcs (object encoding, object stream,
4121 const uintB* *srcp, const uintB* srcend,
4122 chart* *destp, chart* destend) {
4123 var const char* inptr = (const char*)*srcp;
4124 var size_t insize = srcend-*srcp;
4125 var char* outptr = (char*)*destp;
4126 var size_t outsize = (char*)destend-(char*)*destp;
4127 if (eq(stream,nullobj)) {
4128 /* Standalone call, must be consistent with iconv_mblen: */
4129 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4130 charset_asciz, {
4131 begin_system_call();
4132 var iconv_t cd = open_iconv(CLISP_INTERNAL_CHARSET,charset_asciz,
4133 TheEncoding(encoding)->enc_charset);
4134 while (insize > 0 && outsize > 0) {
4135 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4136 if (res == (size_t)(-1)) {
4137 /* At the end of a delimited string, we treat
4138 EINVAL (incomplete input) like EILSEQ (conversion error) */
4139 if (errno == EILSEQ || errno == EINVAL) {
4140 ASSERT(insize > 0);
4141 var object action = TheEncoding(encoding)->enc_towcs_error;
4142 if (eq(action,S(Kignore))) {
4143 inptr++; insize--;
4144 } else if (eq(action,S(Kerror))) {
4145 iconv_close(cd); errno = EILSEQ; ANSIC_error();
4146 } else {
4147 if (outsize < sizeof(chart))
4148 break;
4149 *(chart*)outptr = char_code(action);
4150 outptr += sizeof(chart); outsize -= sizeof(chart);
4151 inptr++; insize--;
4152 }
4153 } else {
4154 var int saved_errno = errno;
4155 iconv_close(cd);
4156 errno = saved_errno;
4157 ANSIC_error();
4158 }
4159 }
4160 }
4161 if (iconv_close(cd) < 0) { ANSIC_error(); }
4162 end_system_call();
4163 ASSERT(insize == 0 && outsize == 0);
4164 });
4165 } else {
4166 /* Called from a channel-stream. */
4167 var iconv_t cd = ChannelStream_iconvdesc(stream);
4168 begin_system_call();
4169 while (insize > 0) {
4170 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4171 if (res == (size_t)(-1)) {
4172 if (errno == EINVAL) /* incomplete input? */
4173 break;
4174 else if (errno == E2BIG) /* output buffer full? */
4175 break;
4176 else if (errno == EILSEQ) {
4177 ASSERT(insize > 0);
4178 var object action = TheEncoding(encoding)->enc_towcs_error;
4179 if (eq(action,S(Kignore))) {
4180 inptr++; insize--;
4181 } else if (eq(action,S(Kerror))) {
4182 if (inptr > (const char*)*srcp)
4183 break;
4184 ANSIC_error();
4185 } else {
4186 if (outsize < sizeof(chart))
4187 break;
4188 *(chart*)outptr = char_code(action);
4189 outptr += sizeof(chart); outsize -= sizeof(chart);
4190 inptr++; insize--;
4191 }
4192 } else {
4193 ANSIC_error();
4194 }
4195 }
4196 }
4197 end_system_call();
4198 }
4199 *srcp = (const uintB*)inptr;
4200 *destp = (chart*)outptr;
4201 }
4202
4203 /* Characters to bytes. */
4204
iconv_wcslen(object encoding,const chart * src,const chart * srcend)4205 global uintL iconv_wcslen (object encoding, const chart* src,
4206 const chart* srcend) {
4207 var uintL count = 0;
4208 #define tmpbufsize 4096
4209 var uintB tmpbuf[tmpbufsize];
4210 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4211 charset_asciz, {
4212 begin_system_call();
4213 var iconv_t cd = open_iconv(charset_asciz,CLISP_INTERNAL_CHARSET,
4214 TheEncoding(encoding)->enc_charset);
4215 {
4216 var const char* inptr = (const char*)src;
4217 var size_t insize = (char*)srcend-(char*)src;
4218 while (insize > 0) {
4219 var char* outptr = (char*)tmpbuf;
4220 var size_t outsize = tmpbufsize;
4221 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4222 if (res == (size_t)(-1) && errno != E2BIG) {
4223 if (errno == EILSEQ) { /* invalid input? */
4224 ASSERT(insize >= sizeof(chart));
4225 var object action = TheEncoding(encoding)->enc_tombs_error;
4226 if (eq(action,S(Kignore))) {
4227 inptr += sizeof(chart); insize -= sizeof(chart);
4228 } else if (uint8_p(action)) {
4229 outptr++; outsize--;
4230 inptr += sizeof(chart); insize -= sizeof(chart);
4231 } else if (!eq(action,S(Kerror))) {
4232 var chart c = char_code(action);
4233 var const char* inptr1 = (const char*)&c;
4234 var size_t insize1 = sizeof(c);
4235 if (iconv(cd,&inptr1,&insize1,&outptr,&outsize)
4236 != (size_t)(-1)) {
4237 inptr += sizeof(chart); insize -= sizeof(chart);
4238 } else {
4239 if (errno != EILSEQ) {
4240 ANSIC_error();
4241 } else {
4242 end_system_call();
4243 error_unencodable(encoding,*(const chart*)inptr);
4244 }
4245 }
4246 } else {
4247 end_system_call();
4248 error_unencodable(encoding,*(const chart*)inptr);
4249 }
4250 } else if (errno == EINVAL) { /* incomplete input? */
4251 NOTREACHED;
4252 } else {
4253 var int saved_errno = errno;
4254 iconv_close(cd);
4255 errno = saved_errno;
4256 ANSIC_error();
4257 }
4258 }
4259 count += (outptr-(char*)tmpbuf);
4260 }
4261 }
4262 {
4263 var char* outptr = (char*)tmpbuf;
4264 var size_t outsize = tmpbufsize;
4265 var size_t res = iconv(cd,NULL,NULL,&outptr,&outsize);
4266 if (res == (size_t)(-1)) {
4267 if (errno == E2BIG) { /* output buffer too small? */
4268 NOTREACHED;
4269 } else {
4270 var int saved_errno = errno;
4271 iconv_close(cd);
4272 errno = saved_errno;
4273 ANSIC_error();
4274 }
4275 }
4276 count += (outptr-(char*)tmpbuf);
4277 }
4278 if (iconv_close(cd) < 0) { ANSIC_error(); }
4279 end_system_call();
4280 });
4281 #undef tmpbufsize
4282 return count;
4283 }
4284
iconv_wcstombs(object encoding,object stream,const chart ** srcp,const chart * srcend,uintB ** destp,uintB * destend)4285 global void iconv_wcstombs (object encoding, object stream,
4286 const chart* *srcp,const chart* srcend,
4287 uintB* *destp, uintB* destend) {
4288 var const char* inptr = (char*)*srcp;
4289 var size_t insize = (char*)srcend-(char*)*srcp;
4290 var char* outptr = (char*)*destp;
4291 var size_t outsize = destend-*destp;
4292 if (eq(stream,nullobj)) {
4293 /* Standalone call, must be consistent with iconv_wcslen: */
4294 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4295 charset_asciz, {
4296 begin_system_call();
4297 var iconv_t cd = open_iconv(charset_asciz,CLISP_INTERNAL_CHARSET,
4298 TheEncoding(encoding)->enc_charset);
4299 while (insize > 0) {
4300 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4301 if (res == (size_t)(-1)) {
4302 if (errno == EILSEQ) { /* invalid input? */
4303 ASSERT(insize >= sizeof(chart));
4304 var object action = TheEncoding(encoding)->enc_tombs_error;
4305 if (eq(action,S(Kignore))) {
4306 inptr += sizeof(chart); insize -= sizeof(chart);
4307 } else if (uint8_p(action)) {
4308 *outptr++ = I_to_uint8(action); outsize--;
4309 inptr += sizeof(chart); insize -= sizeof(chart);
4310 } else if (!eq(action,S(Kerror))) {
4311 var chart c = char_code(action);
4312 var const char* inptr1 = (const char*)&c;
4313 var size_t insize1 = sizeof(c);
4314 if (iconv(cd,&inptr1,&insize1,&outptr,&outsize) != (size_t)(-1)) {
4315 inptr += sizeof(chart); insize -= sizeof(chart);
4316 } else {
4317 if (errno != EILSEQ) {
4318 ANSIC_error();
4319 } else {
4320 end_system_call();
4321 error_unencodable(encoding,*(const chart*)inptr);
4322 }
4323 }
4324 } else {
4325 end_system_call();
4326 error_unencodable(encoding,*(const chart*)inptr);
4327 }
4328 } else if (errno == EINVAL) { /* incomplete input? */
4329 NOTREACHED;
4330 } else if (errno == E2BIG) { /* output buffer too small? */
4331 NOTREACHED;
4332 } else {
4333 var int saved_errno = errno;
4334 iconv_close(cd);
4335 errno = saved_errno;
4336 ANSIC_error();
4337 }
4338 }
4339 }
4340 {
4341 var size_t res = iconv(cd,NULL,NULL,&outptr,&outsize);
4342 if (res == (size_t)(-1)) {
4343 if (errno == E2BIG) { /* output buffer too small? */
4344 NOTREACHED;
4345 } else {
4346 var int saved_errno = errno;
4347 iconv_close(cd);
4348 errno = saved_errno;
4349 ANSIC_error();
4350 }
4351 }
4352 }
4353 if (iconv_close(cd) < 0) { ANSIC_error(); }
4354 end_system_call();
4355 /* Now insize == 0, and if iconv_wcslen has been used to determine
4356 the destination size, then also outsize == 0. */
4357 });
4358 } else {
4359 /* Called from a channel-stream. */
4360 var iconv_t cd = ChannelStream_oconvdesc(stream);
4361 begin_system_call();
4362 while (insize > 0) {
4363 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4364 if (res == (size_t)(-1)) {
4365 if (errno == EILSEQ) { /* invalid input? */
4366 ASSERT(insize >= sizeof(chart));
4367 var object action = TheEncoding(encoding)->enc_tombs_error;
4368 if (eq(action,S(Kignore))) {
4369 inptr += sizeof(chart); insize -= sizeof(chart);
4370 } else if (uint8_p(action)) {
4371 if (outsize == 0)
4372 break;
4373 *outptr++ = I_to_uint8(action); outsize--;
4374 inptr += sizeof(chart); insize -= sizeof(chart);
4375 } else if (!eq(action,S(Kerror))) {
4376 var chart c = char_code(action);
4377 var const char* inptr1 = (const char*)&c;
4378 var size_t insize1 = sizeof(c);
4379 if (iconv(cd,&inptr1,&insize1,&outptr,&outsize) != (size_t)(-1)) {
4380 inptr += sizeof(chart); insize -= sizeof(chart);
4381 } else {
4382 if (errno == E2BIG)
4383 break;
4384 else if (errno != EILSEQ) {
4385 ANSIC_error();
4386 } else {
4387 if (inptr > (char*)*srcp)
4388 break;
4389 end_system_call();
4390 error_unencodable(encoding,*(const chart*)inptr);
4391 }
4392 }
4393 } else {
4394 if (inptr > (char*)*srcp)
4395 break;
4396 end_system_call();
4397 error_unencodable(encoding,*(const chart*)inptr);
4398 }
4399 } else if (errno == EINVAL) { /* incomplete input? */
4400 NOTREACHED;
4401 } else if (errno == E2BIG) { /* output buffer full? */
4402 break;
4403 } else {
4404 ANSIC_error();
4405 }
4406 }
4407 }
4408 end_system_call();
4409 }
4410 *srcp = (const chart*)inptr;
4411 *destp = (uintB*)outptr;
4412 }
4413
4414 /* Determining the range of encodable characters. */
iconv_range(object encoding,uintL start,uintL end,uintL maxintervals)4415 global object iconv_range (object encoding, uintL start, uintL end,
4416 uintL maxintervals) {
4417 var uintL count = 0; /* number of intervals already on the STACK */
4418 if (maxintervals > 0) {
4419 var iconv_t cd;
4420 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4421 charset_asciz, {
4422 begin_system_call();
4423 cd = open_iconv(charset_asciz,CLISP_INTERNAL_CHARSET,
4424 TheEncoding(encoding)->enc_charset);
4425 end_system_call();
4426 });
4427 {
4428 var uintL i1;
4429 var uintL i2;
4430 var bool have_i1_i2 = false; /* [i1,i2] = interval being built */
4431 var uintL i = start;
4432 while (1) {
4433 /* Here count < maxintervals. */
4434 var chart ch = as_chart(i);
4435 var uintB buf[max_bytes_per_chart];
4436 var const char* inptr = (const char*)&ch;
4437 var size_t insize = sizeof(chart);
4438 var char* outptr = (char*)&buf[0];
4439 var size_t outsize = max_bytes_per_chart;
4440 begin_system_call();
4441 {
4442 var size_t res = iconv(cd,&inptr,&insize,&outptr,&outsize);
4443 if (res == (size_t)(-1)) {
4444 if (errno == EILSEQ) { /* invalid input? */
4445 end_system_call();
4446 /* ch not encodable -> finish the interval */
4447 if (have_i1_i2) {
4448 pushSTACK(code_char(as_chart(i1)));
4449 pushSTACK(code_char(as_chart(i2)));
4450 check_STACK(); count++;
4451 have_i1_i2 = false;
4452 /* If we have already produced the maximum number of intervals
4453 requested by the caller, it's of no use to search further. */
4454 if (count == maxintervals)
4455 break;
4456 }
4457 } else if (errno == EINVAL) { /* incomplete input? */
4458 NOTREACHED;
4459 } else if (errno == E2BIG) { /* output buffer too small? */
4460 NOTREACHED;
4461 } else {
4462 var int saved_errno = errno;
4463 iconv_close(cd);
4464 errno = saved_errno;
4465 ANSIC_error();
4466 }
4467 } else {
4468 end_system_call();
4469 /* ch encodable -> extend the interval */
4470 if (!have_i1_i2) {
4471 have_i1_i2 = true;
4472 i1 = i;
4473 }
4474 i2 = i;
4475 }
4476 }
4477 if (i == end)
4478 break;
4479 i++;
4480 }
4481 if (have_i1_i2) {
4482 pushSTACK(code_char(as_chart(i1)));
4483 pushSTACK(code_char(as_chart(i2)));
4484 check_STACK(); count++;
4485 }
4486 }
4487 begin_system_call();
4488 if (iconv_close(cd) < 0) { ANSIC_error(); }
4489 end_system_call();
4490 };
4491 return stringof(2*count);
4492 }
4493
4494 #endif /* ENABLE_UNICODE && HAVE_GOOD_ICONV */
4495
4496 /* Initializes some ChannelStream fields.
4497 ChannelStream_init(stream);
4498 > stream: channel-stream with encoding */
4499 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
ChannelStream_init(object stream)4500 local void ChannelStream_init (object stream) {
4501 var object encoding = TheStream(stream)->strm_encoding;
4502 if (simple_string_p(TheEncoding(encoding)->enc_charset)) {
4503 with_sstring_0(TheEncoding(encoding)->enc_charset,Symbol_value(S(ascii)),
4504 charset_asciz, {
4505 var uintB flags = TheStream(stream)->strmflags;
4506 if (flags & strmflags_rd_B) {
4507 begin_system_call();
4508 ChannelStream_iconvdesc(stream) =
4509 open_iconv(CLISP_INTERNAL_CHARSET,charset_asciz,
4510 TheEncoding(encoding)->enc_charset);
4511 end_system_call();
4512 } else {
4513 ChannelStream_iconvdesc(stream) = (iconv_t)0;
4514 }
4515 if (flags & strmflags_wr_B) {
4516 begin_system_call();
4517 ChannelStream_oconvdesc(stream) =
4518 open_iconv(charset_asciz,CLISP_INTERNAL_CHARSET,
4519 TheEncoding(encoding)->enc_charset);
4520 end_system_call();
4521 } else {
4522 ChannelStream_oconvdesc(stream) = (iconv_t)0;
4523 }
4524 });
4525 } else {
4526 ChannelStream_iconvdesc(stream) = (iconv_t)0;
4527 ChannelStream_oconvdesc(stream) = (iconv_t)0;
4528 }
4529 }
4530 #else
4531 #define ChannelStream_init(stream)
4532 #endif
4533
4534 /* Cleans up some ChannelStream fields.
4535 ChannelStream_fini(stream,abort); */
4536 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
ChannelStream_fini(object stream,uintB abort)4537 local void ChannelStream_fini (object stream, uintB abort) {
4538 if (ChannelStream_iconvdesc(stream) != (iconv_t)0) {
4539 begin_system_call();
4540 if (iconv_close(ChannelStream_iconvdesc(stream)) < 0 && !abort)
4541 { ANSIC_error(); }
4542 end_system_call();
4543 ChannelStream_iconvdesc(stream) = (iconv_t)0;
4544 }
4545 if (ChannelStream_oconvdesc(stream) != (iconv_t)0) {
4546 begin_system_call();
4547 if (iconv_close(ChannelStream_oconvdesc(stream)) < 0 && !abort)
4548 { ANSIC_error(); }
4549 end_system_call();
4550 ChannelStream_oconvdesc(stream) = (iconv_t)0;
4551 }
4552 }
4553 #else
4554 #define ChannelStream_fini(stream,abort)
4555 #endif
4556
4557 /* Closes a handle. */
low_close_handle(object stream,object handle,uintB abort)4558 local maygc void low_close_handle (object stream, object handle, uintB abort) {
4559 var Handle fd = TheHandle(handle);
4560 pushSTACK(stream);
4561 begin_blocking_system_call();
4562 #ifdef UNIX
4563 if (!( CLOSE(fd) ==0) && !abort)
4564 { end_blocking_system_call(); OS_filestream_error(popSTACK()); }
4565 #endif
4566 #ifdef WIN32_NATIVE
4567 if (!CloseHandle(fd) && !abort)
4568 { end_blocking_system_call(); OS_filestream_error(popSTACK()); }
4569 #endif
4570 end_blocking_system_call();
4571 skipSTACK(1);
4572 }
4573
4574 /* Subroutines for Integer-Streams
4575 ===============================
4576
4577 For file streams with element type INTEGER ("byte files") every integer
4578 uses the same amount of bits. The bits and bytes are stored in little-endian
4579 order, because big-endian order would lead to madness. So the bit number i
4580 of element number j is = bit number (i+j*bitsize) of the entire bit stream
4581 = bit number ((i+j*bitsize) mod 8) in byte number floor((i+j*bitsize)/8).
4582
4583 strm_bitbuffer is a simple-bit-vector with ceiling(bitsize/8)*8 bits,
4584 filled in little-endian order.
4585
4586 All subroutines below get passed as arguments: bitsize (size per unit, it is
4587 also stored in the stream), bytesize = ceiling(bitsize/8) = number of bytes
4588 the bitbuffer can hold.
4589
4590 Note that unbuffered file-streams cannot be of type ib or ic (too
4591 complicated for the moment), only type ia is supported for them.
4592
4593 Subroutines for the Input side
4594 ------------------------------ */
4595
bitbuff_iu_I(object bitbuffer,uintL bitsize,uintL bytesize)4596 local maygc object bitbuff_iu_I (object bitbuffer, uintL bitsize,
4597 uintL bytesize) {
4598 var uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize-1];
4599 *bitbufferptr &= (bit(((bitsize-1)%8)+1)-1); /* mask High byte */
4600 pushSTACK(bitbuffer);
4601 var object result = LESbvector_to_UI(bytesize,&STACK_0);
4602 skipSTACK(1);
4603 return result;
4604 }
4605
4606 /* UP for READ-BYTE on File-Streams of Integers, Type u :
4607 Returns the bytesize Bytes contained in the Bitbuffer as Integer >=0.
4608 can trigger GC */
rd_by_iu_I(object stream,uintL bitsize,uintL bytesize)4609 local maygc object rd_by_iu_I (object stream, uintL bitsize, uintL bytesize) {
4610 return bitbuff_iu_I(TheStream(stream)->strm_bitbuffer,bitsize,bytesize);
4611 }
4612
bitbuff_is_I(object bitbuffer,uintL bitsize,uintL bytesize)4613 local maygc object bitbuff_is_I (object bitbuffer, uintL bitsize,
4614 uintL bytesize) {
4615 var uintB* bitbufferptr = &TheSbvector(bitbuffer)->data[bytesize-1];
4616 var uintL signbitnr = (bitsize-1)%8;
4617 if (!(*bitbufferptr & bit(signbitnr))) {
4618 *bitbufferptr &= (bitm(signbitnr+1)-1); /* sign-extend High byte */
4619 } else {
4620 *bitbufferptr |= minus_bitm(signbitnr+1); /* sign-extend High byte */
4621 }
4622 pushSTACK(bitbuffer);
4623 var object result = LESbvector_to_I(bytesize,&STACK_0);
4624 skipSTACK(1);
4625 return result;
4626 }
4627
4628 /* UP for READ-BYTE on File-Streams of Integers, Type s :
4629 Returns the bytesize Bytes contained in the Bitbuffer as Integer.
4630 can trigger GC */
rd_by_is_I(object stream,uintL bitsize,uintL bytesize)4631 local maygc object rd_by_is_I (object stream, uintL bitsize, uintL bytesize) {
4632 return bitbuff_is_I(TheStream(stream)->strm_bitbuffer,bitsize,bytesize);
4633 }
4634
4635 /* Typ rd_by_ix_I: one of these two Subroutines: */
4636 typedef maygc object rd_by_ix_I (object stream, uintL bitsize, uintL bytesize);
4637
4638 /* Subroutines for the Output side
4639 -------------------------------
4640
4641 Function type of a subroutine which writes the bitbuffer contents to the
4642 stream. */
4643 typedef void wr_by_aux_ix (object stream, uintL bitsize, uintL bytesize);
4644
bitbuff_ixu_sub(object stream,object bitbuffer,uintL bitsize,object obj)4645 local inline void bitbuff_ixu_sub (object stream, object bitbuffer,
4646 uintL bitsize, object obj) {
4647 if (UI_to_LEbytes(obj,bitsize,TheSbvector(bitbuffer)->data))
4648 error_bad_integer(stream,obj);
4649 }
4650
4651 /* UP for WRITE-BYTE on File-Streams of Integers, Type u :
4652 Store the Object (an Integer >=0) as bytesize Bytes in the Bitbuffer.
4653 > stream : File-Stream for Integers, Type u
4654 > obj : Object to be written
4655 > finisher : Routine for Finalization */
wr_by_ixu_sub(object stream,object obj,wr_by_aux_ix * finisher)4656 local maygc void wr_by_ixu_sub (object stream, object obj,
4657 wr_by_aux_ix* finisher) {
4658 var uintL bitsize = ChannelStream_bitsize(stream);
4659 var uintL bytesize = ceiling(bitsize,8);
4660 ASSERT_wr_int(stream,obj);
4661 bitbuff_ixu_sub(stream,TheStream(stream)->strm_bitbuffer,bitsize,obj);
4662 (*finisher)(stream,bitsize,bytesize);
4663 }
4664
bitbuff_ixs_sub(object stream,object bitbuffer,uintL bitsize,object obj)4665 local inline void bitbuff_ixs_sub (object stream, object bitbuffer,
4666 uintL bitsize, object obj) {
4667 if (I_to_LEbytes(obj,bitsize,TheSbvector(bitbuffer)->data))
4668 error_bad_integer(stream,obj);
4669 }
4670
4671 /* UP for WRITE-BYTE on File-Streams of Integers, Type s :
4672 Stores the Object (an Integer) as bytesize Bytes in the Bitbuffer.
4673 > stream : File-Stream for Integers, Type s
4674 > obj : Object to be written
4675 > finisher : Routine for Finalization */
wr_by_ixs_sub(object stream,object obj,wr_by_aux_ix * finisher)4676 local maygc void wr_by_ixs_sub (object stream, object obj,
4677 wr_by_aux_ix* finisher) {
4678 var uintL bitsize = ChannelStream_bitsize(stream);
4679 var uintL bytesize = ceiling(bitsize,8);
4680 ASSERT_wr_int(stream,obj);
4681 bitbuff_ixs_sub(stream,TheStream(stream)->strm_bitbuffer,bitsize,obj);
4682 (*finisher)(stream,bitsize,bytesize);
4683 }
4684
4685 /* Handle-Streams, Input side
4686 ==========================
4687
4688 Low-level
4689 ---------
4690
4691 Push a byte into bytebuf.
4692 UnbufferedStreamLow_push_byte(stream,b);
4693 Assumes 0 <= UnbufferedStream_status(stream) < max_bytes_per_chart. */
4694 #if (max_bytes_per_chart > 1) /* i.e. defined(ENABLE_UNICODE) */
4695 #define UnbufferedStreamLow_push_byte(stream,b) \
4696 ASSERT((uintL)UnbufferedStream_status(stream) < max_bytes_per_chart); \
4697 UnbufferedStream_bytebuf(stream)[UnbufferedStream_status(stream)++] = b;
4698 #else
4699 #define UnbufferedStreamLow_push_byte(stream,b) \
4700 UnbufferedStream_bytebuf(stream)[0] = b; \
4701 UnbufferedStream_status(stream) = 1;
4702 #endif
4703
4704 /* Push a byte to the front of bytebuf.
4705 UnbufferedStreamLow_pushfront_byte(stream,b);
4706 Assumes 0 <= UnbufferedStream_status(stream) < max_bytes_per_chart. */
4707 #if (max_bytes_per_chart > 1) /* i.e. defined(ENABLE_UNICODE) */
4708 #define UnbufferedStreamLow_pushfront_byte(stream,b) \
4709 ASSERT((uintL)UnbufferedStream_status(stream) < max_bytes_per_chart); \
4710 { var uintL _count = UnbufferedStream_status(stream)++; \
4711 var uintB* _ptr = &UnbufferedStream_bytebuf(stream)[_count]; \
4712 if (_count > 0) \
4713 { do { _ptr[0] = _ptr[-1]; _ptr--; } while (--_count > 0); } \
4714 _ptr[0] = b; \
4715 }
4716 #else
4717 #define UnbufferedStreamLow_pushfront_byte(stream,b) \
4718 UnbufferedStream_bytebuf(stream)[0] = b; \
4719 UnbufferedStream_status(stream) = 1;
4720 #endif
4721
4722 #ifdef ENABLE_UNICODE
4723 /* Push a number of bytes to the front of bytebuf.
4724 UnbufferedStreamLow_pushfront_bytes(stream,byteptr,bytecount); */
4725 #define UnbufferedStreamLow_pushfront_bytes(stream,byteptr,bytecount) \
4726 { var uintL _push = (bytecount); \
4727 if (_push > 0) { \
4728 var uintL _count = UnbufferedStream_status(stream); \
4729 ASSERT(_push + _count <= max_bytes_per_chart); \
4730 UnbufferedStream_status(stream) = _push + _count; \
4731 { var const uintB* _ptr1 = (byteptr); \
4732 var uintB* _ptr2 = &UnbufferedStream_bytebuf(stream)[_count]; \
4733 if (_count > 0) \
4734 { do { _ptr2--; _ptr2[_push] = _ptr2[0]; } while (--_count > 0); } \
4735 do { *_ptr2++ = *_ptr1++; } while (--_push > 0); \
4736 }} \
4737 }
4738 #endif
4739
4740 /* Pop a byte from bytebuf.
4741 UnbufferedStreamLow_pop_byte(stream,b);
4742 declares and assigns a value to b.
4743 Assumes UnbufferedStream_status(stream) > 0. */
4744 #if (max_bytes_per_chart > 1) /* i.e. defined(ENABLE_UNICODE) */
4745 #define UnbufferedStreamLow_pop_byte(stream,b) \
4746 var uintB b = UnbufferedStream_bytebuf(stream)[0]; \
4747 { var uintL _count = --UnbufferedStream_status(stream); \
4748 if (_count > 0) \
4749 { var uintB* _ptr = &UnbufferedStream_bytebuf(stream)[0]; \
4750 do { _ptr[0] = _ptr[1]; _ptr++; } while (--_count > 0); \
4751 } }
4752 #else
4753 #define UnbufferedStreamLow_pop_byte(stream,b) \
4754 var uintB b; \
4755 UnbufferedStream_status(stream) = 0; \
4756 b = UnbufferedStream_bytebuf(stream)[0];
4757 #endif
4758
4759 /* Pop at most *len bytes from stream's bytebuf and store them at byteptr.
4760 Returns the increased byteptr and decrements *len accordingly. */
UnbufferedStream_pop_all(object stream,uintB * byteptr,uintL * len)4761 local inline uintB* UnbufferedStream_pop_all (object stream,
4762 uintB* byteptr, uintL *len)
4763 { /* pop bytebuf into byteptr */
4764 while (UnbufferedStream_status(stream) > 0) { /* have valid bytes? */
4765 UnbufferedStreamLow_pop_byte(stream,b);
4766 *byteptr++ = b;
4767 if (--*len == 0)
4768 break;
4769 }
4770 return byteptr;
4771 }
4772
low_read_unbuffered_handle(object stream)4773 local maygc sintL low_read_unbuffered_handle (object stream) {
4774 if (UnbufferedStream_status(stream) < 0) { /* already EOF? */
4775 return -1;
4776 }
4777 if (UnbufferedStream_status(stream) > 0) { /* bytebuf contains valid bytes? */
4778 UnbufferedStreamLow_pop_byte(stream,b); return b;
4779 }
4780 var Handle handle = TheHandle(TheStream(stream)->strm_ichannel);
4781 var uintB b;
4782 pushSTACK(stream);
4783 /*restart_it:*/
4784 /* try to read a byte */
4785 var ssize_t result;
4786 GC_SAFE_SYSTEM_CALL(result = full_read(handle,&b,1));
4787 stream=popSTACK();
4788 if (result<0) {
4789 #ifdef WIN32_NATIVE
4790 begin_system_call();
4791 if (GetLastError()==ERROR_SIGINT) { /* Interrupt by Ctrl-C ? */
4792 end_system_call();
4793 error_interrupt();
4794 }
4795 end_system_call();
4796 #endif
4797 if (errno == EIO && TheStream(stream)->strmtype==strmtype_terminal) {
4798 /* An EIO error is seen when the clisp process escapes into
4799 background execution, when started under gdb and gdb reports a
4800 "problem internal to GDB". We need to silence this, otherwise it
4801 runs into an infinite recursion. */
4802 result = 0;
4803 } else
4804 OS_error();
4805 }
4806 if (result==0) { /* no byte available -> must be EOF */
4807 UnbufferedStream_status(stream) = -1; return -1;
4808 } else {
4809 return b;
4810 }
4811 }
4812
listen_handle(Handle handle,bool tty_p,int * byte)4813 local listen_t listen_handle (Handle handle, bool tty_p, int *byte) {
4814 /* Method 1: poll, see POLL(2)
4815 Method 2: select, see SELECT(2)
4816 Method 3: ioctl FIONREAD, see FILIO(4)
4817 Method 4: switch temporarily to non-blocking I/O and try read(),
4818 see READ(2V), FILIO(4), or
4819 see READ(2V), FCNTL(2V), FCNTL(5) */
4820 #if !defined(WIN32_NATIVE)
4821 #if defined(HAVE_POLL) && (defined(HAVE_RELIABLE_POLL) || !defined(HAVE_RELIABLE_SELECT))
4822 {
4823 /* Use poll() with a single handle and timeout = zero interval. */
4824 var struct pollfd pollfd_bag[1];
4825 pollfd_bag[0].fd = handle;
4826 pollfd_bag[0].events = POLLIN;
4827 pollfd_bag[0].revents = 0;
4828 begin_system_call();
4829 restart_poll:
4830 var int result = poll(&pollfd_bag[0],1,0);
4831 if (result<0) {
4832 if (errno==EINTR)
4833 goto restart_poll;
4834 OS_error();
4835 } else {
4836 end_system_call();
4837 /* revents has POLLIN or some other bits set if read() would return
4838 without blocking. */
4839 if (pollfd_bag[0].revents == 0)
4840 return LISTEN_WAIT;
4841 /* When read() returns a result without blocking, this can also be
4842 EOF! (Example: Linux and pipes.) We therefore refrain from simply
4843 doing { return LISTEN_AVAIL; } and instead try methods 3 and 4. */
4844 }
4845 }
4846 #elif defined(HAVE_SELECT) && !defined(UNIX_BEOS)
4847 {
4848 /* Use select() with readfds = singleton set {handle}
4849 and timeout = zero interval. */
4850 var fd_set handle_set; /* set of handles := {handle} */
4851 var struct timeval zero_time; /* time interval := 0 */
4852 begin_system_call();
4853 FD_ZERO(&handle_set); FD_SET(handle,&handle_set);
4854 restart_select:
4855 zero_time.tv_sec = 0; zero_time.tv_usec = 0;
4856 var int result = select(FD_SETSIZE,&handle_set,NULL,NULL,&zero_time);
4857 if (result<0) {
4858 if (errno==EINTR)
4859 goto restart_select;
4860 if (!(errno==EBADF)) { OS_error(); } /* UNIX_LINUX returns EBADF for files! */
4861 end_system_call();
4862 } else {
4863 end_system_call();
4864 /* result = number of handles in handle_set for which read() would
4865 return without blocking. */
4866 if (result==0)
4867 return LISTEN_WAIT;
4868 /* result=1
4869 When read() returns a result without blocking, this can also be
4870 EOF! (Example: Linux and pipes.) We therefore refrain from simply
4871 doing { return LISTEN_AVAIL; } and instead try methods 3 and 4. */
4872 }
4873 }
4874 #endif
4875 begin_system_call();
4876 #ifdef HAVE_FIONREAD
4877 /* Try to enquire the number of available bytes: */
4878 {
4879 var unsigned long bytes_ready;
4880 /* Clear bytes_ready before use. Some kernels (such as Linux-2.4.18 on ia64)
4881 apparently expect an 'int *', not a 'long *', as argument of this ioctl,
4882 and thus fill only part of the bytes_ready variable. Fortunately,
4883 endianness is not a problem here, because we only check whether
4884 bytes_ready is == 0 or != 0. */
4885 bytes_ready = 0;
4886 if ( ioctl(handle,FIONREAD,&bytes_ready) <0) {
4887 /* Enquiry failed, probably wasn't a file */
4888 if (!((errno == ENOTTY)||IS_EINVAL))
4889 { OS_error(); }
4890 } else {
4891 /* Enquiry succeeded, so it was a file */
4892 end_system_call();
4893 if (bytes_ready > 0)
4894 return LISTEN_AVAIL;
4895 #ifdef HAVE_RELIABLE_FIONREAD
4896 /* else we have reached the file's EOF: */
4897 return LISTEN_EOF;
4898 #endif
4899 }
4900 }
4901 #endif
4902 #if !((defined(HAVE_POLL) && (defined(HAVE_RELIABLE_POLL) || !defined(HAVE_RELIABLE_SELECT))) || (defined(HAVE_SELECT) && !defined(UNIX_BEOS)))
4903 if (tty_p) { /* Terminal */
4904 /* switch to non-blocking mode, then try read(): */
4905 var uintB b;
4906 var int result;
4907 restart_read_tty:
4908 { NO_BLOCK_DECL();
4909 START_NO_BLOCK(handle, OS_error());
4910 result = read(handle,&b,1);
4911 var int saved_errno = errno;
4912 END_NO_BLOCK(handle, OS_error());
4913 errno = saved_errno;
4914 }
4915 if (result < 0) {
4916 if (errno==EINTR)
4917 goto restart_read_tty;
4918 if
4919 #ifdef FIONBIO
4920 (errno==EWOULDBLOCK) /* BSD 4.2 Error-Code */
4921 #else
4922 ((errno==EAGAIN) /* Posix Error-Code */
4923 #ifdef EWOULDBLOCK
4924 || (errno==EWOULDBLOCK)
4925 #endif
4926 )
4927 #endif
4928 return LISTEN_WAIT;
4929 OS_error();
4930 }
4931 end_system_call();
4932 if (result==0) {
4933 return LISTEN_WAIT;
4934 } else {
4935 *byte = b;
4936 return LISTEN_AVAIL;
4937 }
4938 /* If this doesn't work, should use a timer 0.1 sec ?? */
4939 } else
4940 #endif
4941 /* file (or pipe) */
4942 restart_read_other: { /* try to read a byte: */
4943 var uintB b;
4944 var int result = read(handle,&b,1);
4945 if (result<0) {
4946 if (errno==EINTR)
4947 goto restart_read_other;
4948 OS_error();
4949 }
4950 end_system_call();
4951 if (result==0) {
4952 return LISTEN_EOF;
4953 } else {
4954 *byte = b;
4955 return LISTEN_AVAIL;
4956 }
4957 }
4958 #elif defined(WIN32_NATIVE)
4959 begin_system_call();
4960 var int wont_hang = fd_read_wont_hang_p(handle);
4961 if (wont_hang == 0) {
4962 end_system_call(); return LISTEN_WAIT;
4963 }
4964 if (wont_hang == 2) {
4965 end_system_call(); return LISTEN_EOF;
4966 }
4967 if (wont_hang == 3) {
4968 end_system_call(); return LISTEN_AVAIL;
4969 }
4970 /* try to read a byte */
4971 var uintB b;
4972 var ssize_t result = full_read(handle,&b,1);
4973 if (result<0) {
4974 OS_error();
4975 }
4976 end_system_call();
4977 if (result==0) {
4978 return LISTEN_EOF;
4979 } else {
4980 if (byte) *byte = b;
4981 return LISTEN_AVAIL;
4982 }
4983 #endif
4984 }
4985
low_listen_unbuffered_handle(object stream)4986 local listen_t low_listen_unbuffered_handle (object stream) {
4987 if (UnbufferedStream_status(stream) < 0) /* already EOF? */
4988 return LISTEN_EOF;
4989 if (UnbufferedStream_status(stream) > 0) /* bytebuf contains valid bytes? */
4990 return LISTEN_AVAIL;
4991 var int byte = -1;
4992 var listen_t ret =
4993 listen_handle(TheHandle(TheStream(stream)->strm_ichannel),
4994 !nullp(TheStream(stream)->strm_isatty),&byte);
4995 if (ret == LISTEN_EOF) UnbufferedStream_status(stream) = -1;
4996 /* Stuff the read byte into the buffer, for next low_read call. */
4997 if (byte >= 0) { UnbufferedStreamLow_push_byte(stream,byte); }
4998 return ret;
4999 }
5000
low_clear_input_unbuffered_handle(object stream)5001 local maygc bool low_clear_input_unbuffered_handle (object stream) {
5002 if (nullp(TheStream(stream)->strm_isatty))
5003 return false; /* it's a file -> nothing to do */
5004 UnbufferedStream_status(stream) = 0; /* forget about past EOF */
5005 /* Terminal. */
5006 clear_tty_input(TheHandle(TheStream(stream)->strm_ichannel));
5007 /* In case this didn't work, and as a general method for platforms on
5008 which clear_tty_input() does nothing: read a byte, as long as listen
5009 says that a byte is available. */
5010
5011 /* low_read_unbuffered_handle is not going to block - we are sure there is
5012 character waiting. May be call directly full_read() without defining
5013 safe gc region ???*/
5014 pushSTACK(stream);
5015 while (LISTEN_AVAIL == low_listen_unbuffered_handle(stream)) {
5016 #ifdef WIN32_NATIVE
5017 /* Our low_listen_unbuffered_handle function, when applied to a WinNT
5018 console, cannot tell when there is an LF pending after the
5019 preceding CR has been eaten. Therefore be careful to set
5020 ChannelStream_ignore_next_LF to true when we read a LF. */
5021 var sintL c = low_read_unbuffered_handle(stream);
5022 stream=STACK_0;
5023 if (c >= 0)
5024 ChannelStream_ignore_next_LF(stream) = (c == CR);
5025 #else
5026 low_read_unbuffered_handle(stream);
5027 stream=STACK_0;
5028 #endif
5029 }
5030 skipSTACK(1);
5031 return true;
5032 }
5033
5034 /* Return true if the last error from fd_read()/fd_write() indicates an EOF. */
fd_error_eof_p(void)5035 local bool fd_error_eof_p (void) {
5036 var bool ret = false;
5037 begin_system_call();
5038 #if defined(WIN32_NATIVE)
5039 var DWORD err = GetLastError();
5040 if (err==ERROR_HANDLE_EOF)
5041 ret = true;
5042 #else
5043 if (errno==ENOENT) /* indicates EOF */
5044 ret = true;
5045 #endif
5046 end_system_call();
5047 return ret;
5048 }
5049
low_read_array_unbuffered_handle(object stream,uintB * byteptr,uintL len,perseverance_t persev)5050 local maygc uintB* low_read_array_unbuffered_handle
5051 (object stream, uintB* byteptr, uintL len, perseverance_t persev) {
5052 if (UnbufferedStream_status(stream) < 0) /* already EOF? */
5053 return byteptr;
5054 byteptr = UnbufferedStream_pop_all(stream,byteptr,&len);
5055 if (len == 0) return byteptr;
5056 var Handle handle = TheHandle(TheStream(stream)->strm_ichannel);
5057 /* On regular file handles, persev_immediate and persev_bonus are effectively
5058 equivalent to persev_partial. Transforming persev_immediate, persev_bonus
5059 here 1) avoids useless system calls for poll(), select() or non-blocking
5060 I/O and 2) improves EOF detection. */
5061 if ((persev == persev_immediate || persev == persev_bonus)
5062 && ChannelStream_regular(stream))
5063 persev = persev_partial;
5064 pushSTACK(stream);
5065 var ssize_t result;
5066 GC_SAFE_SYSTEM_CALL(result = fd_read(handle,byteptr,len,persev));
5067 stream = popSTACK();
5068 if (result<0) {
5069 #if !defined(WIN32_NATIVE)
5070 begin_system_call();
5071 if (errno==EINTR) /* Interrupt (poss. by Ctrl-C) ? */
5072 { interruptp({ end_system_call(); error_interrupt(); }) };
5073 #endif
5074 #ifdef WIN32_NATIVE
5075 begin_system_call();
5076 if (GetLastError()==ERROR_SIGINT) { /* Interrupt by Ctrl-C ? */
5077 end_system_call(); error_interrupt();
5078 }
5079 #endif
5080 OS_error();
5081 }
5082 if (result==0 && fd_error_eof_p())
5083 UnbufferedStream_status(stream) = -1;
5084 return byteptr+result;
5085 }
5086
5087 /* Integer streams
5088 ---------------
5089
5090 UP for READ-BYTE on File-Streams of Integers, Type a :
5091 Fills the Bitbuffer with the next bitsize Bits.
5092 > stream : File-Stream for Integers, Type a
5093 > finisher : Routine for Finalization
5094 < result : read Integer or eof_value */
rd_by_aux_iax_unbuffered(object stream,rd_by_ix_I * finisher)5095 local maygc object rd_by_aux_iax_unbuffered (object stream, rd_by_ix_I* finisher) {
5096 var uintL bitsize = ChannelStream_bitsize(stream);
5097 var uintL bytesize = bitsize/8;
5098 /* transfer sufficiently many bytes into the bitbuffer */
5099 var uintB* bitbufferptr =
5100 &TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0];
5101 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ_WRITE);
5102 pushSTACK(stream);
5103 if (UnbufferedStreamLow_read_array(stream)(stream,bitbufferptr,bytesize,
5104 persev_full)
5105 != bitbufferptr+bytesize)
5106 goto eof;
5107 stream = popSTACK();
5108 unpin_varobject(TheStream(stream)->strm_bitbuffer);
5109 /* convert to number: */
5110 return (*finisher)(stream,bitsize,bytesize);
5111 eof: /* EOF reached */
5112 stream = popSTACK();
5113 unpin_varobject(TheStream(stream)->strm_bitbuffer);
5114 return eof_value;
5115 }
5116
5117 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type au : */
rd_by_iau_unbuffered(object stream)5118 local maygc object rd_by_iau_unbuffered (object stream) {
5119 return rd_by_aux_iax_unbuffered(stream,&rd_by_iu_I);
5120 }
5121
5122 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type as : */
rd_by_ias_unbuffered(object stream)5123 local maygc object rd_by_ias_unbuffered (object stream) {
5124 return rd_by_aux_iax_unbuffered(stream,&rd_by_is_I);
5125 }
5126
5127 /* READ-BYTE - Pseudo-Function for Handle-Streams, Type au, bitsize = 8 : */
rd_by_iau8_unbuffered(object stream)5128 local maygc object rd_by_iau8_unbuffered (object stream) {
5129 rd_by_iau8_unbuffered_retry:
5130 var sintL b = UnbufferedStreamLow_read(stream)(stream);
5131 if (b < 0)
5132 return eof_value;
5133 if (b == LF && ChannelStream_ignore_next_LF(stream)) {
5134 /* see comment in rd_by_array_iau8_unbuffered */
5135 ChannelStream_ignore_next_LF(stream) = false;
5136 goto rd_by_iau8_unbuffered_retry;
5137 }
5138 return fixnum((uintB)b);
5139 }
5140
5141 /* READ-BYTE-ARRAY - Pseudo-Function for Handle-Streams, Type au, bitsize = 8 : */
rd_by_array_iau8_unbuffered(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)5142 local maygc uintL rd_by_array_iau8_unbuffered
5143 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
5144 uintL start, uintL len, perseverance_t persev) {
5145 var uintB* startptr = &TheSbvector(*bytearray_)->data[start];
5146 pin_unprotect_varobject(*bytearray_,PROT_READ_WRITE);
5147 var uintB* endptr =
5148 UnbufferedStreamLow_read_array(*stream_)(*stream_,startptr,len,persev);
5149 unpin_varobject(*bytearray_);
5150 var object stream = *stream_;
5151 if (startptr < endptr && *startptr == LF
5152 && ChannelStream_ignore_next_LF(stream)) {
5153 /* if we switch from character to byte input after a NL,
5154 we need to drop the next CR
5155 https://sourceforge.net/p/clisp/bugs/490/ */
5156 var uintL len = endptr-startptr-1;
5157 /* shift the whole array down by one, dropping CR */
5158 var uintL count = len;
5159 for (; count--; startptr++) startptr[0] = startptr[1];
5160 ChannelStream_ignore_next_LF(stream) = false;
5161 endptr = UnbufferedStreamLow_read_array(stream)(stream,startptr,1,persev);
5162 return len + (endptr - startptr);
5163 } else return endptr-startptr;
5164 }
5165
5166 /* Determines, if a Byte is available on an Unbuffered-Channel-Stream.
5167 listen_byte_ia8_unbuffered(stream)
5168 > stream: Unbuffered-Channel-Stream, Type a, bitsize = 8
5169 < result: input availability */
listen_byte_ia8_unbuffered(object stream)5170 local listen_t listen_byte_ia8_unbuffered (object stream) {
5171 return UnbufferedStreamLow_listen(stream)(stream);
5172 }
5173
5174 /* Character streams
5175 -----------------
5176
5177 READ-CHAR - Pseudo-Function for Unbuffered-Channel-Streams: */
rd_ch_unbuffered(const gcv_object_t * stream_)5178 local maygc object rd_ch_unbuffered (const gcv_object_t* stream_) {
5179 var object stream = *stream_;
5180 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* already EOF? */
5181 return eof_value;
5182 retry: {
5183 var chart c;
5184 #ifdef ENABLE_UNICODE
5185 var uintB buf[max_bytes_per_chart];
5186 var uintL buflen = 0;
5187 while (1) {
5188 var sintL b = UnbufferedStreamLow_read(stream)(stream);
5189 if (b < 0)
5190 return eof_value;
5191 stream=*stream_;
5192 ASSERT(buflen < max_bytes_per_chart);
5193 buf[buflen++] = (uintB)b;
5194 var const uintB* bptr = &buf[0];
5195 var chart* cptr = &c;
5196 var object encoding = TheStream(stream)->strm_encoding;
5197 Encoding_mbstowcs(encoding)
5198 (encoding,stream,&bptr,&buf[buflen],&cptr,cptr+1);
5199 if (cptr == &c) { /* Not a complete character. */
5200 /* Shift the buffer */
5201 if (bptr != &buf[0]) {
5202 var const uintB* ptr1 = bptr;
5203 var uintB* ptr2 = &buf[0];
5204 while (ptr1 != &buf[buflen]) { *ptr2++ = *ptr1++; }
5205 buflen = ptr2 - &buf[0];
5206 }
5207 } else { /* Read a complete character. */
5208 /* Move the remainder of the buffer into bytebuf. */
5209 UnbufferedStreamLow_pushfront_bytes(stream,bptr,&buf[buflen]-bptr);
5210 break;
5211 }
5212 }
5213 #else
5214 {
5215 var sintL b = UnbufferedStreamLow_read(stream)(stream);
5216 if (b < 0)
5217 return eof_value;
5218 stream=*stream_;
5219 c = as_chart((uintB)b);
5220 }
5221 #endif
5222 if (chareq(c,ascii(NL))) {
5223 if (ChannelStream_ignore_next_LF(stream)) {
5224 ChannelStream_ignore_next_LF(stream) = false;
5225 goto retry;
5226 }
5227 /* increment lineno: */
5228 ChannelStream_lineno(stream) += 1;
5229 } else if (chareq(c,ascii(CR))) {
5230 ChannelStream_ignore_next_LF(stream) = true;
5231 c = ascii(NL);
5232 /* increment lineno: */
5233 ChannelStream_lineno(stream) += 1;
5234 } else {
5235 ChannelStream_ignore_next_LF(stream) = false;
5236 }
5237 return code_char(c);
5238 }
5239 }
5240
5241 /* Determines, if a character is available on an Unbuffered-Channel-Stream.
5242 listen_char_unbuffered(stream)
5243 > stream: Unbuffered-Channel-Stream
5244 < result: input availability */
listen_char_unbuffered(object stream)5245 local maygc listen_t listen_char_unbuffered (object stream) {
5246 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* already EOF ? */
5247 return LISTEN_EOF;
5248 var listen_t result;
5249 pushSTACK(stream); /* save it */
5250 #ifdef ENABLE_UNICODE
5251 var chart c;
5252 var uintB buf[max_bytes_per_chart];
5253 var uintL buflen = 0;
5254 while (1) {
5255 result = UnbufferedStreamLow_listen(stream)(stream);
5256 if (result == LISTEN_EOF)
5257 break;
5258 if (result != LISTEN_AVAIL) {
5259 /* Stop reading.
5260 Move the buffer into bytebuf. */
5261 UnbufferedStreamLow_pushfront_bytes(stream,&buf[0],buflen);
5262 break;
5263 }
5264 /* this call is not going to block since we are sure that there is
5265 character waiting to be read. However since low_read_unbuffered_handle
5266 may trigger GC (full_read) so this function also maygc.
5267 Another option is to call full_read() here without surrounding it
5268 in safe for GC ??? */
5269 var sintL b = UnbufferedStreamLow_read(stream)(stream);
5270 if (b < 0) {
5271 result = LISTEN_EOF; break;
5272 }
5273 stream=STACK_0;
5274 ASSERT(buflen < max_bytes_per_chart);
5275 buf[buflen++] = (uintB)b;
5276 var const uintB* bptr = &buf[0];
5277 var chart* cptr = &c;
5278 var object encoding = TheStream(stream)->strm_encoding;
5279 Encoding_mbstowcs(encoding)
5280 (encoding,stream,&bptr,&buf[buflen],&cptr,cptr+1);
5281 if (cptr == &c) {
5282 /* Not a complete character.
5283 Shift the buffer */
5284 if (!(bptr == &buf[0])) {
5285 var const uintB* ptr1 = bptr;
5286 var uintB* ptr2 = &buf[0];
5287 while (ptr1 != &buf[buflen]) { *ptr2++ = *ptr1++; }
5288 buflen = ptr2 - &buf[0];
5289 }
5290 } else {
5291 /* Read a complete character. */
5292 if (ChannelStream_ignore_next_LF(stream) && chareq(c,ascii(NL))) {
5293 /* Move the remainder of the buffer into bytebuf. */
5294 UnbufferedStreamLow_pushfront_bytes(stream,bptr,&buf[buflen]-bptr);
5295 buflen--; /* discard the NL from buf */
5296 ChannelStream_ignore_next_LF(stream) = false;
5297 } else {
5298 /* Move the buffer into bytebuf. */
5299 UnbufferedStreamLow_pushfront_bytes(stream,&buf[0],buflen);
5300 ChannelStream_ignore_next_LF(stream) = false;
5301 result = LISTEN_AVAIL;
5302 break;
5303 }
5304 }
5305 }
5306 #else
5307 retry:
5308 result = UnbufferedStreamLow_listen(stream)(stream);
5309 if (result == LISTEN_AVAIL && ChannelStream_ignore_next_LF(stream)) {
5310 var sintL b = UnbufferedStreamLow_read(stream)(stream);
5311 stream=STACK_0;
5312 if (b < 0)
5313 return LISTEN_EOF;
5314 ChannelStream_ignore_next_LF(stream) = false;
5315 if (b == NL)
5316 goto retry;
5317 UnbufferedStreamLow_pushfront_byte(stream,b);
5318 }
5319 #endif
5320 skipSTACK(1); /* discard the stream */
5321 return result;
5322 }
5323
5324 /* UP: Deletes already entered interactive Input from a
5325 Unbuffered-Channel-Stream.
5326 clear_input_unbuffered(stream);
5327 > stream: Unbuffered-Channel-Stream
5328 < result: true if Input was deleted, else false */
clear_input_unbuffered(object stream)5329 local maygc bool clear_input_unbuffered (object stream) {
5330 UnbufferedStream_status(stream) = 0; /* forget about past EOF & bytebuf */
5331 TheStream(stream)->strm_rd_ch_last = NIL; /* forget last char */
5332 if (nullp(TheStream(stream)->strm_isatty))
5333 return false; /* it's a file -> nothing to do */
5334 #ifdef WIN32_NATIVE
5335 /* Our low_listen_unbuffered_handle function, when applied to a WinNT
5336 console, cannot tell when there is an LF pending after the
5337 preceding CR has been eaten. Therefore be careful not to reset
5338 ChannelStream_ignore_next_LF. */
5339 #else
5340 ChannelStream_ignore_next_LF(stream) = false;
5341 #endif
5342 UnbufferedStreamLow_clear_input(stream)(stream);
5343 return true;
5344 }
5345
5346 /* READ-CHAR-ARRAY - Pseudo-Function for Unbuffered-Channel-Streams: */
rd_ch_array_unbuffered(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)5347 local maygc uintL rd_ch_array_unbuffered (const gcv_object_t* stream_,
5348 const gcv_object_t* chararray_,
5349 uintL start, uintL len) {
5350 /* Need a temporary buffer for CR/LF->NL translation. */
5351 #define tmpbufsize 4096
5352 var chart tmpbuf[tmpbufsize];
5353 var object stream = *stream_;
5354 var uintL end = start+len;
5355 var uintL currindex = start;
5356 while (1) {
5357 var uintL remaining = end - currindex;
5358 if (remaining == 0)
5359 break;
5360 if (remaining > tmpbufsize)
5361 remaining = tmpbufsize;
5362 var uintL count;
5363 #ifdef ENABLE_UNICODE
5364 /* In order to read n characters, we read n bytes. (Fewer than n bytes
5365 will not suffice.) If these aren't enough bytes, the next round
5366 will provide them.
5367 FIXME: Could use TheEncoding(encoding)->min_bytes_per_char here. */
5368 pushSTACK(TheStream(stream)->strm_encoding);
5369 {
5370 var uintB tmptmpbuf[tmpbufsize];
5371 var uintB* tmptmpendptr =
5372 UnbufferedStreamLow_read_array(stream)(stream,tmptmpbuf,remaining,
5373 persev_full);
5374 stream=*stream_; /* restore stream */
5375 var object encoding = STACK_0; /* restore the encoding */
5376 var const uintB* tmptmpptr = &tmptmpbuf[0];
5377 var chart* tmpptr = &tmpbuf[0];
5378 Encoding_mbstowcs(encoding)
5379 (encoding,stream,&tmptmpptr,tmptmpendptr,&tmpptr,&tmpbuf[tmpbufsize]);
5380 count = tmpptr - &tmpbuf[0];
5381 ASSERT(tmptmpendptr-tmptmpptr < max_bytes_per_chart);
5382 /* Move the remainder of tmptmpbuf into bytebuf. */
5383 UnbufferedStreamLow_pushfront_bytes(stream,tmptmpptr,
5384 tmptmpendptr-tmptmpptr);
5385 }
5386 skipSTACK(1); /* the encoding */
5387 if (count == 0) {
5388 /* Filling the last few characters must be done one by one, in
5389 order not to overrun the goal. */
5390 do {
5391 var object ch = rd_ch_unbuffered(stream_);
5392 if (eq(ch,eof_value))
5393 break;
5394 tmpbuf[count++] = char_code(ch);
5395 remaining--;
5396 } while (remaining > 0);
5397 }
5398 #else
5399 count = (chart*)UnbufferedStreamLow_read_array(stream)(stream,(uintB*)tmpbuf,remaining,persev_full) - &tmpbuf[0];
5400 #endif
5401 stream=*stream_; /* rd_ch_unbuffered or read_array maygc */
5402 if (count == 0)
5403 break;
5404 var const chart* tmpptr = &tmpbuf[0];
5405 do {
5406 var chart c = *tmpptr++;
5407 count--;
5408 if (chareq(c,ascii(NL))) {
5409 if (ChannelStream_ignore_next_LF(stream)) {
5410 ChannelStream_ignore_next_LF(stream) = false;
5411 } else {
5412 ChannelStream_lineno(stream) += 1;
5413 sstring_store(*chararray_,currindex++,ascii(NL));
5414 }
5415 } else if (chareq(c,ascii(CR))) {
5416 if (count > 0) {
5417 if (chareq(*tmpptr,ascii(NL))) {
5418 tmpptr++; count--;
5419 }
5420 ChannelStream_ignore_next_LF(stream) = false;
5421 } else {
5422 ChannelStream_ignore_next_LF(stream) = true;
5423 }
5424 ChannelStream_lineno(stream) += 1;
5425 sstring_store(*chararray_,currindex++,ascii(NL));
5426 } else {
5427 ChannelStream_ignore_next_LF(stream) = false;
5428 sstring_store(*chararray_,currindex++,c);
5429 }
5430 } while (count > 0);
5431 }
5432 return currindex - start;
5433 #undef tmpbufsize
5434 }
5435
5436 /* Initializes the input side fields of an unbuffered stream.
5437 UnbufferedHandleStream_input_init(stream); */
5438 #define UnbufferedHandleStream_input_init(stream) do { \
5439 UnbufferedStreamLow_read(stream) = &low_read_unbuffered_handle; \
5440 UnbufferedStreamLow_listen(stream) = &low_listen_unbuffered_handle; \
5441 UnbufferedStreamLow_clear_input(stream) = \
5442 &low_clear_input_unbuffered_handle; \
5443 UnbufferedStreamLow_read_array(stream) = \
5444 &low_read_array_unbuffered_handle; \
5445 UnbufferedHandleStream_input_init_data(stream); \
5446 } while(0)
5447 #define UnbufferedHandleStream_input_init_data(stream) \
5448 UnbufferedStream_status(stream) = 0
5449
5450 /* Closes a Channel-Stream.
5451 close_ichannel(stream, abort);
5452 > stream : Channel-Stream
5453 > abort: flag: non-0 => ignore errors */
close_ichannel(object stream,uintB abort)5454 local maygc void close_ichannel (object stream, uintB abort) {
5455 pushSTACK(stream);
5456 ChannelStreamLow_close(stream)(stream,TheStream(stream)->strm_ichannel,abort);
5457 stream = popSTACK();
5458 ChannelStream_fini(stream,abort);
5459 if (ChannelStream_bitsize(stream) > 0) {
5460 ChannelStream_bitsize(stream) = 0; /* delete bitsize */
5461 TheStream(stream)->strm_bitbuffer = NIL; /* free Bitbuffer */
5462 }
5463 }
5464
5465 /* Handle-Streams, Output side
5466 ===========================
5467
5468 Low-level
5469 --------- */
5470
low_write_unbuffered_handle(object stream,uintB b)5471 local maygc void low_write_unbuffered_handle (object stream, uintB b) {
5472 var Handle handle = TheHandle(TheStream(stream)->strm_ochannel);
5473 restart_it:
5474 /* Try to output the byte. */
5475 pushSTACK(stream);
5476 var ssize_t result;
5477 GC_SAFE_SYSTEM_CALL(result = full_write(handle,&b,1));
5478 stream = popSTACK();
5479 if (result<0) { OS_error(); }
5480 if (result==0) /* not successful? */
5481 error_unwritable(TheSubr(subr_self)->name,stream);
5482 }
5483
low_write_array_unbuffered_handle(object stream,const uintB * byteptr,uintL len,perseverance_t persev)5484 local maygc const uintB* low_write_array_unbuffered_handle
5485 (object stream, const uintB* byteptr, uintL len, perseverance_t persev) {
5486 var Handle handle = TheHandle(TheStream(stream)->strm_ochannel);
5487 /* On regular file handles, persev_immediate and persev_bonus are effectively
5488 equivalent to persev_partial. Transforming persev_immediate, persev_bonus
5489 here 1) avoids useless system calls for poll(), select() or non-blocking
5490 I/O and 2) improves EOWF detection. */
5491 if ((persev == persev_immediate || persev == persev_bonus)
5492 && ChannelStream_regular(stream))
5493 persev = persev_partial;
5494 pushSTACK(stream);
5495 var ssize_t result;
5496 GC_SAFE_SYSTEM_CALL(result = fd_write(handle,byteptr,len,persev));
5497 stream = popSTACK();
5498 if (result<0) { OS_error(); }
5499 /* Safety check whether persev argument was respected or EOWF was reached: */
5500 if ((persev == persev_full && !(result==(sintL)len))
5501 || (persev == persev_partial && !(result>0)))
5502 error_unwritable(TheSubr(subr_self)->name,stream);
5503 return byteptr+result;
5504 }
5505
low_finish_output_unbuffered_handle(object stream)5506 local void low_finish_output_unbuffered_handle (object stream) {
5507 finish_tty_output(TheHandle(TheStream(stream)->strm_ochannel));
5508 }
5509
low_force_output_unbuffered_handle(object stream)5510 local void low_force_output_unbuffered_handle (object stream) {
5511 force_tty_output(TheHandle(TheStream(stream)->strm_ochannel));
5512 }
5513
low_clear_output_unbuffered_handle(object stream)5514 local void low_clear_output_unbuffered_handle (object stream) {
5515 clear_tty_output(TheHandle(TheStream(stream)->strm_ochannel));
5516 }
5517
5518 /* Integer streams
5519 ---------------
5520
5521 UP for WRITE-BYTE on File-Streams of Integers, Type a :
5522 Writes the Bitbuffer-Content to the File. */
wr_by_aux_ia_unbuffered(object stream,uintL bitsize,uintL bytesize)5523 local maygc void wr_by_aux_ia_unbuffered (object stream, uintL bitsize,
5524 uintL bytesize) {
5525 unused(bitsize);
5526 var uintB* bitbufferptr = TheSbvector(TheStream(stream)->strm_bitbuffer)->data;
5527 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ);
5528 UnbufferedStreamLow_write_array(stream)(stream,bitbufferptr,bytesize,
5529 persev_full);
5530 unpin_varobject(TheStream(stream)->strm_bitbuffer);
5531 }
5532
5533 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type au : */
wr_by_iau_unbuffered(object stream,object obj)5534 local maygc void wr_by_iau_unbuffered (object stream, object obj) {
5535 wr_by_ixu_sub(stream,obj,&wr_by_aux_ia_unbuffered);
5536 }
5537
5538 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type as : */
wr_by_ias_unbuffered(object stream,object obj)5539 local maygc void wr_by_ias_unbuffered (object stream, object obj) {
5540 wr_by_ixs_sub(stream,obj,&wr_by_aux_ia_unbuffered);
5541 }
5542
5543 /* WRITE-BYTE - Pseudo-Function for Handle-Streams, Type au, bitsize = 8 : */
wr_by_iau8_unbuffered(object stream,object obj)5544 local maygc void wr_by_iau8_unbuffered (object stream, object obj) {
5545 ASSERT_wr_int(stream,obj);
5546 if (!(posfixnump(obj) && (posfixnum_to_V(obj) < bit(8))))
5547 error_bad_integer(stream,obj);
5548 UnbufferedStreamLow_write(stream)(stream,(uintB)posfixnum_to_V(obj));
5549 }
5550
5551 /* WRITE-BYTE-ARRAY - Pseudo-Function for Handle-Streams, Type au, bitsize = 8 : */
wr_by_array_iau8_unbuffered(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)5552 local maygc uintL wr_by_array_iau8_unbuffered
5553 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
5554 uintL start, uintL len, perseverance_t persev) {
5555 var object stream = *stream_;
5556 var uintB* startp = &TheSbvector(*bytearray_)->data[start];
5557 pin_unprotect_varobject(*bytearray_,PROT_READ);
5558 var const uintB* endp =
5559 UnbufferedStreamLow_write_array(stream)(stream,startp,len,persev);
5560 unpin_varobject(*bytearray_);
5561 return (endp - startp);
5562 }
5563
5564 /* Character streams
5565 -----------------
5566
5567 Three versions, one for each kind of line-terminator: :unix, :mac, :dos.
5568
5569 WRITE-CHAR - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_unbuffered_unix(const gcv_object_t * stream_,object ch)5570 local maygc void wr_ch_unbuffered_unix (const gcv_object_t* stream_, object ch)
5571 {
5572 var object stream = *stream_;
5573 check_wr_char(stream,ch);
5574 var chart c = char_code(ch); /* Code of the character */
5575 #ifdef ENABLE_UNICODE
5576 var uintB buf[max_bytes_per_chart];
5577 var object encoding = TheStream(stream)->strm_encoding;
5578 var const chart* cptr = &c;
5579 var uintB* bptr = &buf[0];
5580 Encoding_wcstombs(encoding)
5581 (encoding,stream,&cptr,cptr+1,&bptr,&buf[max_bytes_per_chart]);
5582 ASSERT(cptr == &c+1);
5583 var uintL buflen = bptr-&buf[0];
5584 if (buflen > 0)
5585 UnbufferedStreamLow_write_array(stream)(stream,&buf[0],buflen,persev_full);
5586 #else
5587 UnbufferedStreamLow_write(stream)(stream,as_cint(c));
5588 #endif
5589 }
5590
5591 /* WRITE-CHAR-ARRAY - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_array_unbuffered_unix(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)5592 local maygc void wr_ch_array_unbuffered_unix (const gcv_object_t* stream_,
5593 const gcv_object_t* chararray_,
5594 uintL start, uintL len) {
5595 var object stream = *stream_;
5596 var const chart* charptr;
5597 unpack_sstring_alloca(*chararray_,len,start, charptr=);
5598 pin_unprotect_varobject(*chararray_,PROT_READ); /*charptr may point to heap*/
5599 #ifdef ENABLE_UNICODE
5600 #define tmpbufsize 4096
5601 var const chart* endptr = charptr + len;
5602 var uintB tmptmpbuf[tmpbufsize*max_bytes_per_chart];
5603 do {
5604 var uintB* bptr = &tmptmpbuf[0];
5605 var object encoding = TheStream(stream)->strm_encoding;
5606 Encoding_wcstombs(encoding)(encoding,stream,&charptr,endptr,&bptr,
5607 &tmptmpbuf[tmpbufsize*max_bytes_per_chart]);
5608 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
5609 if (tmptmpbuflen > 0)
5610 UnbufferedStreamLow_write_array(stream)(stream,&tmptmpbuf[0],
5611 tmptmpbuflen,persev_full);
5612 stream=*stream_; /* write_array maygc */
5613 } while (charptr != endptr);
5614 #undef tmpbufsize
5615 #else
5616 var const chart* endptr = (const chart*)UnbufferedStreamLow_write_array(stream)(stream,(const uintB*)charptr,len,persev_full);
5617 stream=*stream_; /* write_array maygc */
5618 #endif
5619 unpin_varobject(*chararray_);
5620 wr_ss_lpos(stream,endptr,len); /* update Line-Position */
5621 }
5622
5623 /* WRITE-CHAR - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_unbuffered_mac(const gcv_object_t * stream_,object ch)5624 local maygc void wr_ch_unbuffered_mac (const gcv_object_t* stream_, object ch) {
5625 var object stream = *stream_;
5626 check_wr_char(stream,ch);
5627 var chart c = char_code(ch); /* Code of the character */
5628 if (chareq(c,ascii(NL)))
5629 c = ascii(CR);
5630 #ifdef ENABLE_UNICODE
5631 var uintB buf[max_bytes_per_chart];
5632 var object encoding = TheStream(stream)->strm_encoding;
5633 var const chart* cptr = &c;
5634 var uintB* bptr = &buf[0];
5635 Encoding_wcstombs(encoding)(encoding,stream,&cptr,cptr+1,&bptr,
5636 &buf[max_bytes_per_chart]);
5637 ASSERT(cptr == &c+1);
5638 var uintL buflen = bptr-&buf[0];
5639 if (buflen > 0)
5640 UnbufferedStreamLow_write_array(stream)(stream,&buf[0],buflen,persev_full);
5641 #else
5642 UnbufferedStreamLow_write(stream)(stream,as_cint(c));
5643 #endif
5644 }
5645
5646 /* WRITE-CHAR-ARRAY - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_array_unbuffered_mac(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)5647 local maygc void wr_ch_array_unbuffered_mac (const gcv_object_t* stream_,
5648 const gcv_object_t* chararray_,
5649 uintL start, uintL len) {
5650 var object stream = *stream_;
5651 var const chart* charptr;
5652 unpack_sstring_alloca(*chararray_,len,start, charptr=);
5653 pin_unprotect_varobject(*chararray_,PROT_READ);
5654 /* Need a temporary buffer for NL->CR translation. */
5655 #define tmpbufsize 4096
5656 var chart tmpbuf[tmpbufsize];
5657 #ifdef ENABLE_UNICODE
5658 var uintB tmptmpbuf[tmpbufsize*max_bytes_per_chart];
5659 var object encoding;
5660 pushSTACK(TheStream(stream)->strm_encoding);
5661 #endif
5662 var uintL remaining = len;
5663 do {
5664 var uintL n = remaining;
5665 if (n > tmpbufsize)
5666 n = tmpbufsize;
5667 {
5668 var chart* tmpptr = &tmpbuf[0];
5669 var uintL count;
5670 dotimespL(count,n, {
5671 var chart c = *charptr++;
5672 if (chareq(c,ascii(NL)))
5673 c = ascii(CR);
5674 *tmpptr++ = c;
5675 });
5676 #ifdef ENABLE_UNICODE
5677 var const chart* cptr = tmpbuf;
5678 var uintB* bptr = &tmptmpbuf[0];
5679 encoding = STACK_0;
5680 Encoding_wcstombs(encoding)(encoding,stream,&cptr,tmpptr,&bptr,
5681 &tmptmpbuf[tmpbufsize*max_bytes_per_chart]);
5682 ASSERT(cptr == tmpptr);
5683 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
5684 if (tmptmpbuflen > 0)
5685 UnbufferedStreamLow_write_array(stream)(stream,&tmptmpbuf[0],
5686 tmptmpbuflen,persev_full);
5687 #else
5688 UnbufferedStreamLow_write_array(stream)(stream,(const uintB*)tmpbuf,n,
5689 persev_full);
5690 #endif
5691 stream=*stream_; /* write_array maygc */
5692 }
5693 remaining -= n;
5694 } while (remaining > 0);
5695 #undef tmpbufsize
5696 #ifdef ENABLE_UNICODE
5697 skipSTACK(1); /* the encoding */
5698 #endif
5699 unpin_varobject(*chararray_);
5700 wr_ss_lpos(stream,charptr,len); /* update Line-Position */
5701 }
5702
5703 /* WRITE-CHAR - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_unbuffered_dos(const gcv_object_t * stream_,object ch)5704 local maygc void wr_ch_unbuffered_dos (const gcv_object_t* stream_, object ch) {
5705 var object stream = *stream_;
5706 check_wr_char(stream,ch);
5707 var chart c = char_code(ch); /* Code of the character */
5708 static chart const crlf[2] = { ascii(CR), ascii(LF) };
5709 #ifdef ENABLE_UNICODE
5710 var uintB buf[2*max_bytes_per_chart];
5711 var object encoding = TheStream(stream)->strm_encoding;
5712 var const chart* cp;
5713 var uintL n;
5714 if (chareq(c,ascii(NL))) {
5715 cp = crlf; n = 2;
5716 } else {
5717 cp = &c; n = 1;
5718 }
5719 var const chart* cptr = cp;
5720 var uintB* bptr = &buf[0];
5721 Encoding_wcstombs(encoding)(encoding,stream,&cptr,cp+n,&bptr,
5722 &buf[2*max_bytes_per_chart]);
5723 ASSERT(cptr == cp+n);
5724 var uintL buflen = bptr-&buf[0];
5725 if (buflen > 0)
5726 UnbufferedStreamLow_write_array(stream)(stream,&buf[0],buflen,persev_full);
5727 #else
5728 if (chareq(c,ascii(NL))) {
5729 UnbufferedStreamLow_write_array(stream)(stream,(const uintB*)crlf,2,persev_full);
5730 } else {
5731 UnbufferedStreamLow_write(stream)(stream,as_cint(c));
5732 }
5733 #endif
5734 }
5735
5736 /* WRITE-CHAR-ARRAY - Pseudo-Function for Unbuffered-Channel-Streams: */
wr_ch_array_unbuffered_dos(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)5737 local maygc void wr_ch_array_unbuffered_dos (const gcv_object_t* stream_,
5738 const gcv_object_t* chararray_,
5739 uintL start, uintL len) {
5740 var object stream = *stream_;
5741 var const chart* charptr;
5742 unpack_sstring_alloca(*chararray_,len,start, charptr=);
5743 pin_unprotect_varobject(*chararray_,PROT_READ);
5744 /* Need a temporary buffer for NL->CR/LF translation. */
5745 #define tmpbufsize 4096
5746 var chart tmpbuf[2*tmpbufsize];
5747 #ifdef ENABLE_UNICODE
5748 var uintB tmptmpbuf[2*tmpbufsize*max_bytes_per_chart];
5749 var object encoding;
5750 pushSTACK(TheStream(stream)->strm_encoding);
5751 #endif
5752 var uintL remaining = len;
5753 do {
5754 var uintL n = remaining;
5755 if (n > tmpbufsize)
5756 n = tmpbufsize;
5757 {
5758 var chart* tmpptr = &tmpbuf[0];
5759 var uintL count;
5760 dotimespL(count,n, {
5761 var chart c = *charptr++;
5762 if (chareq(c,ascii(NL))) {
5763 *tmpptr++ = ascii(CR); *tmpptr++ = ascii(LF);
5764 } else {
5765 *tmpptr++ = c;
5766 }
5767 });
5768 #ifdef ENABLE_UNICODE
5769 var const chart* cptr = tmpbuf;
5770 var uintB* bptr = &tmptmpbuf[0];
5771 encoding=STACK_0;
5772 Encoding_wcstombs(encoding)(encoding,stream,&cptr,tmpptr,&bptr,&tmptmpbuf[2*tmpbufsize*max_bytes_per_chart]);
5773 ASSERT(cptr == tmpptr);
5774 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
5775 if (tmptmpbuflen > 0)
5776 UnbufferedStreamLow_write_array(stream)(stream,&tmptmpbuf[0],
5777 tmptmpbuflen,persev_full);
5778 #else
5779 UnbufferedStreamLow_write_array(stream)(stream,(const uintB*)tmpbuf,
5780 tmpptr-&tmpbuf[0],persev_full);
5781 #endif
5782 stream=*stream_;
5783 }
5784 remaining -= n;
5785 } while (remaining > 0);
5786 #undef tmpbufsize
5787 #ifdef ENABLE_UNICODE
5788 skipSTACK(1); /* encoding */
5789 #endif
5790 unpin_varobject(*chararray_);
5791 wr_ss_lpos(stream,charptr,len); /* update Line-Position */
5792 }
5793
5794 /* Macro: Emits a shift sequence to let the output conversion descriptor of an
5795 Unbuffered-Channel-Stream return to the initial state.
5796 oconv_unshift_output_unbuffered(stream);
5797 > stream: Unbuffered-Channel-Stream */
5798 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
5799 #define oconv_unshift_output_unbuffered(stream) \
5800 if (ChannelStream_oconvdesc(stream) != (iconv_t)0) { \
5801 oconv_unshift_output_unbuffered_(stream); \
5802 }
oconv_unshift_output_unbuffered_(object stream)5803 local maygc void oconv_unshift_output_unbuffered_ (object stream) {
5804 #define tmpbufsize 4096
5805 var uintB tmpbuf[tmpbufsize];
5806 var char* outptr = (char*)tmpbuf;
5807 var size_t outsize = tmpbufsize;
5808 begin_system_call();
5809 var size_t res =
5810 iconv(ChannelStream_oconvdesc(stream),NULL,NULL,&outptr,&outsize);
5811 if (res == (size_t)(-1)) {
5812 /* BUG: On Windows, after iconv(), we must use errno, not GetLastError(). */
5813 if (OS_errno == E2BIG) { /* output buffer too small? */
5814 NOTREACHED;
5815 } else {
5816 OS_error();
5817 }
5818 }
5819 end_system_call();
5820 var uintL outcount = outptr-(char*)tmpbuf;
5821 if (outcount > 0)
5822 UnbufferedStreamLow_write_array(stream)(stream,&tmpbuf[0],
5823 outcount,persev_full);
5824 #undef tmpbufsize
5825 }
5826 #else
5827 #define oconv_unshift_output_unbuffered(stream)
5828 #endif
5829
5830 /* UP: Move the pending Output of a Unbuffered-Channel-Stream to the destination.
5831 finish_output_unbuffered(stream);
5832 > stream: Handle-Stream
5833 can trigger GC */
finish_output_unbuffered(object stream)5834 local maygc void finish_output_unbuffered (object stream) {
5835 pushSTACK(stream);
5836 oconv_unshift_output_unbuffered(stream);
5837 stream = popSTACK();
5838 UnbufferedStreamLow_finish_output(stream)(stream);
5839 }
5840
5841 /* UP: Move the pending Output of a Unbuffered-Channel-Stream to the destination.
5842 force_output_unbuffered(stream);
5843 > stream: Handle-Stream
5844 can trigger GC */
force_output_unbuffered(object stream)5845 local maygc void force_output_unbuffered (object stream) {
5846 pushSTACK(stream);
5847 oconv_unshift_output_unbuffered(stream);
5848 stream = popSTACK();
5849 UnbufferedStreamLow_force_output(stream)(stream);
5850 }
5851
5852 /* UP: Delete the pending Output of a Unbuffered-Channel-Stream.
5853 clear_output_unbuffered(stream);
5854 > stream: Handle-Stream
5855 can trigger GC */
clear_output_unbuffered(object stream)5856 local maygc void clear_output_unbuffered (object stream) {
5857 UnbufferedStreamLow_clear_output(stream)(stream);
5858 }
5859
5860 /* Initializes the output side fields of an unbuffered handle stream.
5861 UnbufferedHandleStream_output_init(stream); */
5862 #define UnbufferedHandleStream_output_init(stream) do { \
5863 UnbufferedStreamLow_write(stream) = &low_write_unbuffered_handle; \
5864 UnbufferedStreamLow_write_array(stream) = \
5865 &low_write_array_unbuffered_handle; \
5866 UnbufferedStreamLow_finish_output(stream) = \
5867 &low_finish_output_unbuffered_handle; \
5868 UnbufferedStreamLow_force_output(stream) = \
5869 &low_force_output_unbuffered_handle; \
5870 UnbufferedStreamLow_clear_output(stream) = \
5871 &low_clear_output_unbuffered_handle; \
5872 } while (0)
5873
5874 /* Closes a Channel-Stream.
5875 close_ochannel(stream, abort);
5876 > stream : Channel-Stream
5877 > abort: flag: non-0 => ignore errors */
close_ochannel(object stream,uintB abort)5878 local maygc void close_ochannel (object stream, uintB abort) {
5879 pushSTACK(stream);
5880 MAYBE_IGNORE_ERRORS(abort,oconv_unshift_output_unbuffered(stream));
5881 stream = STACK_0;
5882 ChannelStreamLow_close(stream)(stream,TheStream(stream)->strm_ochannel,abort);
5883 stream = popSTACK();
5884 ChannelStream_fini(stream,abort);
5885 if (ChannelStream_bitsize(stream) > 0) {
5886 ChannelStream_bitsize(stream) = 0; /* delete bitsize */
5887 TheStream(stream)->strm_bitbuffer = NIL; /* free Bitbuffer */
5888 }
5889 }
5890
5891
5892 /* Unbuffered File-Stream
5893 ====================== */
5894
5895 /* check if the eltype specifies a binary stream which element size which is
5896 not a whole multiple of a byte, i.e., a stream which must be buffered */
5897 #define NON_WHOLE_BYTE_P(eltype) \
5898 ((eltype->kind != eltype_ch) && ((eltype->size % 8) != 0))
5899
5900 /* UP: Checks an Element-Type for an Unbuffered-Stream
5901 check_unbuffered_eltype(&eltype);
5902 > eltype: Element-Type in decoded form */
check_unbuffered_eltype(const decoded_el_t * eltype)5903 local void check_unbuffered_eltype (const decoded_el_t* eltype) {
5904 if (NON_WHOLE_BYTE_P(eltype)) {
5905 pushSTACK(canon_eltype(eltype));
5906 pushSTACK(S(Kelement_type));
5907 error(error_condition,GETTEXT("Unbuffered streams need an ~S with a bit size being a multiple of 8, not ~S"));
5908 }
5909 }
5910 #define CHECK_UNBUFFERED_ELTYPE(buffered,direction,eltype) \
5911 if ((direction == DIRECTION_INPUT && buffered == BUFFERED_NIL) \
5912 || (direction == DIRECTION_OUTPUT && buffered != BUFFERED_T)) \
5913 check_unbuffered_eltype(&eltype)
5914
5915 /* UP: Fills in the pseudofunctions for an unbuffered stream.
5916 fill_pseudofuns_unbuffered(stream,&eltype);
5917 > stream: stream being built up, with correct strmflags and encoding
5918 > eltype: Element-Type in decoded form */
fill_pseudofuns_unbuffered(object stream,const decoded_el_t * eltype)5919 local void fill_pseudofuns_unbuffered (object stream,
5920 const decoded_el_t* eltype) {
5921 var uintB flags = TheStream(stream)->strmflags;
5922 stream_dummy_fill(stream);
5923 if (flags & strmflags_rd_B) {
5924 if (eltype->kind==eltype_ch) {
5925 TheStream(stream)->strm_rd_ch = P(rd_ch_unbuffered);
5926 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_unbuffered);
5927 } else {
5928 TheStream(stream)->strm_rd_by =
5929 (eltype->kind == eltype_iu
5930 ? (eltype->size == 8
5931 ? P(rd_by_iau8_unbuffered)
5932 : P(rd_by_iau_unbuffered))
5933 : P(rd_by_ias_unbuffered));
5934 TheStream(stream)->strm_rd_by_array =
5935 ((eltype->kind == eltype_iu) && (eltype->size == 8)
5936 ? P(rd_by_array_iau8_unbuffered)
5937 : P(rd_by_array_dummy));
5938 }
5939 }
5940 if (flags & strmflags_wr_B) {
5941 if (eltype->kind == eltype_ch) {
5942 var object eol = TheEncoding(TheStream(stream)->strm_encoding)->enc_eol;
5943 if (eq(eol,S(Kunix))) {
5944 TheStream(stream)->strm_wr_ch =
5945 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_unbuffered_unix);
5946 TheStream(stream)->strm_wr_ch_array =
5947 TheStream(stream)->strm_wr_ch_array_npnl =
5948 P(wr_ch_array_unbuffered_unix);
5949 } else if (eq(eol,S(Kmac))) {
5950 TheStream(stream)->strm_wr_ch =
5951 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_unbuffered_mac);
5952 TheStream(stream)->strm_wr_ch_array =
5953 TheStream(stream)->strm_wr_ch_array_npnl =
5954 P(wr_ch_array_unbuffered_mac);
5955 } else if (eq(eol,S(Kdos))) {
5956 TheStream(stream)->strm_wr_ch =
5957 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_unbuffered_dos);
5958 TheStream(stream)->strm_wr_ch_array =
5959 TheStream(stream)->strm_wr_ch_array_npnl =
5960 P(wr_ch_array_unbuffered_dos);
5961 } else
5962 NOTREACHED;
5963 } else {
5964 TheStream(stream)->strm_wr_by =
5965 (eltype->kind == eltype_iu
5966 ? (eltype->size == 8
5967 ? P(wr_by_iau8_unbuffered)
5968 : P(wr_by_iau_unbuffered))
5969 : P(wr_by_ias_unbuffered));
5970 TheStream(stream)->strm_wr_by_array =
5971 ((eltype->kind == eltype_iu) && (eltype->size == 8)
5972 ? P(wr_by_array_iau8_unbuffered)
5973 : P(wr_by_array_dummy));
5974 TheStream(stream)->strm_wr_ch =
5975 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_error);
5976 TheStream(stream)->strm_wr_ch_array =
5977 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_error);
5978 }
5979 }
5980 }
5981
5982 #define READ_P(dir) ((dir) & bit(0)) /* readable */
5983 #define RO_P(dir) ((dir) & bit(1)) /* immutable */
5984 #define WRITE_P(dir) ((dir) & bit(2)) /* writable */
5985 #define DIRECTION_FLAGS(dir) \
5986 ((READ_P(dir) ? strmflags_rd_B : 0) /* permits READ-CHAR, READ-BYTE */ \
5987 | (WRITE_P(dir) ? strmflags_wr_B : 0) /* permits WRITE-CHAR, WRITE-BYTE */ \
5988 | (RO_P(dir) ? strmflags_immut_B : 0)) /* immutable object */
5989
5990 #define ELTYPE_FLAFS(eltype) \
5991 (strmflags_immut_B | (eltype->kind == eltype_ch \
5992 ? strmflags_ch_B : strmflags_by_B))
5993
5994
5995 /* UP: creates an Unbuffered-Channel-Stream
5996 make_unbuffered_stream(type,direction,&eltype,handle_regular,handle_tty)
5997 > STACK_2: Encoding
5998 > STACK_1: Element-Type
5999 > STACK_0: Handle of the opened File
6000 > type: stream type
6001 > direction: direction_t (see lispbibl.d)
6002 > eltype: Element-Type in decoded form
6003 > handle_regular: whether the handle refers to a regular file
6004 > handle_tty: if the Handle is a tty (only necessary if direction & bit(0))
6005 < result: File-Handle-Stream, Handle_{input,output}_init still needs to be called
6006 < STACK: cleaned up
6007 can trigger GC */
make_unbuffered_stream(uintB type,direction_t direction,const decoded_el_t * eltype,bool handle_regular,bool handle_tty)6008 local maygc object make_unbuffered_stream
6009 (uintB type, direction_t direction, const decoded_el_t* eltype,
6010 bool handle_regular, bool handle_tty) {
6011 var uintB flags = DIRECTION_FLAGS(direction) & ELTYPE_FLAFS(eltype);
6012 /* allocate Stream: */
6013 var object stream = allocate_stream(flags,type,strm_channel_len,
6014 sizeof(strm_unbuffered_extrafields_t));
6015 /* and fill: */
6016 TheStream(stream)->strm_encoding = STACK_2;
6017 fill_pseudofuns_unbuffered(stream,eltype);
6018 ChannelStream_ignore_next_LF(stream) = false;
6019 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; /* Line Position := 0 */
6020 {
6021 var object handle = popSTACK();
6022 if (READ_P(direction))
6023 TheStream(stream)->strm_ichannel = handle; /* enter Handle */
6024 if (WRITE_P(direction))
6025 TheStream(stream)->strm_ochannel = handle; /* enter Handle */
6026 if (type == strmtype_file)
6027 TheStream(stream)->strm_buffered_channel = handle; /* enter Handle */
6028 }
6029 /* enter Flag isatty = (handle_tty ? T : NIL) : */
6030 TheStream(stream)->strm_isatty = (handle_tty ? T : NIL);
6031 TheStream(stream)->strm_eltype = popSTACK();
6032 ChannelStream_buffered(stream) = false;
6033 ChannelStream_regular(stream) = handle_regular;
6034 ChannelStream_init(stream);
6035 /* element-type dependent initializations: */
6036 ChannelStream_bitsize(stream) = eltype->size;
6037 ChannelStream_lineno(stream) = 1; /* initialize always (cf. set-stream-element-type) */
6038 if (!(eltype->kind == eltype_ch)) {
6039 /* File-Stream for Integers
6040 allocate Bitbuffer: */
6041 pushSTACK(stream);
6042 var object bitbuffer = allocate_bit_vector(Atype_Bit,eltype->size);
6043 stream = popSTACK();
6044 TheStream(stream)->strm_bitbuffer = bitbuffer;
6045 }
6046 skipSTACK(1);
6047 return stream;
6048 }
6049
6050
6051 /* File-Stream
6052 ===========
6053
6054 In order to not have to bestir the UNIX for each Character,
6055 our own Buffer is maintained.
6056 (This caused e.g. for the Consumption of a 408 KByte- File on an Atari
6057 an acceleration by a Factor of 2.7 from 500 sec to 180 sec.)
6058
6059 Additional fields:
6060 define strm_file_name strm_field1 - Filename, a pathname or NIL
6061 define strm_file_truename strm_field2 - Truename, a non-logical pathname or NIL
6062 define strm_buffered_channel strm_ochannel - a wrapped Handle
6063 define strm_buffered_bufflen 4096 - buffer length, a power of 2, <2^16
6064 our own buffer, a simple-bit-vector with strm_buffered_bufflen bytes: */
6065 #define strm_buffered_buffer strm_buffer
6066
6067 /* Additional binary (not GCed) fields: */
6068 typedef struct strm_buffered_extrafields_t {
6069 strm_channel_extrafields_t _parent;
6070 uintL (* low_fill) (object stream, perseverance_t persev);
6071 void (* low_flush) (object stream, uintL bufflen);
6072 uoff_t buffstart _attribute_in_misaligned_varobjects_; /* start position of buffer */
6073 uintL endvalid; /* index up to which the data is known to be valid */
6074 uintL index; /* index into buffer (>=0, <=endvalid) */
6075 /*bool*/int have_eof_p : 8; /* indicates that eof is right after endvalid */
6076 /*bool*/int modified : 8; /* true if the buffer contains modified data,
6077 else false */
6078 /*bool*/int blockpositioning : 8; /* whether the handle refers to a regular
6079 file and permits to position the buffer at
6080 buffstart = (sector number) * strm_buffered_bufflen
6081 endvalid always indicates how much of the buffer contains data
6082 have_eof_p = true indicates that the EOF is known to be at the
6083 endvalid position. It could be there without have_eof_p being true,
6084 but it will be discovered by the next buffered_nextbyte() then
6085 buffstart = (sector number) * strm_buffered_bufflen,
6086 if blockpositioning permitted.
6087 The position of handle, known to the OS, set via lseek, is normally
6088 (but not always!) the end of the current buffer. More importantly,
6089 before flushing the buffer to disk, the handle is lseek()ed to
6090 buffstart, which ensures data is written where it should be. This
6091 then leaves the position at the correct point for subsequent reads.
6092 Up to now a file is considered built from bytes of 8 bits.
6093 Logically, it is built up from other units: */
6094 uoff_t position _attribute_in_misaligned_varobjects_; /* position in logical units */
6095 } strm_buffered_extrafields_t;
6096
6097 /* More fields in file streams with element type INTEGER, type ib or ic. */
6098 typedef struct strm_i_buffered_extrafields_t {
6099 strm_buffered_extrafields_t _parent;
6100 /* If bitsize is not a multiple of 8: */
6101 uintL bitindex; /* index in the current byte, >=0, <=8 */
6102 /* The buffer contains 8*index+bitindex bits. The bits are ordered in the
6103 order bit0,....,bit7. If bitsize<8, the length of the file (measured in
6104 bits) is stored in the first 4 bytes of the files [in little-endian order]
6105 when the file is closed. The actual data then begins in the 5th byte. */
6106 uoff_t eofposition _attribute_in_misaligned_varobjects_; /* position of logical EOF */
6107 } strm_i_buffered_extrafields_t;
6108
6109 /* In closed file streams only the fields `name' and `truename' are relevant. */
6110
6111 /* Accessors. */
6112 #define FileStream_name(stream) TheStream(stream)->strm_file_name
6113 #define FileStream_truename(stream) TheStream(stream)->strm_file_truename
6114 #define BufferedStream_channel(stream) TheStream(stream)->strm_buffered_channel
6115 #define BufferedStream_buffer(stream) TheStream(stream)->strm_buffered_buffer
6116 #define BufferedStream_buffer_address(stream,shift) \
6117 (&TheSbvector(BufferedStream_buffer(stream))->data[shift])
6118 #define BufferedStreamLow_fill(stream) \
6119 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_fill
6120 #define BufferedStreamLow_flush(stream) \
6121 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->low_flush
6122 #define BufferedStream_buffstart(stream) \
6123 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->buffstart
6124 #define BufferedStream_endvalid(stream) \
6125 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->endvalid
6126 #define BufferedStream_index(stream) \
6127 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->index
6128 #define BufferedStream_have_eof_p(stream) \
6129 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->have_eof_p
6130 #define BufferedStream_modified(stream) \
6131 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->modified
6132 #define BufferedStream_blockpositioning(stream) \
6133 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->blockpositioning
6134 #define BufferedStream_position(stream) \
6135 ((strm_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->position
6136 #define BufferedStream_bitindex(stream) \
6137 ((strm_i_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->bitindex
6138 #define BufferedStream_eofposition(stream) \
6139 ((strm_i_buffered_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)->eofposition
6140
6141 #define Truename_or_Self(stream) \
6142 (nullp(TheStream(stream)->strm_file_truename) ? (object)stream : \
6143 (object)TheStream(stream)->strm_file_truename)
6144
6145 #define ChannelStream_ihandle(obj) \
6146 TheHandle(ChannelStream_buffered(obj) ? BufferedStream_channel(obj) \
6147 : ChannelStream_ichannel(obj))
6148 #define ChannelStream_ohandle(obj) \
6149 TheHandle(ChannelStream_buffered(obj) ? BufferedStream_channel(obj) \
6150 : ChannelStream_ochannel(obj))
6151
6152 /* File-Stream in general
6153 ====================== */
6154
6155 #ifdef UNIX
6156 /* Assumption: All File-Descriptors delivered by OPEN(2) (called Handles
6157 here) fit in an uintW.
6158 Substantiation: as is generally known: 0 <= fd < getdtablesize() . */
6159 #endif
6160
6161 /* Note about regular and non-regular files:
6162 - For regular files that were opened with O_RDONLY or O_RDWR but not O_WRONLY,
6163 we assume that it makes sense to read a block, modify it, reposition the
6164 handle back to the beginning of the block and write it back.
6165 - For regular files opened with O_WRONLY, we use a simple output buffer.
6166 - For non-regular files, we don't call handle_lseek. Therefore mixed I/O is
6167 not possible. Only input-only and output-only modes are possible.
6168
6169 position the Handle:
6170 handle_lseek(stream,handle,offset,mode,result_assignment);
6171 stream_ should be pointer to GC safe location (since the call itself is
6172 surrounded by GC safe region - multithreading).
6173 > mode: Positioning-Mode:
6174 SEEK_SET "absolute"
6175 SEEK_CUR "relative"
6176 SEEK_END "at the end"
6177 < result: new Position */
6178 #if defined(UNIX) || defined(WIN32_NATIVE)
6179 #define fd_lseek(stream_,fd,offset,mode,result_assignment) \
6180 { var off_t result = lseek(fd,offset,mode); \
6181 if (result<0) /* error occurred? */ \
6182 { end_blocking_system_call(); OS_filestream_error(*stream_); } \
6183 unused (result_assignment result); \
6184 }
6185 #define handle_lseek(stream_,fd,offset,mode,result_assignment) \
6186 fd_lseek(stream_,fd,offset,mode,result_assignment)
6187 #endif
6188
6189 /* UP: Fills the buffer, up to strm_buffered_bufflen bytes.
6190 low_fill_buffered_handle(stream,persev)
6191 > stream: (open) byte-based file stream
6192 > persev: one of persev_partial, persev_immediate, persev_bonus
6193 < result: number of bytes read */
low_fill_buffered_handle(object stream,perseverance_t persev)6194 local maygc uintL low_fill_buffered_handle (object stream, perseverance_t persev) {
6195 var Handle handle = TheHandle(BufferedStream_channel(stream));
6196 var uintB* buff = BufferedStream_buffer_address(stream,0);
6197 /* On regular file handles, persev_immediate and persev_bonus are effectively
6198 equivalent to persev_partial. Transforming persev_immediate, persev_bonus
6199 here 1) avoids useless system calls for poll(), select() or non-blocking
6200 I/O and 2) improves EOF detection. */
6201 if ((persev == persev_immediate || persev == persev_bonus)
6202 && ChannelStream_regular(stream))
6203 persev = persev_partial;
6204 if ((TheStream(stream)->strmflags & strmflags_rd_B) == 0
6205 && !ChannelStream_regular(stream))
6206 return 0; /* wronly stream to a special device, handle is O_WRONLY */
6207 pin_unprotect_varobject(BufferedStream_buffer(stream),PROT_READ_WRITE);
6208 pushSTACK(stream);
6209 var ssize_t result;
6210 GC_SAFE_SYSTEM_CALL(result = fd_read(handle,buff,strm_buffered_bufflen,persev));
6211 stream = popSTACK();
6212 unpin_varobject(BufferedStream_buffer(stream));
6213 if (result<0) /* error occurred? */
6214 OS_filestream_error(stream);
6215 if (result==0 && fd_error_eof_p())
6216 BufferedStream_have_eof_p(stream) = true;
6217 return result;
6218 }
6219
6220 /* Functions for writing the buffer.
6221 low_flush_buffered_handle(stream,bufflen);
6222 buffered_flush(stream);
6223 These are called only if the buffer is modified.
6224 Of course, the buffer is modified only by the WRITE-BYTE/WRITE-CHAR
6225 operations. */
6226
6227 /* UP: Finishes the Writing-Back of the Buffers.
6228 low_flush_buffered_handle(stream,bufflen);
6229 > stream : (open) Byte-based File-Stream.
6230 > bufflen : Number of Bytes to be written
6231 < modified_flag of stream : deleted
6232 changed in stream: index */
low_flush_buffered_handle(object stream,uintL bufflen)6233 local maygc void low_flush_buffered_handle (object stream, uintL bufflen) {
6234 var Handle handle = TheHandle(BufferedStream_channel(stream));
6235 var uintB* buff = BufferedStream_buffer_address(stream,0);
6236 pin_unprotect_varobject(BufferedStream_buffer(stream),PROT_READ);
6237 pushSTACK(stream);
6238 var ssize_t result;
6239 GC_SAFE_SYSTEM_CALL(result = full_write(handle,buff,bufflen));
6240 stream = popSTACK();
6241 unpin_varobject(BufferedStream_buffer(stream));
6242 if (result==bufflen) { /* everything written correctly */
6243 BufferedStream_modified(stream) = false;
6244 } else { /* not everything written */
6245 #ifdef UNIX
6246 if (result<0) /* error occurred? */
6247 #ifdef ENOSPC
6248 if (!(errno == ENOSPC))
6249 #endif
6250 #ifdef EDQUOT
6251 if (!(errno == EDQUOT))
6252 #endif
6253 { OS_filestream_error(stream); }
6254 #endif
6255 #if defined(WIN32_NATIVE)
6256 if (result<0) { /* error occurred? */
6257 OS_filestream_error(stream);
6258 }
6259 #endif
6260 /* Not everything was written, probably because of full disk.
6261 In order to avoid inconsistencies, must close the file. */
6262 BufferedStream_modified(stream) = false; /* data is lost! */
6263 pushSTACK(stream);
6264 builtin_stream_close(&STACK_0,0); /* file close */
6265 clr_break_sem_4(); /* no more UNIX operations are active */
6266 /* Report the error. */
6267 pushSTACK(Truename_or_Self(STACK_0)); /* FILE-ERROR slot PATHNAME */
6268 pushSTACK(STACK_(0+1)); /* stream */
6269 error(file_error,GETTEXT("Closed ~S because disk is full."));
6270 }
6271 }
6272
6273 #define BufferedHandleStream_init(stream) \
6274 { BufferedStreamLow_fill(stream) = &low_fill_buffered_handle; \
6275 BufferedStreamLow_flush(stream) = &low_flush_buffered_handle; \
6276 }
6277
6278 /* UP: Writes the modified Buffer back.
6279 buffered_flush(stream);
6280 > stream : (open) Byte-based File-Stream.
6281 < modified_flag of stream : deleted
6282 changed in stream: index */
buffered_flush(object stream)6283 local maygc void buffered_flush (object stream) {
6284 if (BufferedStream_blockpositioning(stream)) {
6285 var Handle handle = TheHandle(BufferedStream_channel(stream));
6286 var uoff_t buffstart = BufferedStream_buffstart(stream);
6287 pushSTACK(stream);
6288 begin_blocking_system_call();
6289 handle_lseek(&STACK_0,handle,buffstart,SEEK_SET,); /* positioning back */
6290 end_blocking_system_call();
6291 stream = popSTACK();
6292 }
6293 BufferedStreamLow_flush(stream)(stream,BufferedStream_endvalid(stream));
6294 }
6295
6296 /* UP: Positions a Byte-based File-Stream, so the next Byte can be
6297 read or overwritten.
6298 buffered_nextbyte(stream,persev)
6299 > stream : (open) Byte-based File-Stream.
6300 > persev: one of persev_partial, persev_immediate, persev_bonus
6301 < result : 0 = EOF (the next byte can be written, not read)
6302 -1 = would block (only if not persev_partial, next byte cannot yet
6303 be read or written)
6304 else Pointer to the next Byte (can be read or written)
6305 changed in stream: index, endvalid, have_eof_p, buffstart */
buffered_nextbyte(object stream,perseverance_t persev)6306 local maygc uintB* buffered_nextbyte (object stream, perseverance_t persev) {
6307 var sintL endvalid = BufferedStream_endvalid(stream);
6308 var uintL index = BufferedStream_index(stream);
6309 if ((endvalid == index) && !BufferedStream_have_eof_p(stream)) {
6310 pushSTACK(stream);
6311 /* Buffer must be newly filled. */
6312 if (BufferedStream_modified(stream)) {
6313 /* First, the Buffer must be flushed out: */
6314 buffered_flush(stream); /* FIXME: buffered_flush() may hang! */
6315 stream = STACK_0; /* flush maygc */
6316 }
6317 BufferedStream_buffstart(stream) += endvalid;
6318 var uintL result;
6319 if (BufferedStream_blockpositioning(stream)
6320 || (TheStream(stream)->strmflags & strmflags_rd_B)) {
6321 result = BufferedStreamLow_fill(stream)(stream,persev);
6322 stream = popSTACK(); /* fill maygc */
6323 if (result == 0 && !BufferedStream_have_eof_p(stream)
6324 && persev != persev_partial)
6325 return (uintB*)-1; /* would hang */
6326 } else {
6327 skipSTACK(1); /* saved stream */
6328 result = 0;
6329 }
6330 BufferedStream_index(stream) = index = 0;
6331 BufferedStream_modified(stream) = false;
6332 BufferedStream_endvalid(stream) = endvalid = result;
6333 if (result == 0)
6334 BufferedStream_have_eof_p(stream) = true;
6335 }
6336 if (index < endvalid)
6337 return BufferedStream_buffer_address(stream,index);
6338 else if (BufferedStream_have_eof_p(stream))
6339 return (uintB*)NULL; /* EOF reached */
6340 else
6341 NOTREACHED;
6342 }
6343
6344 /* UP: Prepares the writing of a Byte at EOF.
6345 buffered_eofbyte(stream);
6346 > stream : (open) Byte-based File-Stream, for which
6347 currently buffered_nextbyte(stream)==NULL is true.
6348 < result : Pointer to the next (free) Byte
6349 changed in stream: index, endvalid, buffstart */
buffered_eofbyte(object stream)6350 local maygc uintB* buffered_eofbyte (object stream) {
6351 /* EOF. endvalid=index. */
6352 ASSERT(BufferedStream_have_eof_p(stream));
6353 if (BufferedStream_endvalid(stream) == strm_buffered_bufflen) {
6354 /* Buffer must be filled newly. Because after that EOF will occur anyway,
6355 it is sufficient, to flush the Buffer out: */
6356 if (BufferedStream_modified(stream)) {
6357 pushSTACK(stream);
6358 buffered_flush(stream);
6359 stream = popSTACK();
6360 }
6361 BufferedStream_buffstart(stream) += strm_buffered_bufflen;
6362 BufferedStream_endvalid(stream) = 0;
6363 BufferedStream_index(stream) = 0; /* index := 0 */
6364 BufferedStream_modified(stream) = false; /* unmodified */
6365 }
6366 /* increase endvalid: */
6367 BufferedStream_endvalid(stream) += 1;
6368 return BufferedStream_buffer_address(stream,BufferedStream_index(stream));
6369 }
6370
6371 /* UP: Writes a Byte to a Byte-based File-Stream.
6372 buffered_writebyte(stream,b);
6373 > stream : (open) Byteblock-based File-Stream.
6374 > b : Byte to be written
6375 changed in stream: index, endvalid, buffstart */
buffered_writebyte(object stream,uintB b)6376 local maygc void buffered_writebyte (object stream, uintB b) {
6377 pushSTACK(stream);
6378 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
6379 stream = STACK_0;
6380 if (!(ptr == (uintB*)NULL)) {
6381 if (*ptr == b) /* no real Modification? */
6382 goto no_modification;
6383 } else {
6384 ptr = buffered_eofbyte(stream); /* EOF -> make room for 1 Byte */
6385 stream = STACK_0;
6386 }
6387 /* write next Byte in the Buffer: */
6388 *ptr = b; BufferedStream_modified(stream) = true;
6389 no_modification:
6390 skipSTACK(1);
6391 /* increment index */
6392 BufferedStream_index(stream) += 1;
6393 }
6394
6395 /* File-Stream, Byte-based (b_file)
6396 =========== ==========
6397
6398 error-message because of positioning behind EOF.
6399 error_position_beyond_EOF(stream); */
error_position_beyond_EOF(object stream)6400 local _Noreturn void error_position_beyond_EOF (object stream) {
6401 pushSTACK(Truename_or_Self(stream)); /* FILE-ERROR slot PATHNAME */
6402 pushSTACK(stream);
6403 error(file_error,GETTEXT("cannot position ~S beyond EOF"));
6404 }
6405
6406 /* UP: Positions an (open) Byte-based File-Stream to a
6407 specified Position.
6408 position_file_buffered(stream,position);
6409 > stream : (open) Byte-based File-Stream.
6410 > position : new Position
6411 changed in stream: index, endvalid, buffstart */
position_file_buffered(object stream,uoff_t position)6412 local maygc void position_file_buffered (object stream, uoff_t position) {
6413 /* Is the new Position in the same Sector? */
6414 {
6415 var uintL endvalid = BufferedStream_endvalid(stream);
6416 var uoff_t newindex = position - BufferedStream_buffstart(stream);
6417 if (newindex <= endvalid) { /* yes -> only index has to be changed: */
6418 BufferedStream_index(stream) = newindex;
6419 return;
6420 }
6421 }
6422 pushSTACK(stream);
6423 /* poss. flush Buffer: */
6424 if (BufferedStream_modified(stream)) {
6425 buffered_flush(stream);
6426 stream = STACK_0; /* restore stream in case of GC during blocking*/
6427 }
6428 var Handle handle = TheHandle(BufferedStream_channel(stream));
6429 /* Now modified_flag is deleted. */
6430 if (!BufferedStream_blockpositioning(stream)) { /* Positioning: */
6431 begin_blocking_system_call();
6432 handle_lseek(&STACK_0,handle,position,SEEK_SET,);
6433 end_blocking_system_call();
6434 stream = STACK_0;
6435 BufferedStream_buffstart(stream) = position;
6436 BufferedStream_endvalid(stream) = 0;
6437 BufferedStream_index(stream) = 0; /* index := 0 */
6438 BufferedStream_modified(stream) = false; /* unmodified */
6439 BufferedStream_have_eof_p(stream) = false;
6440 } else {
6441 var uoff_t oldposition = BufferedStream_buffstart(stream) + BufferedStream_index(stream);
6442 /* Positioning: */
6443 {
6444 var uoff_t newposition;
6445 begin_blocking_system_call();
6446 handle_lseek(&STACK_0,handle,
6447 floor(position,strm_buffered_bufflen)*strm_buffered_bufflen,
6448 SEEK_SET,newposition=);
6449 end_blocking_system_call();
6450 stream = STACK_0;
6451 BufferedStream_buffstart(stream) = newposition;
6452 }
6453 /* read Sector: */
6454 BufferedStream_endvalid(stream) = 0;
6455 BufferedStream_index(stream) = 0; /* index := 0 */
6456 BufferedStream_modified(stream) = false; /* unmodified */
6457 BufferedStream_have_eof_p(stream) = false;
6458 var uintL newindex = position % strm_buffered_bufflen; /* desired Index in the Sector */
6459 if (newindex!=0) { /* Position between Sectors -> nothing needs to be read */
6460 buffered_nextbyte(stream,persev_partial);
6461 stream = STACK_0;
6462 /* index=0; set index to (position mod bufflen), but check first: */
6463 var uintL endvalid = BufferedStream_endvalid(stream);
6464 /* newindex must be in the valid range */
6465 if (newindex > endvalid) {
6466 /* Error. But first position back to the old Position: */
6467 check_SP();
6468 position_file_buffered(stream,oldposition); /* position back */
6469 stream = popSTACK(); /* error will not return */
6470 error_position_beyond_EOF(stream);
6471 }
6472 BufferedStream_index(stream) = newindex;
6473 }
6474 }
6475 skipSTACK(1);
6476 }
6477
6478 /* UP: flushes pending write (if any), moves OS file pointer so
6479 that there's no more preread data in the buffer to use the handle.
6480 sync_file_buffered(stream,position);
6481 > stream : (open) Byte-based File-Stream.
6482 changed in stream: index, endvalid, buffstart */
sync_file_buffered(object stream)6483 local maygc void sync_file_buffered (object stream) {
6484 var uoff_t position = BufferedStream_buffstart(stream)+BufferedStream_index(stream);
6485 var Handle handle = TheHandle(BufferedStream_channel(stream));
6486 pushSTACK(stream);
6487 /* poss. flush Buffer: */
6488 if (BufferedStream_modified(stream)) {
6489 buffered_flush(stream);
6490 stream = STACK_0;
6491 }
6492 /* Now modified_flag is deleted. */
6493 begin_blocking_system_call();
6494 handle_lseek(&STACK_0,handle,position,SEEK_SET,);
6495 end_blocking_system_call();
6496 stream = popSTACK();
6497 /* ampy: don't respect blockpositioning, acceptable ? */
6498 BufferedStream_buffstart(stream) = position;
6499 BufferedStream_endvalid(stream) = 0;
6500 BufferedStream_index(stream) = 0; /* index == endvalid, next read will refill the buffer */
6501 BufferedStream_modified(stream) = false; /* unmodified */
6502 BufferedStream_have_eof_p(stream) = false;
6503 }
6504
6505 /* UP: Reads an Array of Bytes from an (open) Byte-based
6506 File-Stream.
6507 read_byte_array_buffered(stream,byteptr,len,persev)
6508 > stream : (open) Byte-based File-Stream.
6509 > byteptr[0..len-1] : place
6510 > len : > 0
6511 > persev: how to react on incomplete I/O
6512 < byteptr[0..count-1] : read Bytes.
6513 < result: &byteptr[count] (with count = len, or count < len if EOF reached)
6514 changed in stream: index, endvalid, buffstart */
read_byte_array_buffered(object stream,uintB * byteptr,uintL len,perseverance_t persev)6515 local maygc uintB* read_byte_array_buffered
6516 (object stream, uintB* byteptr, uintL len, perseverance_t persev) {
6517 pushSTACK(stream);
6518 for (;;) {
6519 var uintB* ptr = buffered_nextbyte(stream, persev == persev_full ? persev_partial : persev);
6520 if (ptr == (uintB*)NULL || ptr == (uintB*)-1)
6521 break;
6522 stream = STACK_0; /* restore stream */
6523 var uintL endvalid = BufferedStream_endvalid(stream);
6524 var uintL available = endvalid - BufferedStream_index(stream);
6525 if (available > len)
6526 available = len;
6527 /* copy all available bytes: */
6528 copy_mem_b(byteptr,ptr,available);
6529 byteptr += available;
6530 /* increment index: */
6531 BufferedStream_index(stream) += available;
6532 len -= available;
6533 if (len == 0)
6534 break;
6535 if (available > 0) {
6536 if (persev == persev_partial)
6537 persev = persev_bonus;
6538 #if defined(UNIX) || defined(WIN32_NATIVE)
6539 if (persev == persev_immediate || persev == persev_bonus)
6540 /* There's no need to continue the loop, with persev_immediate or
6541 persev_bonus, because if read() has returned a partial result, it
6542 means that nothing more is immediately available. (The OS doesn't
6543 gratuitously return less bytes to read() than available. Except when
6544 the system call was interrupted by a signal; but this can't happen
6545 because install_signal_handler() is careful to ensure restartable
6546 system calls.) */
6547 break;
6548 #endif
6549 }
6550 }
6551 skipSTACK(1);
6552 return byteptr;
6553 }
6554
6555 /* UP: Writes an Array of Bytes to an (open) Byte-based
6556 File-Stream.
6557 write_byte_array_buffered(stream,byteptr,len,persev)
6558 > stream : (open) Byte-based File-Stream.
6559 > byteptr[0..len-1] : Bytes to be written.
6560 > len : > 0
6561 > persev: how to react on incomplete I/O
6562 < result: &byteptr[len]
6563 changed in stream: index, endvalid, buffstart */
write_byte_array_buffered(object stream,const uintB * byteptr,uintL len,perseverance_t persev)6564 local maygc const uintB* write_byte_array_buffered
6565 (object stream, const uintB* byteptr, uintL len, perseverance_t persev) {
6566 var uintL remaining = len;
6567 var uintB* ptr;
6568 pushSTACK(stream);
6569 for (;;) { /* still remaining>0 Bytes to be filled. */
6570 ptr = buffered_nextbyte(stream, persev == persev_full ? persev_partial : persev);
6571 stream = STACK_0;
6572 if (ptr == (uintB*)NULL)
6573 goto eof_reached;
6574 if (ptr == (uintB*)-1) return byteptr;
6575 var uintL endvalid = BufferedStream_endvalid(stream);
6576 var uintL next = /* as many as still fit in the Buffer or until EOF */
6577 endvalid - BufferedStream_index(stream); /* > 0 ! */
6578 if (next > remaining)
6579 next = remaining;
6580 { /* copy next Bytes in the Buffer: */
6581 var uintL count;
6582 dotimespL(count,next, {
6583 var uintB b = *byteptr++; /* next Byte */
6584 if (!(*ptr == b)) {
6585 *ptr = b; BufferedStream_modified(stream) = true; /* in the Buffer */
6586 }
6587 ptr++;
6588 });
6589 }
6590 remaining = remaining - next;
6591 /* increment index */
6592 BufferedStream_index(stream) += next;
6593 if (remaining == 0)
6594 break;
6595 if (next > 0) {
6596 if (persev == persev_partial)
6597 persev = persev_bonus;
6598 #if defined(UNIX) || defined(WIN32_NATIVE)
6599 if (persev == persev_immediate || persev == persev_bonus)
6600 /* There's no need to continue the loop, with persev_immediate or
6601 persev_bonus, because if write() has returned a partial result, it
6602 means that nothing more is immediately accepted. (The OS doesn't
6603 gratuitously return less bytes to write() than it can. Except when
6604 the system call was interrupted by a signal; but this can't happen
6605 because install_signal_handler() is careful to ensure restartable
6606 system calls.) */
6607 break;
6608 #endif
6609 }
6610 }
6611 if (false) {
6612 eof_reached: /* Write at EOF, endvalid = index */
6613 do { /* Still remaining>0 Bytes to file. */
6614 var uintL next = /* as many as there is still room in the Buffer */
6615 strm_buffered_bufflen - BufferedStream_index(stream);
6616 if (next==0) {
6617 /* Buffer must be filled newly. After that, EOF arrives anyway,
6618 so it is sufficient to flush the buffer: */
6619 if (BufferedStream_modified(stream)) {
6620 buffered_flush(stream);
6621 stream = STACK_0;
6622 }
6623 BufferedStream_buffstart(stream) += strm_buffered_bufflen;
6624 BufferedStream_endvalid(stream) = 0;
6625 BufferedStream_index(stream) = 0; /* index := 0 */
6626 BufferedStream_modified(stream) = false; /* unmodified */
6627 /* Then try again: */
6628 next = strm_buffered_bufflen;
6629 }
6630 if (next > remaining)
6631 next = remaining;
6632 /* copy the next bytes in the buffer: */
6633 copy_mem_b(BufferedStream_buffer_address(stream,BufferedStream_index(stream)),
6634 byteptr,next);
6635 byteptr += next;
6636 BufferedStream_modified(stream) = true;
6637 remaining = remaining - next;
6638 /* increment index and endvalid */
6639 BufferedStream_index(stream) += next;
6640 BufferedStream_endvalid(stream) += next;
6641 } while (remaining != 0);
6642 }
6643 skipSTACK(1);
6644 return byteptr;
6645 }
6646
6647 /* File-Stream of Characters
6648 ==========================
6649
6650 Input side
6651 ----------
6652
6653 READ-CHAR - Pseudo-Function for File-Streams of Characters */
rd_ch_buffered(const gcv_object_t * stream_)6654 local maygc object rd_ch_buffered (const gcv_object_t* stream_) {
6655 rd_ch_buffered_retry:
6656 var uintB* bufferptr = buffered_nextbyte(*stream_,persev_partial);
6657 var object stream = *stream_;
6658 if (bufferptr == (uintB*)NULL) /* EOF ? */
6659 return eof_value;
6660 /* fetch next character: */
6661 var chart c;
6662 #ifdef ENABLE_UNICODE
6663 var object encoding = TheStream(stream)->strm_encoding;
6664 { /* Does the buffer contain a complete character? */
6665 var uintL endvalid = BufferedStream_endvalid(stream);
6666 var uintL available = endvalid - BufferedStream_index(stream);
6667 var const uintB* bptr = bufferptr;
6668 var chart* cptr = &c;
6669 Encoding_mbstowcs(encoding)
6670 (encoding,stream,&bptr,bufferptr+available,&cptr,&c+1);
6671 if (cptr == &c+1) {
6672 var uintL n = bptr-bufferptr;
6673 /* increment index and position */
6674 BufferedStream_index(stream) += n;
6675 BufferedStream_position(stream) += n;
6676 } else {
6677 var uintB buf[max_bytes_per_chart];
6678 var uintL buflen = 0;
6679 pushSTACK(encoding);
6680 while (1) {
6681 ASSERT(buflen < max_bytes_per_chart);
6682 buf[buflen++] = *bufferptr;
6683 /* increment index and position */
6684 BufferedStream_index(stream) += 1;
6685 BufferedStream_position(stream) += 1;
6686 var const uintB* bptr = &buf[0];
6687 var chart* cptr = &c;
6688 Encoding_mbstowcs(encoding)(encoding,stream,&bptr,&buf[buflen],&cptr,cptr+1);
6689 if (cptr == &c) {
6690 /* Not a complete character.
6691 Shift the buffer */
6692 if (!(bptr == &buf[0])) {
6693 var const uintB* ptr1 = bptr;
6694 var uintB* ptr2 = &buf[0];
6695 while (ptr1 != &buf[buflen]) { *ptr2++ = *ptr1++; }
6696 buflen = ptr2 - &buf[0];
6697 }
6698 } else {
6699 /* Read a complete character. */
6700 if (!(bptr == &buf[buflen])) {
6701 /* At most one lookahead byte. Make it unread. */
6702 ASSERT(bptr == &buf[buflen-1]);
6703 /* decrement index and position again: */
6704 BufferedStream_index(stream) -= 1;
6705 BufferedStream_position(stream) -= 1;
6706 }
6707 break;
6708 }
6709 bufferptr = buffered_nextbyte(stream,persev_partial);
6710 if (bufferptr == (uintB*)NULL)
6711 return eof_value;
6712 stream = *stream_; /* restore stream */
6713 encoding = STACK_0;
6714 }
6715 skipSTACK(1);
6716 }
6717 }
6718 #else
6719 c = as_chart(*bufferptr); /* Character from the Buffer */
6720 /* increment index and position */
6721 BufferedStream_index(stream) += 1;
6722 BufferedStream_position(stream) += 1;
6723 #endif
6724 if (chareq(c,ascii(NL))) {
6725 if (ChannelStream_ignore_next_LF(stream)) {
6726 ChannelStream_ignore_next_LF(stream) = false;
6727 goto rd_ch_buffered_retry;
6728 }
6729 ChannelStream_lineno(stream) += 1;
6730 } else if (chareq(c,ascii(CR))) {
6731 ChannelStream_ignore_next_LF(stream) = true;
6732 c = ascii(NL);
6733 ChannelStream_lineno(stream) += 1;
6734 }
6735 return code_char(c);
6736 }
6737
6738 /* Determines, if a character is available on a File-Stream.
6739 listen_char_buffered(stream)
6740 > stream: File-Stream of Characters
6741 < result: input availability */
listen_char_buffered(object stream)6742 local maygc listen_t listen_char_buffered (object stream) {
6743 listen_char_buffered_retry:
6744 pushSTACK(stream);
6745 var uintB* buf = buffered_nextbyte(stream,persev_immediate);
6746 stream = popSTACK();
6747 if (buf == (uintB*)NULL) return LISTEN_EOF; /* EOF */
6748 if (buf == (uintB*)-1) return LISTEN_WAIT; /* will hang */
6749 if (*buf == '\n' && ChannelStream_ignore_next_LF(stream)) { /* discard LF */
6750 /* assume that '\n' is LF in all encodings */
6751 BufferedStream_index(stream) += 1;
6752 BufferedStream_position(stream) += 1;
6753 ChannelStream_ignore_next_LF(stream) = false;
6754 goto listen_char_buffered_retry;
6755 /* we might extract rd_ch_buffered_low from above instead,
6756 but it seems too much work for little gain */
6757 }
6758 /* In case of ENABLE_UNICODE, the presence of a byte does not guarantee the
6759 presence of a multi-byte character. Returning LISTEN_AVAIL here is
6760 therefore not correct. But this doesn't matter since programs seeing
6761 LISTEN_AVAIL will call read-char, and this will do the right thing anyway. */
6762 return LISTEN_AVAIL;
6763 }
6764
6765 /* UP: discard already entered input from a Buffered Stream.
6766 clear_input_buffered(stream);
6767 > stream: Buffered Stream
6768 < result: true if Input was deleted, else false */
clear_input_buffered(object stream)6769 local maygc bool clear_input_buffered (object stream) {
6770 var bool ret = BufferedStream_have_eof_p(stream);
6771 BufferedStream_have_eof_p(stream) = false;
6772 return ret;
6773 }
6774
6775 /* READ-CHAR-ARRAY - Pseudo-Function for File-Streams of Characters: */
rd_ch_array_buffered(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)6776 local maygc uintL rd_ch_array_buffered (const gcv_object_t* stream_,
6777 const gcv_object_t* chararray_,
6778 uintL start, uintL len) {
6779 var object stream = *stream_;
6780 #ifdef ENABLE_UNICODE
6781 #define tmpbufsize 4096
6782 var uintL end = start+len;
6783 var uintL currindex = start;
6784 var object encoding = TheStream(stream)->strm_encoding;
6785 pushSTACK(encoding);
6786 while (1) {
6787 var uintL startindex = currindex;
6788 var uintB* bufferptr = buffered_nextbyte(stream,persev_partial);
6789 stream = *stream_; /* restore */
6790 encoding = STACK_0;
6791 if (bufferptr == (uintB*)NULL) /* EOF -> finished */
6792 break;
6793 { /* Read as many complete characters from the buffer as possible. */
6794 var uintL endvalid = BufferedStream_endvalid(stream);
6795 var uintL available = endvalid - BufferedStream_index(stream);
6796 var const uintB* bptr = bufferptr;
6797 var chart tmpbuf[tmpbufsize];
6798 var chart* cptr = &tmpbuf[0];
6799 Encoding_mbstowcs(encoding)
6800 (encoding,stream,&bptr,bufferptr+available,&cptr,
6801 &tmpbuf[end-currindex < tmpbufsize ? end-currindex : tmpbufsize]);
6802 if (!(cptr == &tmpbuf[0])) {
6803 var uintL n = bptr-bufferptr;
6804 /* increment index and position */
6805 BufferedStream_index(stream) += n;
6806 BufferedStream_position(stream) += n;
6807 /* store the read characters */
6808 sstring_store_array(*chararray_,currindex,tmpbuf,cptr-&tmpbuf[0]);
6809 currindex += cptr-&tmpbuf[0];
6810 stream = *stream_;
6811 encoding = STACK_0;
6812 } else {
6813 var uintB buf[max_bytes_per_chart];
6814 var uintL buflen = 0;
6815 while (1) {
6816 ASSERT(buflen < max_bytes_per_chart);
6817 buf[buflen++] = *bufferptr;
6818 /* increment index and position */
6819 BufferedStream_index(stream) += 1;
6820 BufferedStream_position(stream) += 1;
6821 var const uintB* bptr = &buf[0];
6822 var chart* cptr = &tmpbuf[0];
6823 Encoding_mbstowcs(encoding)(encoding,stream,&bptr,&buf[buflen],&cptr,cptr+1);
6824 if (cptr == &tmpbuf[0]) { /* Not a complete character. */
6825 /* Shift the buffer */
6826 if (!(bptr == &buf[0])) {
6827 var const uintB* ptr1 = bptr;
6828 var uintB* ptr2 = &buf[0];
6829 while (ptr1 != &buf[buflen]) { *ptr2++ = *ptr1++; }
6830 buflen = ptr2 - &buf[0];
6831 }
6832 } else { /* Read a complete character. */
6833 if (!(bptr == &buf[buflen])) {
6834 /* At most one lookahead byte. Make it unread. */
6835 ASSERT(bptr == &buf[buflen-1]);
6836 /* decrement index and position again: */
6837 BufferedStream_index(stream) -= 1;
6838 BufferedStream_position(stream) -= 1;
6839 }
6840 /* store the read character */
6841 sstring_store(*chararray_,currindex++,tmpbuf[0]);
6842 stream = *stream_;
6843 break;
6844 }
6845 bufferptr = buffered_nextbyte(stream,persev_partial);
6846 stream = *stream_;
6847 encoding = STACK_0;
6848 if (bufferptr == (uintB*)NULL) /* EOF -> finished */
6849 break;
6850 }
6851 if (currindex == startindex) /* EOF -> finished */
6852 break;
6853 }
6854 }
6855
6856 /* Now apply CR/LF->NL and CR->NL conversion to the characters
6857 [startindex..currindex). */
6858 {
6859 var object chararray = *chararray_;
6860 sstring_un_realloc(chararray);
6861 SstringDispatch(chararray,X, {
6862 var cintX* startptr = &((SstringX)TheVarobject(chararray))->data[startindex];
6863 var cintX* currptr = &((SstringX)TheVarobject(chararray))->data[currindex];
6864 var const cintX* ptr1 = startptr;
6865 var cintX* ptr2 = startptr;
6866 do {
6867 var cintX c = *ptr1++;
6868 if (chareq(as_chart(c),ascii(NL))) {
6869 if (ChannelStream_ignore_next_LF(stream)) {
6870 ChannelStream_ignore_next_LF(stream) = false;
6871 if (ptr1 == currptr) break; else continue;
6872 }
6873 ChannelStream_lineno(stream) += 1;
6874 } else if (chareq(as_chart(c),ascii(CR))) {
6875 /* check next character for LF */
6876 if (ptr1 == currptr) {
6877 /* cannot check in this buffer; mark for next. */
6878 ChannelStream_ignore_next_LF(stream) = true;
6879 } else {
6880 if (chareq(as_chart(*ptr1),ascii(LF)))
6881 ptr1++;
6882 }
6883 c = NL;
6884 ChannelStream_lineno(stream) += 1;
6885 }
6886 *ptr2++ = c;
6887 } while (ptr1 != currptr);
6888 currindex = ptr2 - &((SstringX)TheVarobject(chararray))->data[0];
6889 });
6890 }
6891 if (currindex == end)
6892 break;
6893 }
6894 skipSTACK(1); /* encoding */
6895 return currindex - start;
6896 #else
6897 var chart* startptr = &TheSnstring(*chararray_)->data[start];
6898 var chart* charptr = startptr;
6899 do {
6900 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
6901 if (ptr == (uintB*)NULL) /* EOF -> finished */
6902 break;
6903 stream = *stream_;
6904 var chart ch = as_chart(*ptr);
6905 /* increment index and position */
6906 BufferedStream_index(stream) += 1;
6907 BufferedStream_position(stream) += 1;
6908 if (chareq(ch,ascii(NL))) {
6909 ChannelStream_lineno(stream) += 1;
6910 } else if (chareq(ch,ascii(CR))) {
6911 /* check next character for LF */
6912 ptr = buffered_nextbyte(stream,persev_partial);
6913 stream = *stream_;
6914 if (!(ptr == (uintB*)NULL) && chareq(as_chart(*ptr),ascii(LF))) {
6915 /* increment index and position */
6916 BufferedStream_index(stream) += 1;
6917 BufferedStream_position(stream) += 1;
6918 }
6919 ch = ascii(NL);
6920 ChannelStream_lineno(stream) += 1;
6921 }
6922 *charptr++ = ch; len--;
6923 } while (len > 0);
6924 return charptr - startptr;
6925 #endif
6926 }
6927
6928 /* Output side
6929 -----------
6930
6931 UP: Writes a Byte to a Byte-based File-Stream.
6932 write_byte_buffered(stream,b);
6933 > stream : (open) Byte-based File-Stream.
6934 > b : Byte to be written
6935 changed in stream: index, endvalid, buffstart, position */
write_byte_buffered(object stream,uintB b)6936 local maygc void write_byte_buffered (object stream, uintB b) {
6937 pushSTACK(stream);
6938 buffered_writebyte(stream,b);
6939 stream = popSTACK();
6940 /* increment position */
6941 BufferedStream_position(stream) += 1;
6942 }
6943
6944 /* WRITE-CHAR - Pseudo-Function for File-Streams of Characters */
wr_ch_buffered_unix(const gcv_object_t * stream_,object obj)6945 local maygc void wr_ch_buffered_unix (const gcv_object_t* stream_, object obj) {
6946 var object stream = *stream_;
6947 check_wr_char(stream,obj);
6948 var chart c = char_code(obj);
6949 #ifdef ENABLE_UNICODE
6950 var uintB buf[max_bytes_per_chart];
6951 var object encoding = TheStream(stream)->strm_encoding;
6952 var const chart* cptr = &c;
6953 var uintB* bptr = &buf[0];
6954 Encoding_wcstombs(encoding)(encoding,stream,&cptr,cptr+1,&bptr,
6955 &buf[max_bytes_per_chart]);
6956 ASSERT(cptr == &c+1);
6957 var uintL buflen = bptr-&buf[0];
6958 if (buflen > 0) {
6959 write_byte_array_buffered(stream,&buf[0],buflen,persev_full);
6960 stream = *stream_;
6961 /* increment position */
6962 BufferedStream_position(stream) += buflen;
6963 }
6964 #else
6965 write_byte_buffered(stream,as_cint(c)); /* write unchanged */
6966 #endif
6967 }
6968
6969 /* WRITE-CHAR-ARRAY - Pseudo-Function for File-Streams of Characters: */
wr_ch_array_buffered_unix(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)6970 local maygc void wr_ch_array_buffered_unix (const gcv_object_t* stream_,
6971 const gcv_object_t* chararray_,
6972 uintL start, uintL len) {
6973 var object stream = *stream_;
6974 var const chart* charptr;
6975 unpack_sstring_alloca(*chararray_,len,start, charptr=);
6976 var const chart* endptr = charptr + len;
6977 pin_unprotect_varobject(*chararray_,PROT_READ);
6978 #ifdef ENABLE_UNICODE
6979 #define tmpbufsize 4096
6980 var uintB tmptmpbuf[tmpbufsize*max_bytes_per_chart];
6981 do {
6982 var uintB* bptr = &tmptmpbuf[0];
6983 var object encoding = TheStream(stream)->strm_encoding;
6984 Encoding_wcstombs(encoding)(encoding,stream,&charptr,endptr,&bptr,
6985 &tmptmpbuf[tmpbufsize*max_bytes_per_chart]);
6986 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
6987 if (tmptmpbuflen > 0) {
6988 write_byte_array_buffered(stream,&tmptmpbuf[0],tmptmpbuflen,persev_full);
6989 stream=*stream_;
6990 /* increment position */
6991 BufferedStream_position(stream) += tmptmpbuflen;
6992 }
6993 } while (charptr != endptr);
6994 #undef tmpbufsize
6995 #else
6996 write_byte_array_buffered(stream,(const uintB*)charptr,len,persev_full);
6997 stream=*stream_;
6998 /* increment position */
6999 BufferedStream_position(stream) += len;
7000 #endif
7001 unpin_varobject(*chararray_);
7002 wr_ss_lpos(stream,endptr,len); /* update Line-Position */
7003 }
7004
7005 /* WRITE-CHAR - Pseudo-Function for File-Streams of Characters */
wr_ch_buffered_mac(const gcv_object_t * stream_,object obj)7006 local maygc void wr_ch_buffered_mac (const gcv_object_t* stream_, object obj) {
7007 var object stream = *stream_;
7008 check_wr_char(stream,obj);
7009 var chart c = char_code(obj);
7010 if (chareq(c,ascii(NL)))
7011 c = ascii(CR);
7012 #ifdef ENABLE_UNICODE
7013 var uintB buf[max_bytes_per_chart];
7014 var object encoding = TheStream(stream)->strm_encoding;
7015 var const chart* cptr = &c;
7016 var uintB* bptr = &buf[0];
7017 Encoding_wcstombs(encoding)(encoding,stream,&cptr,cptr+1,&bptr,&buf[max_bytes_per_chart]);
7018 ASSERT(cptr == &c+1);
7019 var uintL buflen = bptr-&buf[0];
7020 if (buflen > 0) {
7021 write_byte_array_buffered(stream,&buf[0],buflen,persev_full);
7022 /* increment position */
7023 BufferedStream_position(*stream_) += buflen;
7024 }
7025 #else
7026 write_byte_buffered(stream,as_cint(c));
7027 #endif
7028 }
7029
7030 /* WRITE-CHAR-ARRAY - Pseudo-Function for File-Streams of Characters: */
wr_ch_array_buffered_mac(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)7031 local maygc void wr_ch_array_buffered_mac (const gcv_object_t* stream_,
7032 const gcv_object_t* chararray_,
7033 uintL start, uintL len) {
7034 var object stream = *stream_;
7035 var const chart* charptr;
7036 unpack_sstring_alloca(*chararray_,len,start, charptr=);
7037 pin_unprotect_varobject(*chararray_,PROT_READ);
7038 #ifdef ENABLE_UNICODE
7039 /* Need a temporary buffer for NL->CR translation. */
7040 #define tmpbufsize 4096
7041 var chart tmpbuf[tmpbufsize];
7042 var uintB tmptmpbuf[tmpbufsize*max_bytes_per_chart];
7043 var uintL remaining = len;
7044 do {
7045 var uintL n = remaining;
7046 if (n > tmpbufsize)
7047 n = tmpbufsize;
7048 {
7049 var chart* tmpptr = &tmpbuf[0];
7050 var uintL count;
7051 dotimespL(count,n, {
7052 var chart c = *charptr++;
7053 if (chareq(c,ascii(NL)))
7054 c = ascii(CR);
7055 *tmpptr++ = c;
7056 });
7057 var const chart* cptr = tmpbuf;
7058 var uintB* bptr = &tmptmpbuf[0];
7059 var object encoding = TheStream(stream)->strm_encoding;
7060 Encoding_wcstombs(encoding)(encoding,stream,&cptr,tmpptr,&bptr,
7061 &tmptmpbuf[tmpbufsize*max_bytes_per_chart]);
7062 ASSERT(cptr == tmpptr);
7063 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
7064 if (tmptmpbuflen > 0) {
7065 write_byte_array_buffered(stream,&tmptmpbuf[0],tmptmpbuflen,persev_full);
7066 stream = *stream_;
7067 /* increment position */
7068 BufferedStream_position(stream) += tmptmpbuflen;
7069 }
7070 }
7071 remaining -= n;
7072 } while (remaining > 0);
7073 #undef tmpbufsize
7074 #else
7075 var uintL remaining = len;
7076 do {
7077 var chart c = *charptr++;
7078 if (chareq(c,ascii(NL)))
7079 c = ascii(CR);
7080 write_byte_buffered(*stream_,as_cint(c));
7081 remaining--;
7082 } while (remaining != 0);
7083 #endif
7084 unpin_varobject(*chararray_);
7085 wr_ss_lpos(*stream_,charptr,len); /* update Line-Position */
7086 }
7087
7088 /* WRITE-CHAR - Pseudo-Function for File-Streams of Characters */
wr_ch_buffered_dos(const gcv_object_t * stream_,object obj)7089 local maygc void wr_ch_buffered_dos (const gcv_object_t* stream_, object obj) {
7090 var object stream = *stream_;
7091 check_wr_char(stream,obj);
7092 var chart c = char_code(obj);
7093 #ifdef ENABLE_UNICODE
7094 static chart const crlf[2] = { ascii(CR), ascii(LF) };
7095 var uintB buf[2*max_bytes_per_chart];
7096 var object encoding = TheStream(stream)->strm_encoding;
7097 var const chart* cp;
7098 var uintL n;
7099 if (chareq(c,ascii(NL))) {
7100 cp = crlf; n = 2;
7101 } else {
7102 cp = &c; n = 1;
7103 }
7104 var const chart* cptr = cp;
7105 var uintB* bptr = &buf[0];
7106 Encoding_wcstombs(encoding)(encoding,stream,&cptr,cp+n,&bptr,
7107 &buf[2*max_bytes_per_chart]);
7108 ASSERT(cptr == cp+n);
7109 var uintL buflen = bptr-&buf[0];
7110 if (buflen > 0) {
7111 write_byte_array_buffered(stream,&buf[0],buflen,persev_full);
7112 /* increment position */
7113 BufferedStream_position(*stream_) += buflen;
7114 }
7115 #else
7116 if (chareq(c,ascii(NL))) {
7117 write_byte_buffered(stream,CR); write_byte_buffered(*stream_,LF);
7118 } else {
7119 write_byte_buffered(stream,as_cint(c));
7120 }
7121 #endif
7122 }
7123
7124 /* WRITE-CHAR-ARRAY - Pseudo-Function for File-Streams of Characters: */
wr_ch_array_buffered_dos(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)7125 local maygc void wr_ch_array_buffered_dos (const gcv_object_t* stream_,
7126 const gcv_object_t* chararray_,
7127 uintL start, uintL len) {
7128 var object stream = *stream_;
7129 var const chart* charptr;
7130 unpack_sstring_alloca(*chararray_,len,start, charptr=);
7131 pin_unprotect_varobject(*chararray_,PROT_READ);
7132 #ifdef ENABLE_UNICODE
7133 /* Need a temporary buffer for NL->CR translation. */
7134 #define tmpbufsize 4096
7135 var chart tmpbuf[2*tmpbufsize];
7136 var uintB tmptmpbuf[2*tmpbufsize*max_bytes_per_chart];
7137 var uintL remaining = len;
7138 do {
7139 var uintL n = remaining;
7140 if (n > tmpbufsize)
7141 n = tmpbufsize;
7142 {
7143 var chart* tmpptr = &tmpbuf[0];
7144 var uintL count;
7145 dotimespL(count,n, {
7146 var chart c = *charptr++;
7147 if (chareq(c,ascii(NL))) {
7148 *tmpptr++ = ascii(CR); *tmpptr++ = ascii(LF);
7149 } else {
7150 *tmpptr++ = c;
7151 }
7152 });
7153 var const chart* cptr = tmpbuf;
7154 var uintB* bptr = &tmptmpbuf[0];
7155 var object encoding = TheStream(stream)->strm_encoding;
7156 Encoding_wcstombs(encoding)(encoding,stream,&cptr,tmpptr,&bptr,&tmptmpbuf[2*tmpbufsize*max_bytes_per_chart]);
7157 ASSERT(cptr == tmpptr);
7158 var uintL tmptmpbuflen = bptr-&tmptmpbuf[0];
7159 if (tmptmpbuflen > 0) {
7160 write_byte_array_buffered(stream,&tmptmpbuf[0],tmptmpbuflen,persev_full);
7161 stream = *stream_;
7162 /* increment position */
7163 BufferedStream_position(stream) += tmptmpbuflen;
7164 }
7165 }
7166 remaining -= n;
7167 } while (remaining > 0);
7168 #undef tmpbufsize
7169 #else
7170 var uintL remaining = len;
7171 do {
7172 var chart c = *charptr++;
7173 if (chareq(c,ascii(NL))) {
7174 write_byte_buffered(stream,CR); write_byte_buffered(*stream_,LF);
7175 } else {
7176 write_byte_buffered(stream,as_cint(c));
7177 }
7178 stream = *stream_;
7179 remaining--;
7180 } while (remaining != 0);
7181 #endif
7182 unpin_varobject(*chararray_);
7183 wr_ss_lpos(stream,charptr,len); /* update Line-Position */
7184 }
7185
7186 /* Macro: Emits a shift sequence to let the output conversion descriptor of an
7187 Buffered-Channel-Stream return to the initial state.
7188 oconv_unshift_output_buffered(stream);
7189 > stream: Buffered-Channel-Stream */
7190 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
7191 #define oconv_unshift_output_buffered(stream,abort) \
7192 ((ChannelStream_oconvdesc(stream) != (iconv_t)0) \
7193 ? oconv_unshift_output_buffered_(stream,abort) : 0)
oconv_unshift_output_buffered_(object stream,uintB abort)7194 local maygc uintB oconv_unshift_output_buffered_ (object stream, uintB abort) {
7195 #define tmpbufsize 4096
7196 var uintB tmpbuf[tmpbufsize];
7197 var char* outptr = (char*)tmpbuf;
7198 var size_t outsize = tmpbufsize;
7199 begin_system_call();
7200 var size_t res =
7201 iconv(ChannelStream_oconvdesc(stream),NULL,NULL,&outptr,&outsize);
7202 if (res == (size_t)(-1)) {
7203 if (abort) return 1;
7204 /* BUG: On Windows, after iconv(), we must use errno, not GetLastError(). */
7205 if (OS_errno == E2BIG) { /* output buffer too small? */
7206 NOTREACHED;
7207 } else {
7208 OS_error();
7209 }
7210 }
7211 end_system_call();
7212 var uintL outcount = outptr-(char*)tmpbuf;
7213 if (outcount > 0) {
7214 pushSTACK(stream);
7215 write_byte_array_buffered(stream,&tmpbuf[0],outcount,persev_full);
7216 stream = popSTACK();
7217 /* increment position */
7218 BufferedStream_position(stream) += outcount;
7219 }
7220 return 0;
7221 #undef tmpbufsize
7222 }
7223 #else
7224 #define oconv_unshift_output_buffered(stream,abort) 0
7225 #endif
7226
7227 /* File-Stream, Bit-based
7228 ========================
7229
7230 There are 6 types, altogether:
7231 Three Cases
7232 a - bitsize divisible by 8,
7233 b - bitsize < 8,
7234 c - bitsize not divisible by 8 and >= 8,
7235 distinguished by
7236 s - Element-Type (signed-byte bitsize),
7237 including signed-byte = (signed-byte 8)
7238 u - Element-Type (unsigned-byte bitsize),
7239 including unsigned-byte = (unsigned-byte 8)
7240 and bit = (unsigned-byte 1)
7241 and (mod n) = (unsigned-byte (integer-length n))
7242
7243 UP: Positions an (open) Bit-based File-Stream to a
7244 specified Position.
7245 position_file_i_buffered(stream,position);
7246 > stream : (open) Byte-based File-Stream.
7247 > position : new (logical) Position
7248 changed in stream: index, endvalid, buffstart, bitindex */
position_file_i_buffered(object stream,uoff_t position)7249 local maygc void position_file_i_buffered (object stream, uoff_t position) {
7250 var uintL bitsize = ChannelStream_bitsize(stream);
7251 var uoff_t position_bits = position * bitsize;
7252 pushSTACK(stream);
7253 if (bitsize < 8)
7254 position_bits += sizeof(uintL)*8; /* consider Header */
7255 /* position at Bit Number position_bits. */
7256 position_file_buffered(stream,floor(position_bits,8)); /* position to the Byte */
7257 stream = STACK_0;
7258 if ((bitsize % 8) == 0) /* For Type a that's all. */
7259 return;
7260 if (/* Is the addressed position situated in the first byte after EOF ? */
7261 ((!((position_bits%8)==0))
7262 && (buffered_nextbyte(stream,persev_partial) == (uintB*)NULL))
7263 /* Is the addressed position situated in the last byte too far? */
7264 || ((bitsize < 8)
7265 && (position > BufferedStream_eofposition(STACK_0/*stream*/)))) {
7266 /* Error. But first position back to the old Position: */
7267 stream = popSTACK();
7268 var uoff_t oldposition = BufferedStream_position(stream);
7269 check_SP();
7270 position_file_i_buffered(stream,oldposition); /* positioning back */
7271 error_position_beyond_EOF(stream);
7272 }
7273 stream = popSTACK();
7274 BufferedStream_bitindex(stream) = position_bits%8;
7275 }
7276
7277 /* Input side
7278 ----------
7279
7280 UP for READ-BYTE on File-Streams of Integers, Type a :
7281 Fills the Bitbuffer with the next bitsize Bits.
7282 > stream : File-Stream of Integers, Type a
7283 > finisher : Routine for Finalization
7284 < result : read Integer or eof_value */
rd_by_aux_iax_buffered(object stream,rd_by_ix_I * finisher)7285 local object rd_by_aux_iax_buffered (object stream, rd_by_ix_I* finisher) {
7286 var uintL bitsize = ChannelStream_bitsize(stream);
7287 var uintL bytesize = bitsize/8;
7288 /* transfer sufficiently many bytes into the bitbuffer */
7289 var uintB* bitbufferptr =
7290 &TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0];
7291 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ_WRITE);
7292 pushSTACK(stream);
7293 #if 0 /* equivalent, but slower */
7294 var uintL count;
7295 dotimespL(count,bytesize, {
7296 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7297 if (ptr == (uintB*)NULL)
7298 goto eof;
7299 stream = STACK_0;
7300 /* fetch next Byte: */
7301 *bitbufferptr++ = *ptr;
7302 /* increment index */
7303 BufferedStream_index(stream) += 1;
7304 });
7305 #else
7306 if (read_byte_array_buffered(stream,bitbufferptr,bytesize,persev_full)
7307 != bitbufferptr+bytesize)
7308 goto eof;
7309 #endif
7310 stream = popSTACK();
7311 unpin_varobject(TheStream(stream)->strm_bitbuffer);
7312 /* increment position */
7313 BufferedStream_position(stream) += 1;
7314 /* convert to number: */
7315 return (*finisher)(stream,bitsize,bytesize);
7316 eof: /* EOF reached */
7317 stream = popSTACK();
7318 unpin_varobject(TheStream(stream)->strm_bitbuffer);
7319 position_file_buffered(stream,BufferedStream_position(stream)*bytesize);
7320 return eof_value;
7321 }
7322
7323 /* UP for READ-BYTE on File-Streams of Integers, Type b :
7324 Fills the Bitbuffer with the next bitsize Bits.
7325 > stream : File-Stream of Integers, Type b
7326 > finisher : Routine for Finalization
7327 < result : read Integer or eof_value */
rd_by_aux_ibx_buffered(object stream,rd_by_ix_I * finisher)7328 local maygc object rd_by_aux_ibx_buffered(object stream, rd_by_ix_I* finisher) {
7329 /* Only for position < eofposition there's something to read: */
7330 if (BufferedStream_position(stream) == BufferedStream_eofposition(stream))
7331 goto eof;
7332 pushSTACK(stream);
7333 {
7334 var uintL bitsize = ChannelStream_bitsize(stream); /* bitsize (>0, <8) */
7335 /* transfer sufficient many bits into the bitbuffer */
7336 var uintL bitindex = BufferedStream_bitindex(stream);
7337 var uintL count = bitindex + bitsize;
7338 var uint8 bit_akku;
7339 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7340 if (ptr == (uintB*)NULL)
7341 goto eof;
7342 stream = STACK_0;
7343 /* Get first partial byte: */
7344 bit_akku = (*ptr)>>bitindex;
7345 /* bitshift := 8-bitindex
7346 For bit_akku the Bits (bitshift-1)..0 are valid. */
7347 if (count > 8) {
7348 /* increment index, because *ptr is processed: */
7349 BufferedStream_index(stream) += 1;
7350 count -= 8; /* still count (>0) Bits to fetch. */
7351 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7352 stream = STACK_0;
7353 if (ptr == (uintB*)NULL)
7354 goto eof1;
7355 /* fetch next Byte:
7356 (8-bitindex < 8, because else count = 0+bitsize < 8 !) */
7357 bit_akku |= (*ptr)<<(8-bitindex);
7358 }
7359 /* For bit_akku all 8 Bits are valid.
7360 save 8 Bits: */
7361 TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0] = bit_akku;
7362 BufferedStream_bitindex(stream) = count;
7363 /* increment position */
7364 BufferedStream_position(stream) += 1;
7365 skipSTACK(1);
7366 /* convert to number: */
7367 return (*finisher)(stream,bitsize,1);
7368 eof1:
7369 /* position back again: */
7370 position_file_i_buffered(stream,BufferedStream_position(stream));
7371 }
7372 eof: /* EOF was reached */
7373 skipSTACK(1);
7374 return eof_value;
7375 }
7376
7377 /* UP for READ-BYTE on File-Streams of Integers, Type c :
7378 Fills the Bitbuffer with the next bitsize Bits.
7379 > stream : File-Stream of Integers, Type c
7380 > finisher : Routine for Finalization
7381 < result : read Integer or eof_value */
rd_by_aux_icx_buffered(object stream,rd_by_ix_I * finisher)7382 local maygc object rd_by_aux_icx_buffered (object stream,
7383 rd_by_ix_I* finisher) {
7384 var uintL bitsize = ChannelStream_bitsize(stream);
7385 var uintL bytesize = ceiling(bitsize,8);
7386 /* transfer sufficiently many bits into the bitbuffer */
7387 var uintB* bitbufferptr =
7388 &TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0];
7389 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ_WRITE);
7390 pushSTACK(stream);
7391 var uintL count = bitsize;
7392 var uintL bitshift = BufferedStream_bitindex(stream);
7393 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7394 stream = STACK_0;
7395 if (ptr != (uintB*)NULL) {
7396 if (bitshift==0) {
7397 /* Optimized loop, without shifting. */
7398 while (1) {
7399 *bitbufferptr++ = *ptr; /* store 8 bits */
7400 /* After digesting *ptr, increment index: */
7401 BufferedStream_index(stream) += 1;
7402 count -= 8;
7403 /* have to get count (>0) bits. */
7404 ptr = buffered_nextbyte(stream,persev_partial);
7405 stream = STACK_0;
7406 if (ptr == (uintB*)NULL)
7407 goto eof;
7408 if (count<=8) /* are count bits finished? */
7409 break;
7410 }
7411 /* Still need count = bitsize%8 (>0,<8) bits. */
7412 *bitbufferptr++ = *ptr; /* store 8 bits */
7413 } else {
7414 /* start getting bytes: */
7415 var uint16 bit_akku = (*ptr)>>bitshift;
7416 bitshift = 8-bitshift; /* bitshift := 8-bitindex (>0, <8) */
7417 count -= bitshift;
7418 while (1) {
7419 BufferedStream_index(stream) += 1;
7420 /* bit_akku: bits (bitshift-1)..0 are valid.
7421 have to get count (>0) bits. */
7422 {
7423 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7424 stream = STACK_0;
7425 if (ptr == (uintB*)NULL)
7426 goto eof;
7427 /* get next byte: */
7428 bit_akku |= (uint16)(*ptr)<<bitshift;
7429 }
7430 /* bit_akku: bits (7+bitshift)..0 are valid. */
7431 *bitbufferptr++ = (uint8)bit_akku; /* store 8 bits */
7432 bit_akku >>= 8;
7433 if (count<=8) /* are count bits finished? */
7434 break;
7435 count -= 8;
7436 }
7437 if (count == 8) {
7438 count = 0;
7439 BufferedStream_index(stream) += 1;
7440 }
7441 if ((bitsize%8) <= bitshift)
7442 *bitbufferptr++ = (uint8)bit_akku; /* store bitshift bits */
7443 /* Now bitbufferptr has been incremented
7444 ceiling(bitsize-bitshift,8) + ((bitsize%8) <= bitshift ? 1 : 0)
7445 = ceiling(bitsize,8) = bytesize
7446 times. */
7447 }
7448 skipSTACK(1);
7449 unpin_varobject(TheStream(stream)->strm_bitbuffer);
7450 ASSERT(bitbufferptr == &TheSbvector(TheStream(stream)->strm_bitbuffer)->data[bytesize]);
7451 BufferedStream_bitindex(stream) = count;
7452 BufferedStream_position(stream) += 1; /* increment position */
7453 return (*finisher)(stream,bitsize,bytesize); /* convert to a number */
7454 }
7455 eof:
7456 unpin_varobject(TheStream(stream)->strm_bitbuffer);
7457 position_file_i_buffered(stream,BufferedStream_position(stream));
7458 return eof_value;
7459 }
7460
7461 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type au : */
rd_by_iau_buffered(object stream)7462 local maygc object rd_by_iau_buffered (object stream) {
7463 return rd_by_aux_iax_buffered(stream,&rd_by_iu_I);
7464 }
7465
7466 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type as : */
rd_by_ias_buffered(object stream)7467 local maygc object rd_by_ias_buffered (object stream) {
7468 return rd_by_aux_iax_buffered(stream,&rd_by_is_I);
7469 }
7470
7471 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type bu : */
rd_by_ibu_buffered(object stream)7472 local maygc object rd_by_ibu_buffered (object stream) {
7473 return rd_by_aux_ibx_buffered(stream,&rd_by_iu_I);
7474 }
7475
7476 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type bs : */
rd_by_ibs_buffered(object stream)7477 local maygc object rd_by_ibs_buffered (object stream) {
7478 return rd_by_aux_ibx_buffered(stream,&rd_by_is_I);
7479 }
7480
7481 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type cu : */
rd_by_icu_buffered(object stream)7482 local maygc object rd_by_icu_buffered (object stream) {
7483 return rd_by_aux_icx_buffered(stream,&rd_by_iu_I);
7484 }
7485
7486 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type cs : */
rd_by_ics_buffered(object stream)7487 local maygc object rd_by_ics_buffered (object stream) {
7488 return rd_by_aux_icx_buffered(stream,&rd_by_is_I);
7489 }
7490
7491 /* READ-BYTE - Pseudo-Function for File-Streams of Integers, Type au, bitsize = 8 : */
rd_by_iau8_buffered(object stream)7492 local maygc object rd_by_iau8_buffered (object stream) {
7493 pushSTACK(stream);
7494 rd_by_iau8_buffered_retry:
7495 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7496 stream = STACK_0;
7497 if (!(ptr == (uintB*)NULL)) {
7498 BufferedStream_index(stream) += 1;
7499 if (*ptr == LF && ChannelStream_ignore_next_LF(stream)) {
7500 /* see comment in rd_by_array_iau8_unbuffered */
7501 ChannelStream_ignore_next_LF(stream) = false;
7502 goto rd_by_iau8_buffered_retry;
7503 }
7504 skipSTACK(1);
7505 var object obj = fixnum(*ptr);
7506 BufferedStream_position(stream) += 1;
7507 return obj;
7508 } else {
7509 skipSTACK(1);
7510 return eof_value;
7511 }
7512 }
7513
7514 /* READ-BYTE-SEQUENCE for File-Streams of Integers, Type au, bitsize = 8 : */
rd_by_array_iau8_buffered(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)7515 local maygc uintL rd_by_array_iau8_buffered
7516 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
7517 uintL start, uintL len, perseverance_t persev) {
7518 pin_unprotect_varobject(*bytearray_,PROT_READ_WRITE);
7519 var uintB* startptr = &TheSbvector(*bytearray_)->data[start];
7520 var uintB* endptr = read_byte_array_buffered(*stream_,startptr,len,persev);
7521 var uintL result = endptr-startptr;
7522 if (result && *startptr == LF && ChannelStream_ignore_next_LF(*stream_)) {
7523 /* see comment in rd_by_array_iau8_unbuffered */
7524 var uintL count = --result;
7525 for (; count--; startptr++) startptr[0] = startptr[1];
7526 ChannelStream_ignore_next_LF(*stream_) = false;
7527 endptr = read_byte_array_buffered(*stream_,startptr,1,persev);
7528 result += endptr - startptr; /* 0 or 1 */
7529 }
7530 unpin_varobject(*bytearray_);
7531 /* increment position: */
7532 BufferedStream_position(*stream_) += result;
7533 return result;
7534 }
7535
7536 /* Determines, if a Byte is available on a File-Stream.
7537 listen_byte_ia8_buffered(stream)
7538 > stream: File-Stream of Integers, Type a, bitsize = 8
7539 < result: input availability
7540 can trigger GC */
listen_byte_ia8_buffered(object stream)7541 local maygc listen_t listen_byte_ia8_buffered (object stream) {
7542 var uintB* buf = buffered_nextbyte(stream,persev_immediate);
7543 if (buf == (uintB*)NULL) return LISTEN_EOF; /* EOF */
7544 if (buf == (uintB*)-1) return LISTEN_WAIT; /* will hang */
7545 return LISTEN_AVAIL;
7546 }
7547
7548 /* Output side
7549 -----------
7550
7551 UP for WRITE-BYTE on File-Streams of Integers, Type a :
7552 Writes the Bitbuffer-Content to the File. */
wr_by_aux_ia_buffered(object stream,uintL bitsize,uintL bytesize)7553 local maygc void wr_by_aux_ia_buffered (object stream, uintL bitsize,
7554 uintL bytesize)
7555 {
7556 unused(bitsize);
7557 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ);
7558 pushSTACK(stream);
7559 var uintB* bitbufferptr = &TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0];
7560 #if 0 /* equivalent, but slow */
7561 var uintL count;
7562 dotimespL(count,bytesize, {
7563 buffered_writebyte(stream,*bitbufferptr++);
7564 stream = STACK_0;
7565 });
7566 skipSTACK(0);
7567 #else
7568 write_byte_array_buffered(stream,bitbufferptr,bytesize,persev_full);
7569 stream = popSTACK();
7570 #endif
7571 /* increment position: */
7572 BufferedStream_position(stream) += 1;
7573 unpin_varobject(TheStream(stream)->strm_bitbuffer);
7574 }
7575
7576 /* write last byte (count bits): */
7577 #define WRITE_LAST_BYTE \
7578 if (count!=0) { \
7579 ptr = buffered_nextbyte(stream,persev_partial); \
7580 stream = STACK_0; \
7581 if (ptr == (uintB*)NULL) { /* EOF */ \
7582 ptr = buffered_eofbyte(stream); /* 1 Byte */ \
7583 stream = STACK_0; \
7584 *ptr = (uint8)bit_akku; /* write byte */ \
7585 } else { /* overwrite the last byte only partially: */ \
7586 var uint8 diff = (*ptr ^ (uint8)bit_akku) & (uint8)(bit(count)-1); \
7587 if (diff == 0) \
7588 goto no_modification; \
7589 *ptr ^= diff; \
7590 } \
7591 BufferedStream_modified(stream) = true; \
7592 no_modification: ; \
7593 }
7594
7595 /* UP for WRITE-BYTE on File-Streams of Integers, Type b :
7596 Writes the Bitbuffer-Content to the File. */
wr_by_aux_ib_buffered(object stream,uintL bitsize,uintL bytesize)7597 local maygc void wr_by_aux_ib_buffered (object stream, uintL bitsize,
7598 uintL bytesize)
7599 {
7600 unused(bytesize);
7601 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ);
7602 pushSTACK(stream);
7603 var uintL bitshift = BufferedStream_bitindex(stream);
7604 var uint16 bit_akku = (uint16)(TheSbvector(TheStream(stream)->strm_bitbuffer)->data[0])<<bitshift;
7605 var uintL count = bitsize;
7606 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7607 stream = STACK_0;
7608 /* start getting bytes: */
7609 if (!(ptr == (uintB*)NULL))
7610 bit_akku |= (*ptr)&(bit(bitshift)-1);
7611 count += bitshift;
7612 /* poss. write single Byte: */
7613 if (count>=8) {
7614 buffered_writebyte(stream,(uint8)bit_akku);
7615 stream = STACK_0;
7616 bit_akku = bit_akku>>8;
7617 count -= 8;
7618 }
7619 WRITE_LAST_BYTE;
7620 BufferedStream_bitindex(stream) = count;
7621 /* increment position and poss. eofposition: */
7622 if (BufferedStream_eofposition(stream) == BufferedStream_position(stream))
7623 BufferedStream_eofposition(stream) += 1;
7624 BufferedStream_position(stream) += 1;
7625 skipSTACK(1); unpin_varobject(TheStream(stream)->strm_bitbuffer);
7626 }
7627
7628 /* UP for WRITE-BYTE on File-Streams of Integers, Type c :
7629 Writes the Bitbuffer-Content to the File. */
wr_by_aux_ic_buffered(object stream,uintL bitsize,uintL bytesize)7630 local maygc void wr_by_aux_ic_buffered (object stream, uintL bitsize,
7631 uintL bytesize) {
7632 unused(bytesize);
7633 pin_unprotect_varobject(TheStream(stream)->strm_bitbuffer,PROT_READ);
7634 pushSTACK(stream);
7635 var uintB* bitbufferptr=TheSbvector(TheStream(stream)->strm_bitbuffer)->data;
7636 var uintL bitshift = BufferedStream_bitindex(stream);
7637 var uintL count = bitsize;
7638 var uint16 bit_akku;
7639 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
7640 stream = STACK_0;
7641 /* start getting bytes: */
7642 bit_akku = (ptr==(uintB*)NULL ? 0 : (*ptr)&(bit(bitshift)-1) );
7643 count += bitshift;
7644 /* write individual bytes: */
7645 while (1) {
7646 bit_akku |= (uint16)(*bitbufferptr++)<<bitshift;
7647 if (count<8)
7648 break;
7649 buffered_writebyte(stream,(uint8)bit_akku);
7650 stream = STACK_0;
7651 bit_akku = bit_akku>>8;
7652 count -= 8;
7653 if (count<=bitshift)
7654 break;
7655 }
7656 WRITE_LAST_BYTE;
7657 BufferedStream_bitindex(stream) = count;
7658 BufferedStream_position(stream) += 1;
7659 skipSTACK(1); unpin_varobject(TheStream(stream)->strm_bitbuffer);
7660 }
7661 #undef WRITE_LAST_BYTE
7662
7663 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type au : */
wr_by_iau_buffered(object stream,object obj)7664 local maygc void wr_by_iau_buffered (object stream, object obj) {
7665 wr_by_ixu_sub(stream,obj,&wr_by_aux_ia_buffered);
7666 }
7667
7668 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type as : */
wr_by_ias_buffered(object stream,object obj)7669 local maygc void wr_by_ias_buffered (object stream, object obj) {
7670 wr_by_ixs_sub(stream,obj,&wr_by_aux_ia_buffered);
7671 }
7672
7673 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type bu : */
wr_by_ibu_buffered(object stream,object obj)7674 local maygc void wr_by_ibu_buffered (object stream, object obj) {
7675 wr_by_ixu_sub(stream,obj,&wr_by_aux_ib_buffered);
7676 }
7677
7678 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type bs : */
wr_by_ibs_buffered(object stream,object obj)7679 local maygc void wr_by_ibs_buffered (object stream, object obj) {
7680 wr_by_ixs_sub(stream,obj,&wr_by_aux_ib_buffered);
7681 }
7682
7683 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type cu : */
wr_by_icu_buffered(object stream,object obj)7684 local maygc void wr_by_icu_buffered (object stream, object obj) {
7685 wr_by_ixu_sub(stream,obj,&wr_by_aux_ic_buffered);
7686 }
7687
7688 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type cs : */
wr_by_ics_buffered(object stream,object obj)7689 local maygc void wr_by_ics_buffered (object stream, object obj) {
7690 wr_by_ixs_sub(stream,obj,&wr_by_aux_ic_buffered);
7691 }
7692
7693 /* WRITE-BYTE - Pseudo-Function for File-Streams of Integers, Type au, bitsize = 8 : */
wr_by_iau8_buffered(object stream,object obj)7694 local maygc void wr_by_iau8_buffered (object stream, object obj) {
7695 ASSERT_wr_int(stream,obj);
7696 if (!(posfixnump(obj) && (posfixnum_to_V(obj) < bit(8))))
7697 error_bad_integer(stream,obj);
7698 write_byte_buffered(stream,(uintB)posfixnum_to_V(obj));
7699 }
7700
7701 /* WRITE-BYTE-SEQUENCE for File-Streams of Integers, Type au, bitsize = 8 : */
wr_by_array_iau8_buffered(const gcv_object_t * stream_,const gcv_object_t * bytearray_,uintL start,uintL len,perseverance_t persev)7702 local maygc uintL wr_by_array_iau8_buffered
7703 (const gcv_object_t* stream_, const gcv_object_t* bytearray_,
7704 uintL start, uintL len, perseverance_t persev) {
7705 pin_unprotect_varobject(*bytearray_,PROT_READ);
7706 write_byte_array_buffered(*stream_,TheSbvector(*bytearray_)->data+start,len,persev);
7707 unpin_varobject(*bytearray_);
7708 /* increment position: */
7709 BufferedStream_position(*stream_) += len;
7710 return len;
7711 }
7712
7713 /* File-Stream in general
7714 ======================
7715
7716 UP: Positions an (open) File-Stream to the start.
7717 logical_position_file_start(stream);
7718 > stream : (open) File-Stream.
7719 changed in stream: index, endvalid, buffstart, ..., position, rd_ch_last */
logical_position_file_start(object stream)7720 local maygc uoff_t logical_position_file_start (object stream) {
7721 var uintL bitsize = ChannelStream_bitsize(stream);
7722 pushSTACK(stream);
7723 position_file_buffered
7724 (stream,
7725 bitsize > 0 && bitsize < 8 /* Integer-Stream of Type b ? */
7726 ? sizeof(uintL) : 0); /* yes -> Position 4, else Position 0 */
7727 stream = popSTACK();
7728 if (!((bitsize % 8) == 0))
7729 /* Integer-Stream of Type b,c */
7730 BufferedStream_bitindex(stream) = 0; /* bitindex := 0 */
7731 TheStream(stream)->strm_rd_ch_last = NIL; /* Lastchar := NIL */
7732 TheStream(stream)->strmflags &= ~strmflags_unread_B;
7733 return BufferedStream_position(stream) = 0; /* position := 0 */
7734 }
7735
7736 /* UP: Positions an (open) File-Stream to a given Position.
7737 logical_position_file(stream,position);
7738 > stream : (open) File-Stream.
7739 > position : new (logical) Position
7740 changed in stream: index, endvalid, buffstart, ..., position, rd_ch_last */
logical_position_file(object stream,uoff_t position)7741 local maygc uoff_t logical_position_file (object stream, uoff_t position) {
7742 var uintL bitsize = ChannelStream_bitsize(stream);
7743 pushSTACK(stream);
7744 if (bitsize > 0) { /* Integer-Stream ? */
7745 if ((bitsize % 8) == 0) { /* Type a */
7746 position_file_buffered(stream,position*(bitsize/8));
7747 } else { /* Type b,c */
7748 position_file_i_buffered(stream,position);
7749 }
7750 stream = popSTACK();
7751 } else { /* Character-Stream */
7752 position_file_buffered(stream,position);
7753 stream = popSTACK();
7754 TheStream(stream)->strm_rd_ch_last = NIL; /* Lastchar := NIL */
7755 TheStream(stream)->strmflags &= ~strmflags_unread_B;
7756 }
7757 return BufferedStream_position(stream) = position;
7758 }
7759
7760 /* UP: Positions an (open) File-Stream to the end.
7761 logical_position_file_end(stream);
7762 > stream : (open) File-Stream.
7763 changed in stream: index, endvalid, buffstart, ..., position, rd_ch_last */
logical_position_file_end(object stream)7764 local maygc uoff_t logical_position_file_end (object stream) {
7765 pushSTACK(stream);
7766 /* poss. flush Buffer: */
7767 if (BufferedStream_modified(stream)) {
7768 buffered_flush(stream);
7769 stream = STACK_0;
7770 }
7771 var Handle handle = TheHandle(BufferedStream_channel(stream));
7772 var uoff_t eofbytes; /* EOF-Position, measured in Bytes */
7773 /* position to the End: */
7774 begin_blocking_system_call();
7775 handle_lseek(&STACK_0,handle,0,SEEK_END,eofbytes=);
7776 end_blocking_system_call();
7777 stream = STACK_0;
7778 /* calculate logical Position and correct eofbytes: */
7779 var uoff_t position; /* logical Position */
7780 var uintL eofbits = 0; /* Bit-Complement for eofbytes */
7781 var uintL bitsize = ChannelStream_bitsize(stream);
7782 if (bitsize > 0) { /* Integer-Stream ? */
7783 if ((bitsize % 8) == 0) { /* Type a */
7784 var uintL bytesize = bitsize/8;
7785 position = floor(eofbytes,bytesize);
7786 eofbytes = position*bytesize;
7787 } else if (bitsize < 8) { /* Type b */
7788 eofbytes -= sizeof(uintL); /* consider Header */
7789 /* Is the memorized EOF-Position plausible? */
7790 position = BufferedStream_eofposition(stream);
7791 if (!(ceiling(position*bitsize,8)==eofbytes)) /* yes -> use it */
7792 position = floor(eofbytes*8,bitsize); /* no -> recalculate it */
7793 /* recalculate eofbytes and eofbits: */
7794 eofbytes = floor(position*bitsize,8);
7795 eofbits = (position*bitsize)%8;
7796 eofbytes += sizeof(uintL); /* consider Header */
7797 } else { /* Type c */
7798 position = floor(eofbytes*8,bitsize);
7799 eofbytes = floor(position*bitsize,8);
7800 eofbits = (position*bitsize)%8;
7801 }
7802 } else { /* Character-Stream */
7803 position = eofbytes;
7804 }
7805 if (!BufferedStream_blockpositioning(stream)) {
7806 /* Now position at the End: */
7807 BufferedStream_buffstart(stream) = eofbytes;
7808 BufferedStream_endvalid(stream) = 0;
7809 BufferedStream_index(stream) = 0; /* index := 0 */
7810 BufferedStream_modified(stream) = false; /* unmodified */
7811 BufferedStream_have_eof_p(stream) = true;
7812 } else { /* position to the start of the last Sector: */
7813 {
7814 var uoff_t buffstart;
7815 begin_blocking_system_call();
7816 handle_lseek(&STACK_0,handle,
7817 floor(eofbytes,strm_buffered_bufflen)*strm_buffered_bufflen,
7818 SEEK_SET,buffstart=);
7819 end_blocking_system_call();
7820 stream = STACK_0;
7821 BufferedStream_buffstart(stream) = buffstart;
7822 }
7823 /* read Sector: */
7824 BufferedStream_endvalid(stream) = 0;
7825 BufferedStream_index(stream) = 0; /* index := 0 */
7826 BufferedStream_modified(stream) = false; /* unmodified */
7827 BufferedStream_have_eof_p(stream) = false;
7828 var uintL endvalid = eofbytes % strm_buffered_bufflen;
7829 if (!((endvalid==0) && (eofbits==0))) {
7830 /* EOF at end of Sector -> nothing to read */
7831 buffered_nextbyte(stream,persev_partial);
7832 stream = STACK_0;
7833 /* Now index=0. set index and endvalid: */
7834 BufferedStream_index(stream) = endvalid;
7835 if (eofbits != 0)
7836 endvalid += 1;
7837 BufferedStream_endvalid(stream) = endvalid;
7838 }
7839 }
7840 if (!((bitsize % 8) == 0)) { /* Integer-Stream of type b,c */
7841 BufferedStream_bitindex(stream) = eofbits;
7842 }
7843 TheStream(stream)->strm_rd_ch_last = NIL; /* Lastchar := NIL */
7844 TheStream(stream)->strmflags &= ~strmflags_unread_B;
7845 skipSTACK(1);
7846 return BufferedStream_position(stream) = position; /* set position */
7847 }
7848
7849 /* UP: Fills in the pseudofunctions for a buffered stream.
7850 fill_pseudofuns_buffered(stream,&eltype);
7851 > stream: stream being built up, with correct strmflags and encoding
7852 > eltype: Element-Type in decoded form */
fill_pseudofuns_buffered(object stream,const decoded_el_t * eltype)7853 local void fill_pseudofuns_buffered (object stream,
7854 const decoded_el_t* eltype) {
7855 var uintB flags = TheStream(stream)->strmflags;
7856 stream_dummy_fill(stream);
7857 if (flags & strmflags_rd_by_B) {
7858 ELTYPE_DISPATCH(eltype,{},{
7859 TheStream(stream)->strm_rd_by =
7860 ((eltype->size % 8) == 0
7861 ? (eltype->size == 8 ? P(rd_by_iau8_buffered) : P(rd_by_iau_buffered))
7862 : eltype->size < 8 ? P(rd_by_ibu_buffered) : P(rd_by_icu_buffered));
7863 TheStream(stream)->strm_rd_by_array =
7864 (eltype->size == 8
7865 ? P(rd_by_array_iau8_buffered) : P(rd_by_array_dummy));
7866 },{
7867 TheStream(stream)->strm_rd_by =
7868 ((eltype->size % 8) == 0 ? P(rd_by_ias_buffered) :
7869 eltype->size < 8 ? P(rd_by_ibs_buffered) : P(rd_by_ics_buffered));
7870 TheStream(stream)->strm_rd_by_array = P(rd_by_array_dummy);
7871 });
7872 }
7873 if (flags & strmflags_wr_by_B) {
7874 ELTYPE_DISPATCH(eltype,{},{
7875 TheStream(stream)->strm_wr_by =
7876 ((eltype->size % 8) == 0
7877 ? (eltype->size == 8 ? P(wr_by_iau8_buffered) : P(wr_by_iau_buffered))
7878 : eltype->size < 8 ? P(wr_by_ibu_buffered) : P(wr_by_icu_buffered));
7879 TheStream(stream)->strm_wr_by_array =
7880 (eltype->size == 8
7881 ? P(wr_by_array_iau8_buffered) : P(wr_by_array_dummy));
7882 },{
7883 TheStream(stream)->strm_wr_by =
7884 ((eltype->size % 8) == 0 ? P(wr_by_ias_buffered) :
7885 eltype->size < 8 ? P(wr_by_ibs_buffered) : P(wr_by_ics_buffered));
7886 TheStream(stream)->strm_wr_by_array = P(wr_by_array_dummy);
7887 });
7888 }
7889 if (eltype->kind == eltype_ch) {
7890 if (flags & strmflags_rd_ch_B) {
7891 TheStream(stream)->strm_rd_ch = P(rd_ch_buffered);
7892 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_buffered);
7893 }
7894 if (flags & strmflags_wr_ch_B) {
7895 var object eol=TheEncoding(TheStream(stream)->strm_encoding)->enc_eol;
7896 if (eq(eol,S(Kunix))) {
7897 TheStream(stream)->strm_wr_ch =
7898 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_buffered_unix);
7899 TheStream(stream)->strm_wr_ch_array =
7900 TheStream(stream)->strm_wr_ch_array_npnl =
7901 P(wr_ch_array_buffered_unix);
7902 } else if (eq(eol,S(Kmac))) {
7903 TheStream(stream)->strm_wr_ch =
7904 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_buffered_mac);
7905 TheStream(stream)->strm_wr_ch_array =
7906 TheStream(stream)->strm_wr_ch_array_npnl =
7907 P(wr_ch_array_buffered_mac);
7908 } else if (eq(eol,S(Kdos))) {
7909 TheStream(stream)->strm_wr_ch =
7910 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_buffered_dos);
7911 TheStream(stream)->strm_wr_ch_array =
7912 TheStream(stream)->strm_wr_ch_array_npnl =
7913 P(wr_ch_array_buffered_dos);
7914 } else
7915 NOTREACHED;
7916 }
7917 }
7918 }
7919
7920
7921 /* UP: creates a buffered file stream
7922 make_buffered_stream(type,direction,&eltype,handle_regular,handle_blockpositioning)
7923 > STACK_2: Encoding
7924 > STACK_1: Element-Type
7925 > STACK_0: open file handle
7926 > type: stream type
7927 > direction: direction_t (see lispbibl.d)
7928 > eltype: Element-Type in decoded form
7929 > handle_regular: whether the handle refers to a regular file
7930 > handle_blockpositioning: whether the handle refers to a regular file which
7931 can be positioned at n*strm_buffered_bufflen
7932 If direction==DIRECTION_IO(5), handle_blockpositioning must be true.
7933 < result: buffered file stream, Handle_{input,output}_init still to be called,
7934 for eltype.size<8 also eofposition still to be to determined
7935 < STACK: cleaned up
7936 can trigger GC */
make_buffered_stream(uintB type,direction_t direction,const decoded_el_t * eltype,bool handle_regular,bool handle_blockpositioning)7937 local maygc object make_buffered_stream
7938 (uintB type, direction_t direction, const decoded_el_t* eltype,
7939 bool handle_regular, bool handle_blockpositioning) {
7940 var uintB flags = DIRECTION_FLAGS(direction) & ELTYPE_FLAFS(eltype);
7941 var uintC xlen = NON_WHOLE_BYTE_P(eltype)
7942 ? sizeof(strm_i_buffered_extrafields_t) /* integer file-streams */
7943 : sizeof(strm_buffered_extrafields_t); /* all other file-streams */
7944 /* allocate Stream: */
7945 var object stream = allocate_stream(flags,type,strm_channel_len,xlen);
7946 /* and fill: */
7947 TheStream(stream)->strm_encoding = STACK_2;
7948 fill_pseudofuns_buffered(stream,eltype);
7949 TheStream(stream)->strm_rd_ch_last = NIL; /* Lastchar := NIL */
7950 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0; /* Line Position := 0 */
7951 /* Components of File-Streams: */
7952 {
7953 var object handle = popSTACK(); /* restore Handle */
7954 TheStream(stream)->strm_eltype = popSTACK(); /* enter Element-Type */
7955 ChannelStream_buffered(stream) = true;
7956 ChannelStream_regular(stream) = handle_regular;
7957 ChannelStream_init(stream);
7958 if (!nullp(handle)) { /* Handle=NIL -> Rest already initialized with NIL, finished */
7959 BufferedStream_channel(stream) = handle; /* enter Handle */
7960 BufferedStream_blockpositioning(stream) = handle_blockpositioning;
7961 BufferedStream_buffstart(stream) = 0; /* buffstart := 0 */
7962 /* allocate Buffer: */
7963 pushSTACK(stream);
7964 {
7965 var object buffer =
7966 allocate_bit_vector(Atype_8Bit,strm_buffered_bufflen);
7967 stream = popSTACK();
7968 BufferedStream_buffer(stream) = buffer;
7969 }
7970 BufferedStream_endvalid(stream) = 0;
7971 BufferedStream_index(stream) = 0; /* index := 0 */
7972 BufferedStream_modified(stream) = false; /* Buffer unmodified */
7973 BufferedStream_have_eof_p(stream) = false;
7974 BufferedStream_position(stream) = 0; /* position := 0 */
7975 ChannelStream_bitsize(stream) = eltype->size;
7976 ChannelStream_lineno(stream) = 1; /* initialize always (cf. set-stream-element-type) */
7977 if (!(eltype->kind == eltype_ch)) {
7978 /* File-Stream of Integers
7979 allocate Bitbuffer: */
7980 pushSTACK(stream);
7981 {
7982 var object bitbuffer =
7983 allocate_bit_vector(Atype_Bit,ceiling(eltype->size,8)*8);
7984 stream = popSTACK();
7985 TheStream(stream)->strm_bitbuffer = bitbuffer;
7986 }
7987 if (!((eltype->size % 8) == 0)) { /* Types b,c */
7988 BufferedStream_bitindex(stream) = 0; /* bitindex := 0 */
7989 }
7990 }
7991 }
7992 }
7993 if (direction == DIRECTION_PROBE) { /* close stream right away */
7994 STACK_0 = stream; builtin_stream_close(&STACK_0,0); stream = STACK_0;
7995 }
7996 skipSTACK(1);
7997 return stream;
7998 }
7999
8000 #if defined(MULTITHREAD)
8001 /* O(open_files) is guarded by a global lock */
8002 global xmutex_t open_files_lock;
8003 #endif
8004
8005 /* UP: add a stream to the list of open streams O(open_files)
8006 add_to_open_streams()
8007 <> stream
8008 can trigger GC */
add_to_open_streams(object stream)8009 local maygc object add_to_open_streams (object stream) {
8010 pushSTACK(stream);
8011 var gcv_object_t *stream_ = &STACK_0;
8012 WITH_OS_MUTEX_LOCK(0,&open_files_lock, {
8013 var object new_cons = allocate_cons();
8014 Car(new_cons) = *stream_;
8015 Cdr(new_cons) = O(open_files);
8016 O(open_files) = new_cons;
8017 });
8018 return popSTACK();
8019 }
8020
8021 /* UP: removes a stream from the list of open streams O(open_files)
8022 > stream
8023 maygc GC in MT builds */
remove_from_open_streams(object stream)8024 local maygc void remove_from_open_streams(object stream)
8025 {
8026 pushSTACK(stream);
8027 var gcv_object_t *stream_ = &STACK_0;
8028 WITH_OS_MUTEX_LOCK(0,&open_files_lock, {
8029 O(open_files) = deleteq(O(open_files),*stream_);
8030 });
8031 skipSTACK(1);
8032 }
8033
8034 /* Find an open file that matches the given file ID
8035 > struct file_id fid = file ID to match
8036 > uintB flags = open flags to filter
8037 < pointer to the stream saved on STACK or NULL
8038 i.e., on success, adds 1 element to STACK */
8039 global maygc void* find_open_file (struct file_id *fid, uintB flags);
find_open_file(struct file_id * fid,uintB flags)8040 global maygc void* find_open_file (struct file_id *fid, uintB flags) {
8041 pushSTACK(NIL); /* return value if file is found */
8042 var gcv_object_t *stream_ = &STACK_0;
8043 WITH_OS_MUTEX_LOCK(0, &open_files_lock, {
8044 var object tail = O(open_files);
8045 while (nullp(*stream_) && consp(tail)) {
8046 var object stream = Car(tail); tail = Cdr(tail);
8047 if (TheStream(stream)->strmtype == strmtype_file
8048 && TheStream(stream)->strmflags & flags
8049 && file_id_eq(fid,&ChannelStream_file_id(stream))) {
8050 *stream_ = stream;
8051 }
8052 }
8053 });
8054 return nullp(*stream_) ? (skipSTACK(1),(void*)NULL) : (void*)stream_;
8055 }
8056
8057 /* UP: creates a File-Stream
8058 make_file_stream(direction,append_flag,handle_fresh)
8059 > STACK_5: Filename, a Pathname or NIL
8060 > STACK_4: Truename, a Pathname or NIL
8061 > STACK_3: :BUFFERED argument
8062 > STACK_2: :EXTERNAL-FORMAT argument
8063 > STACK_1: :ELEMENT-TYPE argument
8064 > STACK_0: Handle of the opened File
8065 > direction: direction_t (see lispbibl.d)
8066 > append_flag: true if the Stream is to be positioned to the End at the
8067 first go, else false
8068 > handle_fresh: whether the handle is freshly created.
8069 This means 1. that it is currently positioned at position 0,
8070 2. if (direction & bit(2)), it is opened for read/write,
8071 not only for write.
8072 If the handle refers to a regular file, this together means that it
8073 supports handle_lseek, reading/repositioning/writing and close/reopen.
8074 If direction==DIRECTION_IO(5), handle_fresh must be true.
8075 < result: File-Stream (or poss. File-Handle-Stream)
8076 < STACK: cleaned up
8077 can trigger GC */
make_file_stream(direction_t direction,bool append_flag,bool handle_fresh)8078 modexp maygc object make_file_stream
8079 (direction_t direction, bool append_flag, bool handle_fresh) {
8080 var decoded_el_t eltype;
8081 var buffered_t buffered;
8082 /* Check and canonicalize the :ELEMENT-TYPE argument: */
8083 test_eltype_arg(&STACK_1,&eltype);
8084 STACK_1 = canon_eltype(&eltype);
8085 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
8086 STACK_2 = test_external_format_arg(STACK_2);
8087 /* Stack Layout: filename, truename, buffered, encoding, eltype, handle. */
8088 var object stream;
8089 var object handle = STACK_0;
8090 var Handle file_des = INVALID_HANDLE;
8091 var bool handle_regular = true;
8092 if (!nullp(handle))
8093 handle_regular = regular_handle_p(file_des = TheHandle(handle));
8094 /* Check and canonicalize the :BUFFERED argument:
8095 Default is T for regular files, NIL for non-regular files because they
8096 probably don't support lseek(). */
8097 buffered = test_buffered_arg(STACK_3);
8098 #if defined(UNIX)
8099 /* /proc files are unbuffered by default */
8100 if ((buffered == BUFFERED_DEFAULT) && !nullp(STACK_4)) { /* truename */
8101 var object dir = ThePathname(STACK_4)->pathname_directory;
8102 if (consp(dir) && consp(Cdr(dir)))
8103 with_sstring_0(Car(Cdr(dir)),O(pathname_encoding),top_dir,
8104 { if (asciz_equal(top_dir,"proc"))
8105 buffered = BUFFERED_NIL; });
8106 }
8107 #endif
8108 if (buffered == BUFFERED_DEFAULT)
8109 buffered = (handle_regular ? BUFFERED_T : BUFFERED_NIL);
8110 if (buffered == BUFFERED_NIL) {
8111 if (!(eltype.kind == eltype_ch) && !((eltype.size % 8) == 0)) {
8112 pushSTACK(STACK_4); /* Truename, FILE-ERROR slot PATHNAME */
8113 pushSTACK(STACK_0);
8114 pushSTACK(STACK_(1+2));
8115 pushSTACK(S(Kelement_type));
8116 pushSTACK(TheSubr(subr_self)->name);
8117 error(file_error,GETTEXT("~S: argument ~S ~S was specified, but ~S is not a regular file."));
8118 }
8119 var bool handle_tty = false;
8120 if (READ_P(direction)) /* only needed for input handles */
8121 if (!handle_regular) { /* regular files are certainly not ttys */
8122 begin_system_call();
8123 handle_tty = isatty(file_des);
8124 end_system_call();
8125 }
8126 stream = make_unbuffered_stream(strmtype_file,direction,&eltype,
8127 handle_regular,handle_tty);
8128 /* file-handle-streams are treated for pathname purposes as file-streams
8129 thus (wrt file_write_date) strm_buffered_channel == strm_ochannel,
8130 and we have pathnames now: */
8131 TheStream(stream)->strm_file_truename = STACK_1; /* truename */
8132 TheStream(stream)->strm_file_name = STACK_2; /* filename */
8133 if (READ_P(direction))
8134 UnbufferedHandleStream_input_init(stream);
8135 if (WRITE_P(direction))
8136 UnbufferedHandleStream_output_init(stream);
8137 ChannelStreamLow_close(stream) = &low_close_handle;
8138 } else {
8139 if (direction==DIRECTION_IO && !handle_regular) {
8140 /* FIXME: Instead of signalling an error, we could return some kind
8141 of two-way-stream (cf. make_socket_stream). */
8142 pushSTACK(STACK_4); /* Truename, FILE-ERROR slot PATHNAME */
8143 pushSTACK(STACK_0);
8144 pushSTACK(T);
8145 pushSTACK(S(Kbuffered));
8146 pushSTACK(S(Kio));
8147 pushSTACK(S(Kdirection));
8148 pushSTACK(TheSubr(subr_self)->name);
8149 error(file_error,GETTEXT("~S: arguments ~S ~S and ~S ~S were specified, but ~S is not a regular file."));
8150 }
8151 /* Positioning the buffer on block boundaries is possible only if
8152 1. the handle refers to a regular file (otherwise read() and
8153 write() on the handle may be unrelated),
8154 2. if write access is requested, the handle is known to have
8155 read access as well (O_RDWR vs. O_WRONLY). */
8156 var bool handle_blockpositioning =
8157 (handle_regular && (WRITE_P(direction) ? handle_fresh : true));
8158 /* Now, if direction==DIRECTION_IO(5), handle_blockpositioning is true.
8159 allocate stream: */
8160 stream = make_buffered_stream(strmtype_file,direction,&eltype,
8161 handle_regular,handle_blockpositioning);
8162 TheStream(stream)->strm_file_truename = STACK_1; /* truename */
8163 TheStream(stream)->strm_file_name = STACK_2; /* filename */
8164 BufferedHandleStream_init(stream);
8165 ChannelStreamLow_close(stream) = &low_close_handle;
8166 pushSTACK(stream); /* STACK_0 = stream */
8167 if (handle_regular && !handle_fresh) {
8168 var uoff_t position;
8169 var Handle fd = TheHandle(BufferedStream_channel(stream));
8170 begin_blocking_system_call();
8171 handle_lseek(&STACK_0,fd,0,SEEK_CUR,position=);
8172 end_blocking_system_call();
8173 stream = STACK_0;
8174 position_file_buffered(stream,position);
8175 stream = STACK_0;
8176 }
8177 if (!nullp(BufferedStream_channel(stream))
8178 && !(eltype.kind == eltype_ch) && (eltype.size < 8)) {
8179 /* Type b
8180 read eofposition: */
8181 var uoff_t eofposition = 0;
8182 var uintC count;
8183 for (count = 0; count < 8*sizeof(uintL); count += 8) {
8184 var uintB* ptr = buffered_nextbyte(stream,persev_partial);
8185 stream = STACK_0;
8186 if (ptr == (uintB*)NULL)
8187 goto too_short;
8188 eofposition |= ((*ptr) << count);
8189 /* increment index, because *ptr is processed: */
8190 BufferedStream_index(stream) += 1;
8191 }
8192 if (false) {
8193 too_short:
8194 /* File too short (< sizeof(uintL) Bytes) */
8195 if ((TheStream(stream)->strmflags & strmflags_wr_by_B) == 0) /* Read-Only-Stream? */
8196 goto bad_eofposition;
8197 /* File Read/Write -> set eofposition := 0 */
8198 eofposition = 0;
8199 position_file_buffered(stream,0); /* move to position 0 */
8200 stream = STACK_0;
8201 var uintC count; /* and write eofposition = 0 */
8202 dotimespC(count,sizeof(uintL), { buffered_writebyte(stream,0); stream = STACK_0; } );
8203 } else if (eofposition > (uintV)(vbitm(oint_data_len)-1)) {
8204 bad_eofposition:
8205 /* No valid EOF-Position.
8206 close File and report Error: */
8207 TheStream(stream)->strmflags &= ~strmflags_wr_by_B; /* make Stream Read-Only */
8208 /* the stream is already on the stack */
8209 /*pushSTACK(stream);*/
8210 builtin_stream_close(&STACK_0,0);
8211 pushSTACK(Truename_or_Self(STACK_0)); /* STREAM-ERROR slot STREAM */
8212 error(stream_error,GETTEXT("file ~S is not an integer file"));
8213 }
8214 /* We rely on the read EOF-Position now! */
8215 BufferedStream_eofposition(stream) = eofposition;
8216 }
8217 skipSTACK(1); /* the stream */
8218 }
8219 skipSTACK(3);
8220 /* extend List of open File-Streams by stream: */
8221 if (direction != DIRECTION_PROBE) {
8222 if (handle_regular) { /* init file id */
8223 begin_system_call();
8224 if (handle_file_id(file_des,&ChannelStream_file_id(stream)))
8225 OS_filestream_error(stream);
8226 end_system_call();
8227 }
8228 stream = add_to_open_streams(stream);
8229 }
8230 /* treat Mode :APPEND:
8231 CLHS says that :APPEND implies that "the file pointer is _initially_
8232 positioned at the end of the file". Note that this is different from
8233 the Unix O_APPEND semantics. */
8234 if (append_flag) {
8235 pushSTACK(stream);
8236 if (buffered == BUFFERED_NIL) {
8237 /* position to the End: */
8238 var Handle output = TheHandle(TheStream(stream)->strm_ochannel);
8239 begin_blocking_system_call();
8240 handle_lseek(&STACK_0,output,0,SEEK_END,);
8241 end_blocking_system_call();
8242 } else {
8243 logical_position_file_end(stream);
8244 }
8245 stream = popSTACK();
8246 }
8247 return stream;
8248 }
8249
8250 /* UP: Prepares the Closing of a File-Stream.
8251 Thereby the Buffer and poss. eofposition is flushed.
8252 buffered_flush_everything(stream);
8253 > stream : (open) File-Stream.
8254 changed in stream: index, endvalid, buffstart, ... */
buffered_flush_everything(object stream)8255 local maygc void buffered_flush_everything (object stream) {
8256 /* For Integer-Streams (Type b) save eofposition: */
8257 if (ChannelStream_bitsize(stream) > 0 && ChannelStream_bitsize(stream) < 8)
8258 if (TheStream(stream)->strmflags & strmflags_wr_by_B) { /* only if not read-only */
8259 pushSTACK(stream);
8260 position_file_buffered(stream,0); /* move to position 0 */
8261 stream = STACK_0;
8262 var uoff_t eofposition = BufferedStream_eofposition(stream);
8263 /* FIXME: We should give an error if eofposition > ~(uintL)0. */
8264 var uintC count;
8265 dotimespC(count,sizeof(uintL), {
8266 buffered_writebyte(stream,(uintB)eofposition);
8267 stream = STACK_0;
8268 eofposition = eofposition>>8;
8269 });
8270 stream = popSTACK();
8271 }
8272 if (BufferedStream_modified(stream))
8273 buffered_flush(stream);
8274 /* Now the modified_flag is deleted. */
8275 }
8276
8277 /* UP: Moves the pending Output of a File-Stream to the destination.
8278 Writes the Buffer of the File-Stream (also physically) to the File.
8279 finish_output_buffered(stream);
8280 > stream : File-Stream.
8281 changed in stream: handle, index, endvalid, buffstart, ..., rd_ch_last
8282 can trigger GC */
finish_output_buffered(object stream)8283 local maygc void finish_output_buffered (object stream) {
8284 /* Handle=NIL (Stream already closed) -> finished: */
8285 if (nullp(BufferedStream_channel(stream)))
8286 return;
8287 /* no File with write-access -> nothing to do: */
8288 if (!(TheStream(stream)->strmflags & strmflags_wr_B))
8289 return;
8290 pushSTACK(stream);
8291 /* flush pending Output in the iconv-Descriptor: */
8292 (void)oconv_unshift_output_buffered(stream,0);
8293 stream = STACK_0;
8294 /* poss. flush Buffer and eofposition: */
8295 buffered_flush_everything(stream);
8296 stream = STACK_0;
8297 /* Now the modified_flag is deleted. */
8298 if (ChannelStream_regular(stream)) {
8299 #ifdef UNIX
8300 #ifdef HAVE_FSYNC
8301 Handle fd=TheHandle(BufferedStream_channel(stream));
8302 begin_blocking_system_call();
8303 if (fsync(fd)) {
8304 end_blocking_system_call(); OS_filestream_error(popSTACK());
8305 }
8306 end_blocking_system_call();
8307 stream = STACK_0;
8308 #endif
8309 #endif
8310 }
8311 skipSTACK(1);
8312 /* and reposition: */
8313 var uoff_t position = BufferedStream_buffstart(stream) + BufferedStream_index(stream);
8314 BufferedStream_index(stream) = 0; /* index := 0 */
8315 BufferedStream_endvalid(stream) = 0;
8316 if (!BufferedStream_blockpositioning(stream)) {
8317 BufferedStream_buffstart(stream) = position;
8318 } else {
8319 BufferedStream_buffstart(stream) = 0; /* buffstart := 0 */
8320 position_file_buffered(stream,position);
8321 }
8322 /* Components position, ..., lastchar remain unchanged */
8323 }
8324
8325 /* UP: Moves the pending Output of a File-Stream to the destination.
8326 Writes the Buffer of the File-Stream (also physically) to the File.
8327 force_output_buffered(stream);
8328 > stream : File-Stream.
8329 changed in stream: handle, index, endvalid, buffstart, ..., rd_ch_last
8330 can trigger GC */
8331 #define force_output_buffered finish_output_buffered
8332
8333 /* UP: Declares a File-Stream as closed.
8334 closed_buffered(stream);
8335 > stream : (open) File-Stream.
8336 changed in stream: all Components except name and truename */
closed_buffered(object stream)8337 local void closed_buffered (object stream) {
8338 BufferedStream_channel(stream) = NIL; /* Handle becomes invalid */
8339 BufferedStream_buffer(stream) = NIL; /* free Buffer */
8340 BufferedStream_buffstart(stream) = 0; /* delete buffstart (unnecessary) */
8341 BufferedStream_endvalid(stream) = 0; /* delete endvalid (unnecessary) */
8342 BufferedStream_index(stream) = 0; /* delete index (unnecessary) */
8343 BufferedStream_modified(stream) = false; /* delete modified_flag (unnecessary) */
8344 BufferedStream_position(stream) = 0; /* delete position (unnecessary) */
8345 BufferedStream_have_eof_p(stream) = false; /* delete have_eof_p (unnecessary) */
8346 if (ChannelStream_bitsize(stream) > 0) {
8347 ChannelStream_bitsize(stream) = 0; /* delete bitsize */
8348 TheStream(stream)->strm_bitbuffer = NIL; /* free Bitbuffer */
8349 }
8350 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
8351 ChannelStream_iconvdesc(stream) = (iconv_t)0; /* delete iconvdesc */
8352 ChannelStream_oconvdesc(stream) = (iconv_t)0; /* delete oconvdesc */
8353 #endif
8354 }
8355
8356 /* UP: Closes a File-Stream.
8357 close_buffered(stream, abort);
8358 > stream : File-Stream.
8359 > abort: flag: non-0 => ignore errors
8360 changed in stream: all Components except name and truename */
close_buffered(object stream,uintB abort)8361 local maygc void close_buffered (object stream, uintB abort) {
8362 /* Handle=NIL (Stream already closed) -> finished: */
8363 if (nullp(BufferedStream_channel(stream)))
8364 return;
8365 pushSTACK(stream);
8366 /* Flush pending Output in the iconv-Descriptor: */
8367 if (!oconv_unshift_output_buffered(stream,abort)) { /* success */
8368 stream = STACK_0;
8369 /* poss. flush Buffer and eofposition: */
8370 MAYBE_IGNORE_ERRORS(abort,buffered_flush_everything(stream));
8371 }
8372 stream = STACK_0;
8373 /* Now the modified_flag is deleted (unless aborted!)
8374 close File: */
8375 ChannelStreamLow_close(stream)(stream,BufferedStream_channel(stream),abort);
8376 stream = popSTACK();
8377 ChannelStream_fini(stream,abort);
8378 /* make Components invalid (close_dummys comes later): */
8379 closed_buffered(stream);
8380 /* remove stream from the List of all open File-Streams: */
8381 remove_from_open_streams(stream);
8382 }
8383
8384 LISPFUNNF(file_stream_p,1)
8385 { /* (SYS::FILE-STREAM-P stream) == (TYPEP stream 'FILE-STREAM) */
8386 var object arg = popSTACK();
8387 VALUES_IF(builtin_stream_p(arg)
8388 && (TheStream(arg)->strmtype == strmtype_file));
8389 }
8390
8391
8392 #ifdef KEYBOARD
8393
8394 /* Keyboard-Stream
8395 ===============
8396
8397 Functionality:
8398 Reads a character from the keyboard.
8399 Returns a Character with Font=0 and following Bits:
8400 HYPER if special key.
8401 Among the special keys are the Non-Standard-Tasten.
8402 CHAR-CODE For normal keys the Ascii-Code,
8403 SUPER if pressed with Shift-Key(s) and another Code had been the result
8404 without Shift,
8405 CONTROL if pressed with Control-Key,
8406 META if pressed with Alternate-Key. */
8407
8408 #if defined(UNIX)
8409 /* Additional Components: */
8410 #define strm_keyboard_isatty strm_isatty /* Flag, if stdin is a Terminal */
8411 #define strm_keyboard_handle strm_ichannel /* Handle for listen_char_unbuffered() */
8412 #define strm_keyboard_buffer strm_field1 /* List of still to be delivered characters */
8413 #define strm_keyboard_keytab strm_field2 /* List of all key bindings */
8414 /* always (char1 ... charn . result) */
8415 #define strm_keyboard_len strm_channel_len
8416 #define strm_keyboard_xlen sizeof(strm_unbuffered_extrafields_t)
8417 #elif defined(WIN32_NATIVE)
8418 /* Additional Components: */
8419 #define strm_keyboard_isatty strm_isatty /* Flag, if stdin is a Terminal */
8420 #define strm_keyboard_handle strm_ichannel /* Handle for listen_char_unbuffered() */
8421 #define strm_keyboard_len strm_channel_len
8422 #define strm_keyboard_xlen sizeof(strm_unbuffered_extrafields_t)
8423 #else
8424 /* No Additional Components: */
8425 #define strm_keyboard_len strm_len
8426 #define strm_keyboard_xlen 0
8427 #endif
8428
8429 /* The keyboard events are instances of INPUT-CHARACTER. We create them by
8430 calling MAKE-INPUT-CHARACTER or MAKE-CHAR. The following structure describes
8431 the arguments to MAKE-INPUT-CHARACTER. */
8432 typedef struct {
8433 const char * key;
8434 chart code;
8435 uintB bits;
8436 } key_event_t;
8437
8438 /* Initializers for the two most common kinds of keyboard events. */
8439 #define key_ascii(asc) { NULL, ascii(asc), 0 }
8440 #define key_special(name) { name, ascii(0), char_hyper_c }
8441
8442 /* Creates a keyboard event. */
make_key_event(const key_event_t * event)8443 local object make_key_event (const key_event_t* event) {
8444 if ((event->key == NULL) && (event->bits == 0)) {
8445 pushSTACK(S(Kchar)); pushSTACK(code_char(event->code));
8446 funcall(S(make_input_character),2);
8447 } else {
8448 pushSTACK(S(Kkey));
8449 if (event->key == NULL)
8450 pushSTACK(code_char(event->code));
8451 else
8452 pushSTACK(intern_keyword(ascii_to_string(event->key)));
8453 pushSTACK(S(Kbits)); pushSTACK(fixnum(event->bits));
8454 funcall(S(make_input_character),4);
8455 }
8456 return value1;
8457 }
8458
8459 /* Values for the bits, must agree with xcharin.lisp. */
8460 #define char_control_c 1
8461 #define char_meta_c 2
8462 #define char_super_c 4
8463 #define char_hyper_c 8
8464
8465 /* Determines, if a Character is available on the Keyboard-Stream.
8466 listen_char_keyboard(stream)
8467 > stream: Stream
8468 < result: input availability */
8469 #ifdef WIN32_NATIVE
listen_char_keyboard(object stream)8470 local listen_t listen_char_keyboard (object stream) {
8471 var Handle handle = TheHandle(TheStream(stream)->strm_keyboard_handle);
8472 /* See the implementation of listen_char_unbuffered() for consoles. */
8473 var DWORD nevents;
8474 begin_system_call();
8475 if (!GetNumberOfConsoleInputEvents(handle,&nevents)) {
8476 OS_error();
8477 }
8478 /* It's a console. */
8479 if (nevents==0) { /* no character available */
8480 end_system_call(); return LISTEN_WAIT;
8481 }
8482 var DYNAMIC_ARRAY(events,INPUT_RECORD,nevents);
8483 var DWORD nevents_read;
8484 if (!PeekConsoleInput(handle,events,nevents,&nevents_read)) {
8485 OS_error();
8486 }
8487 if (nevents_read==0) { /* no character available */
8488 FREE_DYNAMIC_ARRAY(events);
8489 end_system_call(); return LISTEN_WAIT;
8490 }
8491 { /* Look out for any Key-Down event. */
8492 var DWORD i;
8493 for (i = 0; i < nevents_read; i++) {
8494 if (events[i].EventType == KEY_EVENT
8495 && events[i].Event.KeyEvent.bKeyDown
8496 && events[i].Event.KeyEvent.uAsciiChar != 0) {
8497 /* character available */
8498 FREE_DYNAMIC_ARRAY(events);
8499 end_system_call(); return LISTEN_AVAIL;
8500 }
8501 }
8502 }
8503 /* no character available */
8504 FREE_DYNAMIC_ARRAY(events);
8505 end_system_call(); return LISTEN_WAIT;
8506 }
8507 #endif
8508 #if defined(UNIX)
8509 #define listen_char_keyboard listen_char_unbuffered
8510 #endif
8511
8512 /* UP: Deletes already entered interactive Input from a Keyboard-Stream.
8513 clear_input_keyboard(stream);
8514 > stream: Stream
8515 < result: true if Input was deleted, else false */
clear_input_keyboard(object stream)8516 local bool clear_input_keyboard (object stream) {
8517 #ifdef WIN32_NATIVE
8518 clear_tty_input(TheHandle(TheStream(stream)->strm_keyboard_handle));
8519 pushSTACK(stream);
8520 while (LISTEN_AVAIL == listen_char_keyboard(STACK_0))
8521 read_char(&STACK_0);
8522 skipSTACK(1);
8523 #endif
8524 #if defined(UNIX)
8525 if (nullp(TheStream(stream)->strm_keyboard_isatty)) /* File -> do nothing */
8526 return false;
8527 /* Terminal */
8528 TheStream(stream)->strm_rd_ch_last = NIL; /* EOF forgotten */
8529 clear_tty_input(stdin_handle);
8530 pushSTACK(stream);
8531 while (LISTEN_AVAIL == listen_char_keyboard(STACK_0))
8532 read_char(&STACK_0);
8533 skipSTACK(1);
8534 #endif
8535 return true;
8536 }
8537
8538 /* Read a character from Keyboard: */
8539 #ifdef WIN32_NATIVE
rd_ch_keyboard(const gcv_object_t * stream_)8540 local object rd_ch_keyboard (const gcv_object_t* stream_) {
8541 var INPUT_RECORD event;
8542 var DWORD nevents_read;
8543 var Handle handle;
8544 restart_it:
8545 handle = TheHandle(TheStream(*stream_)->strm_keyboard_handle);
8546 begin_system_call();
8547 while (1) {
8548 if (!ReadConsoleInput1(handle,&event,&nevents_read)) {
8549 if (GetLastError()==ERROR_SIGINT) { /* Break by Ctrl-C ? */
8550 end_system_call();
8551 pushSTACK(S(read_char)); tast_break(); /* call Break-Loop */
8552 goto restart_it;
8553 }
8554 OS_error();
8555 }
8556 ASSERT(nevents_read==1);
8557 if (event.EventType == KEY_EVENT && event.Event.KeyEvent.bKeyDown) {
8558 var key_event_t ev;
8559 if (event.Event.KeyEvent.wRepeatCount > 1) {
8560 var DWORD nevents_written;
8561 event.Event.KeyEvent.wRepeatCount--;
8562 if (!WriteConsoleInput(handle,&event,1,&nevents_written)) {
8563 OS_error();
8564 }
8565 }
8566 if ((uintB)event.Event.KeyEvent.uAsciiChar <= ' ') {
8567 /* Translate Virtual Keycode. */
8568 local const struct { WORD vkcode; key_event_t myevent; } vktable[] = {
8569 VK_BACK, { NULL, BS, 0 }, /* #\Backspace */
8570 VK_TAB, { NULL, TAB, 0 }, /* #\Tab */
8571 VK_CLEAR, { NULL, PG, 0 }, /* #\Page */
8572 VK_RETURN, { NULL, CR, 0 }, /* #\Return */
8573 VK_ESCAPE, { NULL, ESC, 0 }, /* #\Escape */
8574 VK_SHIFT, { "SHIFT", 0, 0 },
8575 VK_CONTROL, { "CONTROL", 0, 0 },
8576 VK_MENU, { "MENU", 0, 0 },
8577 VK_PAUSE, { "PAUSE", 0, 0 },
8578 VK_CAPITAL, { "CAPITAL", 0, 0 },
8579 VK_LEFT, { "LEFT", 0, char_hyper_c }, /* #\Left */
8580 VK_RIGHT, { "RIGHT", 0, char_hyper_c }, /* #\Right */
8581 VK_UP, { "UP", 0, char_hyper_c }, /* #\Up */
8582 VK_DOWN, { "DOWN", 0, char_hyper_c }, /* #\Down */
8583 VK_PRIOR, { "PGUP", 0, char_hyper_c }, /* #\PgUp */
8584 VK_NEXT, { "PGDN", 0, char_hyper_c }, /* #\PgDn */
8585 VK_HOME, { "HOME", 0, char_hyper_c }, /* #\Home */
8586 VK_END, { "END", 0, char_hyper_c }, /* #\End */
8587 VK_INSERT, { "INSERT", 0, char_hyper_c }, /* #\Insert */
8588 VK_DELETE, { "DELETE", 0, char_hyper_c }, /* #\Delete */
8589 12, { "CENTER", 0, char_hyper_c }, /* #\Center */
8590 VK_F1, { "F1", 0, char_hyper_c }, /* #\F1 */
8591 VK_F2, { "F2", 0, char_hyper_c }, /* #\F2 */
8592 VK_F3, { "F3", 0, char_hyper_c }, /* #\F3 */
8593 VK_F4, { "F4", 0, char_hyper_c }, /* #\F4 */
8594 VK_F5, { "F5", 0, char_hyper_c }, /* #\F5 */
8595 VK_F6, { "F6", 0, char_hyper_c }, /* #\F6 */
8596 VK_F7, { "F7", 0, char_hyper_c }, /* #\F7 */
8597 VK_F8, { "F8", 0, char_hyper_c }, /* #\F8 */
8598 VK_F9, { "F9", 0, char_hyper_c }, /* #\F9 */
8599 VK_F10, { "F10", 0, char_hyper_c }, /* #\F10 */
8600 VK_F11, { "F11", 0, char_hyper_c }, /* #\F11 */
8601 VK_F12, { "F12", 0, char_hyper_c }, /* #\F12 */
8602 VK_LWIN, { "WIN", 0, char_hyper_c }, /* Win key */
8603 VK_RWIN, { "WIN", 0, char_hyper_c }, /* Same */
8604 VK_APPS, { "APPS", 0, char_hyper_c }, /* App key */
8605 VK_SELECT, { "SELECT", 0, char_hyper_c },
8606 VK_PRINT, { "PRINT", 0, char_hyper_c },
8607 VK_EXECUTE, { "EXECUTE", 0, char_hyper_c },
8608 VK_SNAPSHOT,{ "SNAPSHOT", 0, char_hyper_c },
8609 VK_ADD, { "ADD", 0, char_hyper_c },
8610 VK_SEPARATOR,{ "SEPARATOR", 0, char_hyper_c },
8611 VK_SUBTRACT,{ "SUBTRACT", 0, char_hyper_c },
8612 VK_DECIMAL, { "DECIMAL", 0, char_hyper_c },
8613 VK_DIVIDE, { "DIVIDE", 0, char_hyper_c },
8614 VK_NUMLOCK, { "NUMLOCK", 0, char_hyper_c },
8615 VK_SCROLL, { "SCROLL", 0, char_hyper_c },
8616 VK_LSHIFT, { "LSHIFT", 0, char_hyper_c },
8617 VK_RSHIFT, { "RSHIFT", 0, char_hyper_c },
8618 VK_LCONTROL,{ "LCONTROL", 0, char_hyper_c },
8619 VK_RCONTROL,{ "RCONTROL", 0, char_hyper_c },
8620 VK_LMENU, { "LMENU", 0, char_hyper_c },
8621 VK_RMENU, { "RMENU", 0, char_hyper_c },
8622 #if (_WIN32_WINNT >= 0x0500)
8623 VK_BROWSER_BACK, { "BROWSER_BACK", 0, char_hyper_c },
8624 VK_BROWSER_FORWARD, { "BROWSER_FORWARD", 0, char_hyper_c },
8625 VK_BROWSER_REFRESH, { "BROWSER_REFRESH", 0, char_hyper_c },
8626 VK_BROWSER_STOP, { "BROWSER_STOP", 0, char_hyper_c },
8627 VK_BROWSER_SEARCH, { "BROWSER_SEARCH", 0, char_hyper_c },
8628 VK_BROWSER_FAVORITES, { "BROWSER_FAVORITES", 0, char_hyper_c },
8629 VK_BROWSER_HOME, { "BROWSER_HOME", 0, char_hyper_c },
8630 VK_VOLUME_MUTE, { "VOLUME_MUTE", 0, char_hyper_c },
8631 VK_VOLUME_DOWN, { "VOLUME_DOWN", 0, char_hyper_c },
8632 VK_VOLUME_UP, { "VOLUME_UP", 0, char_hyper_c },
8633 VK_MEDIA_NEXT_TRACK, { "MEDIA_NEXT_TRACK", 0, char_hyper_c },
8634 VK_MEDIA_PREV_TRACK, { "MEDIA_PREV_TRACK", 0, char_hyper_c },
8635 VK_MEDIA_STOP, { "MEDIA_STOP", 0, char_hyper_c },
8636 VK_MEDIA_PLAY_PAUSE, { "MEDIA_PLAY_PAUSE", 0, char_hyper_c },
8637 VK_LAUNCH_MAIL, { "LAUNCH_MAIL", 0, char_hyper_c },
8638 VK_LAUNCH_MEDIA_SELECT, { "LAUNCH_MEDIA_SELECT", 0, char_hyper_c },
8639 VK_LAUNCH_APP1, { "LAUNCH_APP1", 0, char_hyper_c },
8640 VK_LAUNCH_APP2, { "LAUNCH_APP2", 0, char_hyper_c },
8641 #endif
8642 ' ', { NULL, ' ', 0 }, /* #\Space */
8643 '0', { NULL, '0', 0 }, /* #\0 */
8644 '1', { NULL, '1', 0 }, /* #\1 */
8645 '2', { NULL, '2', 0 }, /* #\2 */
8646 '3', { NULL, '3', 0 }, /* #\3 */
8647 '4', { NULL, '4', 0 }, /* #\4 */
8648 '5', { NULL, '5', 0 }, /* #\5 */
8649 '6', { NULL, '6', 0 }, /* #\6 */
8650 '7', { NULL, '7', 0 }, /* #\7 */
8651 '8', { NULL, '8', 0 }, /* #\8 */
8652 '9', { NULL, '9', 0 }, /* #\9 */
8653 'A', { NULL, 'A', 0 }, /* #\A */
8654 'B', { NULL, 'B', 0 }, /* #\B */
8655 'C', { NULL, 'C', 0 }, /* #\C */
8656 'D', { NULL, 'D', 0 }, /* #\D */
8657 'E', { NULL, 'E', 0 }, /* #\E */
8658 'F', { NULL, 'F', 0 }, /* #\F */
8659 'G', { NULL, 'G', 0 }, /* #\G */
8660 'H', { NULL, 'H', 0 }, /* #\H */
8661 'I', { NULL, 'I', 0 }, /* #\I */
8662 'J', { NULL, 'J', 0 }, /* #\J */
8663 'K', { NULL, 'K', 0 }, /* #\K */
8664 'L', { NULL, 'L', 0 }, /* #\L */
8665 'M', { NULL, 'M', 0 }, /* #\M */
8666 'N', { NULL, 'N', 0 }, /* #\N */
8667 'O', { NULL, 'O', 0 }, /* #\O */
8668 'P', { NULL, 'P', 0 }, /* #\P */
8669 'Q', { NULL, 'Q', 0 }, /* #\Q */
8670 'R', { NULL, 'R', 0 }, /* #\R */
8671 'S', { NULL, 'S', 0 }, /* #\S */
8672 'T', { NULL, 'T', 0 }, /* #\T */
8673 'U', { NULL, 'U', 0 }, /* #\U */
8674 'V', { NULL, 'V', 0 }, /* #\V */
8675 'W', { NULL, 'W', 0 }, /* #\W */
8676 'X', { NULL, 'X', 0 }, /* #\X */
8677 'Y', { NULL, 'Y', 0 }, /* #\Y */
8678 'Z', { NULL, 'Z', 0 }, /* #\Z */
8679 107, { NULL, '+', char_hyper_c }, /* #\HYPER-+ */
8680 109, { NULL, '-', char_hyper_c }, /* #\HYPER-- */
8681 106, { NULL, '*', char_hyper_c }, /* #\HYPER-* */
8682 111, { NULL, '/', char_hyper_c }, /* #\HYPER-/ */
8683 186, { NULL, ';', 0 }, /* #\; */
8684 187, { NULL, '=', 0 }, /* #\= */
8685 188, { NULL, ',', 0 }, /* #\, */
8686 189, { NULL, '-', 0 }, /* #\- */
8687 190, { NULL, '.', 0 }, /* #\. */
8688 191, { NULL, '/', 0 }, /* #\/ */
8689 192, { NULL, '`', 0 }, /* #\` */
8690 219, { NULL, '[', 0 }, /* #\[ */
8691 220, { NULL, '\\', 0 }, /* #\ */\
8692 221, { NULL, ']', 0 }, /* #\] */
8693 222, { NULL, '\'', 0 }, /* #\' */
8694 };
8695 var int i;
8696 for (i = 0; i < sizeof(vktable)/sizeof(vktable[0]); i++) {
8697 if (event.Event.KeyEvent.wVirtualKeyCode == vktable[i].vkcode) {
8698 ev = vktable[i].myevent; goto found_keycode;
8699 }
8700 }
8701 switch (event.Event.KeyEvent.wVirtualKeyCode) {
8702 case VK_SHIFT:
8703 case VK_CONTROL:
8704 case 18: case 20:
8705 break;
8706 default:
8707 fprintf(stderr,"["STRINGIFY(_WIN32_WINNT)"] Unknown keyboard event, VKeyCode = %d, VScanCode = %d, AsciiChar = %d\n",event.Event.KeyEvent.wVirtualKeyCode,event.Event.KeyEvent.wVirtualScanCode,event.Event.KeyEvent.uAsciiChar);
8708 }
8709 continue;
8710 found_keycode:
8711 if (event.Event.KeyEvent.dwControlKeyState & SHIFT_PRESSED)
8712 ev.bits |= char_super_c;
8713 if (event.Event.KeyEvent.dwControlKeyState
8714 & (LEFT_CTRL_PRESSED | RIGHT_CTRL_PRESSED))
8715 ev.bits |= char_control_c;
8716 if (event.Event.KeyEvent.dwControlKeyState
8717 & (LEFT_ALT_PRESSED | RIGHT_ALT_PRESSED))
8718 ev.bits |= char_meta_c;
8719 } else {
8720 #ifdef ENABLE_UNICODE
8721 var object encoding = TheStream(*stream_)->strm_encoding;
8722 var chart c = as_chart(0);
8723 var uintB buf[max_bytes_per_chart];
8724 var chart* cptr = &c;
8725 var const uintB* bptr = buf;
8726 memset(buf,0,max_bytes_per_chart);
8727 buf[0] = (uintB) event.Event.KeyEvent.uAsciiChar;
8728 Encoding_mbstowcs(encoding)
8729 (encoding,*stream_,&bptr,bptr+max_bytes_per_chart,&cptr,cptr+1);
8730 #else
8731 var cint ci = event.Event.KeyEvent.uAsciiChar;
8732 var chart c = as_chart(ci);
8733 OemToCharBuff((char *)&ci,(char *)&ci,1);
8734 c = as_chart(ci);
8735 #endif
8736 ev.key = NULL;
8737 ev.code = c;
8738 ev.bits = 0;
8739 if (event.Event.KeyEvent.dwControlKeyState &
8740 (LEFT_ALT_PRESSED | RIGHT_ALT_PRESSED)) {
8741 /* c = 'a'..'z' -> translate to 'A'..'Z'
8742 c = 'A'..'Z' -> add "Shift"
8743 c = '<','>' etc. -> don't add "Shift" */
8744 ev.code = up_case(ev.code);
8745 if (!chareq(ev.code,down_case(ev.code))) {
8746 if (event.Event.KeyEvent.dwControlKeyState & SHIFT_PRESSED)
8747 ev.bits |= char_super_c;
8748 }
8749 ev.bits |= char_meta_c;
8750 }
8751 }
8752 end_system_call();
8753 return make_key_event(&ev);
8754 }
8755 /* Other events are silently thrown away. */
8756 }
8757 }
8758 #endif
8759
8760 #if defined(UNIX)
kbd_last_buf(const object stream)8761 local inline gcv_object_t* kbd_last_buf (const object stream) {
8762 var gcv_object_t* last_ = &TheStream(stream)->strm_keyboard_buffer;
8763 while (mconsp(*last_)) { last_ = &Cdr(*last_); }
8764 return last_;
8765 }
8766
8767 /* cf. rd_ch_unbuffered() : */
rd_ch_keyboard(const gcv_object_t * stream_)8768 local object rd_ch_keyboard (const gcv_object_t* stream_) {
8769 restart_it: {
8770 var object stream = *stream_;
8771 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* EOF already? */
8772 return eof_value;
8773 /* Still something in the Buffer? */
8774 if (UnbufferedStream_status(stream) > 0) {
8775 var uintL num_bytes = UnbufferedStream_status(stream);
8776 var uintB *bytes = UnbufferedStream_bytebuf(stream);
8777 var uintL count;
8778 UnbufferedStream_status(stream) = 0;
8779 dotimespL(count,num_bytes,{ pushSTACK(code_char(as_chart(*bytes++))); }); /* FIXME: This should take into account the encoding. */
8780 var object new_list = listof(num_bytes);
8781 *kbd_last_buf(stream = *stream_) = new_list;
8782 }
8783 if (mconsp(TheStream(stream)->strm_keyboard_buffer))
8784 goto empty_buffer;
8785 { /* read a character: */
8786 var uintB c;
8787 read_next_char: {
8788 begin_system_call();
8789 var int result = read(stdin_handle,&c,1); /* try to read a byte */
8790 end_system_call();
8791 if (result<0) {
8792 begin_system_call();
8793 if (errno==EINTR) { /* break (poss. by Ctrl-C) ? */
8794 end_system_call();
8795 interruptp({ pushSTACK(S(read_char)); tast_break(); }); /* call Break-Loop */
8796 goto restart_it;
8797 }
8798 OS_error();
8799 }
8800 if (result==0) { /* no character available -> recognize EOF */
8801 TheStream(stream)->strm_rd_ch_last = eof_value; return eof_value;
8802 }
8803 }
8804 next_char_is_read: { /* increase the buffer: */
8805 var object new_cons = allocate_cons();
8806 Car(new_cons) = code_char(as_chart(c)); /* FIXME: This should take into account the encoding. */
8807 *kbd_last_buf(stream = *stream_) = new_cons;
8808 }
8809 /* Is the buffer a complete sequence of characters for a key,
8810 so we will return this key. Is the buffer a genuine starting piece
8811 of a sequence of characters for a key, so we will wait a little bit.
8812 Otherwise we start to empty the buffer character for character. */
8813 {
8814 var object keytab = TheStream(stream)->strm_keyboard_keytab;
8815 while (consp(keytab)) {
8816 var object L1 = Car(keytab);
8817 keytab = Cdr(keytab);
8818 var object L2 = TheStream(stream)->strm_keyboard_buffer;
8819 while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2))) {
8820 L1 = Cdr(L1); L2 = Cdr(L2);
8821 }
8822 if (atomp(L2)) {
8823 if (atomp(L1)) {
8824 /* complete sequence of characters */
8825 TheStream(stream)->strm_keyboard_buffer = NIL;
8826 return L1;
8827 }
8828 }
8829 }
8830 }
8831 {
8832 var object keytab = TheStream(stream)->strm_keyboard_keytab;
8833 while (consp(keytab)) {
8834 var object L1 = Car(keytab);
8835 keytab = Cdr(keytab);
8836 var object L2 = TheStream(stream)->strm_keyboard_buffer;
8837 while (consp(L1) && consp(L2) && eq(Car(L1),Car(L2))) {
8838 L1 = Cdr(L1); L2 = Cdr(L2);
8839 }
8840 if (atomp(L2))
8841 /* As consp(L1), the starting piece of a sequence of characters is there. */
8842 goto wait_for_another;
8843 }
8844 }
8845 goto empty_buffer;
8846 wait_for_another:
8847 #if defined(HAVE_POLL)
8848 {
8849 /* Use poll() with a single handle {stdin_handle}
8850 and timeout = zero interval. */
8851 var struct pollfd pollfd_bag[1];
8852 pollfd_bag[0].fd = stdin_handle;
8853 pollfd_bag[0].events = POLLIN;
8854 pollfd_bag[0].revents = 0;
8855 restart_poll:
8856 begin_system_call();
8857 var int result = poll(&pollfd_bag[0],1,100); /* 1/10 sec */
8858 end_system_call();
8859 if (result<0) {
8860 begin_system_call();
8861 if (errno==EINTR) {
8862 end_system_call(); goto restart_poll;
8863 }
8864 OS_error();
8865 } else {
8866 /* revents has POLLIN or some other bits set if read() would return
8867 without blocking. */
8868 if (pollfd_bag[0].revents == 0)
8869 goto empty_buffer; /* no character available */
8870 }
8871 }
8872 #elif defined(HAVE_SELECT) && !defined(UNIX_BEOS)
8873 {
8874 /* Use select with readfds = one-element set {stdin_handle}
8875 and timeout = small time-interval. */
8876 var fd_set handle_set; /* set of handles := {stdin_handle} */
8877 var struct timeval small_time; /* time-interval := 0 */
8878 FD_ZERO(&handle_set); FD_SET(stdin_handle,&handle_set);
8879 restart_select:
8880 small_time.tv_sec = 0; small_time.tv_usec = 1000000/10; /* 1/10 sec */
8881 begin_system_call();
8882 var int result;
8883 result = select(FD_SETSIZE,&handle_set,NULL,NULL,&small_time);
8884 end_system_call();
8885 if (result<0) {
8886 begin_system_call();
8887 if (errno==EINTR) {
8888 end_system_call(); goto restart_select;
8889 }
8890 if (!(errno == EBADF)) {
8891 OS_error();
8892 }
8893 end_system_call();
8894 } else {
8895 /* result = number of Handles in handle_set, for which read
8896 would return a result immediately. */
8897 if (result==0)
8898 goto empty_buffer; /* no character available */
8899 /* result=1 -> character available */
8900 }
8901 }
8902 #else
8903 #ifdef UNIX_TERM_TERMIOS
8904 {
8905 /* Use the Termio-Elements VMIN and VTIME. */
8906 var struct termios oldtermio;
8907 var struct termios newtermio;
8908 begin_system_call();
8909 if (!( tcgetattr(stdin_handle,&oldtermio) ==0)) {
8910 if (!(errno==ENOTTY)) { OS_error(); }
8911 }
8912 /* We assume now, that oldtermio is now identical with the newtermio
8913 from term_raw() (see below). This is ensured, if
8914 1. (SYS::TERMINAL-RAW T) was called and
8915 2. stdin_handle and stdout_handle both are the same Terminal. ?? */
8916 newtermio = oldtermio;
8917 newtermio.c_cc[VMIN] = 0;
8918 newtermio.c_cc[VTIME] = 1; /* 1/10 second timeout */
8919 if (!( TCSETATTR(stdin_handle,TCSANOW,&newtermio) ==0)) {
8920 if (!(errno==ENOTTY)) { OS_error(); }
8921 }
8922 var int result = read(stdin_handle,&c,1); /* try to read a byte, with timeout */
8923 if (!( TCSETATTR(stdin_handle,TCSANOW,&oldtermio) ==0)) {
8924 if (!(errno==ENOTTY)) { OS_error(); }
8925 }
8926 end_system_call();
8927 if (result<0) {
8928 begin_system_call();
8929 if (errno==EINTR) { /* break (poss. by Ctrl-C) ? */
8930 end_system_call();
8931 interruptp({ pushSTACK(S(read_char)); tast_break(); }); /* call Break-Loop */
8932 goto restart_it;
8933 }
8934 OS_error();
8935 }
8936 if (result==0)
8937 goto empty_buffer; /* no character available */
8938 goto next_char_is_read; /* result=1 -> character available */
8939 }
8940 #else
8941 /* One could use fcntl(stdin_handle,F_SETFL,...|FASYNC) here
8942 and wait for the Signal SIGIO. But this works only on so
8943 few Systems (see Emacs), that it does not pay off. */
8944 #endif
8945 #endif
8946 goto read_next_char;
8947 }
8948 empty_buffer: { /* return buffer character for character: */
8949 var object l = TheStream(stream)->strm_keyboard_buffer;
8950 TheStream(stream)->strm_keyboard_buffer = Cdr(l);
8951 var cint c = as_cint(char_code(Car(l)));
8952 if ((c >= ' ') || (c == ESC) || (c == TAB) || (c == CR) || (c == BS)) {
8953 /* FIXME: This should take into account the encoding. */
8954 pushSTACK(code_char(as_chart(c))); funcall(S(make_char),1);
8955 return value1;
8956 } else {
8957 /* key presumably pressed with Ctrl */
8958 var key_event_t event;
8959 event.key = NULL;
8960 event.code = ascii(c == 0 ? ' ' : (c | bit(6)));
8961 event.bits = char_control_c;
8962 return make_key_event(&event);
8963 }
8964 }
8965 }
8966 }
8967
8968
8969 /* UP: extends the List STACK_0 by one key-assignment.
8970 can trigger GC */
add_keybinding(const char * cap,const key_event_t * event)8971 local maygc void add_keybinding (const char* cap, const key_event_t* event) {
8972 var const uintB* ptr = (const uintB*)cap;
8973 if (*ptr=='\0') /* avoid empty key-sequence */
8974 return;
8975 /* FIXME: This should take into account the encoding. */
8976 pushSTACK(allocate_cons());
8977 /* create List (char1 ... charn . key) : */
8978 {
8979 var uintC count = 0;
8980 do { pushSTACK(code_char(as_chart(*ptr))); ptr++; count++;
8981 } while (*ptr != '\0');
8982 pushSTACK(make_key_event(event)); count++;
8983 funcall(L(liststar),count);
8984 }
8985 /* and push on STACK_0: */
8986 {
8987 var object l = popSTACK();
8988 Car(l) = value1; Cdr(l) = STACK_0; STACK_0 = l;
8989 }
8990 }
8991 #define keybinding(cap,initializer) \
8992 do { key_event_t event = initializer; add_keybinding(cap,&event); } while(0)
8993 #endif
8994
8995 /* returns a Keyboard-Stream.
8996 make_keyboard_stream()
8997 can trigger GC */
make_keyboard_stream(void)8998 local maygc object make_keyboard_stream (void) {
8999 #if defined(UNIX)
9000 {
9001 /* build Table of all assignments character-sequence -> Key : */
9002 pushSTACK(NIL);
9003 /* query Terminal-Type: */
9004 begin_system_call();
9005 var const char* s = getenv("TERM");
9006 if (s==NULL) {
9007 end_system_call();
9008 } else {
9009 var char tbuf[4096]; /* internal Buffer for the Termcap-Routines */
9010 if (tgetent(tbuf,s) !=1) {
9011 end_system_call();
9012 } else {
9013 var char tentry[4096]; /* Buffer for the Capabilities that I need */
9014 var char* tp = &tentry[0];
9015 var const char* cap;
9016 end_system_call();
9017 /* Backspace: */
9018 begin_system_call(); cap = tgetstr("kb",&tp); end_system_call();
9019 if (cap)
9020 keybinding(cap, key_ascii(BS)); /* #\Backspace */
9021 /* Insert, Delete: */
9022 begin_system_call(); cap = tgetstr("kI",&tp); end_system_call();
9023 if (cap)
9024 keybinding(cap, key_special("INSERT")); /* #\Insert */
9025 begin_system_call(); cap = tgetstr("kD",&tp); end_system_call();
9026 if (cap)
9027 keybinding(cap, key_special("DELETE")); /* #\Delete */
9028 /* arrow keys: */
9029 begin_system_call(); cap = tgetstr("ku",&tp); end_system_call();
9030 if (cap)
9031 keybinding(cap, key_special("UP")); /* #\Up */
9032 if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0'))
9033 keybinding(ESCstring"[A", key_special("UP")); /* #\Up */
9034 begin_system_call(); cap = tgetstr("kd",&tp); end_system_call();
9035 if (cap)
9036 keybinding(cap, key_special("DOWN")); /* #\Down */
9037 if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0'))
9038 keybinding(ESCstring"[B", key_special("DOWN")); /* #\Down */
9039 begin_system_call(); cap = tgetstr("kr",&tp); end_system_call();
9040 if (cap)
9041 keybinding(cap, key_special("RIGHT")); /* #\Right */
9042 if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0'))
9043 keybinding(ESCstring"[C", key_special("RIGHT")); /* #\Right */
9044 begin_system_call(); cap = tgetstr("kl",&tp); end_system_call();
9045 if (cap)
9046 keybinding(cap, key_special("LEFT")); /* #\Left */
9047 if (cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0'))
9048 keybinding(ESCstring"[D", key_special("LEFT")); /* #\Left */
9049 /* other cursorblock-keys: */
9050 begin_system_call(); cap = tgetstr("kh",&tp); end_system_call();
9051 if (cap)
9052 keybinding(cap, key_special("HOME")); /* #\Home */
9053 begin_system_call(); cap = tgetstr("K1",&tp); end_system_call();
9054 if (cap)
9055 keybinding(cap, key_special("HOME")); /* #\Home */
9056 begin_system_call(); cap = tgetstr("KH",&tp); end_system_call();
9057 if (cap)
9058 keybinding(cap, key_special("END")); /* #\End */
9059 begin_system_call(); cap = tgetstr("K4",&tp); end_system_call();
9060 if (cap)
9061 keybinding(cap, key_special("END")); /* #\End */
9062 begin_system_call(); cap = tgetstr("kP",&tp); end_system_call();
9063 if (cap)
9064 keybinding(cap, key_special("PGUP")); /* #\PgUp */
9065 begin_system_call(); cap = tgetstr("K3",&tp); end_system_call();
9066 if (cap)
9067 keybinding(cap, key_special("PGUP")); /* #\PgUp */
9068 begin_system_call(); cap = tgetstr("kN",&tp); end_system_call();
9069 if (cap)
9070 keybinding(cap, key_special("PGDN")); /* #\PgDn */
9071 begin_system_call(); cap = tgetstr("K5",&tp); end_system_call();
9072 if (cap)
9073 keybinding(cap, key_special("PGDN")); /* #\PgDn */
9074 begin_system_call(); cap = tgetstr("K2",&tp); end_system_call();
9075 if (cap)
9076 keybinding(cap, key_special("CENTER")); /* #\Center */
9077 /* Function Keys: */
9078 {
9079 typedef struct { const char* capname; key_event_t key; } funkey;
9080 local var const funkey funkey_tab[] = {
9081 { "k1", key_special("F1") }, /* #\F1 */
9082 { "k2", key_special("F2") }, /* #\F2 */
9083 { "k3", key_special("F3") }, /* #\F3 */
9084 { "k4", key_special("F4") }, /* #\F4 */
9085 { "k5", key_special("F5") }, /* #\F5 */
9086 { "k6", key_special("F6") }, /* #\F6 */
9087 { "k7", key_special("F7") }, /* #\F7 */
9088 { "k8", key_special("F8") }, /* #\F8 */
9089 { "k9", key_special("F9") }, /* #\F9 */
9090 { "k0", key_special("F10") }, /* #\F10 */
9091 { "k;", key_special("F10") }, /* #\F10 */
9092 { "F1", key_special("F11") }, /* #\F11 */
9093 { "F2", key_special("F12") }, /* #\F12 */
9094 };
9095 var uintL i;
9096 for (i=0; i < sizeof(funkey_tab)/sizeof(funkey); i++) {
9097 begin_system_call();
9098 cap = tgetstr(funkey_tab[i].capname,&tp);
9099 end_system_call();
9100 if (cap)
9101 add_keybinding(cap,&funkey_tab[i].key);
9102 }
9103 }
9104 /* Special Linux console handling: */
9105 begin_system_call();
9106 cap = tgetstr("kh",&tp); /* Home */
9107 if (!(cap && (cap[0] == ESC) && (cap[1] == '[') && (cap[2] == '1') && (cap[3] == '~') && (cap[4] == '\0')))
9108 goto not_linux;
9109 cap = tgetstr("kI",&tp); /* Insert */
9110 if (!(cap && (cap[0] == ESC) && (cap[1] == '[') && (cap[2] == '2') && (cap[3] == '~') && (cap[4] == '\0')))
9111 goto not_linux;
9112 cap = tgetstr("kD",&tp); /* Delete */
9113 if (!(cap && (cap[0] == ESC) && (cap[1] == '[') && (cap[2] == '3') && (cap[3] == '~') && (cap[4] == '\0')))
9114 goto not_linux;
9115 end_system_call();
9116 keybinding(ESCstring"[4~", key_special("END")); /* #\End */
9117 if (false) {
9118 not_linux:
9119 end_system_call();
9120 }
9121 /* Special xterm handling: */
9122 begin_system_call();
9123 cap = tgetstr("ku",&tp);
9124 if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'A') && (cap[3] == '\0')))
9125 goto not_xterm;
9126 cap = tgetstr("kd",&tp);
9127 if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'B') && (cap[3] == '\0')))
9128 goto not_xterm;
9129 cap = tgetstr("kr",&tp);
9130 if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'C') && (cap[3] == '\0')))
9131 goto not_xterm;
9132 cap = tgetstr("kl",&tp);
9133 if (!(cap && (cap[0] == ESC) && (cap[1] == 'O') && (cap[2] == 'D') && (cap[3] == '\0')))
9134 goto not_xterm;
9135 end_system_call();
9136 /* Insert, Delete: */
9137 keybinding(ESCstring"[2~", key_special("INSERT")); /* #\Insert */
9138 keybinding(ESCstring"[3~", key_special("DELETE")); /* #\Delete */
9139 {
9140 /* Application Keypad: ESC O M -> Return,
9141 ESC O k -> +, ESC O m -> -, ESC O j -> *, ESC O o -> /
9142 (without Hyper-Bit, because that is too terminal-specific)
9143 ESC O x -> Up, ESC O r -> Down,
9144 ESC O v -> Right, ESC O t -> Left,
9145 ESC O p -> Insert, ESC O l -> Delete. */
9146 var char cap[4];
9147 cap[0] = ESC; cap[1] = 'O'; cap[3] = '\0';
9148 cap[2] = 'M'; keybinding(cap, key_ascii('M'-64));
9149 cap[2] = '+'+64; keybinding(cap, key_ascii('+'));
9150 cap[2] = '-'+64; keybinding(cap, key_ascii('-'));
9151 cap[2] = '*'+64; keybinding(cap, key_ascii('*'));
9152 cap[2] = '/'+64; keybinding(cap, key_ascii('/'));
9153 cap[2] = '8'+64; keybinding(cap, key_special("UP")); /* #\Up */
9154 cap[2] = '2'+64; keybinding(cap, key_special("DOWN")); /* #\Down */
9155 cap[2] = '6'+64; keybinding(cap, key_special("RIGHT")); /* #\Right */
9156 cap[2] = '4'+64; keybinding(cap, key_special("LEFT")); /* #\Left */
9157 cap[2] = '0'+64; keybinding(cap, key_special("INSERT")); /* #\Insert */
9158 cap[2] = '.'+64; keybinding(cap, key_special("DELETE")); /* #\Delete */
9159 cap[2] = ','+64; keybinding(cap, key_special("DELETE")); /* #\Delete */
9160 /* "7" -> #\Home, "1" -> #\End, "9" -> #\PgUp, "3" -> #\PgDn,
9161 "5" -> #\Center are already handled above. */
9162 }
9163 xterm:
9164 /* arrow keys (see above)
9165 other cursorblock-keys: */
9166 keybinding(ESCstring"[5~", key_special("PGUP")); /* #\PgUp */
9167 keybinding(ESCstring"[6~", key_special("PGDN")); /* #\PgDn */
9168 keybinding(ESCstring"[7~", key_special("HOME")); /* #\Home */
9169 keybinding(ESCstring"[8~", key_special("END")); /* #\End */
9170 keybinding(ESCstring"OH", key_special("HOME")); /* #\Home */
9171 keybinding(ESCstring"[H", key_special("HOME")); /* #\Home */
9172 keybinding(ESCstring"OF", key_special("END")); /* #\End */
9173 keybinding(ESCstring"[F", key_special("END")); /* #\End */
9174 /* function-keys: */
9175 keybinding(ESCstring"[11~", key_special("F1")); /* #\F1 */
9176 keybinding(ESCstring"[12~", key_special("F2")); /* #\F2 */
9177 keybinding(ESCstring"[13~", key_special("F3")); /* #\F3 */
9178 keybinding(ESCstring"[14~", key_special("F4")); /* #\F4 */
9179 keybinding(ESCstring"[15~", key_special("F5")); /* #\F5 */
9180 keybinding(ESCstring"[17~", key_special("F6")); /* #\F6 */
9181 keybinding(ESCstring"[18~", key_special("F7")); /* #\F7 */
9182 keybinding(ESCstring"[19~", key_special("F8")); /* #\F8 */
9183 keybinding(ESCstring"[20~", key_special("F9")); /* #\F9 */
9184 keybinding(ESCstring"[21~", key_special("F10")); /* #\F10 */
9185 keybinding(ESCstring"[23~", key_special("F11")); /* #\F11 */
9186 keybinding(ESCstring"[24~", key_special("F12")); /* #\F12 */
9187 if (false) {
9188 not_xterm:
9189 end_system_call();
9190 }
9191 }
9192 }
9193 }
9194 pushSTACK(allocate_handle(stdin_handle));
9195 #endif
9196 #ifdef WIN32_NATIVE
9197 /* build Console-Handle:
9198 Maybe use CREATE_ALWAYS ?? Maybe use AllocConsole() ?? */
9199 {
9200 begin_system_call();
9201 var Handle handle = CreateFile("CONIN$", GENERIC_READ | GENERIC_WRITE, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
9202 if (handle==INVALID_HANDLE_VALUE) {
9203 OS_error();
9204 }
9205 end_system_call();
9206 pushSTACK(allocate_handle(handle));
9207 }
9208 #endif
9209 /* allocate new Stream: */
9210 var object stream = /* Flags: only READ-CHAR allowed */
9211 allocate_stream(strmflags_rd_ch_B,strmtype_keyboard,strm_keyboard_len,strm_keyboard_xlen);
9212 /* and fill: */
9213 stream_dummy_fill(stream);
9214 var Stream s = TheStream(stream);
9215 s->strm_encoding = O(terminal_encoding);
9216 s->strm_rd_ch = P(rd_ch_keyboard); /* READ-CHAR-Pseudofunction */
9217 s->strm_rd_ch_array = P(rd_ch_array_dummy); /* READ-CHAR-SEQUENCE-Pseudofunction */
9218 #if defined(UNIX)
9219 /* determine Flag isatty = (stdin_tty ? T : NIL) : */
9220 begin_system_call();
9221 s->strm_keyboard_isatty = (isatty(stdin_handle) ? T : NIL);
9222 end_system_call();
9223 s->strm_keyboard_handle = popSTACK();
9224 s->strm_keyboard_buffer = NIL;
9225 s->strm_keyboard_keytab = popSTACK();
9226 ChannelStream_buffered(stream) = false;
9227 ChannelStream_regular(stream) = false;
9228 ChannelStream_init(stream);
9229 UnbufferedHandleStream_input_init(stream);
9230 #endif
9231 #ifdef WIN32_NATIVE
9232 s->strm_keyboard_isatty = T;
9233 s->strm_keyboard_handle = popSTACK();
9234 ChannelStream_buffered(stream) = false;
9235 ChannelStream_regular(stream) = false;
9236 ChannelStream_init(stream);
9237 UnbufferedHandleStream_input_init(stream);
9238 #endif
9239 return stream;
9240 }
9241
9242 /* (SYSTEM::MAKE-KEYBOARD-STREAM) creates a new keyboard stream.
9243 Should be called once only, and the result assigned to *KEYBOARD-INPUT*. */
9244 LISPFUNN(make_keyboard_stream,0) {
9245 VALUES1(make_keyboard_stream());
9246 }
9247
9248 #endif /* KEYBOARD */
9249
9250
9251 /* Interactive Terminal Stream
9252 =========================== */
9253
9254 #if defined(GNU_READLINE)
9255
9256 #define begin_rl_callback() end_blocking_call(); begin_callback()
9257 #define end_rl_callback() end_callback(); begin_blocking_call()
9258
9259 /* Function to ignore unconvertible symbols. */
lisp_completion_ignore(void * sp,gcv_object_t * frame,object label,object condition)9260 local void lisp_completion_ignore (void* sp, gcv_object_t* frame, object label,
9261 object condition) {
9262 unused(sp); unused(frame); unused(label); unused(condition);
9263 /* (THROW 'SYS::CONVERSION-FAILURE NIL): */
9264 VALUES1(NIL);
9265 throw_to(S(conversion_failure));
9266 }
9267 /* Completion of Lisp-Symbols */
lisp_completion(char * text,int start,int end)9268 local maygc char** lisp_completion (char* text, int start, int end) {
9269 /* text[start..end-1] = thing to complete within line of text
9270 This is a Callback-Function, we must set the Stack correctly again: */
9271 begin_rl_callback();
9272 #ifdef ENABLE_UNICODE
9273 { var object encoding = O(terminal_encoding);
9274 start = Encoding_mblen(encoding)(encoding,(const uintB*)text,
9275 (const uintB*)text+start);
9276 end = Encoding_mblen(encoding)(encoding,(const uintB*)text,
9277 (const uintB*)text+end);
9278 }
9279 #endif
9280 var object mlist = NIL; /* List of the possibilities */
9281 if (!nullpSv(completion)) { /* (funcall CUSTOM:*COMPLETION* text start end) */
9282 pushSTACK(asciz_to_string(text,O(terminal_encoding)));
9283 pushSTACK(fixnum((uintL)start));
9284 pushSTACK(fixnum((uintL)end));
9285 funcall(Symbol_value(S(completion)),3);
9286 mlist = value1;
9287 }
9288 /* reconstruct List of Simple-Strings in malloc-ed Array from malloc-ed
9289 Asciz-Strings: */
9290 if (nullp(mlist)) {
9291 end_rl_callback();
9292 return NULL;
9293 } else if (eq(mlist,Fixnum_0)) { /* complete called describe => redraw */
9294 end_rl_callback();
9295 rl_refresh_line(0,0);
9296 return NULL;
9297 } else if (!consp(mlist)) {
9298 /* This error message is self-defense against people who fiddle
9299 around with sys::completion. */
9300 pushSTACK(mlist); /* slot DATUM of TYPE-ERROR */
9301 pushSTACK(S(list)); /* slot EXPECTED-TYPE of TYPE-ERROR */
9302 pushSTACK(S(completion));
9303 pushSTACK(mlist);
9304 error(type_error,GETTEXT("Return value ~S of call to ~S is not a list."));
9305 }
9306 begin_system_call();
9307 var char** array = (char**) malloc((llength(mlist)+1)*sizeof(char*));
9308 end_system_call();
9309 if (array==NULL) {
9310 end_rl_callback();
9311 return NULL;
9312 }
9313 {
9314 var char** ptr = array;
9315 pushSTACK(mlist);
9316 while (mconsp(STACK_0)) {
9317 var object m = Car(STACK_0);
9318 if (!simple_string_p(m)) {
9319 pushSTACK(m); /* slot DATUM of TYPE-ERROR */
9320 pushSTACK(S(simple_string)); /* slot EXPECTED-TYPE of TYPE-ERROR */
9321 pushSTACK(S(simple_string));
9322 pushSTACK(m);
9323 pushSTACK(S(completion));
9324 pushSTACK(mlist);
9325 error(type_error,GETTEXT("Return value ~S of call to ~S contains ~S which is not a ~S."));
9326 }
9327 sstring_un_realloc(m);
9328 var uintL charcount = Sstring_length(m);
9329 var const chart* ptr1;
9330 unpack_sstring_alloca(m,charcount,0, ptr1=);
9331 { /* (CATCH 'SYS::CONVERSION-FAILURE ...) */
9332 var gcv_object_t* top_of_frame = STACK;
9333 pushSTACK(S(conversion_failure));
9334 var sp_jmp_buf returner;
9335 finish_entry_frame(CATCH,returner,, goto catch_return; );
9336 /* Upon charset_type_error, call lisp_completion_ignore. */
9337 make_C_HANDLER_frame(O(handler_for_charset_type_error),
9338 &lisp_completion_ignore,NULL);
9339 { /* Convert ptr1 to *TERMINAL-ENCODING*: */
9340 var uintL bytecount = cslen(O(terminal_encoding),ptr1,charcount);
9341 begin_system_call();
9342 var char* ptr2 = (char*) malloc((bytecount+1)*sizeof(char));
9343 if (ptr2==NULL) { /* malloc fails -> return everything */
9344 while (ptr != array) { free(*--ptr); }
9345 free(array);
9346 end_system_call();
9347 unwind_C_HANDLER_frame();
9348 skipSTACK(3+1); /* unwind CATCH frame, pop mlist */
9349 end_rl_callback();
9350 return NULL;
9351 }
9352 end_system_call();
9353 cstombs(O(terminal_encoding),ptr1,charcount,(uintB*)ptr2,bytecount);
9354 ptr2[bytecount] = '\0';
9355 *ptr++ = ptr2;
9356 }
9357 unwind_C_HANDLER_frame();
9358 catch_return:
9359 /* Here we need the values of array and ptr. Avoid gcc warnings. */
9360 unused &array; /* avoid "'array' might be clobbered by 'longjmp'" */
9361 unused &ptr; /* avoid "'ptr' might be clobbered by 'longjmp'" */
9362 skipSTACK(3); /* unwind CATCH frame */
9363 STACK_0 = Cdr(STACK_0);
9364 }
9365 }
9366 skipSTACK(1); /* pop mlist */
9367 *ptr = NULL;
9368 }
9369 if (*array == NULL) {
9370 begin_system_call();
9371 free(array);
9372 end_system_call();
9373 array = NULL;
9374 }
9375 end_rl_callback();
9376 return array;
9377 }
9378 #endif
9379
9380 #if defined(UNIX) || defined(WIN32_NATIVE)
9381
9382 /* Functionality:
9383 Standard-Input and Standard-Output are accessed.
9384 Because of the possibility of Redirection some Functions have to determine, if
9385 Standard-Input is a Terminal or not.
9386 If Standard-Output is a Terminal or not, is irrelevant in this context.
9387 However, it is relevant, if Standard-Input and Standard-Output are the same
9388 Terminal; in this case we assume, that after completion of an input line
9389 (by NL) of Standard-Input the Cursor of Standard-Output is situated in
9390 column 0, and in this case we can also use the
9391 GNU readline()-Library.
9392
9393 There are three possible Variants of the Terminal-Streams:
9394 When Standard-Input and Standard-Output are not the same Terminal:
9395 * terminal1 normally,
9396 * terminal2 with per-line-buffering of the input,
9397 When Standard-Input and Standard-Output are the same Terminal:
9398 * terminal3 uses the readline()-Library, with per-line-buffering of
9399 Input and Output. */
9400
9401 #define HAVE_TERMINAL1
9402 /* define TERMINAL_LINEBUFFERED 0
9403 define TERMINAL_OUTBUFFERED 0 */
9404
9405 #ifdef GNU_READLINE
9406 /* We use the GNU Readline-Library. It returns the Input line-by-line,
9407 with possibility for editing, completion and History. unfortunately we
9408 have to save the Output intermediately line-by-line in order to be able to
9409 use the last commenced line as "Prompt". */
9410 #define HAVE_TERMINAL3
9411 /* define TERMINAL_LINEBUFFERED 1
9412 define TERMINAL_OUTBUFFERED 1 */
9413 #endif
9414
9415 /* Additional Components:
9416 ISATTY : Flag, if stdin is a TTY and if stdin and stdout are identical:
9417 NIL: stdin is a File or similar.
9418 T, EQUAL: stdin is a Terminal
9419 EQUAL: stdin and stdout are the same Terminal */
9420 #define strm_terminal_isatty strm_isatty
9421 #define strm_terminal_ihandle strm_ichannel
9422 #define strm_terminal_ohandle strm_ochannel
9423 #if defined(HAVE_TERMINAL2) || defined(HAVE_TERMINAL3)
9424 /* Components because of TERMINAL_LINEBUFFERED:
9425 INBUFF : input-buffer, a Semi-Simple-String */
9426 #define strm_terminal_inbuff strm_field1
9427 /* COUNT = its Fill-Pointer : number of characters in the input-buffer
9428 INDEX : number of already consumed characters */
9429 #define strm_terminal_index strm_other[2] /* FIXME: this is ugly */
9430 #endif
9431 #ifdef HAVE_TERMINAL3
9432 /* Components because of TERMINAL_OUTBUFFERED:
9433 OUTBUFF : output-buffer, a Semi-Simple-String */
9434 #define strm_terminal_outbuff strm_field2
9435 #endif
9436 #define strm_terminal_len strm_channel_len
9437
9438 /* distinction according to type of Terminal-Streams:
9439 terminalcase(stream, statement1,statement2,statement3); */
9440 #if defined(HAVE_TERMINAL2) && defined(HAVE_TERMINAL3)
9441 #define terminalcase(stream,statement1,statement2,statement3) \
9442 if (nullp(TheStream(stream)->strm_field2)) { \
9443 if (nullp(TheStream(stream)->strm_field1)) { statement1 } \
9444 else { statement2 } \
9445 } else { statement3 }
9446 #elif defined(HAVE_TERMINAL2)
9447 #define terminalcase(stream,statement1,statement2,statement3) \
9448 if (nullp(TheStream(stream)->strm_field1)) { statement1 } \
9449 else { statement2 }
9450 #elif defined(HAVE_TERMINAL3)
9451 #define terminalcase(stream,statement1,statement2,statement3) \
9452 if (nullp(TheStream(stream)->strm_field2)) { statement1 } \
9453 else { statement3 }
9454 #else
9455 #define terminalcase(stream,statement1,statement2,statement3) statement1
9456 #endif
9457
9458 #ifdef HAVE_TERMINAL1
9459
9460 /* read a character from a terminal-stream. */
rd_ch_terminal1(const gcv_object_t * stream_)9461 local maygc object rd_ch_terminal1 (const gcv_object_t* stream_) {
9462 var object ch = rd_ch_unbuffered(stream_);
9463 /* If both stdin and stdout are the same Terminal,
9464 and we read a NL, we can assume, that afterwards
9465 the cursor is situated in column 0. */
9466 if (eq(ch,ascii_char(NL))) {
9467 var object stream = *stream_;
9468 if (eq(TheStream(stream)->strm_terminal_isatty,S(equal)))
9469 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
9470 }
9471 return ch;
9472 }
9473
9474 /* Determines, if a character is available on a Terminal-Stream.
9475 listen_char_terminal1(stream)
9476 > stream: Terminal-Stream
9477 < result: input availability */
9478 #define listen_char_terminal1 listen_char_unbuffered
9479
9480 /* UP: Deletes already entered interactive Input from a Terminal-Stream.
9481 clear_input_terminal1(stream);
9482 > stream: Terminal-Stream
9483 < result: true if Input was deleted, else false */
9484 #define clear_input_terminal1 clear_input_unbuffered
9485
9486 /* UP: write a character to a Terminal-Stream.
9487 wr_ch_terminal1(&stream,ch);
9488 > stream: Terminal-Stream
9489 > ch: character to be written */
9490 #define wr_ch_terminal1 wr_ch_unbuffered_unix
9491
9492 /* UP: write several characters on a Terminal-Stream.
9493 wr_ch_array_terminal1(&stream,&chararray,start,len);
9494 > stream: Terminal-Stream
9495 > chararray: not-reallocated Simple-String
9496 > start: Startindex
9497 > len: number of characters to be written */
9498 #define wr_ch_array_terminal1 wr_ch_array_unbuffered_unix
9499
9500 /* UP: Deletes the pending Output of a Terminal-Stream.
9501 clear_output_terminal1(stream);
9502 > stream: Terminal-Stream
9503 can trigger GC */
9504 #define clear_output_terminal1 clear_output_unbuffered
9505
9506 #endif /* HAVE_TERMINAL1 */
9507
9508 #ifdef HAVE_TERMINAL2
9509
9510 #define TERMINAL_LINEBUFFERED true
9511
9512 /* read a character from a terminal-stream. */
rd_ch_terminal2(const gcv_object_t * stream_)9513 local maygc object rd_ch_terminal2 (const gcv_object_t* stream_) {
9514 var object stream = *stream_;
9515 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* EOF already? */
9516 return eof_value;
9517 if (!(posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9518 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1])) {
9519 /* index=count -> must read a whole line from the keyboard: */
9520 TheStream(stream)->strm_terminal_index = Fixnum_0; /* index := 0 */
9521 TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; /* count := 0 */
9522 while (1) {
9523 var object ch = rd_ch_unbuffered(stream_);
9524 if (eq(ch,eof_value)) {
9525 if (TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1] > 0)
9526 break; /* deliver character of the Buffer, only then return eof_value */
9527 else
9528 return eof_value;
9529 }
9530 /* add character ch to the input-line, poss. enlarge the line: */
9531 ssstring_push_extend(TheStream(stream)->strm_terminal_inbuff,char_code(ch));
9532 stream = *stream_;
9533 /* If both stdin and stdout are the same Terminal,
9534 and we read a NL, we can assume, that afterwards the
9535 Cursor is situated in column 0. */
9536 if (chareq(char_code(ch),ascii(NL))) {
9537 if (eq(TheStream(stream)->strm_terminal_isatty,S(equal)))
9538 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
9539 break; /* deliver character of the Buffer */
9540 }
9541 }
9542 ASSERT(posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9543 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1]);
9544 }
9545 /* index<count -> there are still characters in the buffer */
9546 var uintV index =
9547 posfixnum_to_V(TheStream(stream)->strm_terminal_index); /* Index */
9548 TheStream(stream)->strm_terminal_index =
9549 fixnum_inc(TheStream(stream)->strm_terminal_index,1); /* increase Index */
9550 return code_char(TheSnstring(TheIarray(TheStream(stream)->strm_terminal_inbuff)->data)->data[index]); /* next Character */
9551 }
9552
9553 /* Determines, if a character is available on a Terminal-Stream.
9554 listen_char_terminal2(stream)
9555 > stream: Terminal-Stream
9556 < result: input availability */
listen_char_terminal2(object stream)9557 local maygc listen_t listen_char_terminal2 (object stream) {
9558 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* EOF already? */
9559 return LISTEN_EOF;
9560 if (posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9561 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1])
9562 /* index<count -> there are still characters in the buffer */
9563 return LISTEN_AVAIL;
9564 return listen_char_unbuffered(stream);
9565 }
9566
9567 /* UP: Deletes already entered interactive Input from a Terminal-Stream.
9568 clear_input_terminal2(stream);
9569 > stream: Terminal-Stream
9570 < result: true if Input was deleted, else false
9571 can trigger GC */
clear_input_terminal2(object stream)9572 local maygc bool clear_input_terminal2 (object stream) {
9573 if (nullp(TheStream(stream)->strm_terminal_isatty)) /* File -> do nothing */
9574 return false;
9575 /* Terminal */
9576 pushSTACK(stream); /* save */
9577 clear_input_unbuffered(stream); /* forget about past EOF, call clear_tty_input */
9578 #if TERMINAL_LINEBUFFERED
9579 TheStream(STACK_0)->strm_terminal_index = Fixnum_0; /* index := 0 */
9580 TheIarray(TheStream(STACK_0)->strm_terminal_inbuff)->dims[1] = 0; /* count := 0 */
9581 #endif
9582 while (LISTEN_AVAIL == listen_char_terminal2(STACK_0))
9583 read_char(&STACK_0);
9584 skipSTACK(1); /* drop */
9585 return true;
9586 }
9587
9588 /* UP: Write a character to a Terminal-Stream.
9589 wr_ch_terminal2(&stream,ch);
9590 > stream: Terminal-Stream
9591 > ch: character to be written */
9592 #define wr_ch_terminal2 wr_ch_unbuffered_dos
9593
9594 /* UP: Write several characters to a Terminal-Stream.
9595 wr_ch_array_terminal2(&stream,&chararray,start,len);
9596 > stream: Terminal-Stream
9597 > chararray: not-reallocated Simple-String
9598 > start: Startindex
9599 > len: number of characters to be written */
9600 #define wr_ch_array_terminal2 wr_ch_array_unbuffered_dos
9601
9602 /* UP: Deletes the pending Output of a Terminal-Stream.
9603 clear_output_terminal2(stream);
9604 > stream: Terminal-Stream
9605 can trigger GC */
9606 #define clear_output_terminal2 clear_output_unbuffered
9607
9608 #endif /* HAVE_TERMINAL2 */
9609
9610 #ifdef HAVE_TERMINAL3
9611
9612 #define TERMINAL_LINEBUFFERED true
9613 #define TERMINAL_OUTBUFFERED true
9614
9615 local bool want_filename_completion;
lisp_completion_matches(READLINE_CONST char * text,int start,int end)9616 local char** lisp_completion_matches (READLINE_CONST char* text,
9617 int start, int end)
9618 { /* text[0..end-start-1] = the_line[start..end-1] */
9619 unused(text);
9620 if (((start>=2)
9621 && (rl_line_buffer[start-2]=='#')
9622 && (rl_line_buffer[start-1]== '\"'))
9623 || ((start>=3)
9624 && (rl_line_buffer[start-3]=='#')
9625 && (rl_line_buffer[start-2]=='P' || rl_line_buffer[start-2]=='p')
9626 && (rl_line_buffer[start-1]== '\"'))) {
9627 /* Completion after #" or #P" relates to file names: */
9628 want_filename_completion = true; return NULL;
9629 }
9630 var char** result = lisp_completion(rl_line_buffer,start,end);
9631 want_filename_completion = false;
9632 return result;
9633 }
9634
9635 /* If the function above returns NULL (no Matches), the following
9636 function is called until it returns NULL on its part. */
lisp_completion_more(READLINE_CONST char * text,int state)9637 local char* lisp_completion_more (READLINE_CONST char* text, int state) {
9638 if (want_filename_completion)
9639 return READLINE_FILE_COMPLETE(text,state);
9640 else
9641 return NULL;
9642 }
9643
9644 /* Strip trailing '\r' from the end of STRING.
9645 Returns STRING.
9646 Borrowed from BASH 2.05
9647 we do not strip the initial whitespace
9648 since it is needed for indentation.
9649 we do not strip the trailing whitespace since this would break
9650 READ-LINE on terminal streams: it must not strip whitespace. */
strip_white(char * string)9651 local char * strip_white (char *string) {
9652 char *end, *beg=string;
9653 if (beg == NULL) return NULL;
9654 /* while (ch_blank_p(*beg)) beg++; */
9655 if (*beg == 0) return beg;
9656 for (end = beg + strlen (beg) - 1; end > beg && (*end == '\r'); end--) ;
9657 *++end = '\0';
9658 return beg;
9659 }
9660
9661 #ifdef GNU_READLINE
9662 /* prototype here for rd_ch_terminal3()
9663 cannot have the whole thing here since they need rl_memory_abort()
9664 which calls make_terminal_stream() which is not yet defined */
9665 local char* xmalloc (int count);
9666 #endif
9667
9668 /* In the implementation of rd_ch_terminal3 and listen_char_terminal3, we
9669 should not use the corresponding rd_ch_unbuffered and listen_char_unbuffered
9670 functions, because they store intermediately read bytes in
9671 UnbufferedStream_bytebuf(stream), where readline() will not see them.
9672 As a workaround, we use rl_stuff_char() before calling readline().
9673
9674 However, there is a deeper problem with the rd_ch_terminal3/
9675 listen_char_terminal3 implementation: readline() terminates when `rl_done'
9676 gets set to 1, whereas listen_char_unbuffered normally returns LISTEN_AVAIL when
9677 the user has entered a line of characters followed by #\Newline. Normally
9678 this is the same condition, but if the user modifies his readline key
9679 bindings so that newline does not always cause `rl_done' to become 1, then
9680 rd_ch_terminal3() might block although listen_char_terminal3() returned
9681 LISTEN_AVAIL. One possible fix would be to use the READLINE_CALLBACK functions,
9682 see readline.dvi p. 29, but in order to get this right, RUN-PROGRAM and
9683 MAKE-PIPE-INPUT-STREAM might need to be modified to temporarily turn off
9684 readline. */
9685
history_last(void)9686 local HIST_ENTRY * history_last (void)
9687 { /* get the last history entry and its offset */
9688 HIST_ENTRY ** all = history_list();
9689 if (all == NULL) return NULL;
9690 while (*all) all++;
9691 return *(all-1);
9692 }
9693
9694 /* read a character from a terminal-stream.
9695 cp. rd_ch_unbuffered() : */
rd_ch_terminal3(const gcv_object_t * stream_)9696 local object rd_ch_terminal3 (const gcv_object_t* stream_) {
9697 var object stream = *stream_;
9698 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* EOF already? */
9699 return eof_value;
9700 if (!(posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9701 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1])) {
9702 /* index=count -> must read a whole line from the keyboard: */
9703 TheStream(stream)->strm_terminal_index = Fixnum_0; /* index := 0 */
9704 TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1] = 0; /* count := 0 */
9705 /* Pass bytes that we have already read down into readline's buffer. */
9706 while (UnbufferedStream_status(stream) > 0) {
9707 UnbufferedStreamLow_pop_byte(stream,b);
9708 begin_system_call(); rl_stuff_char(b); end_system_call();
9709 }
9710 {
9711 var object lastline = string_to_asciz(TheStream(stream)->strm_terminal_outbuff,TheStream(stream)->strm_encoding);
9712 var DYNAMIC_ARRAY(prompt,char,Sbvector_length(lastline)+1); /* Prompt: last output line */
9713 if (prompt!=NULL) {
9714 begin_system_call();
9715 strcpy(prompt,TheAsciz(lastline));
9716 end_system_call();
9717 }
9718 /* lexema-separating characters: with syntax code whsp,tmac,nmac
9719 (see IO.D, actually depends on the current *READTABLE*): */
9720 rl_basic_word_break_characters = "\t\n \"#'(),;`";
9721 rl_basic_quote_characters = "\"|";
9722 rl_completer_quote_characters = "\\|";
9723 begin_blocking_system_call();
9724 rl_already_prompted = true;
9725 var char* line = strip_white(readline(prompt==NULL ? "" : prompt));
9726 end_blocking_system_call();
9727 FREE_DYNAMIC_ARRAY(prompt);
9728 if (line==NULL)
9729 /* detect EOF (at the start of line) */
9730 return eof_value;
9731 /* add read line to the input line: */
9732 #ifdef ENABLE_UNICODE
9733 {
9734 var object inbuff = TheStream(*stream_)->strm_terminal_inbuff;
9735 var object encoding = TheStream(*stream_)->strm_encoding;
9736 var const uintB* bptr = (uintB*)line;
9737 var const uintB* bendptr = bptr + asciz_length((const char*)bptr);
9738 var uintL clen = Encoding_mblen(encoding)(encoding,bptr,bendptr);
9739 ssstring_extend(inbuff,TheIarray(inbuff)->dims[1]+clen);
9740 inbuff = TheStream(*stream_)->strm_terminal_inbuff;
9741 encoding = TheStream(*stream_)->strm_encoding;
9742 var chart* cptr = &TheSnstring(TheIarray(inbuff)->data)->data[TheIarray(inbuff)->dims[1]];
9743 var chart* cendptr = cptr+clen;
9744 Encoding_mbstowcs(encoding)(encoding,nullobj,&bptr,bendptr,&cptr,cendptr);
9745 ASSERT(cptr == cendptr);
9746 TheIarray(inbuff)->dims[1] += clen;
9747 }
9748 #else
9749 {
9750 var const uintB* ptr = (uintB*)line;
9751 while (*ptr != '\0') {
9752 ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,
9753 as_chart(*ptr++));
9754 }
9755 }
9756 #endif
9757 ssstring_push_extend(TheStream(*stream_)->strm_terminal_inbuff,
9758 ascii(NL));
9759 /* put into the history if non-empty */
9760 begin_system_call();
9761 if (line[0] != '\0') {
9762 var HIST_ENTRY *last = history_last();
9763 if (boundp(Symbol_value(S(terminal_read_open_object)))) {
9764 /* append this line to the previous history entry */
9765 ASSERT(last); /* in the middle of something => history non-empty */
9766 var char *new_line =
9767 (char*)xmalloc(2 + strlen(line) + strlen(last->line));
9768 /* strcpy(new_line,last->line[0]=='\n' ? "" : "\n"); */
9769 strcpy(new_line,last->line);
9770 strcat(new_line,"\n");
9771 strcat(new_line,line);
9772 free(last->line);
9773 last->line = new_line;
9774 } else if (last==NULL || !asciz_equal(line,last->line))
9775 /* this is different from the last one, save it */
9776 add_history(line);
9777 }
9778 free(line); /* must release the original line */
9779 end_system_call();
9780 }
9781 stream = *stream_;
9782 /* If both stdin and stdout are the same Terminal, we can assume,
9783 that the Cursor is situated in column 0. */
9784 if (eq(TheStream(stream)->strm_terminal_isatty,S(equal))) {
9785 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
9786 TheIarray(TheStream(stream)->strm_terminal_outbuff)->dims[1] = 0; /* Fill-Pointer := 0 */
9787 }
9788 ASSERT(posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9789 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1]);
9790 }
9791 /* index<count -> there are still characters in the buffer */
9792 var uintV index =
9793 posfixnum_to_V(TheStream(stream)->strm_terminal_index); /* Index */
9794 TheStream(stream)->strm_terminal_index =
9795 fixnum_inc(TheStream(stream)->strm_terminal_index,1); /* increase Index */
9796 return code_char(TheSnstring(TheIarray(TheStream(stream)->strm_terminal_inbuff)->data)->data[index]); /* next Character */
9797 }
9798
9799 /* Determines, if a character is available on a Terminal-Stream.
9800 listen_char_terminal3(stream)
9801 > stream: Terminal-Stream
9802 < result: input availability */
listen_char_terminal3(object stream)9803 local listen_t listen_char_terminal3 (object stream) {
9804 if (eq(TheStream(stream)->strm_rd_ch_last,eof_value)) /* EOF already? */
9805 return LISTEN_EOF;
9806 if (posfixnum_to_V(TheStream(stream)->strm_terminal_index)
9807 < TheIarray(TheStream(stream)->strm_terminal_inbuff)->dims[1])
9808 /* index<count -> there are still characters in the buffer */
9809 return LISTEN_AVAIL;
9810 return listen_char_unbuffered(stream);
9811 }
9812
9813 /* UP: Deletes already entered interactive Input from a Terminal-Stream.
9814 clear_input_terminal3(stream);
9815 > stream: Terminal-Stream
9816 < result: true if Input was deleted, else false
9817 can trigger GC */
clear_input_terminal3(object stream)9818 local maygc bool clear_input_terminal3 (object stream) {
9819 if (nullp(TheStream(stream)->strm_terminal_isatty)) /* File -> do nothing */
9820 return false;
9821 /* Terminal */
9822 pushSTACK(stream); /* save */
9823 clear_input_unbuffered(stream); /* forget about past EOF, call clear_tty_input */
9824 #if TERMINAL_LINEBUFFERED
9825 TheStream(STACK_0)->strm_terminal_index = Fixnum_0; /* index := 0 */
9826 TheIarray(TheStream(STACK_0)->strm_terminal_inbuff)->dims[1] = 0; /* count := 0 */
9827 #endif
9828 while (LISTEN_AVAIL == listen_char_terminal3(STACK_0))
9829 read_char(&STACK_0);
9830 skipSTACK(1); /* drop */
9831 return true;
9832 }
9833
9834 /* UP: Write a character to a Terminal-Stream.
9835 wr_ch_terminal3(&stream,ch);
9836 > stream: Terminal-Stream
9837 > ch: character to be written */
wr_ch_terminal3(const gcv_object_t * stream_,object ch)9838 local maygc void wr_ch_terminal3 (const gcv_object_t* stream_, object ch) {
9839 check_wr_char(*stream_,ch);
9840 #if TERMINAL_OUTBUFFERED
9841 {
9842 var chart c = char_code(ch); /* Code of the character */
9843 if (chareq(c,ascii(NL)))
9844 TheIarray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; /* Fill-Pointer := 0 */
9845 else
9846 ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,c);
9847 }
9848 #endif
9849 { var object eol = TheEncoding(TheStream(*stream_)->strm_encoding)->enc_eol;
9850 if (eq(eol,S(Kunix)))
9851 wr_ch_unbuffered_unix(stream_,ch);
9852 else if (eq(eol,S(Kmac)))
9853 wr_ch_unbuffered_mac(stream_,ch);
9854 else if (eq(eol,S(Kdos)))
9855 wr_ch_unbuffered_dos(stream_,ch);
9856 else
9857 NOTREACHED;
9858 }
9859 }
9860
9861 /* UP: Write several characters to a Terminal-Stream.
9862 wr_ch_array_terminal3(&stream,&chararray,start,len);
9863 > stream: Terminal-Stream
9864 > chararray: not-reallocated Simple-String
9865 > start: Startindex
9866 > len: number of characters to be written */
wr_ch_array_terminal3(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)9867 local maygc void wr_ch_array_terminal3 (const gcv_object_t* stream_,
9868 const gcv_object_t* chararray_,
9869 uintL start, uintL len) {
9870 { var object eol = TheEncoding(TheStream(*stream_)->strm_encoding)->enc_eol;
9871 if (eq(eol,S(Kunix)))
9872 wr_ch_array_unbuffered_unix(stream_,chararray_,start,len);
9873 else if (eq(eol,S(Kmac)))
9874 wr_ch_array_unbuffered_mac(stream_,chararray_,start,len);
9875 else if (eq(eol,S(Kdos)))
9876 wr_ch_array_unbuffered_dos(stream_,chararray_,start,len);
9877 else
9878 NOTREACHED;
9879 }
9880 #if TERMINAL_OUTBUFFERED
9881 {
9882 var object string = *chararray_;
9883 var const chart* ptr;
9884 unpack_sstring_alloca(string,len,start, ptr =);
9885 /* characters since the last NL in the Buffer: */
9886 var uintL pos = 0; /* count the number of characters since the last NL */
9887 var uintL count;
9888 ptr += len;
9889 dotimespL(count,len, {
9890 if (chareq(*--ptr,ascii(NL)))
9891 goto found_NL;
9892 pos++;
9893 });
9894 if (false) {
9895 found_NL: /* pos characters since the last NL */
9896 ptr++;
9897 TheIarray(TheStream(*stream_)->strm_terminal_outbuff)->dims[1] = 0; /* Fill-Pointer := 0 */
9898 }
9899 if (pos > 0) {
9900 SstringCase(string, {
9901 /* ptr points into the stack, not the string, so it's GC-safe. */
9902 dotimespL(count,pos, {
9903 ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,
9904 *ptr++);
9905 });
9906 },{
9907 /* ptr points into the stack, not the string, so it's GC-safe. */
9908 dotimespL(count,pos, {
9909 ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,
9910 *ptr++);
9911 });
9912 },{
9913 /* ptr points into the string, not GC-safe. */
9914 var uintL index = start + len - pos;
9915 dotimespL(count,pos, {
9916 ssstring_push_extend(TheStream(*stream_)->strm_terminal_outbuff,
9917 TheSnstring(*chararray_)->data[index]);
9918 index++;
9919 });
9920 },{
9921 NOTREACHED;
9922 });
9923 }
9924 }
9925 #endif
9926 }
9927
9928 /* UP: Deletes the pending Output of a Terminal-Stream.
9929 clear_output_terminal3(stream);
9930 > stream: Terminal-Stream
9931 can trigger GC */
clear_output_terminal3(object stream)9932 local maygc void clear_output_terminal3 (object stream) {
9933 #if TERMINAL_OUTBUFFERED
9934 pushSTACK(stream); /* save */
9935 #endif
9936 clear_output_unbuffered(stream);
9937 #if TERMINAL_OUTBUFFERED
9938 stream = popSTACK(); /* restore */
9939 TheIarray(TheStream(stream)->strm_terminal_outbuff)->dims[1] = 0; /* Fill-Pointer := 0 */
9940 #endif
9941 }
9942
9943 #endif /* HAVE_TERMINAL3 */
9944
9945 /* UP: Moves the pending Output of a Terminal-Stream to the destination.
9946 finish_output_terminal(stream);
9947 > stream: Terminal-Stream
9948 can trigger GC */
9949 #define finish_output_terminal finish_output_unbuffered
9950
9951 /* UP: Moves the pending Output of a Terminal-Stream to the destination.
9952 force_output_terminal(stream);
9953 > stream: Terminal-Stream
9954 can trigger GC */
9955 #define force_output_terminal force_output_unbuffered
9956
stdio_same_tty_p(void)9957 local bool stdio_same_tty_p (void)
9958 { /* check that STDIN and STDOUT point to the same TTY */
9959 #ifdef UNIX
9960 #if defined(UNIX_CYGWIN)
9961 /* st_ino does not make sense on Cygwin: they are based on
9962 filenames, and stdin is CONIN$ while stdout is CONOUT$ */
9963 var char* res = ttyname(stdin_handle);
9964 if (strcmp(res,"/dev/conin")) { /* not a windows console, maybe X? */
9965 var char tmp[MAXPATHLEN];
9966 strcpy(tmp,res);
9967 return !strcmp(tmp,ttyname(stdout_handle));
9968 } else
9969 return !strcmp("/dev/conout",ttyname(stdout_handle));
9970 #else /* ttyname() is rather slow, fstat() is faster. */
9971 var struct stat stdin_stat;
9972 var struct stat stdout_stat;
9973 return (fstat(stdin_handle,&stdin_stat) >= 0)
9974 && (fstat(stdout_handle,&stdout_stat) >= 0)
9975 && (stdin_stat.st_dev == stdout_stat.st_dev)
9976 && (stdin_stat.st_ino == stdout_stat.st_ino);
9977 #endif
9978 #endif
9979 #ifdef WIN32_NATIVE
9980 var DWORD console_mode;
9981 return GetConsoleMode(stdin_handle,&console_mode)
9982 && GetConsoleMode(stdout_handle,&console_mode);
9983 #endif
9984 }
9985
9986 /* Returns an interactive Terminal-Stream.
9987 can trigger GC */
make_terminal_stream_(void)9988 local maygc object make_terminal_stream_ (void) {
9989 begin_system_call();
9990 var bool stdin_tty = isatty(stdin_handle); /* stdin a Terminal? */
9991 var bool stdout_tty = isatty(stdout_handle); /* stdout a Terminal? */
9992 var bool same_tty = stdin_tty && stdout_tty && stdio_same_tty_p();
9993 end_system_call();
9994 #ifdef HAVE_TERMINAL3
9995 /* we handle all signals ourselves */
9996 rl_catch_signals = 0;
9997 if (rl_gnu_readline_p && same_tty && !disable_readline) { /* Build a TERMINAL3-Stream: */
9998 pushSTACK(make_ssstring(80)); /* allocate line-buffer */
9999 pushSTACK(make_ssstring(80)); /* allocate line-buffer */
10000 pushSTACK(allocate_handle(stdout_handle));
10001 pushSTACK(allocate_handle(stdin_handle));
10002 /* allocate new Stream: */
10003 var object stream = /* Flags: only READ-CHAR and WRITE-CHAR allowed */
10004 allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal_len,
10005 sizeof(strm_unbuffered_extrafields_t));
10006 /* and fill: */
10007 stream_dummy_fill(stream);
10008 var Stream s = TheStream(stream);
10009 s->strm_encoding = O(terminal_encoding);
10010 s->strm_rd_ch = P(rd_ch_terminal3); /* READ-CHAR-Pseudofunction */
10011 s->strm_rd_ch_array = P(rd_ch_array_dummy); /* READ-CHAR-SEQUENCE-Pseudofunction */
10012 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_terminal3); /* WRITE-CHAR-Pseudofunction */
10013 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_terminal3); /* WRITE-CHAR-SEQUENCE-Pseudofunction */
10014 s->strm_terminal_isatty = S(equal); /* stdout=stdin */
10015 s->strm_terminal_ihandle = popSTACK(); /* Handle for listen_char_unbuffered() */
10016 s->strm_terminal_ohandle = popSTACK(); /* Handle for Output */
10017 #if 1 /* TERMINAL_LINEBUFFERED */
10018 s->strm_terminal_inbuff = popSTACK(); /* register line buffer, count := 0 */
10019 s->strm_terminal_index = Fixnum_0; /* index := 0 */
10020 #endif
10021 #if 1 /* TERMINAL_OUTBUFFERED */
10022 s->strm_terminal_outbuff = popSTACK(); /* register line buffer */
10023 #endif
10024 ChannelStream_buffered(stream) = false;
10025 ChannelStream_regular(stream) = false;
10026 ChannelStream_init(stream);
10027 UnbufferedHandleStream_input_init(stream);
10028 UnbufferedHandleStream_output_init(stream);
10029 return stream;
10030 }
10031 #endif
10032 #ifdef HAVE_TERMINAL2
10033 if (stdin_tty) { /* Build a TERMINAL2-Stream: */
10034 pushSTACK(make_ssstring(80)); /* allocate line-buffer */
10035 pushSTACK(allocate_handle(stdout_handle));
10036 pushSTACK(allocate_handle(stdin_handle));
10037 /* allocate new Stream: */
10038 var object stream = /* Flags: only READ-CHAR and WRITE-CHAR allowed */
10039 allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal_len,
10040 sizeof(strm_unbuffered_extrafields_t));
10041 /* and fill: */
10042 stream_dummy_fill(stream);
10043 var Stream s = TheStream(stream);
10044 s->strm_encoding = O(terminal_encoding);
10045 s->strm_rd_ch = P(rd_ch_terminal2); /* READ-CHAR-Pseudofunction */
10046 s->strm_rd_ch_array = P(rd_ch_array_dummy); /* READ-CHAR-SEQUENCE-Pseudofunction */
10047 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_terminal2); /* WRITE-CHAR-Pseudofunction */
10048 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_terminal2); /* WRITE-CHAR-SEQUENCE-Pseudofunction */
10049 s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL);
10050 s->strm_terminal_ihandle = popSTACK(); /* Handle for listen_char_unbuffered() */
10051 s->strm_terminal_ohandle = popSTACK(); /* Handle for Output */
10052 #if 1 /* TERMINAL_LINEBUFFERED */
10053 s->strm_terminal_inbuff = popSTACK(); /* register line buffer, count := 0 */
10054 s->strm_terminal_index = Fixnum_0; /* index := 0 */
10055 #endif
10056 ChannelStream_buffered(stream) = false;
10057 ChannelStream_regular(stream) = false;
10058 ChannelStream_init(stream);
10059 UnbufferedHandleStream_input_init(stream);
10060 UnbufferedHandleStream_output_init(stream);
10061 return stream;
10062 }
10063 #endif
10064 /* Build a TERMINAL1-Stream: */
10065 {
10066 pushSTACK(allocate_handle(stdout_handle));
10067 pushSTACK(allocate_handle(stdin_handle));
10068 /* allocate new Stream: */
10069 var object stream = /* Flags: only READ-CHAR and WRITE-CHAR allowed */
10070 allocate_stream(strmflags_ch_B,strmtype_terminal,strm_terminal_len,
10071 sizeof(strm_unbuffered_extrafields_t));
10072 /* and fill: */
10073 stream_dummy_fill(stream);
10074 var Stream s = TheStream(stream);
10075 s->strm_encoding = O(terminal_encoding);
10076 s->strm_rd_ch = P(rd_ch_terminal1); /* READ-CHAR-Pseudofunction */
10077 s->strm_rd_ch_array = P(rd_ch_array_dummy); /* READ-CHAR-SEQUENCE-Pseudofunction */
10078 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_terminal1); /* WRITE-CHAR-Pseudofunction */
10079 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_terminal1); /* WRITE-CHAR-SEQUENCE-Pseudofunction */
10080 s->strm_terminal_isatty = (stdin_tty ? (same_tty ? S(equal) : T) : NIL);
10081 s->strm_terminal_ihandle = popSTACK(); /* Handle for listen_char_unbuffered() */
10082 s->strm_terminal_ohandle = popSTACK(); /* Handle for Output */
10083 ChannelStream_buffered(stream) = false;
10084 ChannelStream_regular(stream) = false;
10085 ChannelStream_init(stream);
10086 UnbufferedHandleStream_input_init(stream);
10087 UnbufferedHandleStream_output_init(stream);
10088 return stream;
10089 }
10090 }
10091
10092 #ifdef UNIX
10093
10094 /* (SYS::TERMINAL-RAW *terminal-io* flag [errorp])
10095 flag /= NIL: sets the Terminal in cbreak/noecho-Mode,
10096 flag = NIL: sets the Terminal back in nocbreak/echo-Mode.
10097 If it is not possible and errorp is specified and is /= NIL, Error is reported.
10098 Returns the old Mode. */
10099
10100 /* (SYS::TERMINAL-RAW *terminal-io* t) is essentially
10101 (progn
10102 ; no possibilities for editing, no Echo, no CR<-->NL-conversions:
10103 (shell "stty -icanon -echo -icrnl -inlcr")
10104 ; don't catch anything:
10105 ; C-S C-Q Del C-U C-W C-R C-O C-V C-Y C-C C-\ C-Q C-S C-D
10106 (shell "stty -ixon -ixoff erase ^- kill ^- werase ^- rprnt ^- flush ^- lnext ^- susp ^- intr ^- quit ^- start ^- stop ^- eof ^-")
10107 ; demand 1 character at a time (not 4!):
10108 (shell "stty min 1") ; this has to come at the end, paradoxically...
10109 )
10110 (SYS::TERMINAL-RAW *terminal-io* nil) is essentially
10111 (shell "stty sane") */
10112
10113 local void term_raw (void);
10114 local void term_unraw (void);
10115
10116 local bool oldterm_initialized = false;
10117
10118 #ifdef UNIX_TERM_TERMIOS
10119 local struct termios oldtermio; /* original TTY-Mode */
term_raw()10120 local void term_raw() {
10121 if (!oldterm_initialized) {
10122 if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) {
10123 if (!(errno==ENOTTY)) { OS_error(); }
10124 }
10125 oldterm_initialized = true;
10126 }
10127 var struct termios newtermio;
10128 newtermio = oldtermio;
10129 newtermio.c_iflag &= ( /* IXON|IXOFF|IXANY| */ ISTRIP|IGNBRK);
10130 /* newtermio.c_oflag &= ~OPOST; */ /* Curses is deranged by this! */
10131 newtermio.c_lflag &= ISIG;
10132 {
10133 var uintC i;
10134 for (i=0; i<NCCS; i++)
10135 newtermio.c_cc[i] = 0;
10136 }
10137 newtermio.c_cc[VMIN] = 1;
10138 newtermio.c_cc[VTIME] = 0;
10139 if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&newtermio) ==0)) {
10140 if (!(errno==ENOTTY)) { OS_error(); }
10141 }
10142 }
term_unraw()10143 local void term_unraw() {
10144 if (oldterm_initialized) {
10145 if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) {
10146 if (!(errno==ENOTTY)) { OS_error(); }
10147 }
10148 }
10149 }
10150 /* Some do it like this:
10151 define crmode() (_tty.c_lflag &=~ICANON,_tty.c_cc[VMIN]=1,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
10152 define nocrmode() (_tty.c_lflag |= ICANON,_tty.c_cc[VEOF] = CEOF,tcsetattr(_tty_ch, TCSAFLUSH,&_tty))
10153 define echo() (_tty.c_lflag |= ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
10154 define noecho() (_tty.c_lflag &=~ECHO, tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
10155 define nl() (_tty.c_iflag |= ICRNL,_tty.c_oflag |= ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
10156 define nonl() (_tty.c_iflag &=~ICRNL,_tty.c_oflag &=~ONLCR,tcsetattr(_tty_ch, TCSAFLUSH, &_tty))
10157 define savetty() (tcgetattr(_tty_ch, &_oldtty),tcgetattr(_tty_ch, &_tty))
10158 define resetty() (tcsetattr(_tty_ch, TCSAFLUSH, &_oldtty)) */
10159 #endif
10160
10161 /* We store, if term_raw() or term_unraw() was executed lastly,
10162 therewith we can switch back on program-exit. */
10163 local bool terminal_raw = false;
10164
terminal_sane(void)10165 global void terminal_sane (void) {
10166 if (terminal_raw) {
10167 term_unraw();
10168 terminal_raw = false;
10169 }
10170 }
10171
10172 LISPFUN(terminal_raw,seclass_default,2,1,norest,nokey,0,NIL) {
10173 skipSTACK(1); /* ignore errorp */
10174 var object flag = popSTACK();
10175 var object stream = check_stream(popSTACK());
10176 stream = resolve_synonym_stream(stream);
10177 value1 = NIL;
10178 if (builtin_stream_p(stream)) {
10179 if (((TheStream(stream)->strmtype == strmtype_terminal) /* Terminal-Stream */
10180 && !nullp(TheStream(stream)->strm_terminal_isatty)) /* Terminal */
10181 #ifdef KEYBOARD
10182 || ((TheStream(stream)->strmtype == strmtype_keyboard) /* Keyboard-Stream */
10183 && !nullp(TheStream(stream)->strm_keyboard_isatty))
10184 #endif
10185 ) {
10186 value1 = (terminal_raw ? T : NIL);
10187 begin_system_call();
10188 if (!nullp(flag)) { /* switch to cbreak/noecho-Mode: */
10189 term_raw(); terminal_raw = true;
10190 } else { /* switch to nocbreak/echo-Mode: */
10191 term_unraw(); terminal_raw = false;
10192 }
10193 end_system_call();
10194 }
10195 }
10196 mv_count=1;
10197 }
10198
10199 #endif /* UNIX */
10200
10201 #endif /* UNIX || WIN32_NATIVE */
10202
10203 #if !defined(UNIX)
10204 LISPFUN(terminal_raw,seclass_default,2,1,norest,nokey,0,NIL) {
10205 VALUES1(NIL); skipSTACK(3); /* do nothing */
10206 }
10207 #endif
10208
10209 /* Returns an interactive Terminal-Stream.
10210 can trigger GC */
make_terminal_stream(void)10211 local maygc object make_terminal_stream (void) {
10212 return add_to_open_streams(make_terminal_stream_());
10213 }
10214
10215
10216 /* Window-Stream
10217 ============= */
10218
10219 #ifdef SCREEN
10220
10221 /* Editor-Support:
10222 CURSES: A Window-Stream is essentially a Curses-WINDOW.
10223
10224 (SCREEN:MAKE-WINDOW)
10225 returns a Window-Stream. Until it is closed again,
10226 the Terminal is in cbreak-noecho-Mode; further In-/Output via
10227 *terminal-io* should not happen during this period of time.
10228
10229 (SCREEN:WINDOW-SIZE window-stream)
10230 returns the size of the Window,
10231 as 2 values: Height (= Ymax+1), Width (= Xmax+1).
10232
10233 (SCREEN:WINDOW-CURSOR-POSITION window-stream)
10234 returns the Position of the Cursor in the Window
10235 as 2 values: row (>=0, <=Ymax, 0=oben), column (>=0, <=Xmax, 0=links).
10236
10237 (SCREEN:SET-WINDOW-CURSOR-POSITION window-stream line column)
10238 sets the Position of the Cursor in the Window.
10239
10240 (SCREEN:CLEAR-WINDOW window-stream)
10241 deletes the content of the Window and
10242 positions the Cursor to the upper left corner
10243
10244 (SCREEN:CLEAR-WINDOW-TO-EOT window-stream)
10245 deletes the content of the Window from Cursor-Position to end of screen
10246
10247 (SCREEN:CLEAR-WINDOW-TO-EOL window-stream)
10248 deletes the content of the Window from Cursor-Position to end of line
10249
10250 (SCREEN:DELETE-WINDOW-LINE window-stream)
10251 deletes the cursor-line, shifts the lines below up one row
10252 and deletes the last line of the screen.
10253
10254 (SCREEN:INSERT-WINDOW-LINE window-stream)
10255 inserts a new line at the line of the cursor and thereby shifts down
10256 all lines starting at the cursor by 1.
10257
10258 (SCREEN:HIGHLIGHT-ON window-stream)
10259 switches on "highlighted" output.
10260
10261 (SCREEN:HIGHLIGHT-OFF window-stream)
10262 switches off "highlighted" output again.
10263
10264 (SCREEN:WINDOW-CURSOR-ON window-stream)
10265 turns the Cursor(block) visible.
10266
10267 (SCREEN:WINDOW-CURSOR-OFF window-stream)
10268 turns the Cursor(block) invisible again.
10269
10270 check that the argument is a window-stream. */
check_window_stream(object stream)10271 local object check_window_stream (object stream) {
10272 if (!(builtin_stream_p(stream)
10273 && (TheStream(stream)->strmtype == strmtype_window))) {
10274 pushSTACK(stream);
10275 pushSTACK(TheSubr(subr_self)->name);
10276 error(error_condition,GETTEXT("~S: argument ~S should be a window stream"));
10277 }
10278 return stream;
10279 }
10280
10281 #ifdef WIN32_NATIVE
10282
resize_screen(int rows,int columns)10283 global void resize_screen (int rows, int columns) {}
10284
10285 /* Implementation on top of the Win32 console.
10286 Contributed by Arseny Slobodjuck <ampy@crosswinds.net>, 2001-02-14
10287 modified on 2001-07-31
10288
10289 The API is documented at
10290 http://www.msdn.microsoft.com/library/psdk/winbase/conchar_4svm.htm
10291 (Platform SDK documentation -> Base Services -> Files and I/O ->
10292 Consoles and Character-Mode Support -> About Character Mode Support ->
10293 Consoles)
10294
10295 console is a kind of channel stream
10296
10297 accessor that can be used at the Right Side */
10298 #define ConsoleHandleR(stream) TheHandle(TheStream(stream)->strm_ochannel)
10299
10300 typedef struct win32_console_extrafields_t {
10301 strm_channel_extrafields_t channel_fields;
10302 COORD cursor_position;
10303 COORD console_size;
10304 WORD attribute;
10305 bool handle_reused;
10306 } win32_console_extrafields_t;
10307
10308 #define ConsoleData(stream) ((win32_console_extrafields_t*)&TheStream(stream)->strm_channel_extrafields)
10309
10310 /* The following attribute constants are defined in the <wincon.h> header file:
10311 FOREGROUND_BLUE
10312 FOREGROUND_GREEN
10313 FOREGROUND_RED
10314 FOREGROUND_INTENSITY
10315 BACKGROUND_BLUE
10316 BACKGROUND_GREEN
10317 BACKGROUND_RED
10318 BACKGROUND_INTENSITY */
10319
10320 local const WORD attr_table[5] = {
10321 /* no standout */
10322 BACKGROUND_BLUE
10323 | FOREGROUND_BLUE | FOREGROUND_GREEN | FOREGROUND_RED,
10324 /* standout */
10325 BACKGROUND_BLUE
10326 | FOREGROUND_INTENSITY | FOREGROUND_BLUE | FOREGROUND_GREEN | FOREGROUND_RED,
10327 /* visible bell */
10328 BACKGROUND_BLUE
10329 | FOREGROUND_INTENSITY | FOREGROUND_RED,
10330 /* underline */
10331 BACKGROUND_BLUE
10332 | FOREGROUND_INTENSITY | FOREGROUND_GREEN,
10333 /* alt. char set */
10334 BACKGROUND_BLUE
10335 | FOREGROUND_INTENSITY | FOREGROUND_GREEN | FOREGROUND_RED
10336 };
10337
move_ccp_by(COORD * pos,COORD sz,int by)10338 local void move_ccp_by(COORD *pos,COORD sz,int by) {
10339 var int linear_ccp = pos->Y * sz.X + pos->X;
10340 var int new_linear = linear_ccp + by;
10341 pos->X = new_linear % sz.X;
10342 pos->Y = ( new_linear % ( sz.X * sz.Y )) / sz.X;
10343 }
10344
v_move(HANDLE handle,uintW y,uintW x)10345 local void v_move(HANDLE handle,uintW y,uintW x) {
10346 /* set cursor */
10347 var COORD pos;
10348 pos.X = x; pos.Y = y;
10349 SetConsoleCursorPosition(handle,pos);
10350 }
10351
v_emit_spaces(HANDLE handle,COORD * pos,int nspaces,uintW attr)10352 local void v_emit_spaces(HANDLE handle,COORD *pos,int nspaces,uintW attr) {
10353 var DWORD i;
10354 FillConsoleOutputAttribute(handle,attr,nspaces,*pos,&i);
10355 FillConsoleOutputCharacter(handle,' ',nspaces,*pos,&i);
10356 }
10357
v_cb(HANDLE handle)10358 local void v_cb (HANDLE handle) {
10359 /* cursor have 50 percent fill and visibility */
10360 var CONSOLE_CURSOR_INFO ci = { 50, 1 };
10361 SetConsoleCursorInfo(handle,&ci);
10362 }
10363
v_cs(HANDLE handle)10364 local void v_cs (HANDLE handle) {
10365 /* cursor have 10 percent fill and 0 visibility */
10366 var CONSOLE_CURSOR_INFO ci = { 10, 0 };
10367 SetConsoleCursorInfo(handle,&ci);
10368 }
10369
v_ce(HANDLE handle,COORD * pos,COORD sz,uintW attr)10370 local void v_ce (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10371 /* clear to end: get cursor position and emit the appropriate number
10372 of spaces, without moving cursor. attr of spaces set to default. */
10373 var int nspaces = sz.X - pos->X;
10374 v_emit_spaces(handle,pos,nspaces,attr);
10375 }
10376
v_cl(HANDLE handle,COORD * pos,COORD sz,uintW attr)10377 local void v_cl (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10378 var int nspaces = sz.X * sz.Y;
10379 v_emit_spaces(handle,pos,nspaces,attr);
10380 v_move(handle,0,0);
10381 }
10382
v_cd(HANDLE handle,COORD * pos,COORD sz,uintW attr)10383 local void v_cd (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10384 /* clear to bottom: get position, clear to eol, clear next line to end */
10385 var int nspaces = (sz.Y - pos->Y) * sz.X - pos->X;
10386 v_emit_spaces(handle,pos,nspaces,attr);
10387 }
10388
v_scroll(HANDLE handle,int ax,int ay,int bx,int by,int n,uintW attr)10389 local void v_scroll (HANDLE handle,int ax,int ay,int bx,int by,
10390 int n,uintW attr) {
10391 var CHAR_INFO c;
10392 var SMALL_RECT r1;
10393 var SMALL_RECT r2;
10394 var COORD p;
10395 c.Char.AsciiChar = ' '; c.Attributes = attr;
10396 r1.Left = ax; r1.Top = ay; r1.Right = bx; r1.Bottom = by;
10397 r2 = r1;
10398 p.X = ax; p.Y = ay + n;
10399 ScrollConsoleScreenBuffer(handle,&r1,&r2,p,&c);
10400 }
10401
v_al(HANDLE handle,COORD * pos,COORD sz,uintW attr)10402 local void v_al (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10403 /* add line: scroll rest of screen down */
10404 v_scroll(handle,0,pos->Y+1,sz.X-1,sz.Y-1,1,attr);
10405 }
10406
v_dl(HANDLE handle,COORD * pos,COORD sz,uintW attr)10407 local void v_dl (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10408 /* delete line: scroll rest up */
10409 v_scroll(handle,0,pos->Y,sz.X-1,sz.Y-1,-1,attr);
10410 }
10411
v_su(HANDLE handle,COORD * pos,COORD sz,uintW attr)10412 local void v_su (HANDLE handle,COORD *pos,COORD sz,uintW attr) {
10413 /* not used. why is it here ?
10414 scroll up: scroll whole screen */
10415 v_scroll(handle,0,0,sz.X-1,sz.Y-1,-1,attr);
10416 }
10417
v_put(HANDLE handle,uintW ch,COORD * pos,COORD sz,uintW attr)10418 local uintW v_put(HANDLE handle,uintW ch,COORD *pos,COORD sz,uintW attr) {
10419 /* put character:
10420 put attribute and char (no scroll!), then update cursor position. */
10421 ch &= 0xff;
10422 if (ch==NL) {
10423 pos->Y += 1;
10424 pos->Y %= sz.Y;
10425 pos->X = 0;
10426 } else {
10427 CHAR_INFO c;
10428 SMALL_RECT rto;
10429 COORD p0;
10430 COORD p1;
10431 c.Char.AsciiChar = ch;
10432 c.Attributes = attr;
10433 rto.Left = pos->X; rto.Top = pos->Y;
10434 rto.Right = pos->X+1; rto.Bottom = pos->Y+1;
10435 p0.X = 0; p0.Y = 0;
10436 p1.X = 1; p1.Y = 1;
10437 WriteConsoleOutput(handle,&c,p1,p0,&rto);
10438 move_ccp_by(pos,sz,1);
10439 }
10440 return ch;
10441 }
10442
v_puts(HANDLE handle,char * s,COORD * pos,COORD sz,uintW attr)10443 local void v_puts(HANDLE handle,char *s,COORD *pos,COORD sz,uintW attr) {
10444 var char * cp = s; /* cp = current position */
10445 var char * start = s; /* start of current piece of string */
10446 var char terminator = 0; /* judgement day */
10447 do {
10448 /* move cp to end of line or newline char or right screen border
10449 set terminator accordingly */
10450 while (1) {
10451 if (!(*cp) || *cp == NL) {
10452 terminator = *cp;
10453 break; }
10454 cp++;
10455 if ((cp - start) >= (sz.X - pos->X)) {
10456 terminator = CR;
10457 break; }
10458 }
10459 if (cp > start) {
10460 var CHAR_INFO * ac = (CHAR_INFO *)malloc((cp - start) * sizeof(CHAR_INFO));
10461 var SMALL_RECT rto;
10462 var COORD zp;
10463 var COORD p;
10464 var int i;
10465 zp.X = 0; zp.Y = 0;
10466 if (!ac) return;
10467 for (i=0;i<(cp - start);i++) {
10468 ac[i].Char.AsciiChar = start[i];
10469 ac[i].Attributes = attr;
10470 }
10471 rto.Left = pos->X;
10472 rto.Top = pos->Y;
10473 rto.Right = pos->X + (cp - start) - 1;
10474 rto.Bottom = pos->Y;
10475 p.X = cp - start;
10476 p.Y = 1;
10477 WriteConsoleOutput(handle,ac,p,zp,&rto);
10478 pos->X+=cp - start;
10479 if (terminator == NL || terminator == CR) {
10480 pos->X = 0;
10481 if (pos->Y >= sz.Y - 1)
10482 pos->Y = 0;
10483 else pos->Y++;
10484 }
10485 free(ac);
10486 }
10487 if (terminator == NL) cp++;
10488 start = cp;
10489 } while (terminator == NL || terminator == CR);
10490 }
10491
10492 /* Lisp functions: */
10493
wr_ch_array_window(const gcv_object_t * stream_,const gcv_object_t * chararray_,uintL start,uintL len)10494 local maygc void wr_ch_array_window (const gcv_object_t* stream_,
10495 const gcv_object_t* chararray_,
10496 uintL start, uintL len) {
10497 var Handle handle = ConsoleHandleR(*stream_);
10498 var COORD pos = ConsoleData(*stream_)->cursor_position;
10499 var COORD sz = ConsoleData(*stream_)->console_size;
10500 var uintW attr = attr_table[ConsoleData(*stream_)->attribute];
10501 var uintL end = start + len;
10502 var uintL index = start;
10503 var uintL strindex = 0;
10504 var uintL mbpos = 0;
10505 var chart * chart_str = (chart *)malloc((len + 1)*sizeof(chart));
10506 var char * char_str = (char *)chart_str;
10507 if (!chart_str) return;
10508 SstringDispatch(*chararray_,X, {
10509 do {
10510 chart_str[strindex] = as_chart(((SstringX)TheVarobject(*chararray_))->data[index]);
10511 index++; strindex++;
10512 } while (index < end);
10513 chart_str[strindex] = as_chart(0);
10514 });
10515 #ifdef ENABLE_UNICODE
10516 var uintB *mb_str = (uintB*)malloc((len + 1)*sizeof(char)*max_bytes_per_chart);
10517 if (mb_str) {
10518 var object encoding = TheStream(*stream_)->strm_encoding;
10519 var const chart* cptr = chart_str;
10520 var uintB * bptr = mb_str;
10521 memset(mb_str, 0, (len + 1)*sizeof(char)*max_bytes_per_chart);
10522 Encoding_wcstombs(encoding)
10523 (encoding,*stream_,&cptr,chart_str+strindex,
10524 &bptr,mb_str + len * max_bytes_per_chart);
10525 v_puts(handle,(char*)mb_str,&pos,sz,attr); /* will work only when multi == 1 in multibytes */
10526 free(mb_str);
10527 }
10528 #else
10529 for (mbpos=0; as_cint(chart_str[mbpos]); mbpos++)
10530 char_str[mbpos] = as_cint(chart_str[mbpos]);
10531 char_str[mbpos] = 0;
10532 CharToOem(char_str,char_str);
10533 v_puts(handle,char_str,&pos,sz,attr);
10534 #endif
10535 free(chart_str);
10536 SetConsoleCursorPosition(handle,pos);
10537 ConsoleData(*stream_)->cursor_position = pos;
10538 }
10539
10540 /* UP: write a character to a Window-Stream.
10541 wr_ch_window(&stream,ch);
10542 > stream: Window-Stream
10543 > ch: character to be written */
wr_ch_window(const gcv_object_t * stream_,object ch)10544 local maygc void wr_ch_window (const gcv_object_t* stream_, object ch) {
10545 var Handle handle = ConsoleHandleR(*stream_);
10546 var COORD pos = ConsoleData(*stream_)->cursor_position;
10547 var COORD sz = ConsoleData(*stream_)->console_size;
10548 var uintW attr = attr_table[ConsoleData(*stream_)->attribute];
10549 check_wr_char(*stream_,ch);
10550 var chart c = char_code(ch);
10551 #ifdef ENABLE_UNICODE
10552 var uintB buf[max_bytes_per_chart];
10553 var object encoding = TheStream(*stream_)->strm_encoding;
10554 var const chart* cptr = &c;
10555 var uintB* bptr = buf;
10556 Encoding_wcstombs(encoding)
10557 (encoding,*stream_,&cptr,cptr+1,&bptr,buf+max_bytes_per_chart);
10558 c = as_chart((uintB)*buf);
10559 #else
10560 CharToOemBuff((char *)&c,(char *)&c,1);
10561 #endif
10562 v_put(handle,(uintW)as_cint(c),&pos,sz,attr);
10563 SetConsoleCursorPosition(handle,pos);
10564 ConsoleData(*stream_)->cursor_position = pos;
10565 }
10566
low_close_console(object stream,object handle,uintB abort)10567 local void low_close_console (object stream, object handle, uintB abort) {
10568 if (!ConsoleData(stream)->handle_reused) {
10569 begin_system_call();
10570 if (!CloseHandle(TheHandle(handle)) && !abort)
10571 { end_system_call(); OS_filestream_error(stream); }
10572 end_system_call();
10573 }
10574 }
10575
10576 LISPFUNN(make_window,0) {
10577 var object stream =
10578 allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_channel_len,
10579 sizeof(win32_console_extrafields_t));
10580 /* try to reuse handle on win 95/98
10581 make new handle on NT */
10582 var int nt_systemp = 0;
10583 var bool handle_reused = 1;
10584 var OSVERSIONINFO osvers;
10585 osvers.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
10586 if (GetVersionEx(&osvers) && osvers.dwPlatformId == VER_PLATFORM_WIN32_NT)
10587 nt_systemp = 1;
10588
10589 var HANDLE handle = (nt_systemp ? INVALID_HANDLE_VALUE
10590 : GetStdHandle(STD_OUTPUT_HANDLE));
10591 if (handle==INVALID_HANDLE_VALUE) {
10592 handle = CreateConsoleScreenBuffer(GENERIC_READ|GENERIC_WRITE,
10593 0,
10594 NULL,
10595 CONSOLE_TEXTMODE_BUFFER,
10596 NULL);
10597 if (handle == INVALID_HANDLE_VALUE)
10598 error_unwritable(S(make_window),stream);
10599 SetConsoleActiveScreenBuffer(handle);
10600 handle_reused = 0;
10601 }
10602 var COORD console_size;
10603 var COORD console_pos;
10604 var CONSOLE_SCREEN_BUFFER_INFO info;
10605 if (GetConsoleScreenBufferInfo(handle,&info))
10606 console_size = info.dwSize;
10607 else {
10608 console_size.X = 80; console_size.Y = 25;
10609 }
10610 console_pos.X = 0;console_pos.Y = 0;
10611 pushSTACK(stream); /* save */
10612 var object handle_object = allocate_handle(handle);
10613 stream = popSTACK(); /* restore */
10614 stream_dummy_fill(stream);
10615 var Stream s = TheStream(stream);
10616 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_window); /* WRITE-CHAR Pseudofunction */
10617 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_window); /* WRITE-CHAR-SEQUENCE Pseudofunction */
10618 s->strm_encoding = O(terminal_encoding);
10619 s->strm_isatty = NIL;
10620 s->strm_ichannel = NIL;
10621 TheStream(stream)->strm_ochannel = handle_object;
10622 /* non GC-ed fields */
10623 ConsoleData(stream)->console_size = console_size;
10624 ConsoleData(stream)->cursor_position = console_pos;
10625 ConsoleData(stream)->attribute = 0;
10626 ConsoleData(stream)->handle_reused = handle_reused;
10627 ChannelStream_init(stream); /* iconv extrafields init */
10628 ChannelStream_lineno(stream) = 1;
10629 ChannelStream_buffered(stream) = false;
10630 ChannelStream_regular(stream) = false;
10631 ChannelStream_bitsize(stream) = 0;
10632 ChannelStreamLow_close(stream) = &low_close_console;
10633 v_move(handle,0,0);
10634 v_cl(handle,&console_pos,console_size,attr_table[0]);
10635 v_cs(handle);
10636 VALUES1(stream);
10637 }
10638
10639 /* close a window stream. */
close_window(object stream,uintB abort)10640 local void close_window (object stream, uintB abort) {
10641 close_ochannel(stream,abort);
10642 }
10643
10644 LISPFUNN(window_size,1) {
10645 var object stream = check_window_stream(popSTACK());
10646 var COORD sz = ConsoleData(stream)->console_size;
10647 VALUES2(fixnum(sz.Y),
10648 fixnum(sz.X));
10649 }
10650
10651 LISPFUNN(window_cursor_position,1) {
10652 var object stream = check_window_stream(popSTACK());
10653 var COORD pos = ConsoleData(stream)->cursor_position;
10654 VALUES2(fixnum(pos.Y),
10655 fixnum(pos.X));
10656 }
10657
10658 LISPFUNN(set_window_cursor_position,3) {
10659 var object stream = check_window_stream(STACK_2);
10660 var Handle handle = ConsoleHandleR(stream);
10661 var COORD sz = ConsoleData(stream)->console_size;
10662 var COORD pos;
10663 pos.Y = posfixnum_to_V(STACK_1);
10664 pos.X = posfixnum_to_V(STACK_0);
10665 if ((pos.Y < sz.Y) && (pos.X < sz.X)
10666 && (pos.Y >= 0) && (pos.X >= 0)) {
10667 v_move(handle,pos.Y,pos.X);
10668 ConsoleData(stream)->cursor_position = pos;
10669 }
10670 VALUES2(STACK_1, STACK_0); skipSTACK(3);
10671 }
10672
10673 LISPFUNN(clear_window,1) {
10674 var object stream = check_window_stream(popSTACK());
10675 var Handle handle = ConsoleHandleR(stream);
10676 var COORD pos = ConsoleData(stream)->cursor_position;
10677 var COORD sz = ConsoleData(stream)->console_size;
10678 var uintW attr = attr_table[ConsoleData(stream)->attribute];
10679 v_cl(handle,&pos,sz,attr);
10680 ConsoleData(stream)->cursor_position = pos;
10681 VALUES0;
10682 }
10683
10684 LISPFUNN(clear_window_to_eot,1) {
10685 var object stream = check_window_stream(popSTACK());
10686 var Handle handle = ConsoleHandleR(stream);
10687 var COORD pos = ConsoleData(stream)->cursor_position;
10688 var COORD sz = ConsoleData(stream)->console_size;
10689 var uintW attr = attr_table[ConsoleData(stream)->attribute];
10690 v_cd(handle,&pos,sz,attr);
10691 VALUES0;
10692 }
10693
10694 LISPFUNN(clear_window_to_eol,1) {
10695 var object stream = check_window_stream(popSTACK());
10696 var Handle handle = ConsoleHandleR(stream);
10697 var COORD pos = ConsoleData(stream)->cursor_position;
10698 var COORD sz = ConsoleData(stream)->console_size;
10699 var uintW attr = attr_table[ConsoleData(stream)->attribute];
10700 v_ce(handle,&pos,sz,attr);
10701 VALUES0;
10702 }
10703
10704 LISPFUNN(delete_window_line,1) {
10705 var object stream = check_window_stream(popSTACK());
10706 var Handle handle = ConsoleHandleR(stream);
10707 var COORD pos = ConsoleData(stream)->cursor_position;
10708 var COORD sz = ConsoleData(stream)->console_size;
10709 var uintW attr = attr_table[ConsoleData(stream)->attribute];
10710 v_dl(handle,&pos,sz,attr);
10711 VALUES0;
10712 }
10713
10714 LISPFUNN(insert_window_line,1) {
10715 var object stream = check_window_stream(popSTACK());
10716 var Handle handle = ConsoleHandleR(stream);
10717 var COORD pos = ConsoleData(stream)->cursor_position;
10718 var COORD sz = ConsoleData(stream)->console_size;
10719 var uintW attr = attr_table[ConsoleData(stream)->attribute];
10720 v_al(handle,&pos,sz,attr);
10721 VALUES0;
10722 }
10723
10724 LISPFUNN(highlight_on,1) {
10725 var object stream = check_window_stream(popSTACK());
10726 ConsoleData(stream)->attribute = 1;
10727 VALUES0;
10728 }
10729
10730 LISPFUNN(highlight_off,1) {
10731 var object stream = check_window_stream(popSTACK());
10732 ConsoleData(stream)->attribute = 0;
10733 VALUES0;
10734 }
10735
10736 LISPFUNN(window_cursor_on,1) {
10737 var object stream = check_window_stream(popSTACK());
10738 v_cb(ConsoleHandleR(stream));
10739 VALUES0;
10740 }
10741
10742 LISPFUNN(window_cursor_off,1) {
10743 var object stream = check_window_stream(popSTACK());
10744 v_cs(ConsoleHandleR(stream));
10745 VALUES0;
10746 }
10747
10748
10749 #endif /* WIN32_NATIVE */
10750
10751 #if defined(UNIX)
10752
10753 /* -------------------------------------------------------------------------
10754
10755 Routines for the Emulation of all VT100-Features on normal Terminals.
10756 Idea: Oliver Laumann 1987
10757 Bruno Haible, Tue, 25 Feb 2003 22:23:11 +0100 (CET):
10758 libtermcap is a permanent security problem. Better remove it from your
10759 system, and use libncurses instead.
10760 See also m4/termcap.m4: we look for these routines in libncurses first.
10761
10762 Uses the TERMCAP Library:
10763 Gets the Capability-Informations for Terminal-Type name.
10764 result: 1 if OK, 0 if name unknown, -1 on other error. */
10765 extern_C int tgetent (const char* bp, const char* name);
10766 /* gets the value of a numerical Capability (-1 if not available). */
10767 extern_C int tgetnum (const char* id);
10768 /* gets the value of a boolean Capability (1 if available, else 0). */
10769 extern_C int tgetflag (const char* id);
10770 /* gets the value of a String-significant Capability and (if area/=NULL)
10771 copies it to *area and further advances *area. */
10772 extern_C const char* tgetstr (const char* id, char** area);
10773 /* gets the String, that causes a Cursor-Positioning to (destcol,destline).
10774 (Necessary, because tgetstr("cm") has a special Format!) */
10775 extern_C const char* tgoto (const char* cm, int destcol, int destline);
10776 /* Performs a String-Capability. Thereto the output-function *outcharfun
10777 is called for each Character. (Necessary, because String-Capabilities
10778 can contain Padding-Commands!) */
10779 #ifdef __cplusplus
10780 typedef void (*outcharfun_t) (...);
10781 #else
10782 typedef void (*outcharfun_t) ();
10783 #endif
10784 extern_C const char* tputs (const char* cp, int affcnt, outcharfun_t outcharfun);
10785
10786 /* Adjustable settings: */
10787 #define WANT_INSERT false /* Insert-Mode */
10788 #define WANT_SAVE false /* Save/Restore for the Cursor-Position */
10789 #define WANT_ATTR true /* Attributes (bold, reverse etc.) */
10790 #define WANT_CHARSET false /* Fonts = Charsets */
10791 /* Functions to be defined: */
10792 #define WANT_CURSOR_MOVE false
10793 #define WANT_CURSOR_BACKSPACE false
10794 #define WANT_CURSOR_RETURN true
10795 #define WANT_CURSOR_LINEFEED true
10796 #define WANT_CURSOR_REVLINEFEED false
10797 #define WANT_CLEAR_SCREEN true
10798 #define WANT_CLEAR_FROM_BOS false
10799 #define WANT_CLEAR_TO_EOS true
10800 #define WANT_CLEAR_LINE false
10801 #define WANT_CLEAR_FROM_BOL false
10802 #define WANT_CLEAR_TO_EOL true
10803 #define WANT_INSERT_1CHAR false
10804 #define WANT_INSERT_CHAR false
10805 #define WANT_INSERT_LINE true
10806 #define WANT_DELETE_CHAR false
10807 #define WANT_DELETE_LINE true
10808 #define WANT_OUTPUT_1CHAR true
10809 /* small corrections: */
10810 #define WANT_CLEAR_SCREEN true
10811 #if WANT_OUTPUT_1CHAR && WANT_INSERT
10812 #define WANT_INSERT_1CHAR true
10813 #endif
10814
10815 /* output of a character, directly. */
out_char(uintB c)10816 local void out_char (uintB c) {
10817 restart_it: {
10818 var int result = write(stdout_handle,&c,1); /* try to write character */
10819 if (result<0) {
10820 if (errno==EINTR)
10821 goto restart_it;
10822 OS_error();
10823 }
10824 if (result==0) { /* not successful? */
10825 pushSTACK(var_stream(S(terminal_io),0)); /* FILE-ERROR slot PATHNAME */
10826 error(file_error,GETTEXT("cannot output to standard output"));
10827 }
10828 }
10829 }
10830
10831 /* output of a Capability-String. */
out_capstring(const char * s)10832 local void out_capstring (const char* s) {
10833 if (!(s==NULL)) /* protection against non-existing Capability */
10834 tputs(s,1,(outcharfun_t) &out_char);
10835 }
10836
10837 /* output of a Capability-String with an Argument. */
out_cap1string(const char * s,int arg)10838 local void out_cap1string (const char* s, int arg) {
10839 if (!(s==NULL)) /* protection against non-existing Capability */
10840 tputs(tgoto(s,0,arg),1,(outcharfun_t) &out_char);
10841 }
10842
10843 /* costs of execution of a Capability: */
10844 #define EXPENSIVE 1000
10845 local uintC cost_counter; /* counter */
10846 /* Function, that does not write, but only counts: */
count_char(char c)10847 local void count_char (char c) {
10848 unused(c);
10849 cost_counter++;
10850 }
10851
10852 /* calculates the costs of the writing of a Capability: */
cap_cost(const char * s)10853 local uintC cap_cost (const char* s) {
10854 if (s==NULL) {
10855 return EXPENSIVE; /* Capability non-existing */
10856 } else {
10857 cost_counter = 0;
10858 tputs(s,1,(outcharfun_t) &count_char);
10859 return cost_counter;
10860 }
10861 }
10862
10863 /* Buffer for Capabilities that I need and Pointer to it: */
10864 local char tentry[4096];
10865 local char* tp = &tentry[0];
10866 /* some chosen Capabilities (NULL or Pointer into tentry): */
10867 /* Insert-Mode: */
10868 local const char* IMcap; /* Enter Insert Mode */
10869 local uintC IMcost;
10870 local const char* EIcap; /* End Insert Mode */
10871 local uintC EIcost;
10872 #if WANT_ATTR
10873 /* Attributes: */
10874 local const char* SOcap; /* Enter standout mode */
10875 local const char* SEcap; /* End standout mode */
10876 local const char* UScap; /* Enter underline mode */
10877 local const char* UEcap; /* End underline mode */
10878 local const char* MBcap; /* Turn on blinking */
10879 local const char* MDcap; /* Turn on bold (extra-bright) mode */
10880 local const char* MHcap; /* Turn on half-bright mode */
10881 local const char* MRcap; /* Turn on reverse mode */
10882 local const char* MEcap; /* Turn off all attributes */
10883 #endif
10884 #if WANT_CHARSET
10885 /* charsets: */
10886 local bool ISO2022; /* if charset change according to ISO2022 is supported */
10887 #endif
10888 /* Cursor-Motion: */
10889 local const char* CMcap; /* Cursor motion, common Cursor-Positioning */
10890 local const char* TIcap; /* Initialize mode where CM is usable */
10891 local const char* TEcap; /* Exit mode where CM is usable */
10892 local const char* BCcap; /* Backspace Cursor */
10893 local uintC BCcost;
10894 local const char* NDcap; /* cursor right */
10895 local uintC NDcost;
10896 local const char* DOcap; /* cursor down */
10897 local uintC DOcost;
10898 local const char* UPcap; /* cursor up */
10899 local uintC UPcost;
10900 local const char* NLcap; /* Newline */
10901 local const char* CRcap; /* Carriage Return */
10902 local uintC CRcost;
10903 /* Scrolling: */
10904 local const char* CScap; /* change scroll region */
10905 #if WANT_DELETE_LINE
10906 local const char* SFcap; /* Scroll (text up) */
10907 #endif
10908 #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
10909 local const char* SRcap; /* Scroll reverse (text down) */
10910 #endif
10911 /* Others: */
10912 local const char* IScap; /* Terminal Initialization 2 */
10913 /* local const char* BLcap; - Bell
10914 local const char* VBcap; - Visible Bell (Flash) */
10915 local const char* CLcap; /* clear screen, cursor home */
10916 #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
10917 local const char* CEcap; /* clear to end of line */
10918 #endif
10919 #if WANT_CLEAR_TO_EOS
10920 local const char* CDcap; /* clear to end of screen */
10921 #endif
10922 #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
10923 local const char* ALcap; /* add new blank line */
10924 #endif
10925 #if WANT_DELETE_LINE
10926 local const char* DLcap; /* delete line */
10927 #endif
10928 #if WANT_DELETE_CHAR
10929 local const char* DCcap; /* delete character */
10930 #endif
10931 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
10932 local const char* ICcap; /* insert character */
10933 #endif
10934 #if WANT_INSERT_CHAR
10935 local const char* CICcap; /* insert count characters */
10936 #endif
10937 #if WANT_INSERT_LINE
10938 local const char* CALcap; /* add count blank lines */
10939 #endif
10940 #if WANT_DELETE_CHAR
10941 local const char* CDCcap; /* delete count chars */
10942 #endif
10943 #if WANT_DELETE_LINE
10944 local const char* CDLcap; /* delete count lines */
10945 #endif
10946 local bool AM; /* automatic margins, if scrolling on right bottom corner (??) */
10947 local int rows; /* number of rows of the screen, >0 */
10948 local int cols; /* number of columns of the screen, >0 */
10949 /* top row is row 0, bottom row is row rows-1.
10950 left-most column is column 0, right-most column is column cols-1. */
10951 #if WANT_ATTR || WANT_CHARSET
10952 local uintB* null; /* Pointer to cols Zeros */
10953 #endif
10954 local uintB* blank; /* Pointer to cols Blanks */
10955
10956 /* Description of a Terminal-Output-Unit: */
10957 typedef struct {
10958 uintB** image; /* image[y][x] is the character at Position (x,y) */
10959 #if WANT_ATTR
10960 uintB** attr; /* attr[y][x] is its Attribute */
10961 uintB curr_attr; /* which Attribut is now the current one */
10962 #endif
10963 #if WANT_CHARSET
10964 uintB** font; /* font[y][x] is its Font (Charset) */
10965 #define charset_count 4
10966 uintB charsets[charset_count]; /* Table of charsets */
10967 uintC curr_charset; /* which of the charsets is the current one */
10968 /* (>=0, <charset_count) */
10969 #endif
10970 int x; /* Cursorposition (>=0, <=cols) */
10971 int y; /* Cursorposition (>=0, <rows) */
10972 /* (At x=cols the Cursor is displayed in column cols-1.) */
10973 int top, bot; /* Scroll-Region = rows y with top <= y <= bot, */
10974 /* It applies: 0 <= top <= bot <= rows-1. */
10975 #if WANT_INSERT
10976 bool insert; /* if the Output-Unit works in Insert-Mode */
10977 /* (then the Terminal is mostly in Insert-Mode) */
10978 #endif
10979 #if WANT_SAVE
10980 bool saved;
10981 #if WANT_ATTR
10982 uintB saved_curr_attr;
10983 #endif
10984 #if WANT_CHARSET
10985 uintB saved_charsets[charset_count];
10986 uintC saved_curr_charset;
10987 #endif
10988 int saved_x, saved_y;
10989 #endif
10990 } win;
10991
10992 /* current Output-Unit: */
10993 local win currwin; /* there is only one! */
10994 #define curr (&currwin)
10995
10996 #if WANT_INSERT
10997
10998 /* switch on/of Insert-Mode:
10999 Flag, if the Terminal is in Insert-Mode (if there is one): */
11000 local bool insert;
set_insert_mode(bool flag)11001 local void set_insert_mode (bool flag) {
11002 if (flag) { /* switch on */
11003 if (!insert)
11004 out_capstring(IMcap);
11005 } else { /* switch off */
11006 if (insert)
11007 out_capstring(EIcap);
11008 }
11009 insert = flag;
11010 }
11011
11012 #endif
11013
11014 #if WANT_ATTR
11015
11016 /* toggle the Output-Attributes of the Terminal: */
11017 local uintB term_attr; /* current Attributes of the Terminal */
11018 /* possible Attributes are on ODER off: */
11019 #define A_SO bit(0) /* Standout mode */
11020 #define A_US bit(1) /* Underscore mode */
11021 #define A_BL bit(2) /* Blinking */
11022 #define A_BD bit(3) /* Bold mode */
11023 #define A_DI bit(4) /* Dim mode */
11024 #define A_RV bit(5) /* Reverse mode */
change_attr(uintB new_attr)11025 local void change_attr (uintB new_attr) {
11026 var uintB old_attr = term_attr;
11027 if (old_attr == new_attr)
11028 return;
11029 if (((old_attr & A_SO) && !(new_attr & A_SO))
11030 || ((old_attr & A_US) && !(new_attr & A_US))
11031 || ((old_attr & A_BL) && !(new_attr & A_BL))
11032 || ((old_attr & A_BD) && !(new_attr & A_BD))
11033 || ((old_attr & A_DI) && !(new_attr & A_DI))
11034 || ((old_attr & A_RV) && !(new_attr & A_RV))) {
11035 /* Must switch of Attributes. */
11036 out_capstring(UEcap); /* all are off */
11037 out_capstring(SEcap);
11038 out_capstring(MEcap);
11039 if (new_attr & A_SO) out_capstring(SOcap); /* and switch on selectively */
11040 if (new_attr & A_US) out_capstring(UScap);
11041 if (new_attr & A_BL) out_capstring(MBcap);
11042 if (new_attr & A_BD) out_capstring(MDcap);
11043 if (new_attr & A_DI) out_capstring(MHcap);
11044 if (new_attr & A_RV) out_capstring(MRcap);
11045 } else {
11046 /* switch on selectively: */
11047 if ((new_attr & A_SO) && !(old_attr & A_SO)) out_capstring(SOcap);
11048 if ((new_attr & A_US) && !(old_attr & A_US)) out_capstring(UScap);
11049 if ((new_attr & A_BL) && !(old_attr & A_BL)) out_capstring(MBcap);
11050 if ((new_attr & A_BD) && !(old_attr & A_BD)) out_capstring(MDcap);
11051 if ((new_attr & A_DI) && !(old_attr & A_DI)) out_capstring(MHcap);
11052 if ((new_attr & A_RV) && !(old_attr & A_RV)) out_capstring(MRcap);
11053 }
11054 term_attr = new_attr;
11055 }
11056
11057 #endif
11058
11059 #if WANT_CHARSET
11060
11061 /* change Output-Charset of the Terminal: */
11062 local uintB term_charset; /* current charset of the Terminal */
11063 /* = curr->charsets[curr->curr_charset] */
11064 #define ASCII 0 /* abbreviation for the charset 'B' */
change_charset(uintB new)11065 local void change_charset (uintB new) {
11066 if (term_charset==new)
11067 return;
11068 if (ISO2022) {
11069 out_char(ESC); out_char('('); out_char(new==ASCII ? 'B' : new);
11070 }
11071 term_charset = new;
11072 }
11073 /* change Charset Nr. n to c: */
choose_charset(uintB c,uintC n)11074 local void choose_charset (uintB c, uintC n) {
11075 if (c=='B')
11076 c = ASCII;
11077 if (curr->charsets[n] == c)
11078 return;
11079 curr->charsets[n] = c;
11080 if (curr->curr_charset == n) /* the current one? */
11081 change_charset(c);
11082 }
11083 /* make Charset Nr. n the current one: */
set_curr_charset(uintC n)11084 local void set_curr_charset (uintC n) {
11085 if (curr->curr_charset == n)
11086 return;
11087 curr->curr_charset = n;
11088 change_charset(curr->charsets[n]);
11089 }
11090
11091 #endif
11092
11093 /* calculate the costs of Redisplay of row y, characters x1..x2-1:
11094 (0 <= y < rows, 0 <= x1 <= x2 <= cols) */
rewrite_cost(int y,int x1,int x2)11095 local uintC rewrite_cost (int y, int x1, int x2) {
11096 if (AM && (y==rows-1) && (x2==cols)) /* right bottom corner can scroll? */
11097 return EXPENSIVE;
11098 var int dx = x2-x1;
11099 if (dx==0)
11100 return 0;
11101 #if WANT_ATTR
11102 {
11103 var uintB* p = &curr->attr[y][x1];
11104 var uintC count;
11105 dotimespC(count,dx, {
11106 if (!(*p++ == term_attr)) /* Attribut-Change necessary? */
11107 return EXPENSIVE;
11108 });
11109 }
11110 #endif
11111 #if WANT_CHARSET
11112 {
11113 var uintB* p = &curr->font[y][x1];
11114 var uintC count;
11115 dotimespC(count,dx, {
11116 if (!(*p++ == term_charset)) /* Font-Change necessary? */
11117 return EXPENSIVE;
11118 });
11119 }
11120 #endif
11121 var uintC cost = dx;
11122 #if WANT_INSERT
11123 if (curr->insert)
11124 cost += EIcost + IMcost;
11125 #endif
11126 return cost;
11127 }
11128
11129 /* Moves the Cursor from Position (y1,x1) to Position (y2,x2).
11130 (x1,y1) = (-1,-1) if the current Position is unknown. */
gofromto(int y1,int x1,int y2,int x2)11131 local void gofromto (int y1, int x1, int y2, int x2) {
11132 if (x2==cols) { /* Cursor to the right border? */
11133 x2--; out_capstring(tgoto(CMcap,x2,y2)); return; /* remains in last column */
11134 }
11135 if (x1==cols) { /* Cursor is at the right border? */
11136 out_capstring(tgoto(CMcap,x2,y2)); return; /* address in absolute coords */
11137 }
11138 var int dy = y2-y1;
11139 var int dx = x2-x1;
11140 if ((dy==0) && (dx==0))
11141 return;
11142 if ((y1==-1) || (x1==-1) || (y2 > curr->bot) || (y2 < curr->top)) {
11143 out_capstring(tgoto(CMcap,x2,y2)); return;
11144 }
11145 var enum { MX_NONE, MX_LE, MX_RI, MX_RW, MX_CR } mx = MX_NONE;
11146 var enum { MY_NONE, MY_UP, MY_DO } my = MY_NONE;
11147 /* Option 1: with CMcap */
11148 var uintC CMcost = cap_cost(tgoto(CMcap,x2,y2));
11149 /* Option 2: with separate x- and y-movements: */
11150 var uintC xycost = 0;
11151 if (dx > 0) {
11152 var uintC cost1 = rewrite_cost(y1,x1,x2);
11153 var uintC cost2 = dx * NDcost;
11154 if (cost1 < cost2) {
11155 mx = MX_RW; xycost += cost1;
11156 } else {
11157 mx = MX_RI; xycost += cost2;
11158 }
11159 } else if (dx < 0) {
11160 mx = MX_LE; xycost += (-dx) * BCcost;
11161 }
11162 if (!(dx==0)) {
11163 var uintC cost1 = CRcost + rewrite_cost(y1,0,x2);
11164 if (cost1 < xycost) {
11165 mx = MX_CR; xycost = cost1;
11166 }
11167 }
11168 if (dy > 0) {
11169 my = MY_DO; xycost += dy * DOcost;
11170 } else if (dy < 0) {
11171 my = MY_UP; xycost += (-dy) * UPcost;
11172 }
11173 if (xycost >= CMcost) {
11174 out_capstring(tgoto(CMcap,x2,y2)); return;
11175 }
11176 if (!(mx==MX_NONE)) {
11177 if ((mx==MX_LE) || (mx==MX_RI)) {
11178 var const char* s;
11179 if (mx==MX_LE) {
11180 dx = -dx; s = BCcap;
11181 } else {
11182 s = NDcap;
11183 }
11184 do {
11185 out_capstring(s);
11186 } while (--dx != 0);
11187 } else {
11188 if (mx==MX_CR) {
11189 out_capstring(CRcap); x1=0;
11190 }
11191 /* hereof the costs were calculated with rewrite_cost: */
11192 if (x1<x2) {
11193 #if WANT_INSERT
11194 if (curr->insert)
11195 set_insert_mode(false);
11196 #endif
11197 {
11198 var uintB* ptr = &curr->image[y1][x1];
11199 var uintC count;
11200 dotimespC(count,x2-x1, { out_char(*ptr++); });
11201 }
11202 #if WANT_INSERT
11203 if (curr->insert)
11204 set_insert_mode(true);
11205 #endif
11206 }
11207 }
11208 }
11209 if (!(my==MY_NONE)) {
11210 var const char* s;
11211 if (my==MY_UP) {
11212 dy = -dy; s = UPcap;
11213 } else {
11214 s = DOcap;
11215 }
11216 do {
11217 out_capstring(s);
11218 } while (--dy != 0);
11219 }
11220 }
11221
11222 /* Redisplay
11223 local Variables: */
11224 local int last_x;
11225 local int last_y;
11226 /* Redisplay a line, that might have changed:
11227 pass only Parameters that are really needed: */
11228 #if WANT_ATTR && WANT_CHARSET
11229 #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2)
11230 #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,ofp,nsp,nap,nfp,y,x1,x2)
11231 #endif
11232 #if !WANT_ATTR && WANT_CHARSET
11233 #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2)
11234 #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,ofp,nsp,nfp,y,x1,x2,oap,nap)
11235 #endif
11236 #if WANT_ATTR && !WANT_CHARSET
11237 #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2)
11238 #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,oap,nsp,nap,y,x1,x2,ofp,nfp)
11239 #endif
11240 #if !WANT_ATTR && !WANT_CHARSET
11241 #define RHargs(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2)
11242 #define RHparms(osp,oap,ofp,nsp,nap,nfp,y,x1,x2) (osp,nsp,y,x1,x2,oap,ofp,nap,nfp)
11243 #endif
11244 #undef RHparms
11245 #define RHparms RHargs /* declare correctly */
RHparms(uintB * osp,uintB * oap,uintB * ofp,uintB * nsp,uintB * nap,uintB * nfp,int y,int x1,int x2)11246 local void redisplay_help RHparms (uintB* osp, uintB* oap, uintB* ofp, /* old */
11247 uintB* nsp, uintB* nap, uintB* nfp, /* new */
11248 /* line y, from x1 to x2-1 */
11249 int y, int x1, int x2) {
11250 if (AM && (y == rows-1) && (x2 == cols))
11251 x2--;
11252 #if WANT_ATTR
11253 var uintB a = term_attr; /* last Attribute */
11254 #endif
11255 #if WANT_CHARSET
11256 var uintB f = term_charset; /* last Font */
11257 #endif
11258 var int x = x1;
11259 osp = &osp[x1]; nsp = &nsp[x1];
11260 #if WANT_ATTR
11261 oap = &oap[x1]; nap = &nap[x1];
11262 #endif
11263 #if WANT_CHARSET
11264 ofp = &ofp[x1]; nfp = &nfp[x1];
11265 #endif
11266 while (x < x2) {
11267 if (!((*nsp==*osp)
11268 #if WANT_ATTR
11269 && (*nap==*oap) && (*nap==a)
11270 #endif
11271 #if WANT_CHARSET
11272 && (*nfp==*nap) && (*nfp==f)
11273 #endif
11274 )) {
11275 gofromto(last_y,last_x,y,x);
11276 #if WANT_ATTR
11277 a = *nap;
11278 if (!(a==term_attr))
11279 change_attr(a);
11280 #endif
11281 #if WANT_CHARSET
11282 f = *nfp;
11283 if (!(f==term_charset))
11284 change_charset(f);
11285 #endif
11286 out_char(*nsp);
11287 last_y = y; last_x = x+1;
11288 }
11289 x++;
11290 osp++; nsp++;
11291 #if WANT_ATTR
11292 oap++; nap++;
11293 #endif
11294 #if WANT_CHARSET
11295 ofp++; nfp++;
11296 #endif
11297 }
11298 }
11299 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
11300 /* Redisplay a line:
11301 pass only Parameters that are really needed: */
11302 #if WANT_ATTR && WANT_CHARSET
11303 #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2)
11304 #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,ofp,y,x1,x2)
11305 #endif
11306 #if !WANT_ATTR && WANT_CHARSET
11307 #define RLargs(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2)
11308 #define RLparms(osp,oap,ofp,y,x1,x2) (osp,ofp,y,x1,x2,oap)
11309 #endif
11310 #if WANT_ATTR && !WANT_CHARSET
11311 #define RLargs(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2)
11312 #define RLparms(osp,oap,ofp,y,x1,x2) (osp,oap,y,x1,x2,ofp)
11313 #endif
11314 #if !WANT_ATTR && !WANT_CHARSET
11315 #define RLargs(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2)
11316 #define RLparms(osp,oap,ofp,y,x1,x2) (osp,y,x1,x2,oap,ofp)
11317 #endif
11318 #undef RHparms
11319 #define RHparms RHargs /* declare correctly */
RLparms(uintB * osp,uintB * oap,uintB * ofp,int y,int x1,int x2)11320 local void redisplay_line RLparms (uintB* osp, uintB* oap, uintB* ofp, /* old */
11321 /* line y, from x1 to x2-1 */
11322 int y, int x1, int x2) {
11323 #if WANT_INSERT
11324 if (curr->insert)
11325 set_insert_mode(false);
11326 #endif
11327 #if WANT_ATTR
11328 var uintB saved_attr = term_attr;
11329 change_attr(0);
11330 #endif
11331 #if WANT_CHARSET
11332 var uintB saved_charset = term_charset;
11333 change_charset(ASCII);
11334 #endif
11335 last_y = y; last_x = x1;
11336 redisplay_help RHargs(osp, oap, ofp,
11337 curr->image[y],curr->attr[y],curr->font[y],
11338 y, x1,x2);
11339 #if WANT_CHARSET
11340 change_charset(saved_charset);
11341 #endif
11342 #if WANT_ATTR
11343 change_attr(saved_attr);
11344 #endif
11345 #if WANT_INSERT
11346 if (curr->insert)
11347 set_insert_mode(true);
11348 #endif
11349 }
11350 #endif
11351 /* Redisplay the whole screen: */
redisplay(void)11352 local void redisplay (void) {
11353 #if WANT_INSERT
11354 set_insert_mode(false);
11355 #endif
11356 #if WANT_ATTR
11357 var uintB saved_attr = term_attr;
11358 change_attr(0);
11359 #endif
11360 #if WANT_CHARSET
11361 var uintB saved_charset = term_charset;
11362 change_charset(ASCII);
11363 #endif
11364 out_capstring(CLcap); last_x = 0; last_y = 0;
11365 {
11366 var uintC y = 0;
11367 while (y<rows) {
11368 redisplay_help
11369 RHargs(blank, null, null, /* old */
11370 curr->image[y],curr->attr[y],curr->font[y], /* new */
11371 y, /* line y */
11372 0,cols); /* all columns */
11373 y++;
11374 }
11375 }
11376 #if WANT_CHARSET
11377 change_charset(saved_charset);
11378 #endif
11379 #if WANT_ATTR
11380 change_attr(saved_attr);
11381 #endif
11382 #if WANT_INSERT
11383 if (curr->insert)
11384 set_insert_mode(true);
11385 #endif
11386 gofromto(last_y,last_x,curr->y,curr->x);
11387 }
11388
resize_screen(int lines,int columns)11389 global void resize_screen (int lines, int columns) {
11390 rows = lines; cols = columns;
11391 if (curr->image) redisplay();
11392 }
11393
11394 /* Further Cursor-Movements: */
11395 #if WANT_CURSOR_MOVE
11396
cursor_right(int n)11397 local void cursor_right (int n) {
11398 var int x = curr->x;
11399 if (x==cols)
11400 return;
11401 var int new_x = x + n;
11402 if (new_x > cols)
11403 new_x = cols;
11404 gofromto(curr->y,x,curr->y,curr->x = new_x);
11405 }
11406
cursor_left(int n)11407 local void cursor_left (int n) {
11408 var int x = curr->x;
11409 var int new_x = x - n;
11410 if (new_x < 0)
11411 new_x = 0;
11412 gofromto(curr->y,x,curr->y,curr->x = new_x);
11413 }
11414
cursor_up(int n)11415 local void cursor_up (int n) {
11416 var int y = curr->y;
11417 var int new_y = y - n;
11418 if (new_y < 0)
11419 new_y = 0;
11420 gofromto(y,curr->x,curr->y = new_y,curr->x);
11421 }
11422
cursor_down(int n)11423 local void cursor_down (int n) {
11424 var int y = curr->y;
11425 var int new_y = y + n;
11426 if (new_y >= rows)
11427 new_y = rows-1;
11428 gofromto(y,curr->x,curr->y = new_y,curr->x);
11429 }
11430
11431 #endif
11432
11433 /* Backspace (Cursor to the left by 1, within a line) */
11434 #if WANT_CURSOR_BACKSPACE
cursor_backspace(void)11435 local void cursor_backspace (void) {
11436 if (curr->x > 0) {
11437 if (curr->x < cols) {
11438 if (BCcap)
11439 out_capstring(BCcap);
11440 else
11441 gofromto(curr->y,curr->x,curr->y,curr->x - 1);
11442 }
11443 curr->x = curr->x - 1;
11444 }
11445 }
11446 #endif
11447
11448 /* Return (Cursor to the beginning of a line) */
11449 #if WANT_CURSOR_RETURN
cursor_return(void)11450 local void cursor_return (void) {
11451 if (curr->x > 0) {
11452 out_capstring(CRcap); curr->x = 0;
11453 }
11454 }
11455 #endif
11456
11457 /* auxiliary routines for scrolling: */
11458 #if WANT_CURSOR_LINEFEED || WANT_DELETE_LINE
scroll_up_help(uintB ** pp,uintB filler)11459 local void scroll_up_help (uintB** pp, uintB filler) {
11460 /* shift pp[top..bot] by one to the left,
11461 take out pp[top], delete and insert again as pp[bot]: */
11462 pp = &pp[curr->top];
11463 var uintC count;
11464 var uintB* tmp = *pp;
11465 dotimesC(count,curr->bot - curr->top, { pp[0] = pp[1]; pp++; } );
11466 memset(tmp,filler,cols);
11467 *pp = tmp;
11468 }
scroll_up(void)11469 local void scroll_up (void) {
11470 scroll_up_help(curr->image,' ');
11471 #if WANT_ATTR
11472 scroll_up_help(curr->attr,0);
11473 #endif
11474 #if WANT_CHARSET
11475 scroll_up_help(curr->font,0);
11476 #endif
11477 }
11478 #endif
11479 #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
scroll_down_help(uintB ** pp,uintB filler)11480 local void scroll_down_help (uintB** pp, uintB filler) {
11481 /* shift pp[top..bot] by one to the right,
11482 take out pp[top], delete and insert again as pp[bot]: */
11483 pp = &pp[curr->bot];
11484 var uintC count;
11485 var uintB* tmp = *pp;
11486 dotimesC(count,curr->bot - curr->top, { pp[0] = pp[-1]; pp--; } );
11487 memset(tmp,filler,cols);
11488 *pp = tmp;
11489 }
scroll_down(void)11490 local void scroll_down (void) {
11491 scroll_down_help(curr->image,' ');
11492 #if WANT_ATTR
11493 scroll_down_help(curr->attr,0);
11494 #endif
11495 #if WANT_CHARSET
11496 scroll_down_help(curr->font,0);
11497 #endif
11498 }
11499 #endif
11500
11501 /* Linefeed (Cursor down by 1): */
11502 #if WANT_CURSOR_LINEFEED
cursor_linefeed(void)11503 local void cursor_linefeed (void) {
11504 if (curr->y == curr->bot)
11505 scroll_up();
11506 else if (curr->y < rows-1)
11507 curr->y++;
11508 out_capstring(NLcap);
11509 }
11510 #endif
11511
11512 /* Reverse Linefeed (Cursor up by 1): */
11513 #if WANT_CURSOR_REVLINEFEED
cursor_revlinefeed(void)11514 local void cursor_revlinefeed (void) {
11515 if (curr->y == curr->top) {
11516 scroll_down();
11517 if (SRcap) {
11518 out_capstring(SRcap);
11519 } else if (ALcap) {
11520 gofromto(curr->top,curr->x,curr->top,0); /* Cursor to the left */
11521 out_capstring(ALcap);
11522 gofromto(curr->top,0,curr->top,curr->x); /* Cursor back again */
11523 } else {
11524 redisplay();
11525 }
11526 } else if (curr->y > 0) {
11527 cursor_up(1);
11528 }
11529 }
11530 #endif
11531
11532 /* Deletion-Operations: */
11533
11534 /* delete part of a line: */
11535 #if WANT_CLEAR_SCREEN || WANT_CLEAR_FROM_BOS
cleared_linepart(int y,int x1,int x2)11536 local void cleared_linepart (int y, int x1, int x2) {
11537 var int n = x2-x1;
11538 if (n>0) {
11539 memset(&curr->image[y][x1],' ',n);
11540 #if WANT_ATTR
11541 memset(&curr->attr[y][x1],0,n);
11542 #endif
11543 #if WANT_CHARSET
11544 memset(&curr->font[y][x1],0,n);
11545 #endif
11546 }
11547 }
11548 #endif
11549
11550 /* delete screen: */
11551 #if WANT_CLEAR_SCREEN
clear_screen(void)11552 local void clear_screen (void) {
11553 out_capstring(CLcap);
11554 var uintC y = 0;
11555 while (y<rows) { cleared_linepart(y,0,cols); y++; }
11556 }
11557 #endif
11558
11559 /* delete part of a line: */
11560 #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
clear_linepart(int y,int x1,int x2)11561 local void clear_linepart (int y, int x1, int x2) {
11562 var int n = x2-x1;
11563 if (n>0) {
11564 memset(&curr->image[y][x1],' ',n);
11565 #if WANT_ATTR
11566 memset(&curr->attr[y][x1],0,n);
11567 #endif
11568 #if WANT_CHARSET
11569 memset(&curr->font[y][x1],0,n);
11570 #endif
11571 if ((x2==cols) && CEcap) {
11572 gofromto(curr->y,curr->x,y,x1); curr->y = y; curr->x = x1;
11573 out_capstring(CEcap);
11574 } else {
11575 if ((x2==cols) && (y==rows-1) && AM)
11576 n--;
11577 if (n>0) {
11578 #if WANT_ATTR
11579 var uintB saved_attr = term_attr;
11580 change_attr(0);
11581 #endif
11582 #if WANT_CHARSET
11583 var uintB saved_charset = term_charset;
11584 change_charset(ASCII);
11585 #endif
11586 #if WANT_INSERT
11587 if (curr->insert)
11588 set_insert_mode(false);
11589 #endif
11590 gofromto(curr->y,curr->x,y,x1);
11591 {
11592 var uintC count;
11593 dotimespC(count,n, { out_char(' '); } );
11594 }
11595 curr->y = y; curr->x = x1+n;
11596 #if WANT_CHARSET
11597 change_charset(saved_charset);
11598 #endif
11599 #if WANT_ATTR
11600 change_attr(saved_attr);
11601 #endif
11602 #if WANT_INSERT
11603 if (curr->insert)
11604 set_insert_mode(true);
11605 #endif
11606 }
11607 }
11608 }
11609 }
11610 #endif
11611
11612 /* delete screen up to the Cursor (exclusive): */
11613 #if WANT_CLEAR_FROM_BOS
clear_from_BOS(void)11614 local void clear_from_BOS (void) {
11615 var int y0 = curr->y;
11616 var int x0 = curr->x;
11617 var int y = 0;
11618 while (y<y0) { clear_linepart(y,0,cols); y++; }
11619 clear_linepart(y0,0,x0);
11620 gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
11621 }
11622 #endif
11623
11624 /* delete screen starting at cursor (inclusive): */
11625 #if WANT_CLEAR_TO_EOS
clear_to_EOS(void)11626 local void clear_to_EOS (void) {
11627 var int y0 = curr->y;
11628 var int x0 = curr->x;
11629 if (CDcap) {
11630 out_capstring(CDcap);
11631 cleared_linepart(y0,x0,cols);
11632 var int y = y0;
11633 while (++y < rows) { cleared_linepart(y,0,cols); }
11634 } else {
11635 clear_linepart(y0,x0,cols);
11636 var int y = y0;
11637 while (++y < rows) { clear_linepart(y,0,cols); }
11638 }
11639 gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
11640 }
11641 #endif
11642
11643 /* delete cursor-line: */
11644 #if WANT_CLEAR_LINE
clear_line(void)11645 local void clear_line (void) {
11646 var int y0 = curr->y;
11647 var int x0 = curr->x;
11648 clear_linepart(y0,0,cols);
11649 gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
11650 }
11651 #endif
11652
11653 /* delete cursor-line up to cursor (exclusive): */
11654 #if WANT_CLEAR_FROM_BOL
clear_from_BOL(void)11655 local void clear_from_BOL (void) {
11656 var int y0 = curr->y;
11657 var int x0 = curr->x;
11658 clear_linepart(y0,0,x0);
11659 gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
11660 }
11661 #endif
11662
11663 /* delete cursor-line starting at cursor (inclusive): */
11664 #if WANT_CLEAR_TO_EOL
clear_to_EOL(void)11665 local void clear_to_EOL (void) {
11666 var int y0 = curr->y;
11667 var int x0 = curr->x;
11668 clear_linepart(y0,x0,cols);
11669 gofromto(curr->y,curr->x,y0,x0); curr->y = y0; curr->x = x0;
11670 }
11671 #endif
11672
11673 /* Insertion-Operations: */
11674
11675 /* old content of line: */
11676 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
11677 local uintB* old_image_y;
11678 #if WANT_ATTR
11679 local uintB* old_attr_y;
11680 #endif
11681 #if WANT_CHARSET
11682 local uintB* old_font_y;
11683 #endif
save_line_old(int y)11684 local void save_line_old (int y) {
11685 if (cols > 0) {
11686 memcpy(&old_image_y[0],&curr->image[y][0],cols);
11687 #if WANT_ATTR
11688 memcpy(&old_attr_y[0],&curr->attr[y][0],cols);
11689 #endif
11690 #if WANT_CHARSET
11691 memcpy(&old_font_y[0],&curr->font[y][0],cols);
11692 #endif
11693 }
11694 }
11695 #endif
11696
11697 /* insert a character: */
11698 #if WANT_INSERT_1CHAR
insert_1char(uintB c)11699 local void insert_1char (uintB c) {
11700 var int y = curr->y;
11701 var int x = curr->x;
11702 if (x==cols)
11703 x--; /* do not write beyond right border! */
11704 if (ICcap || IMcap) {
11705 curr->image[y][x] = c;
11706 #if WANT_ATTR
11707 curr->attr[y][x] = curr->curr_attr;
11708 #endif
11709 #if WANT_CHARSET
11710 curr->font[y][x] = curr->charsets[curr->curr_charset]; /* = term_charset */
11711 #endif
11712 #if WANT_INSERT
11713 if (!curr->insert)
11714 #endif
11715 set_insert_mode(true);
11716 out_capstring(ICcap); out_char(c);
11717 #if WANT_INSERT
11718 if (!curr->insert)
11719 #endif
11720 set_insert_mode(false);
11721 curr->x = x+1;
11722 } else {
11723 /* save old line-content: */
11724 save_line_old(y);
11725 /* build new line-content: */
11726 {
11727 var uintB* p1 = &curr->image[y][x];
11728 *p1++ = c;
11729 memcpy(p1,&old_image[x],cols-1-x);
11730 }
11731 #if WANT_ATTR
11732 {
11733 var uintB* p1 = &curr->attr[y][x];
11734 *p1++ = curr->curr_attr;
11735 memcpy(p1,&old_attr[x],cols-1-x);
11736 }
11737 #endif
11738 #if WANT_CHARSET
11739 {
11740 var uintB* p1 = &curr->font[y][x];
11741 *p1++ = term_charset; /* = curr->charsets[curr->curr_charset] */
11742 memcpy(p1,&old_font[x],cols-1-x);
11743 }
11744 #endif
11745 /* display line: */
11746 redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
11747 x++;
11748 gofromto(last_y,last_x,y,x); curr->x = x;
11749 }
11750 }
11751 #endif
11752
11753 /* create room for n characters: */
11754 #if WANT_INSERT_CHAR
insert_char(uintC n)11755 local void insert_char (uintC n) {
11756 var int y = curr->y;
11757 var int x = curr->x;
11758 if (n > cols-x)
11759 n = cols-x;
11760 if (n==0)
11761 return;
11762 /* save old line-content: */
11763 save_line_old(y);
11764 /* build new line-content: */
11765 {
11766 var uintB* p1 = &curr->image[y][x];
11767 memset(p1,' ',n);
11768 memcpy(p1+n,&old_image[x],cols-x-n);
11769 }
11770 #if WANT_ATTR
11771 {
11772 var uintB* p1 = &curr->attr[y][x];
11773 memset(p1,0,n);
11774 memcpy(p1+n,&old_attr[x],cols-x-n);
11775 }
11776 #endif
11777 #if WANT_CHARSET
11778 {
11779 var uintB* p1 = &curr->font[y][x];
11780 memset(p1,0,n);
11781 memcpy(p1+n,&old_font[x],cols-x-n);
11782 }
11783 #endif
11784 if (CICcap && (n > 1)) {
11785 #if WANT_INSERT
11786 if (curr->insert)
11787 set_insert_mode(false);
11788 #endif
11789 out_cap1string(CICcap,n);
11790 {
11791 var uintC count;
11792 dotimespC(count,n, { out_char(' '); } );
11793 }
11794 #if WANT_INSERT
11795 if (curr->insert)
11796 set_insert_mode(true);
11797 #endif
11798 gofromto(y,x+n,y,x);
11799 } else if (ICcap || IMcap) {
11800 #if WANT_INSERT
11801 if (!curr->insert)
11802 #endif
11803 set_insert_mode(true);
11804 {
11805 var uintC count;
11806 dotimespC(count,n, { out_capstring(ICcap); out_char(' '); } );
11807 }
11808 #if WANT_INSERT
11809 if (!curr->insert)
11810 #endif
11811 set_insert_mode(false);
11812 gofromto(y,x+n,y,x);
11813 } else {
11814 redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
11815 gofromto(last_y,last_x,y,x);
11816 }
11817 }
11818 #endif
11819
11820 /* insert lines: */
11821 #if WANT_INSERT_LINE
insert_line(uintC n)11822 local void insert_line (uintC n) {
11823 if (n > curr->bot - curr->y + 1)
11824 n = curr->bot - curr->y + 1;
11825 if (n==0)
11826 return;
11827 var int oldtop = curr->top;
11828 curr->top = curr->y;
11829 {
11830 var uintC count;
11831 dotimespC(count,n, { scroll_down(); } );
11832 }
11833 if (ALcap || CALcap) {
11834 gofromto(curr->y,curr->x,curr->y,0); /* to the beginning of the line */
11835 if ((CALcap && (n>1)) || !ALcap) {
11836 out_cap1string(CALcap,n);
11837 } else {
11838 var uintC count;
11839 dotimespC(count,n, { out_capstring(ALcap); } );
11840 }
11841 gofromto(curr->y,0,curr->y,curr->x);
11842 } else if (CScap && SRcap) {
11843 out_capstring(tgoto(CScap,curr->bot,curr->top));
11844 gofromto(-1,-1,curr->top,0);
11845 {
11846 var uintC count;
11847 dotimespC(count,n, { out_capstring(SRcap); } );
11848 }
11849 out_capstring(tgoto(CScap,curr->bot,oldtop));
11850 gofromto(-1,-1,curr->y,curr->x);
11851 } else {
11852 redisplay();
11853 }
11854 curr->top = oldtop;
11855 }
11856 #endif
11857
11858 /* Deletion-Operations: */
11859
11860 /* delete Characters: */
11861 #if WANT_DELETE_CHAR
delete_char(uintC n)11862 local void delete_char (uintC n) {
11863 var int y = curr->y;
11864 var int x = curr->x;
11865 if (n > cols-x)
11866 n = cols-x;
11867 if (n==0)
11868 return;
11869 /* save old line-content: */
11870 save_line_old(y);
11871 /* build new line-content: */
11872 {
11873 var uintB* p1 = &curr->image[y][x];
11874 memcpy(p1,&old_image[x],cols-x-n);
11875 memset(p1+cols-x-n,' ',n);
11876 }
11877 #if WANT_ATTR
11878 {
11879 var uintB* p1 = &curr->attr[y][x];
11880 memcpy(p1,&old_attr[x],cols-x-n);
11881 memset(p1+cols-x-n,0,n);
11882 }
11883 #endif
11884 #if WANT_CHARSET
11885 {
11886 var uintB* p1 = &curr->font[y][x];
11887 memcpy(p1,&old_font[x],cols-x-n);
11888 memset(p1+cols-x-n,0,n);
11889 }
11890 #endif
11891 if (CDCcap && ((n>1) || !DCcap)) {
11892 out_cap1string(CDCcap,n);
11893 } else if (DCcap) {
11894 var uintC count;
11895 dotimespC(count,n, { out_capstring(DCcap); } );
11896 } else {
11897 redisplay_line RLargs(old_image,old_attr,old_font,y,x,cols);
11898 gofromto(last_y,last_x,y,x);
11899 }
11900 }
11901
11902 #endif
11903
11904 /* delete lines: */
11905 #if WANT_DELETE_LINE
delete_line(uintC n)11906 local void delete_line (uintC n) {
11907 if (n > curr->bot - curr->y + 1)
11908 n = curr->bot - curr->y + 1;
11909 if (n==0)
11910 return;
11911 var int oldtop = curr->top;
11912 curr->top = curr->y;
11913 {
11914 var uintC count;
11915 dotimespC(count,n, { scroll_up(); } );
11916 }
11917 if (DLcap || CDLcap) {
11918 gofromto(curr->y,curr->x,curr->y,0); /* to the beginning of the line */
11919 if ((CDLcap && (n>1)) || !DLcap) {
11920 out_cap1string(CDLcap,n);
11921 } else {
11922 var uintC count;
11923 dotimespC(count,n, { out_capstring(DLcap); } );
11924 }
11925 gofromto(curr->y,0,curr->y,curr->x);
11926 } else if (CScap) {
11927 out_capstring(tgoto(CScap,curr->bot,curr->top));
11928 gofromto(-1,-1,curr->bot,0);
11929 {
11930 var uintC count;
11931 dotimespC(count,n, { out_capstring(SFcap); } );
11932 }
11933 out_capstring(tgoto(CScap,curr->bot,oldtop));
11934 gofromto(-1,-1,curr->y,curr->x);
11935 } else {
11936 redisplay();
11937 }
11938 curr->top = oldtop;
11939 }
11940 #endif
11941
11942 /* write a character: */
11943 #if WANT_OUTPUT_1CHAR
output_1char(uintB c)11944 local void output_1char (uintB c) {
11945 #if WANT_INSERT
11946 if (curr->insert) {
11947 insert_1char(c);
11948 return;
11949 }
11950 #endif
11951 var int y = curr->y;
11952 var int x = curr->x;
11953 if (x==cols)
11954 x--; /* do not write beyond right border! */
11955 curr->image[y][x] = c;
11956 #if WANT_ATTR
11957 curr->attr[y][x] = curr->curr_attr;
11958 #endif
11959 #if WANT_CHARSET
11960 curr->font[y][x] = curr->charsets[curr->curr_charset]; /* = term_charset */
11961 #endif
11962 x++;
11963 if (!(AM && (x==cols) && (curr->y==curr->bot))) /* poss. spare right lower corner */
11964 out_char(c); /* write character */
11965 curr->x = x; /* Cursor is advanced by one */
11966 if (x==cols) /* except it was already located rightmost */
11967 gofromto(-1,-1,curr->y,curr->x);
11968 }
11969 #endif
11970
11971 #if WANT_SAVE
11972
11973 /* stored Cursor-Position: */
save_cursor(void)11974 local void save_cursor (void) {
11975 curr->saved_x = curr->x;
11976 curr->saved_y = curr->y;
11977 #if WANT_ATTR
11978 curr->saved_curr_attr = curr->curr_attr;
11979 #endif
11980 #if WANT_CHARSET
11981 curr->saved_curr_charset = curr->curr_charset;
11982 {
11983 var uintC i = 0;
11984 while (i<charset_count)
11985 { curr->saved_charsets[i] = curr->charsets[i]; i++; }
11986 }
11987 #endif
11988 curr->saved = true;
11989 }
restore_cursor(void)11990 local void restore_cursor (void) {
11991 if (curr->saved) {
11992 gofromto(curr->y,curr->x,curr->saved_y,curr->saved_x);
11993 curr->y = curr->saved_y; curr->x = curr->saved_x;
11994 #if WANT_ATTR
11995 curr->curr_attr = curr->saved_curr_attr;
11996 change_attr(curr->curr_attr);
11997 #endif
11998 #if WANT_CHARSET
11999 curr->curr_charset = curr->saved_curr_charset;
12000 {
12001 var uintC i = 0;
12002 while (i<charset_count)
12003 { curr->charsets[i] = curr->saved_charsets[i]; i++; }
12004 }
12005 change_charset(curr->charsets[curr->curr_charset]);
12006 #endif
12007 }
12008 }
12009
12010 #endif
12011
12012 /* Initializes the Terminal.
12013 Returns NULL if OK, else returns an error-string. */
12014 local bool term_initialized = false;
init_term(void)12015 local const char * init_term (void) {
12016 var char tbuf[4096]; /* internal Buffer for the Termcap-Routines */
12017 if (term_initialized)
12018 return NULL; /* already initialized -> OK */
12019 /* query Terminal-Type: */
12020 begin_system_call();
12021 {
12022 var const char* s = getenv("TERM");
12023 if (s==NULL) {
12024 end_system_call();
12025 return GETTEXT("environment has no TERM variable");
12026 }
12027 if (!(tgetent(tbuf,s)==1)) {
12028 end_system_call();
12029 pushSTACK(asciz_to_string(s,O(misc_encoding)));
12030 return GETTEXT("terminal type ~S unknown to termcap");
12031 }
12032 }
12033 {
12034 var int i = tgetnum("co");
12035 cols = (i>0 ? i : 80);
12036 }
12037 {
12038 var int i = tgetnum("li");
12039 rows = (i>0 ? i : 24);
12040 }
12041 if (tgetflag("hc")) {
12042 end_system_call();
12043 return GETTEXT("insufficient terminal: hardcopy terminal");
12044 }
12045 if (tgetflag("os")) {
12046 end_system_call();
12047 return GETTEXT("insufficient terminal: overstrikes, cannot clear output");
12048 }
12049 if (tgetflag("ns")) {
12050 end_system_call();
12051 return GETTEXT("insufficient terminal: cannot scroll");
12052 }
12053 if (!(CLcap = tgetstr("cl",&tp))) {
12054 /* Could use CLcap = "\n\n\n\n"; as Default ('weird HPs') */
12055 end_system_call();
12056 return GETTEXT("insufficient terminal: cannot clear screen");
12057 }
12058 if (!(CMcap = tgetstr("cm",&tp))) {
12059 end_system_call();
12060 return GETTEXT("insufficient terminal: cannot position cursor randomly");
12061 }
12062 /* initialize Capabilities: */
12063 AM = tgetflag("am"); if (tgetflag("LP")) AM = false;
12064 TIcap = tgetstr("ti",&tp);
12065 TEcap = tgetstr("te",&tp);
12066 /* BLcap = tgetstr("bl",&tp); if (!BLcap) BLcap = "\007";
12067 VBcap = tgetstr("vb",&tp); */
12068 BCcap = tgetstr("bc",&tp); if (!BCcap) BCcap = (tgetflag("bs") ? "\b" : tgetstr("le",&tp));
12069 CRcap = tgetstr("cr",&tp); if (!CRcap) CRcap = "\r";
12070 NLcap = tgetstr("nl",&tp); if (!NLcap) NLcap = "\n";
12071 DOcap = tgetstr("do",&tp); if (!DOcap) DOcap = NLcap;
12072 UPcap = tgetstr("up",&tp);
12073 NDcap = tgetstr("nd",&tp);
12074 IScap = tgetstr("is",&tp);
12075 #if WANT_ATTR
12076 if ((tgetnum("sg") > 0) || (tgetnum("ug") > 0)) {
12077 /* switching to Standout-Mode or switching to
12078 Underline-Mode yields blankspace -> unusable! */
12079 SOcap = NULL; SEcap = NULL; UScap = NULL; UEcap = NULL;
12080 MBcap = NULL; MDcap = NULL; MHcap = NULL; MRcap = NULL; MEcap = NULL;
12081 } else {
12082 SOcap = tgetstr("so",&tp);
12083 SEcap = tgetstr("se",&tp);
12084 UScap = tgetstr("us",&tp);
12085 UEcap = tgetstr("ue",&tp);
12086 if (!UScap && !UEcap) { /* no Underline? */
12087 UScap = SOcap; UEcap = SEcap; /* use Standout as replacement */
12088 }
12089 MBcap = tgetstr("mb",&tp);
12090 MDcap = tgetstr("md",&tp);
12091 MHcap = tgetstr("mh",&tp);
12092 MRcap = tgetstr("mr",&tp);
12093 MEcap = tgetstr("me",&tp);
12094 /* Does ME also reverse the effect of SO and/or US? This is not
12095 clearly specified by the termcap manual.
12096 Anyway, we should at least look whether ME/SE/UE are equal: */
12097 if (UEcap && SEcap && asciz_equal(UEcap,SEcap)) UEcap = NULL;
12098 if (UEcap && MEcap && asciz_equal(UEcap,MEcap)) UEcap = NULL;
12099 if (SEcap && MEcap && asciz_equal(SEcap,MEcap)) SEcap = NULL;
12100 /* tgetstr("uc",&tp) returns an underline-character. Then execute
12101 backspace() and out_capstring(UCcap) at a time in redisplay_help()
12102 and output_1char() after out_char().
12103 For which Terminals is this worthwhile?? */
12104 }
12105 #endif
12106 #if WANT_CHARSET
12107 ISO2022 = tgetflag("G0");
12108 #endif
12109 CScap = tgetstr("cs",&tp);
12110 #if WANT_DELETE_LINE
12111 SFcap = tgetstr("sf",&tp); if (!SFcap) SFcap = NLcap;
12112 #endif
12113 #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
12114 SRcap = tgetstr("sr",&tp);
12115 #endif
12116 #if WANT_CLEAR_FROM_BOS || WANT_CLEAR_TO_EOS || WANT_CLEAR_LINE || WANT_CLEAR_FROM_BOL || WANT_CLEAR_TO_EOL
12117 CEcap = tgetstr("ce",&tp);
12118 #endif
12119 #if WANT_CLEAR_TO_EOS
12120 CDcap = tgetstr("cd",&tp);
12121 #endif
12122 #if WANT_CURSOR_REVLINEFEED || WANT_INSERT_LINE
12123 ALcap = tgetstr("al",&tp);
12124 #endif
12125 #if WANT_DELETE_LINE
12126 DLcap = tgetstr("dl",&tp);
12127 #endif
12128 #if WANT_DELETE_CHAR
12129 DCcap = tgetstr("dc",&tp);
12130 #endif
12131 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
12132 ICcap = tgetstr("ic",&tp);
12133 #endif
12134 #if WANT_INSERT_CHAR
12135 CICcap = tgetstr("IC",&tp);
12136 #endif
12137 #if WANT_INSERT_LINE
12138 CALcap = tgetstr("AL",&tp);
12139 #endif
12140 #if WANT_DELETE_CHAR
12141 CDCcap = tgetstr("DC",&tp);
12142 #endif
12143 #if WANT_DELETE_LINE
12144 CDLcap = tgetstr("DL",&tp);
12145 #endif
12146 IMcap = tgetstr("im",&tp);
12147 EIcap = tgetstr("ei",&tp);
12148 if (tgetflag ("in")) { /* Insert-Mode unusable? */
12149 IMcap = NULL; EIcap = NULL;
12150 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
12151 ICcap = NULL;
12152 #endif
12153 #if WANT_INSERT_CHAR
12154 CICcap = NULL;
12155 #endif
12156 }
12157 if (IMcap && (IMcap[0]==0)) IMcap = NULL; /* IMcap empty? */
12158 if (EIcap && (EIcap[0]==0)) EIcap = NULL; /* EIcap empty? */
12159 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR
12160 if (ICcap && (ICcap[0]==0)) ICcap = NULL; /* ICcap empty? */
12161 #endif
12162 /* calculate the costs of the Capabilities: */
12163 IMcost = cap_cost(IMcap);
12164 EIcost = cap_cost(EIcap);
12165 BCcost = cap_cost(BCcap);
12166 NDcost = cap_cost(NDcap);
12167 DOcost = cap_cost(DOcap);
12168 #ifndef NL_HACK
12169 /* If DOcap writes a LF, it is not sure, if this arrives
12170 at the Terminal as such (and not as CR/LF). In this case we
12171 declare DOcap as unusable. This spares us the NL_HACK. */
12172 if (DOcap[0]=='\n')
12173 DOcost = EXPENSIVE;
12174 #endif
12175 UPcost = cap_cost(UPcap);
12176 CRcost = cap_cost(CRcap);
12177 /* provide Auxiliary-Data-Structures: */
12178 blank = (uintB*) malloc(cols*sizeof(uintB));
12179 memset(blank,' ',cols);
12180 #if WANT_ATTR || WANT_CHARSET
12181 {
12182 var uintB* ptr = (uintB*) malloc(cols*sizeof(uintB));
12183 null = ptr;
12184 memset(ptr,0,cols);
12185 }
12186 #endif
12187 #if WANT_INSERT_1CHAR || WANT_INSERT_CHAR || WANT_DELETE_CHAR
12188 old_image_y = (uintB*) malloc(cols*sizeof(uintB));
12189 #if WANT_ATTR
12190 old_attr_y = (uintB*) malloc(cols*sizeof(uintB));
12191 #endif
12192 #if WANT_CHARSET
12193 old_font_y = (uintB*) malloc(cols*sizeof(uintB));
12194 #endif
12195 #endif
12196 end_system_call();
12197 term_initialized = true;
12198 return NULL;
12199 }
12200
12201
12202 #ifdef NL_HACK
12203
12204 /* If NLcap = "\n" , we must execute an "stty -onlcr", because otherwise
12205 the NL is converted to CR by the Terminal-Driver, before it
12206 arrives at the Terminal. */
12207 local void term_nlraw (void);
12208 local void term_nlunraw (uintB abort);
12209 #ifdef UNIX_TERM_TERMIOS
12210 static unsigned long old_c_oflag = 0;
term_nlraw()12211 local void term_nlraw() {
12212 var struct termios oldtermio;
12213 if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) {
12214 if (!(errno==ENOTTY)) { OS_error(); }
12215 }
12216 old_c_oflag = oldtermio.c_oflag;
12217 oldtermio.c_oflag &= ~ONLCR;
12218 if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) {
12219 if (!(errno==ENOTTY)) { OS_error(); }
12220 }
12221 }
term_nlunraw(uintB abort)12222 local void term_nlunraw (uintB abort) {
12223 if (old_c_oflag & ONLCR) {
12224 var struct termios oldtermio;
12225 if (!( tcgetattr(stdout_handle,&oldtermio) ==0)) {
12226 if (!abort && errno!=ENOTTY) { OS_error(); }
12227 }
12228 oldtermio.c_oflag |= ONLCR;
12229 if (!( TCSETATTR(stdout_handle,TCSAFLUSH,&oldtermio) ==0)) {
12230 if (!abort && errno!=ENOTTY) { OS_error(); }
12231 }
12232 }
12233 }
12234 #endif
12235
12236 #endif /* NL_HACK */
12237
12238 /* Begin of Processing this Packet: */
start_term(void)12239 local void start_term (void) {
12240 #ifdef NL_HACK
12241 if (NLcap[0] == '\n')
12242 term_nlraw();
12243 #endif
12244 out_capstring (IScap);
12245 out_capstring (TIcap);
12246 }
12247
12248 /* End of Processing this Packet: */
end_term(uintB abort)12249 local void end_term (uintB abort) {
12250 out_capstring (TEcap);
12251 out_capstring (IScap);
12252 #if 0
12253 /* On ANSI-Terminals with several colors: TEcap resets the colors. */
12254 out_capstring(CLcap); /* delete screen, this time with the normal color */
12255 #endif
12256 #ifdef NL_HACK
12257 if (NLcap[0] == '\n')
12258 term_nlunraw(abort);
12259 #else
12260 unused(abort);
12261 #endif
12262 }
12263
12264 /* Initializes the Window curr. */
init_curr(void)12265 local void init_curr (void) {
12266 {
12267 var uintB** ptr = (uintB**) malloc(rows*sizeof(uintB*));
12268 var uintC count;
12269 curr->image = ptr;
12270 dotimespC(count,rows, { *ptr++ = (uintB*) malloc(cols*sizeof(uintB)); } );
12271 }
12272 #if WANT_ATTR
12273 {
12274 var uintB** ptr = (uintB**) malloc(rows*sizeof(uintB*));
12275 var uintC count;
12276 curr->attr = ptr;
12277 dotimespC(count,rows, { *ptr++ = (uintB*) malloc(cols*sizeof(uintB)); } );
12278 }
12279 /* deactivate Attribute: */
12280 out_capstring(UEcap); /* all deactivated */
12281 out_capstring(SEcap);
12282 out_capstring(MEcap);
12283 term_attr = curr->curr_attr = 0;
12284 #endif
12285 #if WANT_CHARSET
12286 {
12287 var uintB** ptr = (uintB**) malloc(rows*sizeof(uintB*));
12288 var uintC count;
12289 curr->font = ptr;
12290 dotimespC(count,rows, { *ptr++ = (uintB*) malloc(cols*sizeof(uintB)); } );
12291 }
12292 {
12293 var uintC i = 0;
12294 while (i<charset_count) { curr->charsets[i] = ASCII; i++; }
12295 }
12296 curr->curr_charset = 0;
12297 if (ISO2022) {
12298 out_char(ESC); out_char('('); out_char('B'); /*)*/
12299 }
12300 term_charset = ASCII;
12301 #endif
12302 curr->x = 0; curr->y = 0;
12303 curr->top = 0; curr->bot = rows-1;
12304 #if WANT_INSERT
12305 curr->insert = false;
12306 #endif
12307 #if WANT_SAVE
12308 curr->saved = false;
12309 #endif
12310 if (CScap)
12311 out_capstring(tgoto(CScap,curr->bot,curr->top));
12312 clear_screen();
12313 }
12314
12315 /* ------------------------------------------------------------------------
12316
12317 UP: Write character to a Window-Stream.
12318 wr_ch_window(&stream,ch);
12319 > stream: Window-Stream
12320 > ch: character to be written */
wr_ch_window(const gcv_object_t * stream_,object ch)12321 local maygc void wr_ch_window (const gcv_object_t* stream_, object ch) {
12322 check_wr_char(*stream_,ch);
12323 var uintB c = as_cint(char_code(ch)); /* FIXME: This should take into account the encoding. */
12324 begin_system_call();
12325 if (graphic_char_p(as_chart(c))) {
12326 if (curr->x == cols) {
12327 cursor_return(); cursor_linefeed(); /* Wrap! */
12328 }
12329 output_1char(c);
12330 } else if (c == NL) {
12331 cursor_return(); cursor_linefeed();
12332 } else if (c == BS) {
12333 var int x0 = curr->x;
12334 if (x0>0) {
12335 var int y0 = curr->y;
12336 clear_linepart(y0,x0-1,x0);
12337 gofromto(curr->y,curr->x,y0,x0-1); curr->y = y0; curr->x = x0-1;
12338 }
12339 }
12340 end_system_call();
12341 }
12342
12343 LISPFUNN(make_window,0) {
12344 var object stream = /* Flags: only WRITE-CHAR allowed */
12345 allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1,0);
12346 /* and fill: */
12347 stream_dummy_fill(stream);
12348 var Stream s = TheStream(stream);
12349 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_window); /* WRITE-CHAR-Pseudofunction */
12350 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_dummy); /* WRITE-CHAR-SEQUENCE-Pseudofunction */
12351 /* Initialize: */
12352 begin_system_call();
12353 {
12354 var const char * result = init_term();
12355 if (!(result==NULL))
12356 error(error_condition,result);
12357 }
12358 start_term();
12359 init_curr();
12360 end_system_call();
12361 VALUES1(stream);
12362 }
12363
12364 /* Closes a Window-Stream. */
close_window(object stream,uintB abort)12365 local void close_window (object stream, uintB abort) {
12366 unused(stream);
12367 begin_system_call();
12368 end_term(abort);
12369 end_system_call();
12370 }
12371
12372 LISPFUNN(window_size,1) {
12373 check_window_stream(popSTACK());
12374 VALUES2(fixnum(rows), /* query Variables rows,cols */
12375 fixnum(cols));
12376 }
12377
12378 LISPFUNN(window_cursor_position,1) {
12379 check_window_stream(popSTACK());
12380 VALUES2(fixnum(curr->y),
12381 fixnum(curr->x));
12382 }
12383
12384 LISPFUNN(set_window_cursor_position,3) {
12385 check_window_stream(STACK_2);
12386 var uintV line = posfixnum_to_V(STACK_1);
12387 var uintV column = posfixnum_to_V(STACK_0);
12388 if ((line < rows) && (column < cols)) {
12389 begin_system_call();
12390 gofromto(curr->y,curr->x,line,column); /* position Cursor */
12391 curr->y = line; curr->x = column;
12392 end_system_call();
12393 }
12394 VALUES2(STACK_1, STACK_0); skipSTACK(3);
12395 }
12396
12397 LISPFUNN(clear_window,1) {
12398 check_window_stream(popSTACK());
12399 begin_system_call();
12400 clear_screen();
12401 end_system_call();
12402 VALUES0;
12403 }
12404
12405 LISPFUNN(clear_window_to_eot,1) {
12406 check_window_stream(popSTACK());
12407 begin_system_call();
12408 clear_to_EOS();
12409 end_system_call();
12410 VALUES0;
12411 }
12412
12413 LISPFUNN(clear_window_to_eol,1) {
12414 check_window_stream(popSTACK());
12415 begin_system_call();
12416 clear_to_EOL();
12417 end_system_call();
12418 VALUES0;
12419 }
12420
12421 LISPFUNN(delete_window_line,1) {
12422 check_window_stream(popSTACK());
12423 begin_system_call();
12424 delete_line(1);
12425 end_system_call();
12426 VALUES0;
12427 }
12428
12429 LISPFUNN(insert_window_line,1) {
12430 check_window_stream(popSTACK());
12431 begin_system_call();
12432 insert_line(1);
12433 end_system_call();
12434 VALUES0;
12435 }
12436
12437 LISPFUNN(highlight_on,1) {
12438 check_window_stream(popSTACK());
12439 begin_system_call();
12440 change_attr(curr->curr_attr |= A_US);
12441 end_system_call();
12442 VALUES0;
12443 }
12444
12445 LISPFUNN(highlight_off,1) {
12446 check_window_stream(popSTACK());
12447 begin_system_call();
12448 change_attr(curr->curr_attr &= ~A_US);
12449 end_system_call();
12450 VALUES0;
12451 }
12452
12453 LISPFUNN(window_cursor_on,1) {
12454 check_window_stream(popSTACK());
12455 /* Cursor is permanently activated! */
12456 VALUES0;
12457 }
12458
12459 LISPFUNN(window_cursor_off,1) {
12460 check_window_stream(popSTACK());
12461 /* not possible, because Cursor is activated permanently! */
12462 VALUES0;
12463 }
12464
12465 #endif /* UNIX */
12466
12467 #if defined(UNIX) && 0
12468
12469 /* Normal CURSES-Package, we use only stdscr. */
12470
12471 #undef BS
12472 #undef CR
12473 #undef NL
12474 #include <curses.h>
12475 #undef OK
12476 #define CR 13
12477 #define NL 10
12478
12479 /* UP: Write character to Window-Stream.
12480 wr_ch_window(&stream,ch);
12481 > stream: Window-Stream
12482 > ch: character to be written */
wr_ch_window(const gcv_object_t * stream_,object ch)12483 local maygc void wr_ch_window (const gcv_object_t* stream_, object ch) {
12484 check_wr_char(*stream_,ch);
12485 var uintB c = as_cint(char_code(ch)); /* FIXME: This should take into account the encoding. */
12486 begin_system_call();
12487 if (graphic_char_p(as_chart(c))) { /* let only printable characters pass to the screen */
12488 addch(c);
12489 } else if (c == NL) { /* convert NL to CR/LF */
12490 addch(CR); addch(LF);
12491 } else { /* write something, for the Cursor-Position to be correct */
12492 addch('?');
12493 }
12494 end_system_call();
12495 }
12496
12497 LISPFUNN(make_window,0) {
12498 var object stream = /* Flags: only WRITE-CHAR allowed */
12499 allocate_stream(strmflags_wr_ch_B,strmtype_window,strm_len+1,0);
12500 /* and fill: */
12501 stream_dummy_fill(stream);
12502 var Stream s = TheStream(stream);
12503 s->strm_wr_ch = s->strm_wr_ch_npnl = P(wr_ch_window); /* WRITE-CHAR-Pseudofunction */
12504 s->strm_wr_ch_array = s->strm_wr_ch_array_npnl = P(wr_ch_array_dummy); /* WRITE-CHAR-SEQUENCE-Pseudofunction */
12505 begin_system_call();
12506 initscr(); /* initialize Curses - What, if this crashes?? use newterm()?? */
12507 cbreak(); noecho(); /* Input not line-buffered, without Echo */
12508 #ifdef SUN4
12509 keypad(stdscr,true); /* activate Function-Key-Detection */
12510 #endif
12511 end_system_call();
12512 VALUES1(stream);
12513 }
12514
12515 /* Closes a Window-Stream. */
close_window(object stream,uintB abort)12516 local void close_window (object stream, uintB abort) {
12517 begin_system_call();
12518 nocbreak(); echo(); /* Input is line-buffered again, with Echo */
12519 #ifdef SUN4
12520 keypad(stdscr,false); /* deactivate Function-Key-Detection again */
12521 #endif
12522 endwin(); /* deactivate Curses */
12523 end_system_call();
12524 }
12525
12526 LISPFUNN(window_size,1) {
12527 check_window_stream(popSTACK());
12528 VALUES2(fixnum(LINES), /* query Curses-Variables LINES, COLS */
12529 fixnum(COLS));
12530 }
12531
12532 LISPFUNN(window_cursor_position,1) {
12533 check_window_stream(popSTACK());
12534 var int y;
12535 var int x;
12536 begin_system_call();
12537 getyx(stdscr,y,x); /* (y,x) := cursor position */
12538 end_system_call();
12539 VALUES2(fixnum(y),
12540 fixnum(x));
12541 }
12542
12543 LISPFUNN(set_window_cursor_position,3) {
12544 check_window_stream(STACK_2);
12545 var uintV line = posfixnum_to_V(STACK_1);
12546 var uintV column = posfixnum_to_V(STACK_0);
12547 if ((line < LINES) && (column < COLS)) {
12548 begin_system_call();
12549 move(line,column); refresh(); /* position Cursor */
12550 end_system_call();
12551 }
12552 VALUES2(STACK_1, STACK_0); skipSTACK(3);
12553 }
12554
12555 LISPFUNN(clear_window,1) {
12556 check_window_stream(popSTACK());
12557 begin_system_call();
12558 clear(); refresh();
12559 end_system_call();
12560 VALUES0;
12561 }
12562
12563 LISPFUNN(clear_window_to_eot,1) {
12564 check_window_stream(popSTACK());
12565 begin_system_call();
12566 clrtobot(); refresh();
12567 end_system_call();
12568 VALUES0;
12569 }
12570
12571 LISPFUNN(clear_window_to_eol,1) {
12572 check_window_stream(popSTACK());
12573 begin_system_call();
12574 clrtoeol(); refresh();
12575 end_system_call();
12576 VALUES0;
12577 }
12578
12579 LISPFUNN(delete_window_line,1) {
12580 check_window_stream(popSTACK());
12581 begin_system_call();
12582 deleteln(); refresh();
12583 end_system_call();
12584 VALUES0;
12585 }
12586
12587 LISPFUNN(insert_window_line,1) {
12588 check_window_stream(popSTACK());
12589 begin_system_call();
12590 insertln(); refresh();
12591 end_system_call();
12592 VALUES0;
12593 }
12594
12595 LISPFUNN(highlight_on,1) {
12596 check_window_stream(popSTACK());
12597 #ifdef A_STANDOUT /* only works, if Curses manages the Attributes */
12598 begin_system_call();
12599 attron(A_STANDOUT); /* add Attribut A_STANDOUT with OR at addch() */
12600 end_system_call();
12601 #endif
12602 VALUES0;
12603 }
12604
12605 LISPFUNN(highlight_off,1) {
12606 check_window_stream(popSTACK());
12607 #ifdef A_STANDOUT /* only works, if Curses manages the Attributes */
12608 begin_system_call();
12609 attroff(A_STANDOUT); /* don't add Attribute with OR at addch() */
12610 end_system_call();
12611 #endif
12612 VALUES0;
12613 }
12614
12615 LISPFUNN(window_cursor_on,1) {
12616 check_window_stream(popSTACK());
12617 /* Cursor is permanently activated! */
12618 VALUES0;
12619 }
12620
12621 LISPFUNN(window_cursor_off,1) {
12622 check_window_stream(popSTACK());
12623 /* not possible, because Cursor is activated permanently! */
12624 VALUES0;
12625 }
12626
12627 #endif /* UNIX */
12628
12629 #endif /* SCREEN */
12630
12631
12632 #ifdef PIPES
12633
12634 /* Pipe-Input-Stream, Pipe-Output-Stream
12635 =====================================
12636
12637 Additional Components:
12638 define strm_pipe_pid strm_field1 - Process-Id, a Fixnum >=0 */
12639
12640 #if defined(UNIX) || defined(WIN32_NATIVE)
12641 #define low_close_pipe low_close_handle
12642 #endif
12643
12644 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
12645
12646 /* Be careful to disable SIGPIPE during write() to a subprocess. */
12647
low_flush_buffered_pipe(object stream,uintL bufflen)12648 local maygc void low_flush_buffered_pipe (object stream, uintL bufflen) {
12649 begin_system_call();
12650 var Handle fd = TheHandle(BufferedStream_channel(stream));
12651 var uintB* buff = BufferedStream_buffer_address(stream,0);
12652 pin_unprotect_varobject(BufferedStream_buffer(stream),PROT_READ);
12653 pushSTACK(stream);
12654 START_WRITING_TO_SUBPROCESS;
12655 var ssize_t result;
12656 GC_SAFE_CALL(result = full_write(fd,buff,bufflen));
12657 STOP_WRITING_TO_SUBPROCESS;
12658 stream = popSTACK();
12659 unpin_varobject(BufferedStream_buffer(stream));
12660 if (result == bufflen) { /* everything was written correctly */
12661 end_system_call(); BufferedStream_modified(stream) = false;
12662 } else { /* not everything was written */
12663 if (result<0) { /* Error? */
12664 end_system_call(); OS_filestream_error(stream);
12665 }
12666 end_system_call();
12667 error_unwritable(TheSubr(subr_self)->name,stream);
12668 }
12669 }
12670
12671 #else
12672
12673 #define low_flush_buffered_pipe low_flush_buffered_handle
12674
12675 #endif
12676
12677 #define BufferedPipeStream_init(stream) \
12678 { BufferedStreamLow_fill(stream) = &low_fill_buffered_handle; \
12679 BufferedStreamLow_flush(stream) = &low_flush_buffered_pipe; \
12680 }
12681
12682 /* Pipe-Input-Stream
12683 =================
12684
12685 Low-level. */
12686
12687 #define UnbufferedPipeStream_input_init(stream) UnbufferedHandleStream_input_init(stream)
12688
create_input_pipe(const char * command)12689 local inline void create_input_pipe (const char* command) {
12690 var int child;
12691 #ifdef UNIX
12692 var int handles[2]; /* two Handles for the pipe */
12693 {
12694 /* As shell we always use the Command-Shell.
12695 copy command to Stack: */
12696 var uintL command_length = asciz_length(command)+1;
12697 var DYNAMIC_ARRAY(command_data,char,command_length);
12698 begin_system_call();
12699 memcpy(command_data,command,command_length);
12700 begin_want_sigcld();
12701 /* build pipe: */
12702 if (!( pipe(handles) ==0)) {
12703 FREE_DYNAMIC_ARRAY(command_data);
12704 end_want_sigcld(); OS_error();
12705 }
12706 /* Everything, that is stuffed in handles[1], resurfaces at handles[0]
12707 again. We will utilize this as follows:
12708 write system read
12709 child -> handles[1] -> handles[0] -> parent
12710 start a new process: */
12711 if ((child = vfork()) ==0) {
12712 /* this piece of code is executed by the child-process: */
12713 if ( dup2(handles[1],stdout_handle) >=0) /* redirect standard-output */
12714 if ( CLOSE(handles[1]) ==0) /* we want to write only via stdout_handle */
12715 if ( CLOSE(handles[0]) ==0) { /* we do not want to read from the pipe */
12716 /* (I have to tell this the operating system. Then - if the Child
12717 has filled the pipe - the parent-process is called
12718 in order to empty the pipe (and not the child-process).)
12719 turn child-process into a background process: */
12720 SETSID(); /* it receives its own process group */
12721 close_all_fd();
12722 execl(SHELL, /* call shell */
12723 SHELL, /* =: argv[0] */
12724 "-c", /* =: argv[1] */
12725 &command_data[0], /* =: argv[2] */
12726 NULL);
12727 }
12728 _exit(-1); /* if this fails, finish child-process */
12729 }
12730 /* This piece of code is again executed by the caller: */
12731 end_want_sigcld();
12732 if (child==-1)
12733 /* Something failed, either on vfork or on execl.
12734 In both cases errno was set. */
12735 OS_error_saving_errno({
12736 CLOSE(handles[1]); CLOSE(handles[0]);
12737 FREE_DYNAMIC_ARRAY(command_data);
12738 });
12739 /* We only want to read from the pipe, not write: */
12740 if (!( CLOSE(handles[1]) ==0))
12741 OS_error_saving_errno({
12742 CLOSE(handles[0]);
12743 FREE_DYNAMIC_ARRAY(command_data);
12744 });
12745 /* (I have to tell this the operating system. Then - if the parent-process
12746 has emptied the pipe - the child-process is called in order to fill the
12747 pipe again (and not the parent-process).) */
12748 end_system_call();
12749 FREE_DYNAMIC_ARRAY(command_data);
12750 }
12751 #endif
12752 #ifdef WIN32_NATIVE
12753 var Handle handles[2]; /* two Handles for the pipe */
12754 {
12755 begin_system_call();
12756 var Handle child_write_handle;
12757 /* Create a pipe and make one of the two handles inheritable. */
12758 if (!CreatePipe(&handles[0],&handles[1],NULL,0)) { OS_error(); }
12759 if (!DuplicateHandle(GetCurrentProcess(),handles[1],
12760 GetCurrentProcess(),&child_write_handle,
12761 0, true, DUPLICATE_SAME_ACCESS)) {
12762 OS_error();
12763 }
12764 if (!CloseHandle(handles[1])) { OS_error(); }
12765 var HANDLE stdinput,stderror;
12766 var PROCESS_INFORMATION pinfo;
12767 stdinput = GetStdHandle(STD_INPUT_HANDLE);
12768 if (stdinput == INVALID_HANDLE_VALUE) { OS_error(); }
12769 stderror = GetStdHandle(STD_ERROR_HANDLE);
12770 if (stderror == INVALID_HANDLE_VALUE) { OS_error(); }
12771 if (!MyCreateProcess((TCHAR*)command,stdinput,child_write_handle,
12772 stderror,&pinfo))
12773 { OS_error(); }
12774 /* Close our copy of the child's handle, so that the OS knows
12775 that we won't write on it. */
12776 if (!CloseHandle(child_write_handle)) { OS_error(); }
12777 if (!CloseHandle(pinfo.hThread)) { OS_error(); }
12778 if (!CloseHandle(pinfo.hProcess)) { OS_error(); }
12779 child = pinfo.dwProcessId;
12780 end_system_call();
12781 }
12782 #endif
12783 pushSTACK(UL_to_I(child));
12784 pushSTACK(STACK_(1+1));
12785 pushSTACK(STACK_(2+2));
12786 pushSTACK(allocate_handle(handles[0]));
12787 }
12788
12789 /* forward declaration */
12790 local maygc object make_pipe (buffered_t, direction_t, decoded_el_t*);
12791
12792 /* UP: The common part of MAKE-PIPE-INPUT-STREAM & MAKE-PIPE-OUTPUT-STREAM
12793 > STACK_0: :buffered
12794 > STACK_1: :external-format
12795 > STACK_2: :element-type
12796 > STACK_3: command line
12797 < value1: pipe stream
12798 cleans up the STACK
12799 can trigger GC */
make_pipe_stream(direction_t direction,void create_pipe (const char *))12800 local maygc Values make_pipe_stream (direction_t direction,
12801 void create_pipe (const char*)) {
12802 var decoded_el_t eltype;
12803 var buffered_t buffered;
12804 STACK_3 = check_string(STACK_3); /* check command */
12805 /* Check and canonicalize the :BUFFERED argument: */
12806 buffered = test_buffered_arg(STACK_0);
12807 /* Check and canonicalize the :ELEMENT-TYPE argument: */
12808 test_eltype_arg(&STACK_2,&eltype);
12809 STACK_2 = canon_eltype(&eltype);
12810 CHECK_UNBUFFERED_ELTYPE(buffered,direction,eltype);
12811 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
12812 STACK_1 = test_external_format_arg(STACK_1);
12813 /* Now create the pipe. */
12814 with_string_0(STACK_3,O(misc_encoding),command_asciz,
12815 { create_pipe(command_asciz); });
12816 /* allocate Stream: */
12817 var object stream = make_pipe(buffered,direction,&eltype);
12818 TheStream(stream)->strm_pipe_pid = popSTACK(); /* Child-Pid */
12819 skipSTACK(4);
12820 VALUES1(stream); /* return stream */
12821 }
12822
12823 /* (MAKE-PIPE-INPUT-STREAM command [:element-type] [:external-format] [:buffered])
12824 calls a shell, that executes command, whereby its Standard-Output
12825 is directed into our pipe. */
12826 LISPFUN(make_pipe_input_stream,seclass_default,1,0,norest,key,3,
12827 (kw(element_type),kw(external_format),kw(buffered)) )
12828 { make_pipe_stream(DIRECTION_INPUT,create_input_pipe); }
12829
12830 /* Pipe-Output-Stream
12831 ================== */
12832
12833 /* Low-level. */
12834
12835 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
12836
12837 /* Be careful to disable SIGPIPE during write() to a subprocess. */
12838
low_write_unbuffered_pipe(object stream,uintB b)12839 local maygc void low_write_unbuffered_pipe (object stream, uintB b) {
12840 var Handle handle = TheHandle(TheStream(stream)->strm_ochannel);
12841 restart_it:
12842 begin_system_call();
12843 /* Try to output the byte. */
12844 pushSTACK(stream);
12845 START_WRITING_TO_SUBPROCESS;
12846 var int result;
12847 GC_SAFE_CALL(result = write(handle,&b,1));
12848 STOP_WRITING_TO_SUBPROCESS;
12849 stream = popSTACK();
12850 if (result<0) {
12851 if (errno==EINTR) { /* Break (poss. by Ctrl-C) ? */
12852 end_system_call();
12853 interruptp({ error_interrupt(); });
12854 goto restart_it;
12855 }
12856 OS_error();
12857 }
12858 end_system_call();
12859 if (result==0) /* not successful? */
12860 error_unwritable(TheSubr(subr_self)->name,stream);
12861 }
12862
low_write_array_unbuffered_pipe(object stream,const uintB * byteptr,uintL len,perseverance_t persev)12863 local maygc const uintB* low_write_array_unbuffered_pipe
12864 (object stream, const uintB* byteptr, uintL len, perseverance_t persev) {
12865 var Handle handle = TheHandle(TheStream(stream)->strm_ochannel);
12866 begin_system_call();
12867 pushSTACK(stream);
12868 START_WRITING_TO_SUBPROCESS;
12869 var ssize_t result;
12870 GC_SAFE_CALL(result = fd_write(handle,byteptr,len,persev));
12871 STOP_WRITING_TO_SUBPROCESS;
12872 stream = popSTACK();
12873 if (result<0) { OS_error(); }
12874 end_system_call();
12875 /* Safety check whether persev argument was respected or EOWF was reached: */
12876 if ((persev == persev_full && !(result==(sintL)len))
12877 || (persev == persev_partial && !(result>0)))
12878 error_unwritable(TheSubr(subr_self)->name,stream);
12879 return byteptr+result;
12880 }
12881
12882 #else
12883
12884 #define low_write_unbuffered_pipe low_write_unbuffered_handle
12885 #define low_write_array_unbuffered_pipe low_write_array_unbuffered_handle
12886
12887 #endif
12888
low_finish_output_unbuffered_pipe(object stream)12889 local void low_finish_output_unbuffered_pipe (object stream) /* do nothing */
12890 { unused(stream); }
low_force_output_unbuffered_pipe(object stream)12891 local void low_force_output_unbuffered_pipe (object stream) /* do nothing */
12892 { unused(stream); }
low_clear_output_unbuffered_pipe(object stream)12893 local void low_clear_output_unbuffered_pipe (object stream) /* do nothing */
12894 { unused(stream); }
12895
12896 /* make, init, and register pipe stream object
12897 > buffered
12898 > direction
12899 > eltype
12900 < stream object
12901 can trigger GC */
make_pipe(buffered_t buffered,direction_t direction,decoded_el_t * eltype)12902 local maygc object make_pipe (buffered_t buffered, direction_t direction,
12903 decoded_el_t *eltype) {
12904 var object stream;
12905 var uintB type = (direction == DIRECTION_INPUT
12906 ? strmtype_pipe_in : strmtype_pipe_out);
12907 if (buffered == BUFFERED_NIL) {
12908 stream = make_unbuffered_stream(type,direction,eltype,false,false);
12909 if (READ_P(direction)) UnbufferedPipeStream_input_init(stream);
12910 if (WRITE_P(direction)) { /*UnbufferedPipeStream_output_init(stream);*/
12911 UnbufferedStreamLow_write(stream) = &low_write_unbuffered_pipe;
12912 UnbufferedStreamLow_write_array(stream) =
12913 &low_write_array_unbuffered_pipe;
12914 UnbufferedStreamLow_finish_output(stream) =
12915 &low_finish_output_unbuffered_pipe;
12916 UnbufferedStreamLow_force_output(stream) =
12917 &low_force_output_unbuffered_pipe;
12918 UnbufferedStreamLow_clear_output(stream) =
12919 &low_clear_output_unbuffered_pipe;
12920 }
12921 } else {
12922 stream = make_buffered_stream(type,direction,eltype,false,false);
12923 BufferedPipeStream_init(stream);
12924 }
12925 ChannelStreamLow_close(stream) = &low_close_pipe;
12926 return add_to_open_streams(stream);
12927 }
12928
create_output_pipe(const char * command)12929 local inline void create_output_pipe (const char* command) {
12930 var int child;
12931 #ifdef UNIX
12932 var int handles[2]; /* two Handles for the pipe */
12933 {
12934 /* As shell we always use the Command-Shell.
12935 copy command to Stack: */
12936 var uintL command_length = asciz_length(command)+1;
12937 var DYNAMIC_ARRAY(command_data,char,command_length);
12938 begin_system_call();
12939 memcpy(command_data,command,command_length);
12940 begin_want_sigcld();
12941 if (!( pipe(handles) ==0)) {
12942 FREE_DYNAMIC_ARRAY(command_data);
12943 end_want_sigcld(); OS_error();
12944 }
12945 /* Everything, that is stuffed in handles[1], resurfaces at handles[0]
12946 again. We will utilize this as follows:
12947 write system read
12948 parent -> handles[1] -> handles[0] -> child
12949 start a new process: */
12950 if ((child = vfork()) ==0) {
12951 /* this piece of code is executed by the child-process: */
12952 if ( dup2(handles[0],stdin_handle) >=0) /* redirect standard-input */
12953 if ( CLOSE(handles[0]) ==0) /* we want to read only via stdin_handle */
12954 if ( CLOSE(handles[1]) ==0) { /* we do not want to write to the pipe */
12955 /* (I have to tell this the operating system, so that - when the
12956 Child has emptied the pipe - the parent-process and not the
12957 child-process is called, in order to fill the pipe again.)
12958 turn child-process into a background process: */
12959 SETSID(); /* it receives its own process group */
12960 close_all_fd();
12961 execl(SHELL, /* call shell */
12962 SHELL, /* =: argv[0] */
12963 "-c", /* =: argv[1] */
12964 &command_data[0], /* =: argv[2] */
12965 NULL);
12966 }
12967 _exit(-1); /* if this fails, finish child-process */
12968 }
12969 /* This piece of code is again executed by the caller: */
12970 end_want_sigcld();
12971 if (child==-1)
12972 /* Something failed, either on vfork or on execl.
12973 In both cases errno was set. */
12974 OS_error_saving_errno({
12975 CLOSE(handles[1]); CLOSE(handles[0]);
12976 FREE_DYNAMIC_ARRAY(command_data);
12977 });
12978 /* We only want to write to the pipe, not read: */
12979 if (!( CLOSE(handles[0]) ==0))
12980 OS_error_saving_errno({
12981 CLOSE(handles[1]);
12982 FREE_DYNAMIC_ARRAY(command_data);
12983 });
12984 /* (I have to tell this the operating system, so that - when the
12985 parent-process has filled the pipe - the child-process and not the
12986 parent-process is called, in order to empty the pipe again.) */
12987 end_system_call();
12988 FREE_DYNAMIC_ARRAY(command_data);
12989 }
12990 #endif
12991 #ifdef WIN32_NATIVE
12992 var Handle handles[2]; /* two Handles for the Pipe */
12993 {
12994 begin_system_call();
12995 var Handle child_read_handle;
12996 /* Create a pipe and make one of the two handles inheritable. */
12997 if (!CreatePipe(&handles[0],&handles[1],NULL,0)) { OS_error(); }
12998 if (!DuplicateHandle(GetCurrentProcess(),handles[0],
12999 GetCurrentProcess(),&child_read_handle,
13000 0, true, DUPLICATE_SAME_ACCESS)) {
13001 OS_error();
13002 }
13003 if (!CloseHandle(handles[0])) { OS_error(); }
13004 var HANDLE stdoutput,stderror;
13005 var PROCESS_INFORMATION pinfo;
13006 stdoutput = GetStdHandle(STD_OUTPUT_HANDLE);
13007 if (stdoutput == INVALID_HANDLE_VALUE) { OS_error(); }
13008 stderror = GetStdHandle(STD_ERROR_HANDLE);
13009 if (stderror == INVALID_HANDLE_VALUE) { OS_error(); }
13010 if (!MyCreateProcess((TCHAR*)command,child_read_handle,stdoutput,
13011 stderror,&pinfo))
13012 { OS_error(); }
13013 /* Close our copy of the child's handle, so that the OS knows
13014 that we won't read from it. */
13015 if (!CloseHandle(child_read_handle)) { OS_error(); }
13016 if (!CloseHandle(pinfo.hThread)) { OS_error(); }
13017 if (!CloseHandle(pinfo.hProcess)) { OS_error(); }
13018 child = pinfo.dwProcessId;
13019 end_system_call();
13020 }
13021 #endif
13022 pushSTACK(UL_to_I(child));
13023 pushSTACK(STACK_(1+1));
13024 pushSTACK(STACK_(2+2));
13025 pushSTACK(allocate_handle(handles[1]));
13026 }
13027
13028 /* (MAKE-PIPE-OUTPUT-STREAM command [:element-type] [:external-format] [:buffered])
13029 calls a shell, that executes command, whereby our Pipe is redirected
13030 into the standard-input of the command. */
13031 LISPFUN(make_pipe_output_stream,seclass_default,1,0,norest,key,3,
13032 (kw(element_type),kw(external_format),kw(buffered)) )
13033 { make_pipe_stream(DIRECTION_OUTPUT,create_output_pipe); }
13034
13035 /* mk_pipe_from_handle(pipe,process_id,dir)
13036 Make a PIPE-OUTPUT-STREAM from pipe handle and a process-id
13037 > STACK_0: buffered
13038 > STACK_1: element-type
13039 > STACK_2: encoding
13040 > pipe: input or output pipe, depending on direction
13041 > process_id: PID of the underlying process
13042 > direction: pipe stream direction
13043 < result - a PIPE-OUTPUT-STREAM
13044 Used in LAUNCH
13045 can trigger GC */
mk_pipe_from_handle(Handle pipe,int process_id,direction_t direction)13046 extern maygc object mk_pipe_from_handle (Handle pipe, int process_id,
13047 direction_t direction) {
13048 var decoded_el_t eltype;
13049 var buffered_t buffered;
13050 /* Check and canonicalize the :BUFFERED argument: */
13051 buffered = test_buffered_arg(STACK_0);
13052 /* Check and canonicalize the :ELEMENT-TYPE argument: */
13053 test_eltype_arg(&STACK_1,&eltype);
13054 STACK_1 = canon_eltype(&eltype);
13055 CHECK_UNBUFFERED_ELTYPE(buffered,direction,eltype);
13056 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
13057 STACK_2 = test_external_format_arg(STACK_2);
13058 STACK_0 = allocate_handle(pipe);
13059 var object stream = make_pipe(buffered,direction,&eltype);
13060 pushSTACK(stream);
13061 var object pid = UL_to_I(process_id);
13062 TheStream(STACK_0)->strm_pipe_pid = pid;
13063 return popSTACK(); /* return stream */
13064 }
13065
13066
13067 #ifdef PIPES2
13068
13069 /* Bidirectional Pipes
13070 ==================== */
13071
create_io_pipe(const char * command)13072 local inline void create_io_pipe (const char* command) {
13073 var int child;
13074 #ifdef UNIX
13075 var int in_handles[2]; /* two Handles for the Pipe to the Input-Stream */
13076 var int out_handles[2]; /* two Handles for the Pipe to the Output-Stream */
13077 {
13078 /* As shell we always use the Command-Shell.
13079 copy command to Stack: */
13080 var uintL command_length = asciz_length(command)+1;
13081 var DYNAMIC_ARRAY(command_data,char,command_length);
13082 begin_system_call();
13083 memcpy(command_data,command,command_length);
13084 begin_want_sigcld();
13085 /* build Pipes: */
13086 if (pipe(in_handles))
13087 OS_error_saving_errno({
13088 FREE_DYNAMIC_ARRAY(command_data);
13089 end_want_sigcld();
13090 });
13091 if (pipe(out_handles))
13092 OS_error_saving_errno({
13093 FREE_DYNAMIC_ARRAY(command_data);
13094 end_want_sigcld();
13095 CLOSE(in_handles[1]); CLOSE(in_handles[0]);
13096 });
13097 /* Everything, that is stuffed in handles[1], resurfaces at handles[0]
13098 again. We will utilize this as follows:
13099 write system read
13100 parent -> out_handles[1] -> out_handles[0] -> child
13101 parent <- in_handles[0] <- in_handles[1] <- child
13102 read system write
13103 start a new process: */
13104 if ((child = vfork()) ==0) {
13105 /* this piece of code is executed by the child-process: */
13106 if ( dup2(out_handles[0],stdin_handle) >=0) /* redirect Standard-Input */
13107 if ( dup2(in_handles[1],stdout_handle) >=0) /* redirect Standard-Output */
13108 if ( CLOSE(out_handles[0]) ==0) /* read only via stdin_handle */
13109 if ( CLOSE(in_handles[1]) ==0) /* write only via stdout_handle */
13110 if ( CLOSE(out_handles[1]) ==0) /* do not write to the pipe */
13111 /* (I have to tell this the operating system, so that -
13112 when the child-process has emptied the pipe -
13113 the parent-process and not the child-process is called,
13114 in order to fill the pipe again.) */
13115 if ( CLOSE(in_handles[0]) ==0) { /* do not to read from the pipe */
13116 /* (I have to tell this the operating system, so that -
13117 when the child-process has filled the pipe -
13118 the parent-process and not the child-process is called,
13119 in order to empty the pipe.)
13120 turn child-process into a background process: */
13121 SETSID(); /* it receives its own process group */
13122 close_all_fd();
13123 execl(SHELL, /* call shell */
13124 SHELL, /* =: argv[0] */
13125 "-c", /* =: argv[1] */
13126 &command_data[0], /* =: argv[2] */
13127 NULL);
13128 }
13129 _exit(-1); /* if this fails, finish child-process */
13130 }
13131 /* This piece of code is again executed by the caller: */
13132 end_want_sigcld();
13133 if (child==-1)
13134 /* Something failed, either on vfork or on execl.
13135 In both cases errno was set. */
13136 OS_error_saving_errno({
13137 CLOSE(in_handles[1]); CLOSE(in_handles[0]);
13138 CLOSE(out_handles[1]); CLOSE(out_handles[0]);
13139 FREE_DYNAMIC_ARRAY(command_data);
13140 });
13141 /* We only want to write to the pipe, not read: */
13142 if (!( CLOSE(out_handles[0]) ==0))
13143 OS_error_saving_errno({
13144 CLOSE(in_handles[1]); CLOSE(in_handles[0]);
13145 CLOSE(out_handles[1]);
13146 FREE_DYNAMIC_ARRAY(command_data);
13147 });
13148 /* (I have to tell this the operating system, so that - when the
13149 parent-process has filled the pipe - the child-process and not the
13150 parent-process is called, in order to empty the pipe again.)
13151 We only want to read from the pipe, not write: */
13152 if (!( CLOSE(in_handles[1]) ==0))
13153 OS_error_saving_errno({
13154 CLOSE(in_handles[0]); CLOSE(out_handles[1]);
13155 FREE_DYNAMIC_ARRAY(command_data);
13156 });
13157 /* (I have to tell this the operating system, so that - when the
13158 parent-process has emptied the pipe - the child-process and not the
13159 parent-process is called, in order to fill the pipe again.) */
13160 end_system_call();
13161 FREE_DYNAMIC_ARRAY(command_data);
13162 }
13163 #endif
13164 #ifdef WIN32_NATIVE
13165 var Handle in_handles[2]; /* two Handles for the Pipe to the Input-Stream */
13166 var Handle out_handles[2]; /* two Handles for the Pipe to the Output-Stream */
13167 {
13168 begin_system_call();
13169 var Handle child_read_handle;
13170 var Handle child_write_handle;
13171 var Handle stderror;
13172 /* Create two pipes and make two of the four handles inheritable. */
13173 if (!CreatePipe(&in_handles[0],&in_handles[1],NULL,0)) { OS_error(); }
13174 if (!DuplicateHandle(GetCurrentProcess(),in_handles[1],
13175 GetCurrentProcess(),&child_write_handle,
13176 0, true, DUPLICATE_SAME_ACCESS))
13177 { OS_error(); }
13178 if (!CloseHandle(in_handles[1])) { OS_error(); }
13179 if (!CreatePipe(&out_handles[0],&out_handles[1],NULL,0)) { OS_error(); }
13180 if (!DuplicateHandle(GetCurrentProcess(),out_handles[0],
13181 GetCurrentProcess(),&child_read_handle,
13182 0, true, DUPLICATE_SAME_ACCESS))
13183 { OS_error(); }
13184 if (!CloseHandle(out_handles[0])) { OS_error(); }
13185 stderror = GetStdHandle(STD_ERROR_HANDLE);
13186 if (stderror == INVALID_HANDLE_VALUE) { OS_error(); }
13187 var PROCESS_INFORMATION pinfo;
13188 if (!MyCreateProcess((TCHAR*)command,child_read_handle,child_write_handle,
13189 stderror,&pinfo))
13190 { OS_error(); }
13191 /* Close our copies of the child's handles, so that the OS knows
13192 that we won't use them. */
13193 if (!CloseHandle(child_read_handle)) { OS_error(); }
13194 if (!CloseHandle(child_write_handle)) { OS_error(); }
13195 if (!CloseHandle(pinfo.hThread)) { OS_error(); }
13196 if (!CloseHandle(pinfo.hProcess)) { OS_error(); }
13197 child = pinfo.dwProcessId;
13198 end_system_call();
13199 }
13200 #endif
13201 pushSTACK(UL_to_I(child));
13202 pushSTACK(allocate_handle(in_handles[0]));
13203 pushSTACK(allocate_handle(out_handles[1]));
13204 }
13205
13206 /* (MAKE-PIPE-IO-STREAM command [:element-type] [:external-format] [:buffered])
13207 calls a shell, that executes command, whereby the output of our pipe
13208 is redirected into the standard-input of command and its standard-output
13209 is redirected into our pipe. */
13210 LISPFUN(make_pipe_io_stream,seclass_default,1,0,norest,key,3,
13211 (kw(element_type),kw(external_format),kw(buffered)) ) {
13212 var decoded_el_t eltype;
13213 var buffered_t buffered;
13214 /* check command: */
13215 pushSTACK(STACK_3); funcall(L(string),1); /* (STRING command) */
13216 STACK_3 = value1;
13217 /* Check and canonicalize the :BUFFERED argument: */
13218 buffered = test_buffered_arg(STACK_0);
13219 /* Check and canonicalize the :ELEMENT-TYPE argument: */
13220 test_eltype_arg(&STACK_2,&eltype);
13221 STACK_2 = canon_eltype(&eltype);
13222 if (buffered <= 0) { check_unbuffered_eltype(&eltype); }
13223 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
13224 STACK_1 = test_external_format_arg(STACK_1);
13225 /* Now create the pipe. */
13226 with_string_0(STACK_3,O(misc_encoding),command_asciz, {
13227 create_io_pipe(command_asciz);
13228 });
13229 /* allocate Input-Stream: */
13230 {
13231 pushSTACK(STACK_(1+3)); /* encoding */
13232 pushSTACK(STACK_(2+3+1)); /* eltype */
13233 pushSTACK(STACK_(1+2));
13234 var object stream = make_pipe(buffered,DIRECTION_INPUT,&eltype);
13235 TheStream(stream)->strm_pipe_pid = STACK_2; /* Child-Pid */
13236 STACK_1 = stream;
13237 }
13238 /* allocate Output-Stream: */
13239 {
13240 pushSTACK(STACK_(1+3)); /* encoding */
13241 pushSTACK(STACK_(2+3+1)); /* eltype */
13242 pushSTACK(STACK_(0+2));
13243 var object stream = make_pipe(buffered,DIRECTION_OUTPUT,&eltype);
13244 TheStream(stream)->strm_pipe_pid = STACK_2; /* Child-Pid */
13245 STACK_0 = stream;
13246 }
13247 /* 3 values:
13248 (make-two-way-stream input-stream output-stream), input-stream, output-stream. */
13249 STACK_2 = make_twoway_stream(STACK_1,STACK_0);
13250 STACK_to_mv(3);
13251 skipSTACK(4);
13252 }
13253
13254 #endif /* PIPES2 */
13255
13256 #endif /* PIPES */
13257
13258
13259 #if defined(X11SOCKETS) || defined(SOCKET_STREAMS)
13260
13261 /* X11-Socket-Stream, Socket-Stream
13262 ================================
13263
13264 Socket streams are just like handle streams (unbuffered file streams),
13265 except that on UNIX_BEOS and WIN32_NATIVE, the low-level functions are
13266 different.
13267
13268 Both sides
13269 ----------
13270
13271 Closes a socket handle. */
13272 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
low_close_socket(object stream,object handle,uintB abort)13273 local void low_close_socket (object stream, object handle, uintB abort) {
13274 begin_system_call();
13275 var int closed;
13276 var SOCKET socket = TheSocket(handle);
13277 GC_SAFE_CALL(closed = close(socket));
13278 if (!(closed == 0) && !abort)
13279 { ANSIC_error(); }
13280 end_system_call();
13281 }
13282 #else
13283 #define low_close_socket low_close_handle
13284 #endif
13285
13286 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
13287
13288 #ifdef WIN32_NATIVE
13289 #define CHECK_INTERRUPT \
13290 if (errno==EINTR) /* Break by Ctrl-C ?*/ \
13291 { end_system_call(); error_interrupt(); }
13292 #else
13293 #define CHECK_INTERRUPT
13294 #endif
13295
13296 #define SYSCALL(result,call) \
13297 do { \
13298 begin_system_call(); \
13299 begin_blocking_call(); \
13300 result = (call); \
13301 end_blocking_call(); \
13302 if (result<0) { CHECK_INTERRUPT; ANSIC_error(); } \
13303 end_system_call(); \
13304 } while(0)
13305
13306 #endif
13307
13308 /* Return true if the last error from sock_read()/sock_write() indicates an EOF. */
sock_error_eof_p(void)13309 local bool sock_error_eof_p (void) {
13310 var bool ret = false;
13311 begin_system_call();
13312 #if defined(WIN32_NATIVE)
13313 if (errno==ENOENT || errno==WSAESHUTDOWN) /* indicates EOF */
13314 ret = true;
13315 #else
13316 if (errno==ENOENT) /* indicates EOF */
13317 ret = true;
13318 #endif
13319 end_system_call();
13320 return ret;
13321 }
13322
13323 /* Input side
13324 ---------- */
13325
13326 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
13327
low_read_unbuffered_socket(object stream)13328 local maygc sintL low_read_unbuffered_socket (object stream) {
13329 if (UnbufferedStream_status(stream) < 0) /* already EOF? */
13330 return -1;
13331 if (UnbufferedStream_status(stream) > 0) { /* bytebuf contains valid bytes? */
13332 UnbufferedStreamLow_pop_byte(stream,b); return b;
13333 }
13334 var SOCKET handle = TheSocket(TheStream(stream)->strm_ichannel);
13335 var uintB b;
13336 var ssize_t result;
13337 pushSTACK(stream);
13338 SYSCALL(result,sock_read(handle,&b,1,persev_full)); /* try to read a byte */
13339 stream = popSTACK();
13340 if (result==0) {
13341 ASSERT(sock_error_eof_p()); /* no byte available -> must be EOF */
13342 UnbufferedStream_status(stream) = -1; return -1;
13343 } else {
13344 return b;
13345 }
13346 }
13347
low_listen_unbuffered_socket(object stream)13348 local listen_t low_listen_unbuffered_socket (object stream) {
13349 if (UnbufferedStream_status(stream) < 0) /* already EOF? */
13350 return LISTEN_EOF;
13351 if (UnbufferedStream_status(stream) > 0) /* bytebuf contains valid bytes? */
13352 return LISTEN_AVAIL;
13353 var SOCKET handle = TheSocket(TheStream(stream)->strm_ichannel);
13354 /* Use select() with readfds = singleton set {handle}
13355 and timeout = zero interval. */
13356 var fd_set handle_set; /* set of handles := {handle} */
13357 var struct timeval zero_time; /* time interval := 0 */
13358 begin_system_call();
13359 FD_ZERO(&handle_set); FD_SET(handle,&handle_set);
13360 restart_select:
13361 zero_time.tv_sec = 0; zero_time.tv_usec = 0;
13362 var int result = select(FD_SETSIZE,&handle_set,NULL,NULL,&zero_time);
13363 if (result<0) {
13364 CHECK_INTERRUPT;
13365 #ifdef UNIX_BEOS
13366 if (errno==EINTR)
13367 goto restart_select;
13368 #endif
13369 ANSIC_error();
13370 } else {
13371 /* result = number of handles in handle_set for which read() would
13372 return without blocking. */
13373 if (result==0) {
13374 end_system_call(); return LISTEN_WAIT;
13375 }
13376 /* result=1
13377 When read() returns a result without blocking, this can also be EOF!
13378 try to read a byte: */
13379 var uintB b;
13380 /* read will not block */
13381 var ssize_t result = sock_read(handle,&b,1,persev_full);
13382 if (result<0) {
13383 CHECK_INTERRUPT;
13384 ANSIC_error();
13385 }
13386 end_system_call();
13387 if (result==0) {
13388 ASSERT(sock_error_eof_p());
13389 UnbufferedStream_status(stream) = -1; return LISTEN_EOF;
13390 } else {
13391 /* Stuff the read byte into the buffer, for next low_read call. */
13392 UnbufferedStreamLow_push_byte(stream,b);
13393 return LISTEN_AVAIL;
13394 }
13395 }
13396 }
13397
low_clear_input_unbuffered_socket(object stream)13398 local bool low_clear_input_unbuffered_socket (object stream) {
13399 /* This is not called anyway, because TheStream(stream)->strm_isatty = NIL. */
13400 return false; /* Not sure whether this is the correct behaviour?? */
13401 }
13402
low_read_array_unbuffered_socket(object stream,uintB * byteptr,uintL len,perseverance_t persev)13403 local maygc uintB* low_read_array_unbuffered_socket
13404 (object stream, uintB* byteptr, uintL len, perseverance_t persev) {
13405 if (UnbufferedStream_status(stream) < 0) /* already EOF? */
13406 return byteptr;
13407 byteptr = UnbufferedStream_pop_all(stream,byteptr,&len);
13408 if (len == 0) return byteptr;
13409 var SOCKET handle = TheSocket(TheStream(stream)->strm_ichannel);
13410 var ssize_t result;
13411 pushSTACK(stream);
13412 SYSCALL(result,sock_read(handle,byteptr,len,persev));
13413 stream = popSTACK();
13414 if (result==0 && sock_error_eof_p())
13415 UnbufferedStream_status(stream) = -1;
13416 return byteptr+result;
13417 }
13418
13419 /* Initializes the input side fields of a socket stream.
13420 UnbufferedSocketStream_input_init(stream); */
13421 #define UnbufferedSocketStream_input_init(stream) do { \
13422 UnbufferedStreamLow_read(stream) = &low_read_unbuffered_socket; \
13423 UnbufferedStreamLow_listen(stream) = &low_listen_unbuffered_socket; \
13424 UnbufferedStreamLow_clear_input(stream) = \
13425 &low_clear_input_unbuffered_socket; \
13426 UnbufferedStreamLow_read_array(stream) = \
13427 &low_read_array_unbuffered_socket; \
13428 UnbufferedHandleStream_input_init_data(stream); \
13429 } while (0)
13430
13431 #else
13432
13433 #define UnbufferedSocketStream_input_init(stream) \
13434 UnbufferedHandleStream_input_init(stream)
13435
13436 #endif /* UNIX_BEOS || WIN32_NATIVE */
13437
13438 /* Output side
13439 ----------- */
13440
13441 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
13442
low_write_unbuffered_socket(object stream,uintB b)13443 local maygc void low_write_unbuffered_socket (object stream, uintB b) {
13444 var SOCKET handle = TheSocket(TheStream(stream)->strm_ochannel);
13445 var ssize_t result;
13446 pushSTACK(stream);
13447 SYSCALL(result,sock_write(handle,&b,1,persev_full)); /* Try to output the byte. */
13448 stream = popSTACK();
13449 if (result==0) /* not successful? */
13450 error_unwritable(TheSubr(subr_self)->name,stream);
13451 }
13452
low_write_array_unbuffered_socket(object stream,const uintB * byteptr,uintL len,perseverance_t persev)13453 local maygc const uintB* low_write_array_unbuffered_socket
13454 (object stream, const uintB* byteptr, uintL len, perseverance_t persev) {
13455 var SOCKET handle = TheSocket(TheStream(stream)->strm_ochannel);
13456 var ssize_t result;
13457 pushSTACK(stream);
13458 SYSCALL(result,sock_write(handle,byteptr,len,persev));
13459 stream = popSTACK();
13460 /* Safety check whether persev argument was respected or EOWF was reached: */
13461 if ((persev == persev_full && !(result==(sintL)len))
13462 || (persev == persev_partial && !(result>0)))
13463 error_unwritable(TheSubr(subr_self)->name,stream);
13464 return byteptr+result;
13465 }
13466
13467 #endif /* UNIX_BEOS || WIN32_NATIVE */
13468
13469 /* Initializes the output side fields of a socket stream.
13470 UnbufferedSocketStream_output_init(stream); */
13471 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
13472 #define UnbufferedSocketStream_output_init(stream) \
13473 { UnbufferedStreamLow_write(stream) = &low_write_unbuffered_socket; \
13474 UnbufferedStreamLow_write_array(stream) = \
13475 &low_write_array_unbuffered_socket; \
13476 UnbufferedStreamLow_finish_output(stream) = \
13477 &low_finish_output_unbuffered_pipe; \
13478 UnbufferedStreamLow_force_output(stream) = \
13479 &low_force_output_unbuffered_pipe; \
13480 UnbufferedStreamLow_clear_output(stream) = \
13481 &low_clear_output_unbuffered_pipe; \
13482 }
13483 #else
13484 /* Use low_write_unbuffered_pipe, not low_write_unbuffered_handle, here because
13485 writing to a closed socket generates a SIGPIPE signal, just like for pipes. */
13486 #define UnbufferedSocketStream_output_init(stream) \
13487 { UnbufferedStreamLow_write(stream) = &low_write_unbuffered_pipe; \
13488 UnbufferedStreamLow_write_array(stream) = \
13489 &low_write_array_unbuffered_pipe; \
13490 UnbufferedStreamLow_finish_output(stream) = \
13491 &low_finish_output_unbuffered_pipe; \
13492 UnbufferedStreamLow_force_output(stream) = \
13493 &low_force_output_unbuffered_pipe; \
13494 UnbufferedStreamLow_clear_output(stream) = \
13495 &low_clear_output_unbuffered_pipe; \
13496 }
13497 #endif /* UNIX_BEOS || WIN32_NATIVE */
13498
13499 #endif /* X11SOCKETS || SOCKET_STREAMS */
13500
13501
13502 #ifdef X11SOCKETS
13503
13504 /* X11-Socket-Stream
13505 =================
13506
13507 usage: for X-Windows.
13508
13509 Additional Components:
13510 define strm_x11socket_connect strm_field1 - List (host display) */
13511
13512 extern SOCKET connect_to_x_server (const char* host, int display); /* a piece X-Source... */
13513
13514 /* (SYS::MAKE-SOCKET-STREAM host display)
13515 returns an X11-Socket-Stream for X-Windows or NIL. */
13516 LISPFUNN(make_x11socket_stream,2) {
13517 if (!stringp(STACK_1)) {
13518 pushSTACK(STACK_1); /* TYPE-ERROR slot DATUM */
13519 pushSTACK(S(string)); /* TYPE-ERROR slot EXPECTED-TYPE */
13520 pushSTACK(STACK_(1+2));
13521 error(type_error,GETTEXT("host should be string, not ~S"));
13522 }
13523 if (!uint16_p(STACK_0)) {
13524 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
13525 pushSTACK(O(type_uint16)); /* TYPE-ERROR slot EXPECTED-TYPE */
13526 pushSTACK(STACK_(0+2));
13527 error(type_error,
13528 GETTEXT("display should be a small nonnegative integer, not ~S"));
13529 }
13530 var int display = I_to_uint16(STACK_0);
13531 var SOCKET handle;
13532 with_string_0(STACK_1,O(misc_encoding),host, {
13533 GC_SAFE_SYSTEM_CALL(handle = connect_to_x_server(host,display));
13534 });
13535 if (handle == INVALID_SOCKET) { ANSIC_error(); }
13536 /* build list: */
13537 { var object list = listof(2); pushSTACK(list); }
13538 pushSTACK(test_external_format_arg(S(Kunix)));
13539 pushSTACK(O(strmtype_ubyte8));
13540 pushSTACK(allocate_socket(handle));
13541 /* allocate Stream: */
13542 var decoded_el_t eltype = { eltype_iu, 8 };
13543 var object stream = make_unbuffered_stream(strmtype_x11socket,DIRECTION_IO,
13544 &eltype,false,false);
13545 UnbufferedSocketStream_input_init(stream);
13546 UnbufferedSocketStream_output_init(stream);
13547 ChannelStreamLow_close(stream) = &low_close_socket;
13548 TheStream(stream)->strm_x11socket_connect = popSTACK(); /* two-element list */
13549 VALUES1(add_to_open_streams(stream)); /* return stream */
13550 }
13551
13552 /* The two following functions should
13553 1. not only work for Handle- and Socket-Streams, but also for Synonym-
13554 and Concatenated-Streams, ideally for File-Streams, too.
13555 2. also accept non-simple Byte-Vectors.
13556 For CLX this implementation is sufficient.
13557
13558 (SYS::READ-N-BYTES stream vector start count)
13559 reads n Bytes at once.
13560 Source:
13561 stream: Handle- or Socket-Stream
13562 Destination: (aref vector start), ..., (aref vector (+ start (- count 1))),
13563 whereby
13564 vector: semi-simple 8Bit-Byte-Vector
13565 start: Start-Index in the Vector
13566 count: Number of bytes
13567
13568 (SYS::WRITE-N-BYTES stream vector start count)
13569 writes n Bytes at once.
13570 Source: (aref vector start), ..., (aref vector (+ start (- count 1))),
13571 whereby
13572 vector: semi-simple 8Bit-Byte-Vector
13573 start: Start-Index in the Vector
13574 count: Number of Bytes
13575 Destination:
13576 stream: Handle- or Socket-Stream
13577
13578 Argument-Checks:
13579 Returns the Index in *index_, the count in *count_, the data-vector in the
13580 Stack instead of the vector, and cleans up the Stack by 2.
13581 can trigger GC */
test_n_bytes_args(uintL * index_,uintL * count_)13582 local maygc void test_n_bytes_args (uintL* index_, uintL* count_) {
13583 CHECK_streamtype(STACK_3,S(x11_socket_stream),
13584 (builtin_stream_p(STACK_3)
13585 && eq(TheStream(STACK_3)->strm_rd_by,
13586 P(rd_by_iau8_unbuffered))
13587 && eq(TheStream(STACK_3)->strm_wr_by,
13588 P(wr_by_iau8_unbuffered))));
13589 *count_ = I_to_UL(check_uint32(popSTACK()));
13590 *index_ = I_to_UL(check_uint32(popSTACK()));
13591 STACK_0 = array_displace_check(check_byte_vector(STACK_0),*count_,index_);
13592 }
13593
13594 /* UP: report END-OF-FILE error
13595 > stream: the stream that has reached EOS */
error_eos(object stream)13596 local _Noreturn void error_eos (object stream) {
13597 pushSTACK(stream); /* STREAM-ERROR slot STREAM */
13598 pushSTACK(stream); pushSTACK(TheSubr(subr_self)->name);
13599 error(end_of_file,GETTEXT("~S: input stream ~S has reached its end"));
13600 }
13601 #define HANDLE_EOF(eof_e_p,eofval,skip_stack) \
13602 if (nullp(eof_e_p)) { /* handle EOF: */ \
13603 value1 = eofval; \
13604 if (!boundp(value1)) value1 = NIL; /* Default is NIL */ \
13605 mv_count = 1; skipSTACK(skip_stack); /* return eofval */ \
13606 } else /* eof-error-p /= NIL (e.g. = #<UNBOUND>) ? */ \
13607 error_eos(STACK_2);
13608
13609 LISPFUNN(read_n_bytes,4) {
13610 var uintL startindex;
13611 var uintL totalcount;
13612 test_n_bytes_args(&startindex,&totalcount);
13613 if (totalcount !=0
13614 && (read_byte_array(&STACK_1,&STACK_0,startindex,totalcount,persev_full)
13615 != totalcount))
13616 error_eos(STACK_1);
13617 skipSTACK(2);
13618 VALUES1(T);
13619 }
13620
13621 LISPFUNN(write_n_bytes,4) {
13622 var uintL startindex;
13623 var uintL totalcount;
13624 test_n_bytes_args(&startindex,&totalcount);
13625 if (!(totalcount==0)) {
13626 write_byte_array(&STACK_1,&STACK_0,startindex,totalcount,persev_full);
13627 }
13628 skipSTACK(2);
13629 VALUES1(T);
13630 }
13631
13632 #endif /* X11SOCKETS */
13633
13634
13635 #ifdef SOCKET_STREAMS
13636
13637 /* Socket-Streams
13638 ==============
13639
13640 define strm_socket_port strm_field1 - port, a fixnum >=0
13641 define strm_socket_host strm_field2 - host, NIL or a string */
13642
13643 #define SocketChannel(stream) \
13644 TheSocket(ChannelStream_buffered(stream) ? BufferedStream_channel(stream) \
13645 : ChannelStream_ichannel(stream))
13646
13647 /* Low-level functions for buffered socket streams. */
13648
13649 #if defined(UNIX_BEOS) || defined(WIN32_NATIVE)
13650
13651 /* UP: Fills the buffer, up to strm_buffered_bufflen bytes.
13652 low_fill_buffered_socket(stream,persev)
13653 > stream: (open) byte-based socket stream
13654 > persev: one of persev_partial, persev_immediate, persev_bonus
13655 < result: number of bytes read */
low_fill_buffered_socket(object stream,perseverance_t persev)13656 local maygc uintL low_fill_buffered_socket (object stream,
13657 perseverance_t persev) {
13658 var SOCKET handle=TheSocket(BufferedStream_channel(stream));
13659 var uintB *buff=BufferedStream_buffer_address(stream,0);
13660 pin_unprotect_varobject(BufferedStream_buffer(stream),PROT_READ_WRITE);
13661 pushSTACK(stream);
13662 var ssize_t result;
13663 SYSCALL(result,sock_read(handle,buff,strm_buffered_bufflen,persev));
13664 stream = popSTACK();
13665 unpin_varobject(BufferedStream_buffer(stream));
13666 if (result==0 && sock_error_eof_p())
13667 BufferedStream_have_eof_p(stream) = true;
13668 return result;
13669 }
13670
13671 /* UP: Finshes the Write-Back of the Buffer.
13672 low_flush_buffered_socket(stream,bufflen);
13673 > stream : (open) Byte-based File-Stream.
13674 > bufflen : number of bytes to be written
13675 < modified_flag von stream : deleted
13676 changed in stream: index */
low_flush_buffered_socket(object stream,uintL bufflen)13677 local maygc void low_flush_buffered_socket (object stream, uintL bufflen) {
13678 begin_system_call();
13679 START_WRITING_TO_SUBPROCESS;
13680 var SOCKET handle=TheSocket(BufferedStream_channel(stream));
13681 var uintB *buff=BufferedStream_buffer_address(stream,0);
13682 pin_unprotect_varobject(BufferedStream_buffer(stream),PROT_READ);
13683 pushSTACK(stream);
13684 var ssize_t result; /* flush Buffer */
13685 GC_SAFE_CALL(result = sock_write(handle,buff,bufflen,persev_full));
13686 stream = popSTACK();
13687 unpin_varobject(BufferedStream_buffer(stream));
13688 STOP_WRITING_TO_SUBPROCESS;
13689 if (result==bufflen) {
13690 /* everything written correctly */
13691 end_system_call(); BufferedStream_modified(stream) = false;
13692 } else { /* not everything written */
13693 if (result<0) {
13694 CHECK_INTERRUPT;
13695 ANSIC_error();
13696 }
13697 end_system_call();
13698 error_unwritable(TheSubr(subr_self)->name,stream);
13699 }
13700 }
13701
13702 #else
13703
13704 /* Use low_flush_buffered_pipe, not low_flush_buffered_handle, here because
13705 writing to a closed socket generates a SIGPIPE signal, just like for pipes. */
13706 #define low_fill_buffered_socket low_fill_buffered_handle
13707 #define low_flush_buffered_socket low_flush_buffered_pipe
13708
13709 #endif
13710
13711 #define BufferedSocketStream_init(stream) \
13712 { BufferedStreamLow_fill(stream) = &low_fill_buffered_socket; \
13713 BufferedStreamLow_flush(stream) = &low_flush_buffered_socket; \
13714 }
13715
13716 /* Twoway-Socket-Streams are twoway streams with both input and output side
13717 being socket streams. (They are needed because the input and output side
13718 need different buffers. Sockets are not regular files.)
13719 define strm_twoway_socket_input strm_twoway_input - input side, a socket stream */
13720 #define strm_twoway_socket_output strm_twoway_output /* output side, a socket stream */
13721
13722 /* Hack for avoiding that the handle is closed twice. */
low_close_socket_nop(object stream,object handle,uintB abort)13723 local void low_close_socket_nop (object stream, object handle, uintB abort) {
13724 unused(stream); unused(handle); unused(abort);
13725 }
13726
13727 /* Creates a socket stream.
13728 > STACK_2: element-type
13729 > STACK_1: encoding */
make_socket_stream(SOCKET handle,decoded_el_t * eltype,buffered_t buffered,object host,object port)13730 local object make_socket_stream (SOCKET handle, decoded_el_t* eltype,
13731 buffered_t buffered, object host, object port)
13732 {
13733 pushSTACK(host);
13734 pushSTACK(STACK_(1+1)); /* encoding */
13735 pushSTACK(STACK_(2+2)); /* eltype */
13736 pushSTACK(allocate_socket(handle));
13737 /* allocate stream: */
13738 var object stream;
13739 if (buffered == BUFFERED_NIL) {
13740 stream = make_unbuffered_stream(strmtype_socket,DIRECTION_IO,
13741 eltype,false,false);
13742 UnbufferedSocketStream_input_init(stream);
13743 UnbufferedSocketStream_output_init(stream);
13744 ChannelStreamLow_close(stream) = &low_close_socket;
13745 TheStream(stream)->strm_socket_port = port;
13746 TheStream(stream)->strm_socket_host = popSTACK();
13747 } else {
13748 /* allocate Input-Stream: */
13749 pushSTACK(STACK_2); pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
13750 stream = make_buffered_stream(strmtype_socket,DIRECTION_INPUT,
13751 eltype,false,false);
13752 BufferedSocketStream_init(stream);
13753 ChannelStreamLow_close(stream) = &low_close_socket;
13754 TheStream(stream)->strm_socket_port = port;
13755 TheStream(stream)->strm_socket_host = STACK_3;
13756 pushSTACK(stream);
13757 /* allocate Output-Stream: */
13758 pushSTACK(STACK_(2+1)); pushSTACK(STACK_(1+2)); pushSTACK(STACK_(0+3));
13759 if (buffered != BUFFERED_T) {
13760 stream = make_unbuffered_stream(strmtype_socket,DIRECTION_OUTPUT,
13761 eltype,false,false);
13762 UnbufferedSocketStream_output_init(stream);
13763 } else {
13764 stream = make_buffered_stream(strmtype_socket,DIRECTION_OUTPUT,
13765 eltype,false,false);
13766 BufferedSocketStream_init(stream);
13767 }
13768 ChannelStreamLow_close(stream) = &low_close_socket;
13769 TheStream(stream)->strm_socket_port = port;
13770 TheStream(stream)->strm_socket_host = STACK_(3+1);
13771 pushSTACK(stream);
13772 /* Allocate a Two-Way-Socket-Stream: */
13773 stream = allocate_stream(strmflags_rdwr_B,strmtype_twoway_socket,
13774 strm_len+2,0);
13775 TheStream(stream)->strm_rd_by = P(rd_by_twoway);
13776 TheStream(stream)->strm_rd_by_array = P(rd_by_array_twoway);
13777 TheStream(stream)->strm_wr_by = P(wr_by_twoway);
13778 TheStream(stream)->strm_wr_by_array = P(wr_by_array_twoway);
13779 TheStream(stream)->strm_rd_ch = P(rd_ch_twoway);
13780 TheStream(stream)->strm_pk_ch = P(pk_ch_twoway);
13781 TheStream(stream)->strm_rd_ch_array = P(rd_ch_array_twoway);
13782 TheStream(stream)->strm_rd_ch_last = NIL;
13783 TheStream(stream)->strm_wr_ch =
13784 TheStream(stream)->strm_wr_ch_npnl = P(wr_ch_twoway);
13785 TheStream(stream)->strm_wr_ch_array =
13786 TheStream(stream)->strm_wr_ch_array_npnl = P(wr_ch_array_twoway);
13787 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
13788 TheStream(stream)->strm_twoway_socket_input = STACK_1;
13789 TheStream(stream)->strm_twoway_socket_output = STACK_0;
13790 skipSTACK(6);
13791 }
13792 return stream;
13793 }
13794
test_socket_server(object obj,bool check_open)13795 local void test_socket_server (object obj, bool check_open) {
13796 if (!socket_server_p(obj)) {
13797 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
13798 pushSTACK(S(socket_server)); /* TYPE-ERROR slot EXPECTED-TYPE */
13799 pushSTACK(S(socket_server)); pushSTACK(obj);
13800 pushSTACK(TheSubr(subr_self)->name);
13801 error(type_error,GETTEXT("~S: ~S is not a ~S"));
13802 }
13803 if (check_open && nullp(TheSocketServer(obj)->socket_handle)) {
13804 pushSTACK(obj);
13805 pushSTACK(TheSubr(subr_self)->name);
13806 error(error_condition,GETTEXT("~S on ~S is illegal"));
13807 }
13808 }
13809
13810 /* Called when some socket server dies. */
13811 LISPFUNN(socket_server_close,1) {
13812 test_socket_server(STACK_0,false);
13813 var object ss = STACK_0;
13814 if (!nullp(TheSocketServer(ss)->socket_handle)) {
13815 var SOCKET s = TheSocket(TheSocketServer(ss)->socket_handle);
13816 begin_system_call();
13817 while (1) {
13818 var int closed;
13819 GC_SAFE_CALL(closed = close(s));
13820 if (closed >= 0) break;
13821 if (errno != EINTR) { ANSIC_error(); }
13822 }
13823 end_system_call();
13824 ss = STACK_0;
13825 TheSocketServer(ss)->socket_handle = NIL;
13826 }
13827 skipSTACK(1);
13828 VALUES1(NIL);
13829 }
13830
13831 extern SOCKET create_server_socket_by_string
13832 (host_data_t *hd, const char *ip_interface, unsigned int port, int backlog);
13833 extern SOCKET create_server_socket_by_socket
13834 (host_data_t *hd, SOCKET sock, unsigned int port, int backlog);
13835
test_socket_stream(object obj,bool check_open)13836 local object test_socket_stream (object obj, bool check_open) {
13837 if (builtin_stream_p(obj)) {
13838 switch (TheStream(obj)->strmtype) {
13839 case strmtype_twoway_socket:
13840 obj = TheStream(obj)->strm_twoway_socket_input;
13841 /*FALLTHROUGH*/
13842 case strmtype_socket:
13843 if (check_open
13844 && ((TheStream(obj)->strmflags & strmflags_open_B) == 0)) {
13845 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
13846 pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
13847 pushSTACK(obj);
13848 pushSTACK(TheSubr(subr_self)->name);
13849 error(type_error,
13850 GETTEXT("~S: argument ~S is not an open SOCKET-STREAM"));
13851 }
13852 return obj;
13853 default:
13854 break;
13855 }
13856 }
13857 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
13858 pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
13859 pushSTACK(obj);
13860 pushSTACK(TheSubr(subr_self)->name);
13861 error(type_error,GETTEXT("~S: argument ~S is not a SOCKET-STREAM"));
13862 }
13863
13864 /* (SOCKET-SERVER &optional port &key backlog interface)
13865 * old version (SOCKET-SERVER socket) allowed, but deprecated. */
13866 LISPFUN(socket_server,seclass_default,0,1,norest,key,2,
13867 (kw(backlog),kw(interface)) ) {
13868 var unsigned int port=0; /* port to be used */
13869 var int backlog=1; /* parameter for listen(2) */
13870 var SOCKET sock = INVALID_SOCKET; /* interface to be bound, as peer */
13871 if (!missingp (STACK_1)) /* backlog */
13872 backlog = I_to_sint32(check_sint32(STACK_1));
13873 if (!missingp(STACK_2)) { /* port */
13874 if (builtin_stream_p(STACK_2)) {
13875 pushSTACK(CLSTEXT("WARNING: (socket-server <socket>) is deprecated, use (socket-server <port> :interface <socket>)"));
13876 funcall(S(warn),1);
13877 stream_handles(test_socket_stream(STACK_2,true),true,NULL,&sock,NULL);
13878 } else /* Leave this last, so that type error talks about integer */
13879 port = I_to_uint16(check_uint16(STACK_2));
13880 }
13881 {
13882 var SOCKET sk = INVALID_SOCKET;
13883 var host_data_t myname;
13884 if (!missingp(STACK_0)) { /* interface */
13885 if (builtin_stream_p(STACK_0)) {
13886 stream_handles(test_socket_stream(STACK_0,true),true,NULL,&sock,NULL);
13887 } else { /* Leave this last, so that type error talks about string */
13888 with_string_0(check_string(STACK_0),O(misc_encoding),interfacez, {
13889 begin_blocking_system_call();
13890 sk = create_server_socket_by_string(&myname,interfacez,port,backlog);
13891 end_blocking_system_call();
13892 });
13893 goto got_sk;
13894 }
13895 }
13896 begin_blocking_system_call();
13897 if (sock != INVALID_SOCKET)
13898 sk = create_server_socket_by_socket(&myname,sock,port,backlog);
13899 else
13900 sk = create_server_socket_by_string(&myname,"0.0.0.0",port,backlog);
13901 end_blocking_system_call();
13902 got_sk:
13903 if (sk == INVALID_SOCKET) { ANSIC_error(); }
13904 pushSTACK(allocate_socket(sk));
13905 pushSTACK(allocate_socket_server());
13906 TheSocketServer(STACK_0)->socket_handle = STACK_1;
13907 TheSocketServer(STACK_0)->port = fixnum(myname.port);
13908 { /* for GC-safety: */
13909 var object host = asciz_to_string(myname.hostname,O(misc_encoding));
13910 TheSocketServer(STACK_0)->host = host;
13911 }
13912 pushSTACK(STACK_4);
13913 pushSTACK(L(socket_server_close));
13914 funcall(L(finalize),2); /* (FINALIZE socket-server #'socket-server-close) */
13915 VALUES1(popSTACK());
13916 skipSTACK(4);
13917 }
13918 }
13919
13920 /* (SOCKET-SERVER-PORT socket-server) */
13921 LISPFUNN(socket_server_port,1) {
13922 test_socket_server(STACK_0,false);
13923 VALUES1(TheSocketServer(STACK_0)->port);
13924 skipSTACK(1);
13925 }
13926
13927 /* (SOCKET-SERVER-HOST socket-server) */
13928 LISPFUNN(socket_server_host,1) {
13929 test_socket_server(STACK_0,false);
13930 VALUES1(TheSocketServer(STACK_0)->host);
13931 skipSTACK(1);
13932 }
13933
13934 /* parse timeout argument
13935 sec = posfixnum or (SEC . USEC) or (SEC USEC) or float or ratio or nil/unbound
13936 usec = posfixnum or nil/unbound
13937 can trigger GC */
sec_usec(object sec,object usec,struct timeval * tv)13938 modexp maygc struct timeval * sec_usec
13939 (object sec, object usec, struct timeval *tv) {
13940 if (missingp(sec)) {
13941 return NULL;
13942 } else if (consp(sec)) {
13943 if (!nullp(Cdr(sec)) && !boundp(usec))
13944 usec = (consp(Cdr(sec)) ? Car(Cdr(sec)) : Cdr(sec));
13945 sec = Car(sec);
13946 } else if (floatp(sec) || ratiop(sec)) { /* sec = sec mod 1 */
13947 pushSTACK(sec); funcall(L(floor),1);
13948 sec = value1;
13949 if (!boundp(usec)) { /* usec = round(sec*1000000) */
13950 pushSTACK(value2); pushSTACK(fixnum(1000000)); funcall(L(star),2);
13951 pushSTACK(value1); funcall(L(round),1);
13952 usec = value1;
13953 }
13954 }
13955 #if defined(SIZEOF_STRUCT_TIMEVAL) && SIZEOF_STRUCT_TIMEVAL == 16
13956 #define TV_SEC(s) I_to_uint64(check_uint64(s))
13957 #else
13958 #define TV_SEC(s) I_to_uint32(check_uint32(s))
13959 #endif
13960 tv->tv_sec = TV_SEC(sec);
13961 tv->tv_usec = (missingp(usec) ? 0 : TV_SEC(usec));
13962 #undef TV_SEC
13963 return tv;
13964 }
13965
13966 /* Convert C sec/usec (struct timeval et al) pair into Lisp number (of seconds)
13967 if abs_p is true, add UNIX_LISP_TIME_DIFF
13968 can trigger GC */
13969 #if defined(SIZEOF_STRUCT_TIMEVAL) && SIZEOF_STRUCT_TIMEVAL == 16
13970 #define TO_INT(x) uint64_to_I(x)
sec_usec_number(uint64 sec,uint64 usec,bool abs_p)13971 modexp maygc object sec_usec_number (uint64 sec, uint64 usec, bool abs_p)
13972 #else
13973 #define TO_INT(x) uint32_to_I(x)
13974 modexp maygc object sec_usec_number (uint32 sec, uint32 usec, bool abs_p)
13975 #endif
13976 {
13977 pushSTACK(TO_INT((abs_p ? UNIX_LISP_TIME_DIFF : 0) + sec));
13978 if (usec) {
13979 /* this is likely to end up as a ratio... */
13980 pushSTACK(TO_INT(usec)); pushSTACK(fixnum(1000000)); funcall(L(slash),2);
13981 pushSTACK(value1); funcall(L(plus),2);
13982 return value1;
13983 } else
13984 return popSTACK();
13985 }
13986 #undef TO_INT
13987
13988 #if defined(HAVE_SELECT) || defined(WIN32_NATIVE)
13989 /* wait for the socket server to have a connection ready
13990 returns true if socket_accept will return immediately */
socket_server_wait(gcv_object_t * sose_,struct timeval * tvp)13991 local maygc bool socket_server_wait (gcv_object_t *sose_, struct timeval *tvp) {
13992 var SOCKET handle = TheSocket(TheSocketServer(*sose_)->socket_handle);
13993 #if defined(WIN32_NATIVE)
13994 return interruptible_socket_wait(handle,socket_wait_read,tvp);
13995 #else
13996 restart_select:
13997 begin_system_call();
13998 var int ret;
13999 var fd_set handle_set;
14000 FD_ZERO(&handle_set); FD_SET(handle,&handle_set);
14001 GC_SAFE_CALL(ret = select(FD_SETSIZE,&handle_set,NULL,NULL,tvp));
14002 if (ret < 0) {
14003 if (errno == EINTR) {
14004 end_system_call(); goto restart_select;
14005 }
14006 ANSIC_error();
14007 }
14008 end_system_call();
14009 return (ret != 0);
14010 #endif /* WIN32_NATIVE */
14011 }
14012 #endif
14013
14014 /* (SOCKET-ACCEPT socket-server [:element-type] [:external-format] [:buffered]
14015 [:timeout]) */
14016 LISPFUN(socket_accept,seclass_default,1,0,norest,key,4,
14017 (kw(element_type),kw(external_format),kw(buffered),kw(timeout)) ) {
14018 var struct timeval tv;
14019 var struct timeval *tvp = sec_usec(popSTACK(),unbound,&tv);
14020
14021 test_socket_server(STACK_3,true);
14022
14023 /* Check and canonicalize the :BUFFERED argument: */
14024 var buffered_t buffered = test_buffered_arg(STACK_0);
14025
14026 /* Check and canonicalize the :ELEMENT-TYPE argument: */
14027 var decoded_el_t eltype;
14028 test_eltype_arg(&STACK_2,&eltype);
14029 STACK_2 = canon_eltype(&eltype);
14030 if (buffered != BUFFERED_T) { check_unbuffered_eltype(&eltype); }
14031
14032 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
14033 STACK_1 = test_external_format_arg(STACK_1);
14034
14035 #if defined(HAVE_SELECT) || defined(WIN32_NATIVE)
14036 if (tvp && !socket_server_wait(&STACK_3,tvp)) { /* handle :TIMEOUT */
14037 skipSTACK(4); errno = ETIMEDOUT; OS_error();
14038 }
14039 #endif
14040
14041 var SOCKET sock = TheSocket(TheSocketServer(STACK_3)->socket_handle);
14042 begin_blocking_system_call();
14043 var SOCKET handle = accept_connection (sock);
14044 end_blocking_system_call();
14045 if (handle == INVALID_SOCKET) { ANSIC_error(); }
14046 value1 = make_socket_stream(handle,&eltype,buffered,
14047 TheSocketServer(STACK_3)->host,
14048 TheSocketServer(STACK_3)->port);
14049 VALUES1(add_to_open_streams(value1));
14050 skipSTACK(4);
14051 }
14052
14053 /* (SOCKET-WAIT socket-server [seconds [microseconds]]) */
14054 LISPFUN(socket_wait,seclass_default,1,2,norest,nokey,0,NIL) {
14055 test_socket_server(STACK_2,true);
14056 #if defined(HAVE_SELECT) || defined(WIN32_NATIVE)
14057 var struct timeval timeout;
14058 var struct timeval * timeout_ptr = sec_usec(STACK_1,STACK_0,&timeout);
14059 VALUES_IF(socket_server_wait(&STACK_2,timeout_ptr));
14060 #else
14061 VALUES1(NIL);
14062 #endif
14063 skipSTACK(3);
14064 }
14065
14066 /* (SOCKET-CONNECT port [host] [:element-type] [:external-format] [:buffered]
14067 [:timeout]) */
14068 LISPFUN(socket_connect,seclass_default,1,1,norest,key,4,
14069 (kw(element_type),kw(external_format),kw(buffered),kw(timeout)) ) {
14070 var struct timeval tv;
14071 var struct timeval *tvp = sec_usec(popSTACK(),unbound,&tv);
14072
14073 STACK_4 = check_uint16(STACK_4);
14074
14075 /* Check and canonicalize the :BUFFERED argument: */
14076 var buffered_t buffered = test_buffered_arg(STACK_0);
14077
14078 /* Check and canonicalize the :ELEMENT-TYPE argument: */
14079 var decoded_el_t eltype;
14080 test_eltype_arg(&STACK_2,&eltype);
14081 STACK_2 = canon_eltype(&eltype);
14082 if (buffered != BUFFERED_T) { check_unbuffered_eltype(&eltype); }
14083
14084 /* Check and canonicalize the :EXTERNAL-FORMAT argument: */
14085 STACK_1 = test_external_format_arg(STACK_1);
14086
14087 /* ensure that we have host name*/
14088 if (missingp(STACK_3))
14089 STACK_3 = asciz_to_string("localhost",O(misc_encoding));
14090
14091 var SOCKET handle;
14092 begin_blocking_system_call();
14093 /* instead to pin the host name object in the heap - let's allocate it
14094 on the stack.*/
14095 with_string_0(STACK_3,O(misc_encoding),hostname, {
14096 handle = create_client_socket(hostname,I_to_uint16(STACK_4),tvp);
14097 });
14098 end_blocking_system_call();
14099 if (handle == INVALID_SOCKET) { ANSIC_error(); }
14100
14101 value1 = make_socket_stream(handle,&eltype,buffered,STACK_3,STACK_4);
14102 VALUES1(add_to_open_streams(value1));
14103 skipSTACK(5);
14104 }
14105
14106 /* check whether the object is a handle stream or a socket-server
14107 and return its socket-like handle(s) */
stream_handles(object obj,bool check_open,bool * char_p,SOCKET * in_sock,SOCKET * out_sock)14108 modexp void stream_handles (object obj, bool check_open, bool* char_p,
14109 SOCKET* in_sock, SOCKET* out_sock) {
14110 if (uint_p(obj)) {
14111 if (in_sock) *in_sock = (SOCKET)I_to_uint(obj);
14112 if (out_sock) *out_sock = (SOCKET)I_to_uint(obj);
14113 if (char_p) *char_p = false;
14114 return;
14115 }
14116 if (socket_server_p(obj)) {
14117 if (check_open) test_socket_server(obj,true);
14118 if (in_sock) *in_sock = TheSocket(TheSocketServer(obj)->socket_handle);
14119 return;
14120 }
14121 if (!(streamp(obj)
14122 && (!check_open || TheStream(obj)->strmflags & strmflags_open_B))) {
14123 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
14124 pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
14125 pushSTACK(obj);
14126 pushSTACK(TheSubr(subr_self)->name);
14127 error(type_error,GETTEXT("~S: argument ~S is not an open stream"));
14128 }
14129 restart_stream_handles:
14130 switch (TheStream(obj)->strmtype) {
14131 case strmtype_synonym:
14132 obj = resolve_synonym_stream(obj);
14133 goto restart_stream_handles;
14134 case strmtype_terminal:
14135 if (in_sock) *in_sock = (SOCKET)stdin_handle;
14136 if (out_sock) *out_sock = (SOCKET)stdout_handle;
14137 if (char_p) *char_p = true;
14138 return;
14139 #ifdef KEYBOARD
14140 case strmtype_keyboard:
14141 if (in_sock)
14142 *in_sock = TheSocket(TheStream(obj)->strm_keyboard_handle);
14143 if (char_p) *char_p = true;
14144 return;
14145 #endif
14146 #ifdef X11SOCKETS
14147 case strmtype_x11socket:
14148 if (in_sock && input_stream_p(obj))
14149 *in_sock = TheSocket(TheStream(obj)->strm_ichannel);
14150 if (out_sock && output_stream_p(obj))
14151 *out_sock = TheSocket(TheStream(obj)->strm_ochannel);
14152 if (char_p) *char_p = false;
14153 return;
14154 #endif
14155 case strmtype_twoway_socket:
14156 obj = TheStream(obj)->strm_twoway_socket_input;
14157 if (in_sock) *in_sock = SocketChannel(obj);
14158 if (out_sock) *out_sock = SocketChannel(obj);
14159 if (char_p) *char_p = eq(TheStream(obj)->strm_eltype,S(character));
14160 return;
14161 case strmtype_socket:
14162 if (in_sock && input_stream_p(obj)) *in_sock = SocketChannel(obj);
14163 if (out_sock && output_stream_p(obj)) *out_sock = SocketChannel(obj);
14164 if (char_p) *char_p = eq(TheStream(obj)->strm_eltype,S(character));
14165 return;
14166 case strmtype_echo:
14167 case strmtype_twoway:
14168 stream_handles(TheStream(obj)->strm_twoway_input,
14169 check_open,char_p,in_sock,NULL);
14170 stream_handles(TheStream(obj)->strm_twoway_output,
14171 check_open,NULL,NULL,out_sock);
14172 return;
14173 #ifdef PIPES
14174 case strmtype_pipe_in:
14175 if (in_sock) *in_sock = (SOCKET)ChannelStream_ihandle(obj);
14176 if (char_p) *char_p = eq(TheStream(obj)->strm_eltype,S(character));
14177 return;
14178 case strmtype_pipe_out:
14179 if (out_sock) *out_sock = (SOCKET)ChannelStream_ohandle(obj);
14180 return;
14181 #endif
14182 case strmtype_file: {
14183 var Handle handle = ChannelStream_ihandle(obj);
14184 if (in_sock && input_stream_p(obj)) *in_sock = (SOCKET)handle;
14185 if (out_sock && output_stream_p(obj)) *out_sock = (SOCKET)handle;
14186 if (char_p) *char_p = eq(TheStream(obj)->strm_eltype,S(character));
14187 return;
14188 }
14189 default: error_illegal_streamop(TheSubr(subr_self)->name,obj);
14190 }
14191 }
14192
14193 /* extract socket, direction and status place from the SOCKET-STATUS
14194 argument. returns the cons which cdr should be changed with the status */
parse_sock_list(object obj,object * sock,direction_t * dir)14195 local object parse_sock_list (object obj,object *sock,direction_t *dir)
14196 {
14197 if (consp(obj)) { /* (sock ...) */
14198 *sock = (object)Car(obj);
14199 if (nullp(Cdr(obj))) { /* (sock) */
14200 *dir = DIRECTION_IO;
14201 return obj;
14202 } else if (consp(Cdr(obj))) { /* (sock dir . place) */
14203 *dir = check_direction(Car(Cdr(obj)));
14204 return Cdr(obj);
14205 } else { /* (sock . dir) or (server . place) */
14206 if (socket_server_p(*sock)) { /* (server . place) */
14207 *dir = DIRECTION_INPUT;
14208 return obj;
14209 } else { /* (sock . dir) */
14210 *dir = check_direction(Cdr(obj));
14211 return NIL;
14212 }
14213 }
14214 } else { /* sock */
14215 *sock = obj;
14216 *dir = DIRECTION_IO;
14217 return NIL;
14218 }
14219 }
14220
14221 /* set the appropriate fd_sets for the socket,
14222 either a socket-server, a socket-stream or a (socket . direction)
14223 if the socket is a buffered stream with non-empty input buffer,
14224 reset non_empty_buffers_p to true
14225 see socket_status() for details
14226 return the number of handles set */
14227 local uintB stream_isbuffered_low (object stream, uintL *avail);
handle_set(object socket,fd_set * readfds,fd_set * writefds,fd_set * errorfds,bool * need_new_list,bool * non_empty_buffers_p)14228 local uintL handle_set (object socket, fd_set *readfds, fd_set *writefds,
14229 fd_set *errorfds, bool *need_new_list,
14230 bool *non_empty_buffers_p) {
14231 var object sock;
14232 var direction_t dir;
14233 var SOCKET in_sock = INVALID_SOCKET;
14234 var SOCKET out_sock = INVALID_SOCKET;
14235 var uintL ret = 0, avail = 0;
14236 if (nullp(parse_sock_list(socket,&sock,&dir)) && need_new_list)
14237 *need_new_list = true;
14238 stream_handles(sock,true,NULL,
14239 READ_P(dir) ? &in_sock : NULL,
14240 WRITE_P(dir) ? &out_sock : NULL);
14241 if (READ_P(dir) && streamp(sock) /* read from stream - check buffer */
14242 && (bit(1) & stream_isbuffered_low(sock,&avail)) && avail)
14243 *non_empty_buffers_p = true;
14244 if (in_sock != INVALID_SOCKET) {
14245 ret++;
14246 FD_SET(in_sock,errorfds);
14247 FD_SET(in_sock,readfds);
14248 }
14249 if (out_sock != INVALID_SOCKET) {
14250 ret++;
14251 FD_SET(out_sock,errorfds);
14252 FD_SET(out_sock,writefds);
14253 }
14254 return ret;
14255 }
14256
14257 /* check the appropriate fd_sets for the socket,
14258 either a socket-server, a socket-stream or a (socket . direction)
14259 see socket_status() for details
14260 can trigger GC */
handle_isset(object socket,fd_set * readfds,fd_set * writefds,fd_set * errorfds)14261 local maygc object handle_isset (object socket, fd_set *readfds,
14262 fd_set *writefds, fd_set *errorfds) {
14263 var object sock, ret;
14264 var direction_t dir;
14265 var object status_cons = parse_sock_list(socket,&sock,&dir);
14266 var SOCKET in_sock = INVALID_SOCKET;
14267 var SOCKET out_sock = INVALID_SOCKET;
14268 var bool char_p = true, wr = false;
14269 var listen_t rd = LISTEN_WAIT;
14270 stream_handles(sock,true,&char_p,
14271 READ_P(dir) ? &in_sock : NULL,
14272 WRITE_P(dir) ? &out_sock : NULL);
14273 if (in_sock != INVALID_SOCKET) {
14274 if (FD_ISSET(in_sock,errorfds)) return S(Kerror);
14275 if (socket_server_p(sock)) {
14276 ret = FD_ISSET(in_sock,readfds) ? T : NIL;
14277 if (!nullp(status_cons)) Cdr(status_cons) = ret;
14278 return ret;
14279 } else if (uint_p(sock)) {
14280 if (FD_ISSET(in_sock,readfds)) rd = LISTEN_AVAIL;
14281 } else { /* stream */
14282 if (FD_ISSET(in_sock,readfds) || (stream_isbuffered(sock) & bit(1))) {
14283 pushSTACK(status_cons);
14284 rd = (char_p ? listen_char(sock) : listen_byte(sock));
14285 status_cons = popSTACK();
14286 }
14287 }
14288 }
14289 if (out_sock != INVALID_SOCKET) {
14290 if (FD_ISSET(out_sock,errorfds)) return S(Kerror);
14291 wr = FD_ISSET(out_sock,writefds);
14292 }
14293 switch (rd) {
14294 case LISTEN_AVAIL: ret = wr ? S(Kio) : S(Kinput); break;
14295 case LISTEN_EOF: ret = wr ? S(Kappend) : S(Keof); break;
14296 case LISTEN_WAIT: ret = wr ? S(Koutput) : NIL; break;
14297 case LISTEN_ERROR: ret = S(Kerror); break;
14298 }
14299 if (!nullp(status_cons)) Cdr(status_cons) = ret;
14300 return ret;
14301 }
14302
14303 /* (SOCKET-STATUS socket-or-list [seconds [microseconds]])
14304 socket-or-list should be either
14305 -- socket [socket-stream or socket-server]
14306 -- (socket . direction) [direction is :input or :output or :io (default)]
14307 -- (socket direction . ???) [??? is replaced with the status, no consing]
14308 -- non-empty list of the above
14309 NIL signals an error because (SOCKET-STATUS X NIL) returning means that
14310 some operation is available (the second value is non-0)
14311 returns either a single symbol :ERROR/:INPUT/:OUTPUT/:IO/:EOF/:APPEND/NIL
14312 (for streams) or T/NIL (for socket-servers) - when a single object was
14313 given - or a list of such symbols:
14314 we can distinguish between 3 states for input:
14315 <i1> available
14316 <i2> EOF
14317 <i3> no info/will block/did not request information
14318 and 2 states for output:
14319 <o1> available
14320 <o2> no info/will block/did not request information/EOF
14321 the return values are:
14322 <i1> <i2> <i3>
14323 <o1> :IO :APPEND :OUTPUT
14324 <o2> :INPUT :EOF NIL
14325 The second value is the number of "actionable" objects, i.e.,
14326 the number of arguments for which non-NIL is returned (or set).
14327 May cons the list (and thus can trigger GC) if the list does not
14328 provide space for the return values. */
14329 LISPFUN(socket_status,seclass_default,1,2,norest,nokey,0,NIL) {
14330 #if defined(HAVE_SELECT) || defined(WIN32_NATIVE)
14331 var struct timeval timeout;
14332 var struct timeval * timeout_ptr = sec_usec(STACK_1,STACK_0,&timeout);
14333
14334 restart_select:
14335 begin_system_call();
14336 { var fd_set readfds, writefds, errorfds;
14337 var object all = STACK_2;
14338 var bool non_empty_buffers_p = false;
14339 FD_ZERO(&readfds); FD_ZERO(&writefds); FD_ZERO(&errorfds);
14340 var bool many_sockets_p =
14341 (consp(all) && !(symbolp(Cdr(all)) && keywordp(Cdr(all))));
14342 var bool need_new_list = false;
14343 if (many_sockets_p) {
14344 var object list = all;
14345 var int index = 0;
14346 for(; !nullp(list); list = Cdr(list)) {
14347 if (!listp(list)) error_list(list);
14348 index += handle_set(Car(list),&readfds,&writefds,&errorfds,
14349 &need_new_list,&non_empty_buffers_p);
14350 if (index > FD_SETSIZE) {
14351 pushSTACK(fixnum(FD_SETSIZE));
14352 pushSTACK(all);
14353 pushSTACK(S(socket_status));
14354 error(error_condition,GETTEXT("~S: list ~S is too long (~S maximum)"));
14355 }
14356 }
14357 } else
14358 handle_set(all,&readfds,&writefds,&errorfds,NULL,&non_empty_buffers_p);
14359 if (non_empty_buffers_p) {
14360 /* reset timeout to 0 because we should return immediately even if
14361 the user specified waiting forever: the socket may not be ready
14362 because the buffer contains everything it has got */
14363 timeout_ptr = &timeout;
14364 timeout.tv_sec = timeout.tv_usec = 0;
14365 }
14366 var int selectret;
14367 GC_SAFE_CALL(selectret = select(FD_SETSIZE,&readfds,&writefds,&errorfds,timeout_ptr));
14368 if (selectret < 0) {
14369 if (errno == EINTR) { end_system_call(); goto restart_select; }
14370 if (errno != EBADF) { ANSIC_error(); }
14371 }
14372 all=STACK_2; /* reload */
14373 if (many_sockets_p) {
14374 var object list = all;
14375 var uintL index = 0, count = 0;
14376 while(!nullp(list)) {
14377 index++; pushSTACK(list); /* save list */
14378 var object tmp = handle_isset(Car(list),&readfds,&writefds,&errorfds);
14379 if (need_new_list) {
14380 list = Cdr(STACK_0); /* (POP list) */
14381 STACK_0 = tmp;
14382 } else
14383 list = Cdr(popSTACK()); /* (POP list) */
14384 if (!nullp(tmp)) count ++;
14385 }
14386 if (need_new_list)
14387 VALUES2(listof(index),fixnum(count));
14388 else VALUES2(STACK_2,fixnum(count));
14389 } else {
14390 value1 = handle_isset(all,&readfds,&writefds,&errorfds);
14391 value2 = nullp(value1) ? Fixnum_0 : Fixnum_1;
14392 mv_count = 2;
14393 }
14394 end_system_call();
14395 }
14396 #else
14397 VALUES2(NIL,Fixnum_0);
14398 #endif
14399 skipSTACK(3);
14400 }
14401
14402 /* the next three functions handle getsockopt()/setsockopt() calls
14403 for boolean, integer and timeval options respectively.
14404 each pushes one result on STACK */
14405 #if defined(SO_DEBUG) || defined(SO_ACCEPTCONN) || defined(SO_BROADCAST) || defined(SO_REUSEADDR) || defined(SO_DONTROUTE) || defined(SO_KEEPALIVE) || defined(SO_ERROR) || defined(SO_OOBINLINE) || defined(SO_TYPE)
sock_opt_bool(SOCKET handle,int option,object value)14406 local void sock_opt_bool (SOCKET handle, int option, object value)
14407 {
14408 var int val;
14409 var socklen_t len = sizeof(val);
14410 #ifdef HAVE_GETSOCKOPT
14411 if (-1 == getsockopt(handle,SOL_SOCKET,option,(char*)&val,&len))
14412 OS_error();
14413 pushSTACK(val ? T : NIL);
14414 if (!(eq(value,nullobj)))
14415 #endif
14416 {
14417 val = !nullp(value);
14418 if (-1 == setsockopt(handle,SOL_SOCKET,option,(char*)&val,len))
14419 OS_error();
14420 }
14421 }
14422 #endif
14423 #if defined(SO_RCVBUF) || defined(SO_SNDBUF) || defined(SO_RCVLOWAT) || defined(SO_SNDLOWAT)
14424 /* can trigger GC */
sock_opt_int(SOCKET handle,int option,object value)14425 local maygc void sock_opt_int (SOCKET handle, int option, object value)
14426 {
14427 var unsigned int val;
14428 var socklen_t len = sizeof(val);
14429 #ifdef HAVE_GETSOCKOPT
14430 if (-1 == getsockopt(handle,SOL_SOCKET,option,(char*)&val,&len))
14431 OS_error();
14432 pushSTACK(uint_to_I(val));
14433 if (!(eq(value,nullobj)))
14434 #endif
14435 {
14436 val = I_to_uint(check_uint(value));
14437 if (-1 == setsockopt(handle,SOL_SOCKET,option,(char*)&val,len))
14438 OS_error();
14439 }
14440 }
14441 #endif
14442 #if defined(SO_RCVTIMEO) || defined(SO_SNDTIMEO)
14443 /* can trigger GC */
sock_opt_time(SOCKET handle,int option,object value)14444 local maygc void sock_opt_time (SOCKET handle, int option, object value)
14445 {
14446 var struct timeval val;
14447 var socklen_t len = sizeof(val);
14448 #ifdef HAVE_GETSOCKOPT
14449 if (-1 == getsockopt(handle,SOL_SOCKET,option,(char *)&val,&len)) OS_error();
14450 if (val.tv_usec) {
14451 var double x = val.tv_sec + val.tv_sec*0.000001;
14452 var dfloatjanus t = *(dfloatjanus*)&x;
14453 pushSTACK(c_double_to_DF(&t));
14454 } else
14455 pushSTACK(fixnum(val.tv_sec));
14456 if (!(eq(value,nullobj)))
14457 #endif
14458 {
14459 sec_usec(value,unbound,&val);
14460 if (-1 == setsockopt(handle,SOL_SOCKET,option,(char*)&val,len))
14461 OS_error();
14462 }
14463 }
14464 #endif
14465
14466
14467 /* (SOCKET-OPTIONS socket-stream &rest options)
14468 queries and sets socket options.
14469 returns the old value for each option:
14470 (SOCKET-OPTIONS s :so-keepalive :so-rcvlowat 10)
14471 will set :so-rcvlowat to 10 and return the current
14472 value of :so-keepalive and the old value of :so-rcvlowat */
14473 LISPFUN(socket_options,seclass_default,1,0,rest,nokey,0,NIL) {
14474 var object socket = *(rest_args_pointer STACKop 1);
14475 var gcv_object_t *arg_p = rest_args_pointer;
14476 var int count = argcount;
14477 var SOCKET handle;
14478 stream_handles(socket,true,NULL,&handle,NULL);
14479 var gcv_object_t *old_STACK = STACK;
14480 while (count-->0) {
14481 check_STACK();
14482 var object kwd = NEXT(arg_p);
14483 var object arg = Next(arg_p);
14484 if (count && !(symbolp(arg) && keywordp(arg))) {
14485 (void)NEXT(arg_p);
14486 count--;
14487 } else
14488 arg = nullobj;
14489 begin_system_call();
14490 if (false)
14491 ;
14492 #ifdef SO_DEBUG
14493 else if (eq(kwd,S(Kso_debug)))
14494 sock_opt_bool(handle,SO_DEBUG,arg);
14495 #endif
14496 #ifdef SO_ACCEPTCONN
14497 else if (eq(kwd,S(Kso_acceptconn)))
14498 sock_opt_bool(handle,SO_ACCEPTCONN,arg);
14499 #endif
14500 #ifdef SO_BROADCAST
14501 else if (eq(kwd,S(Kso_broadcast)))
14502 sock_opt_bool(handle,SO_BROADCAST,arg);
14503 #endif
14504 #ifdef SO_REUSEADDR
14505 else if (eq(kwd,S(Kso_reuseaddr)))
14506 sock_opt_bool(handle,SO_REUSEADDR,arg);
14507 #endif
14508 #ifdef SO_DONTROUTE
14509 else if (eq(kwd,S(Kso_dontroute)))
14510 sock_opt_bool(handle,SO_DONTROUTE,arg);
14511 #endif
14512 #ifdef SO_KEEPALIVE
14513 else if (eq(kwd,S(Kso_keepalive)))
14514 sock_opt_bool(handle,SO_KEEPALIVE,arg);
14515 #endif
14516 #ifdef SO_ERROR
14517 else if (eq(kwd,S(Kso_error)))
14518 sock_opt_bool(handle,SO_ERROR,arg);
14519 #endif
14520 #ifdef SO_LINGER
14521 else if (eq(kwd,S(Kso_linger))) {
14522 struct linger val;
14523 var socklen_t len = sizeof(val);
14524 #ifdef HAVE_GETSOCKOPT
14525 if (-1 == getsockopt(handle,SOL_SOCKET,SO_LINGER,(char*)&val,&len))
14526 OS_error();
14527 if (val.l_onoff)
14528 pushSTACK(fixnum(val.l_linger));
14529 else
14530 pushSTACK(NIL);
14531 if (!(eq(arg,nullobj)))
14532 #endif
14533 { /* arg points to STACK so it is safe */
14534 if (eq(T,arg)) {
14535 val.l_onoff = 1;
14536 } else if (nullp(arg)) {
14537 val.l_onoff = 0;
14538 } else {
14539 val.l_onoff = 1;
14540 val.l_linger = I_to_uint(check_uint(arg));
14541 }
14542 if (-1 == setsockopt(handle,SOL_SOCKET,SO_LINGER,(char*)&val,len))
14543 OS_error();
14544 }
14545 }
14546 #endif
14547 #ifdef SO_OOBINLINE
14548 else if (eq(kwd,S(Kso_oobinline)))
14549 sock_opt_bool(handle,SO_OOBINLINE,arg);
14550 #endif
14551 #ifdef SO_TYPE
14552 else if (eq(kwd,S(Kso_type)))
14553 sock_opt_bool(handle,SO_TYPE,arg);
14554 #endif
14555 #ifdef SO_RCVBUF
14556 else if (eq(kwd,S(Kso_rcvbuf)))
14557 sock_opt_int(handle,SO_RCVBUF,arg);
14558 #endif
14559 #ifdef SO_SNDBUF
14560 else if (eq(kwd,S(Kso_sndbuf)))
14561 sock_opt_int(handle,SO_SNDBUF,arg);
14562 #endif
14563 #ifdef SO_RCVLOWAT
14564 else if (eq(kwd,S(Kso_rcvlowat)))
14565 sock_opt_int(handle,SO_RCVLOWAT,arg);
14566 #endif
14567 #ifdef SO_SNDLOWAT
14568 else if (eq(kwd,S(Kso_sndlowat)))
14569 sock_opt_int(handle,SO_SNDLOWAT,arg);
14570 #endif
14571 #ifdef SO_RCVTIMEO
14572 else if (eq(kwd,S(Kso_rcvtimeo)))
14573 sock_opt_time(handle,SO_RCVTIMEO,arg);
14574 #endif
14575 #ifdef SO_SNDTIMEO
14576 else if (eq(kwd,S(Kso_sndtimeo)))
14577 sock_opt_time(handle,SO_SNDTIMEO,arg);
14578 #endif
14579 else {
14580 pushSTACK(kwd); /* TYPE-ERROR slot DATUM */
14581 pushSTACK(O(type_socket_option)); /* TYPE-ERROR slot EXPECTED-TYPE */
14582 pushSTACK(O(type_socket_option));
14583 pushSTACK(kwd); pushSTACK(S(socket_options));
14584 error(type_error,GETTEXT("~S: argument ~S should be of type ~S."));
14585 }
14586 end_system_call();
14587 }
14588 #ifdef STACK_DOWN
14589 var uintL retval_count = old_STACK - STACK;
14590 #endif
14591 #ifdef STACK_UP
14592 var uintL retval_count = STACK - old_STACK;
14593 #endif
14594 STACK_to_mv(retval_count);
14595 skipSTACK(argcount+1);
14596 }
14597
14598 LISPFUNN(socket_stream_port,1)
14599 { /* (SOCKET-STREAM-PORT socket-stream) */
14600 var object stream = test_socket_stream(STACK_0,false);
14601 VALUES1(TheStream(stream)->strm_socket_port);
14602 skipSTACK(1);
14603 }
14604
14605 LISPFUNN(socket_stream_host,1)
14606 { /* (SOCKET-STREAM-HOST socket-stream) */
14607 var object stream = test_socket_stream(STACK_0,false);
14608 VALUES1(TheStream(stream)->strm_socket_host);
14609 skipSTACK(1);
14610 }
14611
14612 typedef host_data_t * host_data_fetcher_t (SOCKET, host_data_t *, bool);
14613 extern host_data_fetcher_t socket_getpeername, socket_getlocalname;
14614
publish_host_data(host_data_fetcher_t * func)14615 local maygc void publish_host_data (host_data_fetcher_t* func) {
14616 var bool resolve_p = missingp(STACK_0);
14617 var SOCKET sk;
14618 var host_data_t hd;
14619 var object hostname;
14620 if (uint_p(STACK_1)) sk = I_to_uint(STACK_1);
14621 else {
14622 STACK_1 = test_socket_stream(STACK_1,true);
14623 sk = SocketChannel(STACK_1);
14624 }
14625 skipSTACK(2); /* drop the arguments */
14626 begin_system_call();
14627 begin_blocking_call();
14628 if ((*func)(sk,&hd,resolve_p) == NULL) { end_blocking_call();ANSIC_error(); }
14629 end_blocking_call();
14630 end_system_call();
14631 if (hd.truename[0] == '\0') {
14632 hostname = asciz_to_string(hd.hostname,O(misc_encoding));
14633 } else {
14634 var DYNAMIC_ARRAY(tmp_str,char,strlen(hd.truename)+2+strlen(hd.hostname)+1+1);
14635 strcpy(tmp_str, hd.hostname);
14636 strcat(tmp_str, " (");
14637 strcat(tmp_str, hd.truename);
14638 strcat(tmp_str, ")");
14639 hostname = asciz_to_string(tmp_str,O(misc_encoding));
14640 FREE_DYNAMIC_ARRAY(tmp_str);
14641 }
14642 VALUES2(hostname, fixnum(hd.port));
14643 }
14644
14645 LISPFUN(socket_stream_peer,seclass_default,1,1,norest,nokey,0,NIL)
14646 { /* (SOCKET-STREAM-PEER socket-stream [do-not-resolve-p]) */
14647 publish_host_data (&socket_getpeername);
14648 }
14649
14650 LISPFUN(socket_stream_local,seclass_default,1,1,norest,nokey,0,NIL)
14651 { /* (SOCKET-STREAM-LOCAL socket-stream [do-not-resolve-p]) */
14652 publish_host_data (&socket_getlocalname);
14653 }
14654
14655 #ifdef HAVE_SHUTDOWN
14656
14657 /* close a socket stream using shutdown(2)
14658 (SOCKET-STREAM-SHUTDOWN socket direction) */
get_handle_and_mark(object stream,uintB flag,int channel)14659 local SOCKET get_handle_and_mark (object stream, uintB flag, int channel) {
14660 TheStream(stream)->strmflags &= ~flag;
14661 if (ChannelStream_buffered(stream)) {
14662 buffered_flush_everything(stream);
14663 return TheSocket(BufferedStream_channel(stream));
14664 } else
14665 return TheSocket(TheStream(stream)->strm_other[channel]);
14666 }
14667 LISPFUNN(socket_stream_shutdown,2) {
14668 var direction_t dir = check_direction(popSTACK());
14669 var int shutdown_how = -1;
14670 var bool rd_p = true;
14671 var bool wr_p = true;
14672 var uintB flag = 0;
14673 var SOCKET handle = -1;
14674 if (!integerp(STACK_0)) {
14675 test_socket_stream(STACK_0,false);
14676 rd_p = ((TheStream(STACK_0)->strmflags & strmflags_rd_B) != 0);
14677 wr_p = ((TheStream(STACK_0)->strmflags & strmflags_wr_B) != 0);
14678 } else /* raw socket */
14679 handle = (SOCKET)(I_to_uint(check_uint(STACK_0)));
14680 switch (dir) {
14681 case DIRECTION_PROBE: /* INPUT/OUTPUT/IO */
14682 if (rd_p) {
14683 if (wr_p) value1 = S(Kio);
14684 else value1 = S(Kinput);
14685 } else {
14686 if (wr_p) value1 = S(Koutput);
14687 else value1 = NIL;
14688 }
14689 goto done;
14690 case DIRECTION_INPUT_IMMUTABLE: case DIRECTION_INPUT:
14691 if (!rd_p) { /* not readable => done */
14692 value1 = NIL; goto done;
14693 } else {
14694 shutdown_how = SHUT_RD;
14695 flag = strmflags_rd_B;
14696 }
14697 break;
14698 case DIRECTION_OUTPUT:
14699 if (!wr_p) { /* not writable => done */
14700 value1 = NIL; goto done;
14701 } else {
14702 shutdown_how = SHUT_WR;
14703 flag = strmflags_wr_B;
14704 }
14705 break;
14706 case DIRECTION_IO:
14707 shutdown_how = SHUT_RDWR;
14708 flag = strmflags_wr_B | strmflags_rd_B;
14709 break;
14710 default: NOTREACHED;
14711 }
14712 if (streamp(STACK_0)) {
14713 switch (TheStream(STACK_0)->strmtype) {
14714 case strmtype_twoway_socket:
14715 switch (dir) {
14716 case DIRECTION_OUTPUT:
14717 TheStream(STACK_0)->strmflags &= ~strmflags_wr_B;
14718 handle =
14719 get_handle_and_mark(TheStream(STACK_0)->strm_twoway_socket_output,
14720 strmflags_wr_B,strm_ochannel_position);
14721 break;
14722 case DIRECTION_IO:
14723 TheStream(STACK_0)->strmflags &= ~strmflags_wr_B;
14724 get_handle_and_mark(TheStream(STACK_0)->strm_twoway_socket_output,
14725 strmflags_wr_B,strm_ochannel_position);
14726 /*FALLTHROUGH*/
14727 case DIRECTION_INPUT: case DIRECTION_INPUT_IMMUTABLE:
14728 TheStream(STACK_0)->strmflags &= ~strmflags_rd_B;
14729 handle =
14730 get_handle_and_mark(TheStream(STACK_0)->strm_twoway_socket_input,
14731 strmflags_rd_B,strm_ichannel_position);
14732 break;
14733 default: NOTREACHED;
14734 }
14735 break;
14736 case strmtype_socket:
14737 handle = get_handle_and_mark(STACK_0,flag,strm_ichannel_position);
14738 break;
14739 default: NOTREACHED;
14740 }
14741 }
14742 begin_system_call();
14743 begin_blocking_call();
14744 if (shutdown(handle,shutdown_how)) {
14745 end_blocking_call();
14746 ANSIC_error();
14747 }
14748 end_blocking_call();
14749 end_system_call();
14750 { value1 = NIL; }
14751 done:
14752 skipSTACK(1);
14753 mv_count = 1;
14754 }
14755 #endif
14756
14757 #endif /* SOCKET_STREAMS */
14758
14759
14760 /* Streams in general
14761 ================== */
14762
14763 #if defined(WIN32_NATIVE)
14764 /* http://msdn.microsoft.com/en-us/library/ms804359.aspx */
14765 typedef NTSTATUS (__stdcall *QueryInformationFile_t)
14766 (IN HANDLE FileHandle, OUT PIO_STATUS_BLOCK IoStatusBlock,
14767 OUT PVOID FileInformation, IN ULONG Length,
14768 IN FILE_INFORMATION_CLASS FileInformationClass);
14769 static QueryInformationFile_t qif = (QueryInformationFile_t) -1;
get_qif(void)14770 static QueryInformationFile_t get_qif (void) {
14771 if (qif == NULL) return qif;
14772 var HMODULE ntdll = LoadLibrary("ntdll.dll");
14773 if (ntdll == NULL) return (qif = NULL);
14774 return (qif = (QueryInformationFile_t)
14775 GetProcAddress(ntdll, "NtQueryInformationFile"));
14776 }
14777 #endif
14778
14779 /* UP: find out whether the direction is compatible with the handle
14780 > fd: file handle
14781 > dir: direction
14782 > true is the direction is compatible with the handle */
handle_direction_compatible(Handle fd,direction_t dir)14783 local bool handle_direction_compatible (Handle fd, direction_t dir) {
14784 #if defined(UNIX)
14785 begin_blocking_system_call();
14786 var int fcntl_flags = fcntl(fd,F_GETFL,0);
14787 end_blocking_system_call();
14788 if (fcntl_flags < 0)
14789 return false; /* closed handle? errno is probably EBADF */
14790 var bool ret =
14791 !( (READ_P(dir) && ((fcntl_flags & O_ACCMODE) == O_WRONLY))
14792 || (WRITE_P(dir) && ((fcntl_flags & O_ACCMODE) == O_RDONLY)));
14793 DEBUG_OUT(("\nhandle_direction_compatible(%d,%d): 0x%x => %d\n",
14794 fd,dir,fcntl_flags,ret));
14795 return ret;
14796 #elif defined(WIN32_NATIVE)
14797 var bool ret = true; /* assume compatibility */
14798 /* http://groups.google.com/group/microsoft.public.win32.programmer.kernel/browse_thread/thread/a446be4fb332aeba */
14799 begin_blocking_system_call();
14800 switch (GetFileType(fd)) {
14801 case FILE_TYPE_DISK: {
14802 var QueryInformationFile_t qif = get_qif();
14803 if (qif != NULL) {
14804 var IO_STATUS_BLOCK iosb;
14805 var FILE_ACCESS_INFORMATION fai;
14806 var NTSTATUS s = qif(fd,&iosb,(void*)&fai,sizeof(fai),
14807 FileAccessInformation);
14808 ret = (s == STATUS_SUCCESS
14809 && (!READ_P(dir) || fai.AccessFlags & FILE_READ_DATA)
14810 && (!WRITE_P(dir) || fai.AccessFlags & FILE_WRITE_DATA));
14811 DEBUG_OUT(("\nhandle_direction_compatible(%d,%d)D: 0x%x 0x%x => %d\n",
14812 fd,dir,s,fai.AccessFlags,ret));
14813 }
14814 } break;
14815 case FILE_TYPE_CHAR: if (READ_P(dir)) {
14816 var DWORD nevents = -1, nr = 0;
14817 if (GetNumberOfConsoleInputEvents(fd,&nevents)) { /* It's a console. */
14818 var INPUT_RECORD ir;
14819 ret = PeekConsoleInput(fd,&ir,1,&nr);
14820 } else switch (GetLastError()) {
14821 case ERROR_INVALID_HANDLE: case ERROR_ACCESS_DENIED:
14822 case ERROR_INVALID_FUNCTION: ret = false;
14823 }
14824 DEBUG_OUT(("\nhandle_direction_compatible(%d,%d)C: %d %d => %d (%d)\n",
14825 fd,dir,nevents,nr,ret,GetLastError()));
14826 } break;
14827 case FILE_TYPE_PIPE: if (READ_P(dir)) {
14828 var DWORD nbytes;
14829 ret = PeekNamedPipe(fd,NULL,0,NULL,&nbytes,NULL);
14830 DEBUG_OUT(("\nhandle_direction_compatible(%d,%d)P: %d => %d (%d)\n",
14831 fd,dir,nbytes,ret,GetLastError()));
14832 } break;
14833 case FILE_TYPE_REMOTE:
14834 break; /* assume compatibility */
14835 case FILE_TYPE_UNKNOWN:
14836 /* GetFileType failed => handle was invalid */
14837 if (GetLastError() != NO_ERROR) ret = false;
14838 }
14839 end_blocking_system_call();
14840 return ret;
14841 #else
14842 return true; /* assume compatibility */
14843 #endif
14844 }
14845
14846 /* UP: find the pathname corresponding to the given handle
14847 > fd: file handle
14848 < pathname or NIL
14849 can trigger GC */
handle_pathname(Handle fd)14850 local maygc object handle_pathname (Handle fd) {
14851 /* Most UNIX platforms have /dev/fd/[012] pseudo-files. */
14852 /* AIX has /proc/<pid>/fd/[012] pseudo-files but they have zero permissions
14853 and are therefore not usable for any purpose. */
14854 #if defined(UNIX) && !(defined(UNIX_AIX) || defined(UNIX_HPUX) || defined(UNIX_BEOS) || defined(UNIX_HAIKU) || defined(UNIX_MINIX))
14855 var char buf[20];
14856 begin_system_call();
14857 sprintf(buf,"/dev/fd/%d",fd);
14858 end_system_call();
14859 pushSTACK(ascii_to_string(buf)); funcall(L(pathname),1);
14860 return value1;
14861 #elif defined(WIN32_NATIVE)
14862 var NTSTATUS s = ~STATUS_SUCCESS;
14863 var char wbuf[MAXPATHLEN*sizeof(WCHAR) + sizeof(ULONG)];
14864 begin_blocking_system_call();
14865 switch (GetFileType(fd)) {
14866 case FILE_TYPE_DISK: {
14867 var QueryInformationFile_t qif = get_qif();
14868 if (qif != NULL) {
14869 var IO_STATUS_BLOCK iosb;
14870 s = qif(fd,&iosb,(void*)wbuf,sizeof(wbuf),FileNameInformation);
14871 }
14872 } break;
14873 case FILE_TYPE_CHAR: case FILE_TYPE_PIPE: case FILE_TYPE_REMOTE:
14874 case FILE_TYPE_UNKNOWN: break;
14875 }
14876 end_blocking_system_call();
14877 if (s == STATUS_SUCCESS) {
14878 var FILE_NAME_INFORMATION *fni = (FILE_NAME_INFORMATION*)&wbuf;
14879 var char abuf[2 * MAXPATHLEN];
14880 var int n = WideCharToMultiByte(CP_ACP,0,fni->FileName,
14881 fni->FileNameLength/sizeof(WCHAR),
14882 abuf,2 * MAXPATHLEN,NULL,NULL);
14883 pushSTACK(n_char_to_string(abuf,n,O(pathname_encoding)));
14884 funcall(L(pathname),1);
14885 return value1;
14886 } else return NIL;
14887 #else
14888 return NIL;
14889 #endif
14890 }
14891
14892 /* Create a stream based on a handle
14893 can trigger GC */
handle_to_stream(Handle fd,object direction,object buff_p,object ext_fmt,object eltype)14894 local maygc object handle_to_stream (Handle fd, object direction, object buff_p,
14895 object ext_fmt, object eltype) {
14896 var direction_t dir;
14897 pushSTACK(NIL); /* Filename */
14898 pushSTACK(NIL); /* Truename */
14899 pushSTACK(buff_p);
14900 pushSTACK(ext_fmt);
14901 pushSTACK(eltype);
14902 pushSTACK(allocate_handle(handle_dup(fd)));
14903 dir = check_direction(direction);
14904 STACK_5 = handle_pathname(fd);
14905 if (!handle_direction_compatible(fd,dir)) {
14906 var condition_t errortype = nullp(STACK_5)
14907 ? (pushSTACK(STACK_0), error_condition)
14908 : (pushSTACK(STACK_5), /* FILE-ERROR slot PATHNAME */
14909 pushSTACK(STACK_0), file_error);
14910 pushSTACK(direction);
14911 error(errortype,GETTEXT("Invalid direction ~S for accessing ~S"));
14912 }
14913 return make_file_stream(dir,false,dir == DIRECTION_IO);
14914 }
14915
14916 LISPFUNN(stream_handles,1)
14917 { /* (STREAM-HANDLES stream) */
14918 var SOCKET in_sock=INVALID_SOCKET, out_sock=INVALID_SOCKET;
14919 stream_handles(popSTACK(),false,NULL,&in_sock,&out_sock);
14920 VALUES2(in_sock == INVALID_SOCKET ? NIL : fixnum(in_sock),
14921 out_sock == INVALID_SOCKET ? NIL : fixnum(out_sock));
14922 }
14923
14924 LISPFUN(make_stream,seclass_default,1,0,norest,key,4,
14925 (kw(direction),kw(element_type),kw(external_format),kw(buffered)) )
14926 {
14927 var Handle fd;
14928 restart_make_stream:
14929 if (uint_p(STACK_4)) {
14930 fd = (Handle)I_to_uint(STACK_4);
14931 } else if (eq(STACK_4,S(Kinput))) {
14932 fd = stdin_handle;
14933 if (missingp(STACK_3)) STACK_3 = S(Kinput);
14934 } else if (eq(STACK_4,S(Koutput))) {
14935 fd = stdout_handle;
14936 if (missingp(STACK_3)) STACK_3 = S(Koutput);
14937 } else if (eq(STACK_4,S(Kerror))) {
14938 fd = stderr_handle;
14939 if (missingp(STACK_3)) STACK_3 = S(Koutput);
14940 } else if (streamp(STACK_4)) {
14941 var direction_t dir = check_direction(STACK_3);
14942 fd = stream_lend_handle(&STACK_4,READ_P(dir),NULL);
14943 } else {
14944 pushSTACK(NIL); /* no PLACE */
14945 pushSTACK(S(Kerror)); pushSTACK(S(Koutput)); pushSTACK(S(Kinput));
14946 pushSTACK(STACK_(4+4)); pushSTACK(TheSubr(subr_self)->name);
14947 check_value(error_condition,GETTEXT("~S: ~S should be a handle, handle stream, or one of ~S, ~S, ~S"));
14948 STACK_4 = value1;
14949 goto restart_make_stream;
14950 }
14951 VALUES1(handle_to_stream(fd,STACK_3,STACK_0,STACK_1,STACK_2));
14952 skipSTACK(5);
14953 }
14954
14955 #undef READ_P
14956 #undef WRITE_P
14957
14958 /* Allocates the equivalent of the C stream stdin.
14959 can trigger GC */
make_standard_input_file_stream(void)14960 local inline maygc object make_standard_input_file_stream (void) {
14961 if (!handle_direction_compatible(stdin_handle,DIRECTION_INPUT))
14962 /* no stdin: nohup or embedded */
14963 return make_concatenated_stream(NIL); /* empty stream */
14964 /* This uses the external-format :default, not O(terminal_encoding),
14965 because this stream is used when *terminal-io* is not interactive. */
14966 return handle_to_stream(stdin_handle,S(Kinput),S(Kdefault),S(Kdefault),
14967 S(character));
14968 }
14969
14970 /* Allocates the equivalent of the C stream stdout/stderr.
14971 > handle : file descriptor (stdout_handle or stderr_handle)
14972 can trigger GC */
make_standard_output_file_stream(Handle handle)14973 local inline maygc object make_standard_output_file_stream (Handle handle) {
14974 if (!handle_direction_compatible(handle,DIRECTION_OUTPUT))
14975 /* no stdout/stderr: nohup or embedded */
14976 return make_broadcast_stream(NIL); /* empty stream */
14977 /* This uses the external-format :default, not O(terminal_encoding),
14978 because this stream is used when *terminal-io* is not interactive. */
14979 return handle_to_stream(handle,S(Koutput),S(Kdefault),S(Kdefault),
14980 S(character));
14981 }
14982
14983 /* It is important to allocate each of the standard_output_file_stream,
14984 standard_error_file_stream only _once_, because otherwise FRESH-LINE on one
14985 of these streams would not see that some output has been sent to another
14986 of these streams and would therefore not print a newline when it should.
14987 (FRESH-LINE is only allowed to err in the other direction: It may output
14988 a newline although it is not needed.)
14989
14990 Returns the equivalent of the C stream stdin.
14991 can trigger GC */
get_standard_input_file_stream(void)14992 local maygc object get_standard_input_file_stream (void) {
14993 if (nullp(O(standard_input_file_stream)))
14994 O(standard_input_file_stream) = make_standard_input_file_stream();
14995 return O(standard_input_file_stream);
14996 }
14997
14998 /* Returns the equivalent of the C stream stdout.
14999 can trigger GC */
get_standard_output_file_stream(void)15000 local maygc object get_standard_output_file_stream (void) {
15001 #if defined(UNIX) || defined(WIN32_NATIVE)
15002 /* On these systems make_terminal_stream() uses stdout_handle. */
15003 var object terminal_stream = Symbol_value(S(terminal_io)); /* *TERMINAL-IO* */
15004 if (builtin_stream_p(terminal_stream)
15005 && (TheStream(terminal_stream)->strmflags & strmflags_open_B)
15006 && (TheStream(terminal_stream)->strmflags & strmflags_wr_ch_B)
15007 && TheStream(terminal_stream)->strmtype == strmtype_terminal) {
15008 /* For FRESH-LINE to work correctly, we must avoid that *TERMINAL-IO* and
15009 the stream returned by this function have a different wr_ch_lpos field.
15010 Therefore we just return (MAKE-SYNONYM-STREAM (QUOTE *TERMINAL-IO*)). */
15011 return make_synonym_stream(S(terminal_io));
15012 }
15013 #endif
15014 if (nullp(O(standard_output_file_stream)))
15015 O(standard_output_file_stream) =
15016 make_standard_output_file_stream(stdout_handle);
15017 return O(standard_output_file_stream);
15018 }
15019
15020 /* Returns the equivalent of the C stream stderr.
15021 can trigger GC */
get_standard_error_file_stream(void)15022 local maygc object get_standard_error_file_stream (void) {
15023 #if 0
15024 /* On these systems make_terminal_stream() uses stderr_handle. */
15025 var object terminal_stream = Symbol_value(S(terminal_io)); /* *TERMINAL-IO* */
15026 if (builtin_stream_p(terminal_stream)
15027 && (TheStream(terminal_stream)->strmflags & strmflags_open_B)
15028 && (TheStream(terminal_stream)->strmflags & strmflags_wr_ch_B)
15029 && TheStream(terminal_stream)->strmtype == strmtype_terminal) {
15030 /* For FRESH-LINE to work correctly, we must avoid that *TERMINAL-IO* and
15031 the stream returned by this function have a different wr_ch_lpos field.
15032 Therefore we just return (MAKE-SYNONYM-STREAM (QUOTE *TERMINAL-IO*)). */
15033 return make_synonym_stream(S(terminal_io));
15034 }
15035 #endif
15036 if (nullp(O(standard_error_file_stream)))
15037 O(standard_error_file_stream) =
15038 (same_handle_p(stderr_handle,stdout_handle)
15039 ? get_standard_output_file_stream()
15040 : make_standard_output_file_stream(stderr_handle));
15041 return O(standard_error_file_stream);
15042 }
15043
15044 /* UP: Returns the default value for *terminal-io*.
15045 can trigger GC */
make_terminal_io(void)15046 local maygc object make_terminal_io (void) {
15047 /* If stdin or stdout is a file, use a buffered stream instead of an
15048 unbuffered terminal stream. For the ud2cd program used as filter,
15049 this reduces the runtime on Solaris from 165 sec to 47 sec. */
15050 var bool stdin_terminal =
15051 handle_direction_compatible(stdin_handle,DIRECTION_INPUT)
15052 && !regular_or_pipe_handle_p(stdin_handle);
15053 var bool stdout_terminal =
15054 handle_direction_compatible(stdout_handle,DIRECTION_OUTPUT)
15055 && !regular_or_pipe_handle_p(stdout_handle);
15056 DEBUG_OUT(("\nmake_terminal_io: %d %d\n",stdin_terminal,stdout_terminal));
15057 /* note that if a stream is incompatible, handle_direction_compatible
15058 will be called again by get_standard_*_file_stream;
15059 this is an extra system call on startup; should not be a big deal */
15060 if (!stdin_terminal || !stdout_terminal) {
15061 var object istream = stdin_terminal ? /* Input side */
15062 make_terminal_stream() : get_standard_input_file_stream();
15063 pushSTACK(istream);
15064 var object ostream = stdout_terminal ? /* Output side */
15065 make_terminal_stream() : get_standard_output_file_stream();
15066 /* Build a two-way-stream: */
15067 return make_twoway_stream(popSTACK(),ostream);
15068 }
15069 return make_terminal_stream();
15070 }
15071
15072 /* UP: Returns the input side of *TERMINAL-IO*.
15073 Defaults to a (make-synonym-stream '*terminal-io*).
15074 > preallocated_default: (make-synonym-stream '*terminal-io*) or unbound
15075 < result: a stream that can be used for *STANDARD-INPUT*
15076 can trigger GC - if preallocated_default is unbound */
terminal_io_input_stream(object preallocated_default)15077 local /*maygc*/ object terminal_io_input_stream (object preallocated_default) {
15078 GCTRIGGER_IF(!boundp(preallocated_default), GCTRIGGER());
15079 var object terminal_io = Symbol_value(S(terminal_io));
15080 /* Optimization: Extract the input side if possible. */
15081 if (stream_twoway_p(terminal_io))
15082 return TheStream(terminal_io)->strm_twoway_input;
15083 /* General case: Use a synonym stream. */
15084 return (boundp(preallocated_default) ? preallocated_default :
15085 make_synonym_stream(S(terminal_io)));
15086 }
15087
15088 /* UP: Returns the output side of *TERMINAL-IO*.
15089 Defaults to a (make-synonym-stream '*terminal-io*).
15090 > preallocated_default: (make-synonym-stream '*terminal-io*) or unbound
15091 < result: a stream that can be used for *STANDARD-OUTPUT*
15092 can trigger GC - if preallocated_default is unbound */
terminal_io_output_stream(object preallocated_default)15093 local /*maygc*/ object terminal_io_output_stream (object preallocated_default) {
15094 GCTRIGGER_IF(!boundp(preallocated_default), GCTRIGGER());
15095 var object terminal_io = Symbol_value(S(terminal_io));
15096 /* Optimization: Extract the output side if possible. */
15097 if (stream_twoway_p(terminal_io))
15098 return TheStream(terminal_io)->strm_twoway_output;
15099 /* General case: Use a synonym stream. */
15100 return (boundp(preallocated_default) ? preallocated_default :
15101 make_synonym_stream(S(terminal_io)));
15102 }
15103
15104 #ifdef GNU_READLINE
15105 local int next_line_virtual(int,int);
15106 local int previous_line_virtual(int,int);
get_col(void)15107 local int get_col (void) {
15108 var int col = rl_point;
15109 while(col && rl_line_buffer[col]!='\n') col--;
15110 return rl_point - col;
15111 }
next_line_virtual(int count,int key)15112 local int next_line_virtual (int count, int key) {
15113 if (count > 0) {
15114 var int col = get_col();
15115 var int len = strlen(rl_line_buffer);
15116 while (count--) {
15117 while (rl_point<len && rl_line_buffer[rl_point]!='\n') rl_point++;
15118 if (rl_point<len) rl_point++;
15119 }
15120 rl_point += col-1;
15121 if (rl_point>=len) rl_point = len-1;
15122 } else if (count < 0)
15123 return previous_line_virtual(-count,key);
15124 /* else rl_variable_dumper(1); */
15125 return 0;
15126 }
previous_line_virtual(int count,int key)15127 local int previous_line_virtual (int count, int key) {
15128 if (count > 0) {
15129 var int col = get_col();
15130 do {
15131 while(rl_point && rl_line_buffer[rl_point]!='\n') rl_point--;
15132 if (rl_point) rl_point--;
15133 else return 0;
15134 } while (count--);
15135 rl_point += col+1;
15136 } else if (count < 0)
15137 return next_line_virtual(-count,key);
15138 /* else rl_variable_dumper(1); */
15139 return 0;
15140 }
15141 #endif
15142
15143 /* UP: Initializes the stream-variables.
15144 init_streamvars(batch_p);
15145 > batch_p: Flag, whether *standard-input*, *standard-output*, *error-output*
15146 should be initialized to the C stdio handle-streams
15147 (deviates from the standard)
15148 can trigger GC */
init_streamvars(bool batch_p)15149 global maygc void init_streamvars (bool batch_p) {
15150 #ifdef GNU_READLINE
15151 begin_call();
15152 #if HAVE_DECL_RL_READLINE_NAME
15153 { /* we could have used a string literal, but then readline:readline-name
15154 would have to be read-only because one cannot free() a string literal */
15155 var char* name = (char*)malloc(6); strcpy(name,"CLISP");
15156 rl_readline_name = name;
15157 }
15158 #endif
15159 if (ilisp_mode) {
15160 /* Simulate the following instruction in .inputrc:
15161 Control-i: self-insert */
15162 rl_bind_key(CTRL('I'),rl_named_function("self-insert"));
15163 }
15164 rl_attempted_completion_function = &lisp_completion_matches;
15165 rl_completion_entry_function = &lisp_completion_more;
15166 rl_variable_bind("comment-begin",";");
15167 rl_variable_bind("blink-matching-paren","on");
15168 /* rl_set_paren_blink_timeout(1000000); == 1 sec [default 0.5 sec] */
15169 rl_add_defun("next-line-virtual",&next_line_virtual,META('n'));
15170 rl_add_defun("previous-line-virtual",&previous_line_virtual,META('p'));
15171 end_call();
15172 #endif /* GNU_READLINE */
15173 #ifdef MULTITHREAD
15174 /* clear per thread binding */
15175 #define def_var(sym,val) do { \
15176 define_variable(sym,val); \
15177 current_thread()->_ptr_symvalues[TheSymbol(sym)->tls_index]=SYMVALUE_EMPTY;\
15178 } while(0)
15179 #else
15180 #define def_var(sym,val) define_variable(sym,val)
15181 #endif
15182 {
15183 var object stream = make_terminal_io();
15184 def_var(S(terminal_io),stream); /* *TERMINAL-IO* */
15185 }
15186 {
15187 var object stream = make_synonym_stream(S(terminal_io));
15188 def_var(S(query_io),stream); /* *QUERY-IO* */
15189 def_var(S(debug_io),stream); /* *DEBUG-IO* */
15190 def_var(S(trace_output),stream); /* *TRACE-OUTPUT* */
15191 def_var(S(standard_input), /* *STANDARD-INPUT* */
15192 batch_p ? get_standard_input_file_stream()
15193 : terminal_io_input_stream(stream));
15194 def_var(S(standard_output), /* *STANDARD-OUTPUT* */
15195 batch_p ? get_standard_output_file_stream()
15196 : terminal_io_output_stream(stream));
15197 def_var(S(error_output), /* *ERROR-OUTPUT* */
15198 batch_p ? get_standard_error_file_stream()
15199 : (object)Symbol_value(S(standard_output)));
15200 }
15201 #ifdef KEYBOARD
15202 /* Initialize the *KEYBOARD-INPUT* stream. This can fail in some cases,
15203 therefore we do it after the standard streams are in place, so that
15204 the user will get a reasonable error message. */
15205 #ifdef UNIX
15206 /* Building the keyboard stream is a costly operation. Delay it
15207 until we really need it. */
15208 def_var(S(keyboard_input),NIL); /* *KEYBOARD-INPUT* */
15209 #else
15210 {
15211 var object stream = make_keyboard_stream();
15212 def_var(S(keyboard_input),stream); /* *KEYBOARD-INPUT* */
15213 }
15214 #endif
15215 #endif
15216 #undef def_var
15217 }
15218
15219 /* Returns error-message, if the value of the symbol sym is not a stream. */
error_value_stream(object sym)15220 local void error_value_stream (object sym) {
15221 /* Possibly repair before the error-message
15222 (initialized as in init_streamvars resp. init_pathnames): */
15223 var object stream;
15224 pushSTACK(sym); /* save sym */
15225 #ifdef KEYBOARD
15226 if (eq(sym,S(keyboard_input))) { /* Keyboard-Stream as Default */
15227 stream = make_keyboard_stream();
15228 } else
15229 #endif
15230 if (eq(sym,S(terminal_io))) {
15231 /* Terminal-Stream as Default
15232 (Use make_terminal_stream() here, not make_terminal_io(), because
15233 that might have been a file stream and got closed when the disk
15234 became full.) */
15235 stream = make_terminal_stream();
15236 } else if (eq(sym,S(query_io)) || eq(sym,S(debug_io))
15237 || eq(sym,S(error_output)) || eq(sym,S(trace_output))) {
15238 /* Synonym-Stream to *TERMINAL-IO* as Default */
15239 stream = make_synonym_stream(S(terminal_io));
15240 } else if (eq(sym,S(standard_input))) {
15241 stream = terminal_io_input_stream(unbound);
15242 } else if (eq(sym,S(standard_output))) {
15243 stream = terminal_io_output_stream(unbound);
15244 } else {
15245 /* other Symbol, not fixable -> instant error-message: */
15246 pushSTACK(Symbol_value(sym)); /* TYPE-ERROR slot DATUM */
15247 pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
15248 pushSTACK(Symbol_value(sym)); /* variable value */
15249 pushSTACK(sym); /* variable */
15250 pushSTACK(TheSubr(subr_self)->name);
15251 if (!streamp(Symbol_value(sym))) {
15252 error(type_error,GETTEXT("~S: The value of ~S is not a stream: ~S"));
15253 } else {
15254 error(type_error,GETTEXT("~S: The value of ~S is not an appropriate stream: ~S"));
15255 }
15256 }
15257 sym = popSTACK();
15258 /* repair finished: stream is the new value of sym. */
15259 var object oldvalue = Symbol_value(sym);
15260 Symbol_value(sym) = stream;
15261 pushSTACK(oldvalue); /* TYPE-ERROR slot DATUM */
15262 pushSTACK(S(stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
15263 pushSTACK(stream); /* new variable value */
15264 pushSTACK(oldvalue); /* old variable value */
15265 pushSTACK(sym); /* Variable */
15266 pushSTACK(TheSubr(subr_self)->name);
15267 error(type_error,GETTEXT("~S: The value of ~S was not an appropriate stream: ~S. It has been changed to ~S."));
15268 }
15269
15270 #ifdef GNU_READLINE
15271 /* Auxiliary functions for the GNU ReadLine Library: */
rl_memory_abort(void)15272 local _Noreturn void rl_memory_abort (void) {
15273 /* when there is no more memory for the ReadLine
15274 drop it and replace the *TERMINAL-IO* with another
15275 terminal-stream without ReadLine */
15276 rl_deprep_terminal(); /* cancel all ioctl()s */
15277 begin_rl_callback(); /* reset STACK to a reasonable value */
15278 rl_gnu_readline_p = false;
15279 Symbol_value(S(terminal_io)) = make_terminal_stream();
15280 error(storage_condition,GETTEXT("readline library: out of memory."));
15281 }
15282
xmalloc(int count)15283 local char* xmalloc (int count) {
15284 var char* tmp = (char*)malloc(count);
15285 if (tmp) return tmp;
15286 else rl_memory_abort();
15287 }
15288 #endif
15289
15290 LISPFUNNR(built_in_stream_open_p,1)
15291 { /* (SYS::BUILT-IN-STREAM-OPEN-P stream) */
15292 var object stream = popSTACK();
15293 CHECK_builtin_stream(stream);
15294 VALUES_IF(TheStream(stream)->strmflags & strmflags_open_B); /* open? */
15295 }
15296
15297 LISPFUNNR(input_stream_p,1)
15298 { /* (INPUT-STREAM-P stream), CLTL p. 332, CLtL2 p. 505 */
15299 var object stream = check_stream(popSTACK());
15300 VALUES_IF(input_stream_p(stream));
15301 }
15302
15303 LISPFUNNR(output_stream_p,1)
15304 { /* (OUTPUT-STREAM-P stream), CLTL p. 332, CLtL2 p. 505 */
15305 var object stream = check_stream(popSTACK());
15306 VALUES_IF(output_stream_p(stream));
15307 }
15308
15309 /* (SYS::STREAM-ELEMENT-TYPE-EQ T0 T1)
15310 this function is used for `stream-element-type' type merging
15311 it does not handle types not seen as stream element types
15312 it should be reasonably fast, so we are not using `canonicalize-type'
15313 (defun stream-element-type-eq (t0 t1)
15314 (or (eq t0 t1)
15315 (and (consp t0) (consp t1)
15316 (eq (car t0) (car t1))
15317 (member (car t0) '(unsigned-byte signed-byte))
15318 (eql (cadr t0) (cadr t1))))) */
15319 LISPFUNN(stream_element_type_eq,2) {
15320 var object t0 = popSTACK();
15321 var object t1 = popSTACK();
15322 VALUES_IF(eq(t0,t1)
15323 || (consp(t0) && consp(t1) && eq(Car(t0),Car(t1))
15324 && (eq(Car(t0),S(unsigned_byte)) || eq(Car(t0),S(signed_byte)))
15325 && consp(Cdr(t0)) && consp(Cdr(t1))
15326 && eql(Car(Cdr(t0)),Car(Cdr(t1)))));
15327 }
15328
15329 /* combine several stream-element-type into one, using OR
15330 types are on the STACK (numarg or them)
15331 remove numarg elements from STACK
15332 can trigger GC */
combine_stream_element_types(uintL numarg)15333 local maygc object combine_stream_element_types (uintL numarg) {
15334 var uintL count = numarg;
15335 var gcv_object_t *arg_ptr = &STACK_0;
15336 do { /* remove OR / listify */
15337 if (consp(*arg_ptr) && eq(Car(*arg_ptr),S(or)))
15338 *arg_ptr = Cdr(*arg_ptr);
15339 else if (!nullp(*arg_ptr)) {
15340 var object tmp = allocate_cons();
15341 Car(tmp) = *arg_ptr;
15342 *arg_ptr = tmp;
15343 }
15344 (void)BEFORE(arg_ptr);
15345 } while (--count);
15346 funcall(L(append),numarg);
15347 pushSTACK(value1); pushSTACK(S(Ktest));
15348 pushSTACK(L(stream_element_type_eq));
15349 funcall(L(remove_duplicates),3);
15350 if (consp(value1)) {
15351 if (!nullp(Cdr(value1))) { /* (PUSH 'OR LIST) */
15352 pushSTACK(value1);
15353 var object tmp = allocate_cons();
15354 Car(tmp) = S(or); Cdr(tmp) = popSTACK();
15355 return tmp;
15356 } else return Car(value1); /* single type, no OR */
15357 } else return value1; /* NIL */
15358 }
15359
15360 /* (SYS::BUILT-IN-STREAM-ELEMENT-TYPE stream)
15361 returns CHARACTER or INTEGER or T
15362 or (more specific) (UNSIGNED-BYTE n) or (SIGNED-BYTE n). */
15363 LISPFUNNR(built_in_stream_element_type,1) {
15364 var object stream = popSTACK();
15365 var object eltype;
15366 CHECK_builtin_stream(stream);
15367 start:
15368 switch (TheStream(stream)->strmtype) {
15369 case strmtype_synonym: /* Synonym-Stream: follow further */
15370 resolve_as_synonym(stream);
15371 if (builtin_stream_p(stream))
15372 goto start;
15373 else { /* Call (STREAM-ELEMENT-TYPE stream): */
15374 pushSTACK(stream); funcall(S(stream_element_type),1);
15375 return;
15376 }
15377 case strmtype_broad: /* issue 021 */
15378 stream = broadcast_stream_last(stream);
15379 if (streamp(stream)) {
15380 pushSTACK(stream); funcall(S(stream_element_type),1);
15381 return;
15382 } else eltype = T; /* empty stream list */
15383 break;
15384 /* first the stream-types with restricted element-types: */
15385 case strmtype_str_out: { /* could be (VECTOR NIL) */
15386 eltype = (((Iarray_flags(TheStream(stream)->strm_str_out_string)
15387 & arrayflags_atype_mask) == Atype_NIL)
15388 ? NIL : S(character));
15389 } break;
15390 case strmtype_str_in:
15391 case strmtype_str_push:
15392 case strmtype_pphelp:
15393 case strmtype_buff_in:
15394 case strmtype_buff_out:
15395 /* CHARACTER */
15396 { eltype = S(character); } break;
15397 #ifdef KEYBOARD
15398 case strmtype_keyboard:
15399 { eltype = T; } break;
15400 #endif
15401 case strmtype_terminal:
15402 #ifdef SCREEN
15403 case strmtype_window:
15404 #endif
15405 #ifdef PRINTER
15406 case strmtype_printer:
15407 #endif
15408 /* CHARACTER */
15409 { eltype = S(character); } break;
15410 case strmtype_file:
15411 #ifdef PIPES
15412 case strmtype_pipe_in:
15413 case strmtype_pipe_out:
15414 #endif
15415 #ifdef X11SOCKETS
15416 case strmtype_x11socket:
15417 #endif
15418 #ifdef SOCKET_STREAMS
15419 case strmtype_socket:
15420 #endif
15421 /* CHARACTER or ([UN]SIGNED-BYTE n) */
15422 eltype = TheStream(stream)->strm_eltype; break;
15423 #ifdef SOCKET_STREAMS
15424 case strmtype_twoway_socket:
15425 /* CHARACTER or ([UN]SIGNED-BYTE n) */
15426 stream = TheStream(stream)->strm_twoway_socket_input;
15427 eltype = TheStream(stream)->strm_eltype; break;
15428 #endif
15429 case strmtype_twoway:
15430 case strmtype_echo: {
15431 /* (let ((itype (stream-element-type (two-way-input-stream stream)))
15432 (otype (stream-element-type (two-way-output-stream stream))))
15433 ; Simplify `(OR ,itype ,otype)
15434 (cond ((eq itype 'NIL) otype)
15435 ((eq otype 'NIL) itype)
15436 ((eq itype otype) itype)
15437 (t
15438 (cons 'OR
15439 (remove-duplicates
15440 (append
15441 (if (and (consp itype) (eq (car itype) 'OR))
15442 (cdr itype)
15443 (list itype))
15444 (if (and (consp otype) (eq (car otype) 'OR))
15445 (cdr otype)
15446 (list otype))))))))) */
15447 pushSTACK(TheStream(stream)->strm_twoway_input);
15448 pushSTACK(TheStream(stream)->strm_twoway_output);
15449 pushSTACK(STACK_1); funcall(S(stream_element_type),1);
15450 STACK_1 = value1; funcall(S(stream_element_type),1);
15451 pushSTACK(value1);
15452 var object itype = STACK_1;
15453 var object otype = STACK_0;
15454 if (nullp(itype)) {
15455 eltype = otype;
15456 skipSTACK(2);
15457 } else if (nullp(otype) || eq(itype,otype)) {
15458 eltype = itype;
15459 skipSTACK(2);
15460 } else
15461 eltype = combine_stream_element_types(2);
15462 } break;
15463 case strmtype_concat: {
15464 var uintL count = 0;
15465 var gcv_object_t *stream_list_;
15466 pushSTACK(TheStream(stream)->strm_concat_list);
15467 stream_list_ = &STACK_0;
15468 while (consp(*stream_list_)) {
15469 pushSTACK(Car(*stream_list_)); funcall(S(stream_element_type),1);
15470 pushSTACK(value1); count++;
15471 *stream_list_ = Cdr(*stream_list_);
15472 }
15473 switch (count) {
15474 case 0: { eltype = NIL; skipSTACK(1); } break; /* no streams */
15475 case 1: { eltype = STACK_0; skipSTACK(2); } break;
15476 default: eltype = combine_stream_element_types(count); skipSTACK(1);
15477 }
15478 } break;
15479 /* then the general streams: */
15480 #ifdef GENERIC_STREAMS
15481 case strmtype_generic:
15482 #endif
15483 default: {
15484 var uintB flags = TheStream(stream)->strmflags;
15485 if (flags & strmflags_by_B) {
15486 if (flags & strmflags_ch_B) { /* (OR CHARACTER INTEGER) */
15487 pushSTACK(S(or)); pushSTACK(S(character)); pushSTACK(S(integer));
15488 eltype = listof(3);
15489 } else eltype = S(integer);
15490 } else
15491 if (flags & strmflags_ch_B) eltype = S(character);
15492 else eltype = NIL;
15493 }
15494 break;
15495 }
15496 VALUES1(eltype);
15497 }
15498
15499 /* UP: reset the stream for the eltype and flush out the missing LF.
15500 IF the stream is unbuffered, AND ignore_next_LF is true, THEN
15501 this can block (we will try to read the next LF) and trigger GC
15502 > stream: a channel-stream
15503 < result: the same stream
15504 can trigger GC */
stream_reset_eltype(object stream,decoded_el_t * eltype_)15505 local maygc object stream_reset_eltype (object stream, decoded_el_t* eltype_) {
15506 if (ChannelStream_buffered(stream)) {
15507 fill_pseudofuns_buffered(stream,eltype_);
15508 } else {
15509 if (ChannelStream_ignore_next_LF(stream)
15510 && eq(TheStream(stream)->strm_eltype,S(character))) {
15511 pushSTACK(stream);
15512 ChannelStream_ignore_next_LF(stream) = false; /* do not skip LF! */
15513 var object ch = read_char(&STACK_0);
15514 if (!eq(ch,eof_value) && !chareq(char_code(ch),ascii(LF)))
15515 unread_char(&STACK_0,ch);
15516 stream = popSTACK();
15517 }
15518 fill_pseudofuns_unbuffered(stream,eltype_);
15519 }
15520 return stream;
15521 }
15522
15523 /* (SYSTEM::BUILT-IN-STREAM-SET-ELEMENT-TYPE stream element-type) */
15524 LISPFUNN(built_in_stream_set_element_type,2) {
15525 var object stream = STACK_1;
15526 var decoded_el_t eltype;
15527 CHECK_builtin_stream(stream);
15528 test_eltype_arg(&STACK_0,&eltype);
15529 pushSTACK(canon_eltype(&eltype));
15530 /* Stack contents: stream, element-type, canon-element-type. */
15531 stream = STACK_2;
15532 start:
15533 switch (TheStream(stream)->strmtype) {
15534 case strmtype_synonym: /* Synonym-Stream: follow further */
15535 resolve_as_synonym(stream);
15536 if (builtin_stream_p(stream))
15537 goto start;
15538 else { /* Call ((SETF STREAM-ELEMENT-TYPE) element-type stream): */
15539 pushSTACK(STACK_1); pushSTACK(stream);
15540 funcall(O(setf_stream_element_type),2);
15541 return;
15542 }
15543 case strmtype_broad: /* Recurse. */
15544 check_SP(); check_STACK();
15545 pushSTACK(TheStream(stream)->strm_broad_list);
15546 while (consp(STACK_0)) {
15547 pushSTACK(Car(STACK_0)); pushSTACK(STACK_(1+2));
15548 C_built_in_stream_set_element_type();
15549 STACK_0 = Cdr(STACK_0);
15550 }
15551 skipSTACK(1);
15552 break;
15553 case strmtype_concat: /* Recurse. */
15554 check_SP(); check_STACK();
15555 pushSTACK(TheStream(stream)->strm_concat_totallist);
15556 while (consp(STACK_0)) {
15557 pushSTACK(Car(STACK_0)); pushSTACK(STACK_(1+2));
15558 C_built_in_stream_set_element_type();
15559 STACK_0 = Cdr(STACK_0);
15560 }
15561 skipSTACK(1);
15562 break;
15563 case strmtype_file:
15564 #ifdef PIPES
15565 case strmtype_pipe_in:
15566 case strmtype_pipe_out:
15567 #endif
15568 #ifdef SOCKET_STREAMS
15569 case strmtype_socket:
15570 #endif
15571 if (!equal(STACK_0,TheStream(stream)->strm_eltype)) {/* nothing to change? */
15572 /* Check eltype. */
15573 if (!ChannelStream_buffered(stream))
15574 check_unbuffered_eltype(&eltype);
15575 /* The FILE-POSITION return value is constrained by CLHS to
15576 - be an integer,
15577 - represent a position into the file (and therefore be
15578 independent of the stream's current element type),
15579 - increment by 1 when READ-BYTE or WRITE-BYTE is called.
15580 In order to achieve these constraints altogether, we allow
15581 switching only (UNSIGNED-BYTE n) and (SIGNED-BYTE n) with
15582 the same n, and between ([UN]SIGNED-BYTE 8) and CHARACTER.
15583 Reading (UNSIGNED-BYTE 8) and (UNSIGNED-BYTE 16) and
15584 (UNSIGNED-BYTE 32) values from the same stream in succession
15585 can be achieved through READ-INTEGER and WRITE-INTEGER. */
15586 if ((ChannelStream_bitsize(stream) > 0 ?
15587 ChannelStream_bitsize(stream) : 8)
15588 != (eltype.size > 0 ? eltype.size : 8)) {
15589 /* canon-element-type in STACK_0. */
15590 pushSTACK(TheStream(stream)->strm_eltype);
15591 pushSTACK(stream);
15592 pushSTACK(S(Kelement_type));
15593 pushSTACK(O(setf_stream_element_type));
15594 error(error_condition,
15595 GETTEXT("~S: The ~S of ~S cannot be changed from ~S to ~S."));
15596 }
15597 /* Transform the lastchar back, if possible. */
15598 if (TheStream(stream)->strmflags & strmflags_open_B) /* stream open? */
15599 if (eltype.size > 0)
15600 /* New element type is an integer type. */
15601 if (ChannelStream_bitsize(stream) == 0) {
15602 /* Old element type was CHARACTER.
15603 Transform the lastchar back to bytes. */
15604 if (charp(TheStream(stream)->strm_rd_ch_last)
15605 && (TheStream(stream)->strmflags & strmflags_unread_B)) {
15606 /* FIXME: This should take into account the encoding. */
15607 var uintB b = as_cint(char_code(TheStream(stream)->strm_rd_ch_last));
15608 if (ChannelStream_buffered(stream)) {
15609 if ((BufferedStream_index(stream) > 0)
15610 && (BufferedStream_position(stream) > 0)
15611 && (*BufferedStream_buffer_address(stream,BufferedStream_index(stream)-1)
15612 == b)) {
15613 /* decrement index and position: */
15614 BufferedStream_index(stream) -= 1;
15615 BufferedStream_position(stream) -= 1;
15616 TheStream(stream)->strm_rd_ch_last = NIL;
15617 TheStream(stream)->strmflags &= ~strmflags_unread_B;
15618 }
15619 } else {
15620 if (UnbufferedStream_status(stream) == 0) {
15621 UnbufferedStreamLow_push_byte(stream,b);
15622 ChannelStream_ignore_next_LF(stream) = false;
15623 TheStream(stream)->strm_rd_ch_last = NIL;
15624 TheStream(stream)->strmflags &= ~strmflags_unread_B;
15625 }
15626 }
15627 }
15628 }
15629 { /* Actually change the stream's element type. */
15630 var uintB flags = TheStream(stream)->strmflags;
15631 flags = (flags & ~strmflags_rdwr_B)
15632 | (flags & strmflags_rd_B ? strmflags_rd_B : 0)
15633 | (flags & strmflags_wr_B ? strmflags_wr_B : 0);
15634 ChannelStream_bitsize(stream) = eltype.size;
15635 if (eltype.kind == eltype_ch) {
15636 /* New element type is CHARACTER. */
15637 flags &= ~(strmflags_rdwr_B & ~strmflags_ch_B);
15638 } else {
15639 /* New element type is an integer type.
15640 allocate Bitbuffer: */
15641 pushSTACK(stream);
15642 var object bitbuffer = allocate_bit_vector(Atype_Bit,eltype.size);
15643 stream = popSTACK();
15644 TheStream(stream)->strm_bitbuffer = bitbuffer;
15645 flags &= ~(strmflags_rdwr_B & ~strmflags_by_B);
15646 }
15647 TheStream(stream)->strmflags = flags;
15648 }
15649 stream = stream_reset_eltype(stream,&eltype);
15650 TheStream(stream)->strm_eltype = STACK_0;
15651 }
15652 break;
15653 #ifdef SOCKET_STREAMS
15654 case strmtype_twoway_socket: {
15655 /* Apply to the input and output side individually. */
15656 pushSTACK(TheStream(STACK_2)->strm_twoway_socket_input); /* stream */
15657 pushSTACK(STACK_(0+1));
15658 funcall(L(built_in_stream_set_element_type),2);
15659 pushSTACK(TheStream(STACK_2)->strm_twoway_socket_output); /* stream */
15660 pushSTACK(STACK_(0+1));
15661 funcall(L(built_in_stream_set_element_type),2);
15662 } break;
15663 #endif
15664 default:
15665 error_illegal_streamop(O(setf_stream_element_type),stream);
15666 }
15667 VALUES1(STACK_1);
15668 skipSTACK(3);
15669 }
15670
15671 LISPFUNNR(stream_external_format,1)
15672 { /* (STREAM-EXTERNAL-FORMAT stream) */
15673 var object stream = check_stream(popSTACK());
15674 start:
15675 if (builtin_stream_p(stream))
15676 switch (TheStream(stream)->strmtype) {
15677 case strmtype_synonym: /* Synonym-Stream: follow further */
15678 resolve_as_synonym(stream);
15679 goto start;
15680 #ifdef SOCKET_STREAMS
15681 case strmtype_twoway_socket:
15682 pushSTACK(TheStream(stream)->strm_twoway_socket_input);
15683 pushSTACK(TheStream(stream)->strm_twoway_socket_output);
15684 goto stream_external_format_strmtype_twoway;
15685 #endif
15686 case strmtype_twoway:
15687 case strmtype_echo:
15688 pushSTACK(TheStream(stream)->strm_twoway_input);
15689 pushSTACK(TheStream(stream)->strm_twoway_output);
15690 stream_external_format_strmtype_twoway:
15691 C_stream_external_format();
15692 if (eq(value1,S(Kdefault))) {
15693 skipSTACK(1); /* drop input stream */
15694 return; /* return :DEFAULT */
15695 }
15696 pushSTACK(STACK_0); /* input stream */
15697 STACK_1 = value1; /* save output external format */
15698 C_stream_external_format();
15699 { object output_ex_fmt = popSTACK();
15700 if (equalp(value1,output_ex_fmt)) /* same ex fmt for input & output */
15701 return; /* return this same ex fmt */
15702 VALUES1(S(Kdefault));
15703 }
15704 break;
15705 case strmtype_file:
15706 #ifdef PIPES
15707 case strmtype_pipe_in:
15708 case strmtype_pipe_out:
15709 #endif
15710 #ifdef X11SOCKETS
15711 case strmtype_x11socket:
15712 #endif
15713 #ifdef SOCKET_STREAMS
15714 case strmtype_socket:
15715 #endif
15716 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(ENABLE_UNICODE)
15717 case strmtype_terminal:
15718 #endif
15719 VALUES1(TheStream(stream)->strm_encoding); break;
15720 case strmtype_concat:
15721 stream = TheStream(stream)->strm_concat_list;
15722 if (consp(stream)) {
15723 pushSTACK(Car(stream)); funcall(L(stream_external_format),1);
15724 return;
15725 }
15726 VALUES1(S(Kdefault)); break;
15727 case strmtype_broad:
15728 stream = broadcast_stream_last(stream);
15729 if (streamp(stream)) {
15730 pushSTACK(stream); funcall(L(stream_external_format),1);
15731 return;
15732 } /* empty => FALLTHROUGH*/
15733 default:
15734 VALUES1(S(Kdefault)); break;
15735 }
15736 else
15737 VALUES1(S(Kdefault));
15738 }
15739
15740 /* (SYSTEM::SET-STREAM-EXTERNAL-FORMAT stream external-format [direction])
15741 direction can be :INPUT or :OUTPUT or NIL.
15742 If no direction is given, the operation is nonrecursive. */
15743 LISPFUN(set_stream_external_format,seclass_default,2,1,norest,nokey,0,NIL) {
15744 STACK_2 = check_stream(STACK_2);
15745 var object encoding = STACK_1 =
15746 check_encoding(STACK_1,&O(default_file_encoding),false);
15747 var object stream = STACK_2;
15748 var object direction = STACK_0;
15749 start:
15750 if (builtin_stream_p(stream))
15751 switch (TheStream(stream)->strmtype) {
15752 case strmtype_synonym: /* Synonym-Stream: follow further */
15753 resolve_as_synonym(stream);
15754 goto start;
15755 case strmtype_broad:
15756 if (eq(direction,S(Kinput)))
15757 goto done;
15758 if (eq(direction,S(Koutput))) { /* Recurse. */
15759 check_SP(); check_STACK();
15760 pushSTACK(TheStream(stream)->strm_broad_list);
15761 while (consp(STACK_0)) {
15762 pushSTACK(Car(STACK_0)); pushSTACK(STACK_(1+2));
15763 pushSTACK(STACK_(0+3)); C_set_stream_external_format();
15764 STACK_0 = Cdr(STACK_0);
15765 }
15766 skipSTACK(1);
15767 encoding = STACK_1;
15768 goto done;
15769 }
15770 goto unchangeable_external_format;
15771 case strmtype_concat:
15772 if (eq(direction,S(Kinput))) { /* Recurse. */
15773 check_SP(); check_STACK();
15774 pushSTACK(TheStream(stream)->strm_concat_totallist);
15775 while (consp(STACK_0)) {
15776 pushSTACK(Car(STACK_0)); pushSTACK(STACK_(1+2));
15777 pushSTACK(STACK_(0+3)); C_set_stream_external_format();
15778 STACK_0 = Cdr(STACK_0);
15779 }
15780 skipSTACK(1);
15781 encoding = STACK_1;
15782 goto done;
15783 }
15784 if (eq(direction,S(Koutput)))
15785 goto done;
15786 goto unchangeable_external_format;
15787 case strmtype_str_in:
15788 case strmtype_str_out:
15789 case strmtype_str_push:
15790 case strmtype_pphelp:
15791 case strmtype_buff_in:
15792 case strmtype_buff_out:
15793 #ifdef GENERIC_STREAMS
15794 case strmtype_generic:
15795 #endif
15796 if (eq(direction,S(Kinput)) || eq(direction,S(Koutput)))
15797 goto done;
15798 goto unchangeable_external_format;
15799 case strmtype_file:
15800 #ifdef PIPES
15801 case strmtype_pipe_in:
15802 case strmtype_pipe_out:
15803 #endif
15804 #ifdef X11SOCKETS
15805 case strmtype_x11socket:
15806 #endif
15807 #ifdef SOCKET_STREAMS
15808 case strmtype_socket:
15809 #endif
15810 {
15811 var decoded_el_t eltype;
15812 STACK_2 = stream; /* save stream */
15813 test_eltype_arg(&TheStream(stream)->strm_eltype,&eltype);
15814 stream = STACK_2; /* restore stream */
15815 ChannelStream_fini(stream,0);
15816 stream = stream_reset_eltype(stream,&eltype);
15817 encoding = STACK_1; /* restore encoding */
15818 TheStream(stream)->strm_encoding = encoding;
15819 /* reset pseudofunctions in case line terminator changed */
15820 stream_reset_eltype(stream,&eltype);
15821 stream = STACK_2; /* restore stream */
15822 ChannelStream_init(stream);
15823 VALUES1(TheStream(stream)->strm_encoding);
15824 }
15825 break;
15826 #ifdef SOCKET_STREAMS
15827 case strmtype_twoway_socket:
15828 #endif
15829 case strmtype_twoway:
15830 case strmtype_echo:
15831 if (eq(direction,S(Kinput))) { /* Recurse. */
15832 stream = TheStream(stream)->strm_twoway_input; goto start;
15833 }
15834 if (eq(direction,S(Koutput))) { /* Recurse. */
15835 stream = TheStream(stream)->strm_twoway_output; goto start;
15836 }
15837 /* Recurse twice. */
15838 pushSTACK(TheStream(stream)->strm_twoway_output);
15839 pushSTACK(STACK_(1+1)); pushSTACK(STACK_(0+2));
15840 pushSTACK(TheStream(stream)->strm_twoway_input);
15841 pushSTACK(STACK_(1+4)); pushSTACK(STACK_(0+5));
15842 C_set_stream_external_format();
15843 C_set_stream_external_format();
15844 encoding = STACK_1;
15845 goto done;
15846 default:
15847 if (eq(direction,S(Kinput)))
15848 if ((TheStream(stream)->strmflags & strmflags_rd_B) == 0)
15849 goto done;
15850 if (eq(direction,S(Koutput)))
15851 if ((TheStream(stream)->strmflags & strmflags_wr_B) == 0)
15852 goto done;
15853 unchangeable_external_format:
15854 if (!eq(encoding,S(Kdefault)))
15855 error_illegal_streamop(S(set_stream_external_format),stream);
15856 done:
15857 VALUES1(encoding); break;
15858 }
15859 else {
15860 if (eq(direction,S(Kinput)))
15861 if (!instanceof(stream,O(class_fundamental_input_stream)))
15862 goto done2;
15863 if (eq(direction,S(Koutput)))
15864 if (!instanceof(stream,O(class_fundamental_output_stream)))
15865 goto done2;
15866 if (!eq(encoding,S(Kdefault)))
15867 error_illegal_streamop(S(set_stream_external_format),stream);
15868 done2:
15869 VALUES1(encoding);
15870 }
15871 skipSTACK(3);
15872 }
15873
15874 #ifdef ENABLE_UNICODE
15875
15876 /* Changes a terminal stream's external format.
15877 > stream: a stream
15878 > encoding: an encoding
15879 can trigger GC */
set_terminalstream_external_format(object stream,object encoding)15880 global maygc void set_terminalstream_external_format (object stream,
15881 object encoding) {
15882 if (builtin_stream_p(stream)
15883 && TheStream(stream)->strmtype == strmtype_terminal
15884 && eq(TheStream(stream)->strm_encoding,O(terminal_encoding))) {
15885 /* This is the only place which is allowed to modify the terminal
15886 stream's encoding.
15887 The terminal stream's end-of-line coding is hardwired, therefore we
15888 don't need to do the equivalent of fill_pseudofuns_unbuffered here. */
15889 ChannelStream_fini(stream,0);
15890 TheStream(stream)->strm_encoding = encoding;
15891 ChannelStream_init(stream);
15892 } else {
15893 pushSTACK(stream); pushSTACK(encoding);
15894 funcall(L(set_stream_external_format),2);
15895 }
15896 }
15897
15898 #endif
15899
15900 /* UP: Determines, if a Stream is "interactive", i.e. if Input of Stream
15901 will presumably depend on a previously printed prompt.
15902 interactive_stream_p(stream)
15903 > stream: Stream
15904 NB: Relation between clear_input, listen, interactive_stream_p:
15905 If LISTEN_WAIT==listen_char(stream) after clear_input(stream)
15906 (i.e. no more character available and no EOF), then
15907 interactive_stream_p(stream) is true.
15908 (Because then stream is effectively a Keyboard-Stream, Terminal-Stream,
15909 Handle-Stream with !regular_handle_p(ihandle), Pipe-Input-Stream,
15910 X11-Socket-Stream, Socket-Stream or Generic-Stream.)
15911 (For a Concatenated-Stream, which is at the end of a non-interactive
15912 Sub-Stream and where the next Sub-Stream is non-interactive, this is
15913 possibly not valid. But this can be caught by inserting a
15914 listen_char(stream) before the query.)
15915 But not vice-versa: For Streams of type strmtype_pipe_in,
15916 strmtype_x11socket, strmtype_socket (that comply with
15917 interactive_stream_p(stream)) clear_input(stream) does nothing,
15918 and listen_char(stream) can return LISTEN_AVAIL. */
interactive_stream_p(object stream)15919 global bool interactive_stream_p (object stream) {
15920 start:
15921 if (!builtin_stream_p(stream)) /* Assume the worst. */
15922 return true;
15923 if ((TheStream(stream)->strmflags & strmflags_rd_B) == 0)
15924 /* Stream is closed for Input */
15925 return false;
15926 /* Stream open */
15927 switch (TheStream(stream)->strmtype) {
15928 case strmtype_synonym: /* Synonym-Stream: follow further */
15929 resolve_as_synonym(stream);
15930 goto start;
15931 case strmtype_concat:
15932 /* Here one could call listen_char(stream) in order to ignore Streams,
15933 that arrived at EOF. But it is no good for
15934 interactive_stream_p to do system-calls and I/O.??
15935 Query the first of the streams: */
15936 {
15937 var object streamlist = TheStream(stream)->strm_concat_list;
15938 if (consp(streamlist)) {
15939 stream = Car(streamlist);
15940 goto start;
15941 } else
15942 return false;
15943 }
15944 case strmtype_twoway:
15945 case strmtype_echo:
15946 /* Two-Way-Stream or Echo-Stream: look at Input-Stream */
15947 stream = TheStream(stream)->strm_twoway_input;
15948 goto start;
15949 case strmtype_str_in:
15950 return false;
15951 case strmtype_buff_in:
15952 #ifdef GENERIC_STREAMS
15953 case strmtype_generic:
15954 #endif
15955 return true;
15956 case strmtype_terminal:
15957 case strmtype_file:
15958 if (ChannelStream_buffered(stream))
15959 /* Buffered file streams are not considered to be interactive. */
15960 return false;
15961 if (nullp(TheStream(stream)->strm_isatty))
15962 /* regular files are for sure not interactive. */
15963 if (regular_handle_p(TheHandle(TheStream(stream)->strm_ichannel)))
15964 return false;
15965 #ifdef KEYBOARD
15966 case strmtype_keyboard:
15967 #endif
15968 #ifdef PIPES
15969 case strmtype_pipe_in:
15970 #endif
15971 #ifdef X11SOCKETS
15972 case strmtype_x11socket:
15973 #endif
15974 #ifdef SOCKET_STREAMS
15975 case strmtype_socket:
15976 case strmtype_twoway_socket:
15977 #endif
15978 return true;
15979 default:
15980 return false;
15981 }
15982 }
15983
15984 /* (INTERACTIVE-STREAM-P stream), CLTL2 p. 507/508
15985 determines, if stream is interactive. */
15986 LISPFUNN(interactive_stream_p,1) {
15987 var object arg = check_stream(popSTACK());
15988 VALUES_IF(interactive_stream_p(arg));
15989 }
15990
15991 /* UP: Closes a Stream.
15992 builtin_stream_close(&stream, abort);
15993 > stream: Builtin-Stream
15994 > abort: flag: non-0 => ignore errors: may be called from GC & quit()
15995 -- if abort is non-0, we end up calling close(2) on the underlying object
15996 no matter what else might have failed (iconv, buffer flushing &c)
15997 -- even if abort is non-0, we do try to flush buffers et al, but we do that
15998 under IGNORE-ERRORS, i.e., some output might be silently lost
15999 < stream: Builtin-Stream
16000 can trigger GC */
builtin_stream_close(const gcv_object_t * stream_,uintB abort)16001 modexp maygc void builtin_stream_close
16002 (const gcv_object_t* stream_, uintB abort) {
16003 if ((TheStream(*stream_)->strmflags & strmflags_open_B) == 0) /* Stream already closed? */
16004 return;
16005 if (!abort) harden_elastic_newline(stream_);
16006 var object stream = *stream_;
16007 /* call type-specific routine (can trigger GC): */
16008 switch (TheStream(stream)->strmtype) {
16009 case strmtype_synonym:
16010 close_synonym(stream,abort); break; /* X3J13_014 says: non-recursive */
16011 case strmtype_broad: break; /* non-recursive */
16012 case strmtype_concat: break; /* non-recursive */
16013 case strmtype_twoway: break; /* non-recursive */
16014 case strmtype_echo: break; /* non-recursive */
16015 case strmtype_str_in: close_str_in(stream); break;
16016 case strmtype_str_out: break;
16017 case strmtype_str_push: break;
16018 case strmtype_pphelp: break;
16019 case strmtype_buff_in: close_buff_in(stream); break;
16020 case strmtype_buff_out: close_buff_out(stream,abort); break;
16021 #ifdef GENERIC_STREAMS
16022 case strmtype_generic: close_generic(stream,abort); break;
16023 #endif
16024 case strmtype_file:
16025 #ifdef PIPES
16026 case strmtype_pipe_in:
16027 case strmtype_pipe_out:
16028 #endif
16029 #ifdef X11SOCKETS
16030 case strmtype_x11socket:
16031 #endif
16032 #ifdef SOCKET_STREAMS
16033 case strmtype_socket:
16034 #endif
16035 if (ChannelStream_buffered(stream)) {
16036 close_buffered(stream,abort);
16037 } else {
16038 if (!nullp(TheStream(stream)->strm_ochannel))
16039 close_ochannel(stream,abort);
16040 else
16041 close_ichannel(stream,abort);
16042 /* remove stream from the List of all open File-Streams: */
16043 remove_from_open_streams(*stream_);
16044 }
16045 break;
16046 #ifdef SOCKET_STREAMS
16047 case strmtype_twoway_socket:
16048 /* Close the two substreams, but close the handle once only. */
16049 ChannelStreamLow_close(TheStream(stream)->strm_twoway_socket_input) =
16050 &low_close_socket_nop;
16051 pushSTACK(TheStream(stream)->strm_twoway_socket_input);
16052 pushSTACK(TheStream(stream)->strm_twoway_socket_output);
16053 builtin_stream_close(&STACK_1,abort);
16054 builtin_stream_close(&STACK_0,abort);
16055 skipSTACK(2);
16056 break;
16057 #endif
16058 #ifdef KEYBOARD
16059 case strmtype_keyboard: break;
16060 #endif
16061 case strmtype_terminal: break;
16062 #ifdef SCREEN
16063 case strmtype_window: close_window(stream,abort); break;
16064 #endif
16065 default: NOTREACHED;
16066 }
16067 /* enter dummys: */
16068 close_dummys(*stream_);
16069 }
16070
16071 /* UP: Closes a list of open files - no errors!
16072 close_some_files(list);
16073 > list: list of open Builtin-Streams
16074 can trigger GC */
close_some_files(object list)16075 global maygc void close_some_files (object list) {
16076 pushSTACK(NIL); /* dummy */
16077 pushSTACK(list); /* list */
16078 while (mconsp(STACK_0)) {
16079 var object streamlist = STACK_0;
16080 STACK_0 = Cdr(streamlist); /* remaining streams */
16081 STACK_1 = Car(streamlist); /* a stream from the list */
16082 builtin_stream_close(&STACK_1,1); /* close -- no errors! */
16083 }
16084 skipSTACK(2);
16085 }
16086
16087 /* UP: Closes all open files.
16088 close_all_files();
16089 can trigger GC */
close_all_files(void)16090 global maygc void close_all_files (void) {
16091 /* NB: no locking on O(open_files). it is used only when exitting process.*/
16092 close_some_files(O(open_files)); /* list of all open File-Streams */
16093 }
16094
16095 /* UP: Declares all open File-Streams as closed.
16096 closed_all_files(); */
closed_all_files(void)16097 global void closed_all_files (void) {
16098 /* NB: no locking on O(open_files). it is used only during runtime
16099 initialization (loadmem()). */
16100 var object streamlist = O(open_files); /* list of all open File-Streams */
16101 while (consp(streamlist)) {
16102 var object stream = Car(streamlist); /* a Stream from the list */
16103 if (TheStream(stream)->strmtype == strmtype_file) { /* File-Stream ? */
16104 if (!nullp(BufferedStream_channel(stream))) /* with Handle /= NIL ? */
16105 /* yes: Stream still open */
16106 closed_buffered(stream);
16107 }
16108 close_dummys(stream);
16109 streamlist = Cdr(streamlist); /* remaining Streams */
16110 }
16111 O(open_files) = NIL; /* no more open Files */
16112 }
16113
16114 /* (SYS::BUILT-IN-STREAM-CLOSE stream :abort) */
16115 LISPFUN(built_in_stream_close,seclass_default,1,0,norest,key,1, (kw(abort)) ) {
16116 var uintB abort = !missingp(STACK_0); skipSTACK(1);
16117 var object stream = STACK_0; /* Argument */
16118 CHECK_builtin_stream(stream); /* must be a Stream */
16119 builtin_stream_close(&STACK_0,abort);
16120 skipSTACK(1);
16121 VALUES1(T); /* T as result */
16122 }
16123
16124 /* Reads a line of characters from a stream.
16125 read_line(&stream,&buffer)
16126 > stream: stream
16127 > buffer: a semi-simple string
16128 < stream: stream
16129 < buffer: contains the read characters, excluding the terminating #\Newline
16130 < result: true if EOF was seen before newline, else false
16131 can trigger GC */
push_ch(object ch,object buffer)16132 local inline maygc bool push_ch (object ch, object buffer) {
16133 if (!charp(ch)) {
16134 if (eq(subr_self,L(read_line))) error_char(ch);
16135 else with_saved_back_trace_subr(L(read_line),STACK STACKop -4,-1,
16136 error_char(ch));
16137 }
16138 if (eq(ch,ascii_char(NL)))
16139 return false;
16140 ssstring_push_extend(buffer,char_code(ch));
16141 return true;
16142 }
read_line(const gcv_object_t * stream_,const gcv_object_t * buffer_)16143 global maygc bool read_line (const gcv_object_t* stream_,
16144 const gcv_object_t* buffer_) {
16145 var object stream = *stream_;
16146 if (builtin_stream_p(stream)) {
16147 if (TheStream(stream)->strmflags & strmflags_unread_B) { /* Char after UNREAD ? */
16148 /* yes -> delete Flagbit and fetch last character: */
16149 TheStream(stream)->strmflags &= ~strmflags_unread_B;
16150 if (!push_ch(TheStream(stream)->strm_rd_ch_last,*buffer_))
16151 return false;
16152 }
16153 var bool eofp;
16154 switch (TheStream(stream)->strmtype) {
16155 case strmtype_synonym:
16156 eofp = read_line_synonym(stream,buffer_);
16157 break;
16158 case strmtype_twoway:
16159 #ifdef SOCKET_STREAMS
16160 case strmtype_twoway_socket:
16161 #endif
16162 eofp = read_line_twoway(stream,buffer_);
16163 break;
16164 /* No special-casing of strmtype_echo, because the echo-stream may
16165 be interactive, and delaying the echo in this case is undesirable. */
16166 default:
16167 do {
16168 var object ch = rd_ch(*stream_)(stream_); /* read next character */
16169 if (eq(ch,eof_value)) { /* EOF ? */
16170 eofp = true; break;
16171 }
16172 eofp = push_ch(ch,*buffer_);
16173 } while (eofp);
16174 break;
16175 }
16176 stream = *stream_;
16177 TheStream(stream)->strm_rd_ch_last = (eofp ? eof_value : ascii_char(NL));
16178 TheStream(stream)->strmflags &= ~strmflags_unread_B;
16179 return eofp;
16180 } else {
16181 pushSTACK(stream);
16182 /* Call the generic function (STREAM-READ-LINE stream): */
16183 pushSTACK(stream); funcall(S(stream_read_line),1);
16184 if (!stringp(value1)) {
16185 pushSTACK(value1); /* TYPE-ERROR slot DATUM */
16186 pushSTACK(S(string)); /* TYPE-ERROR slot EXPECTED-TYPE */
16187 pushSTACK(S(stream_read_line));
16188 pushSTACK(value1);
16189 error(type_error,GETTEXT("Return value ~S of call to ~S is not a string."));
16190 }
16191 var bool eofp = (mv_count >= 2 && !nullp(value2));
16192 /* Add the line to the buffer: */
16193 var uintL len;
16194 var uintL offset;
16195 var object srcstring = unpack_string_ro(value1,&len,&offset);
16196 if (len > 0) {
16197 if (simple_nilarray_p(srcstring)) error_nilarray_retrieve();
16198 ssstring_append_extend(*buffer_,srcstring,offset,len);
16199 }
16200 /* Set the stream's $lastchar := #\Newline or #<EOF>: */
16201 stream_set_lastchar(popSTACK(), eofp ? eof_value : ascii_char(NL));
16202 return eofp;
16203 }
16204 }
16205
16206 /* UP: Determines, if a character is instantly available in the Stream stream.
16207 listen_char(stream)
16208 > stream: Stream
16209 < result: input availability
16210 can trigger GC */
listen_char(object stream)16211 global maygc listen_t listen_char (object stream) {
16212 if (builtin_stream_p(stream)) {
16213 check_SP(); check_STACK();
16214 if (TheStream(stream)->strmflags & strmflags_unread_B) { /* Char after UNREAD ? */
16215 return LISTEN_AVAIL; /* yes -> available */
16216 } else {
16217 /* else branch according to Streamtype.
16218 Each single routine can trigger GC. Except for Keyboard-Stream
16219 or Terminal-Stream this is a pure EOF-Test. */
16220 switch (TheStream(stream)->strmtype) {
16221 case strmtype_synonym: return listen_char_synonym(stream);
16222 case strmtype_broad: return LISTEN_EOF; /* no READ-CHAR */
16223 case strmtype_concat: return listen_char_concat(stream);
16224 case strmtype_twoway:
16225 case strmtype_echo:
16226 #ifdef SOCKET_STREAMS
16227 case strmtype_twoway_socket:
16228 #endif
16229 return listen_char_twoway(stream);
16230 case strmtype_str_in: return listen_char_str_in(stream);
16231 case strmtype_str_out: return LISTEN_EOF; /* no READ-CHAR */
16232 case strmtype_str_push: return LISTEN_EOF; /* no READ-CHAR */
16233 case strmtype_pphelp: return LISTEN_EOF; /* no READ-CHAR */
16234 case strmtype_buff_in: return listen_char_buff_in(stream);
16235 case strmtype_buff_out: return LISTEN_EOF; /* no READ-CHAR */
16236 #ifdef GENERIC_STREAMS
16237 case strmtype_generic: return listen_char_generic(stream);
16238 #endif
16239 case strmtype_file:
16240 #ifdef PIPES
16241 case strmtype_pipe_in:
16242 case strmtype_pipe_out:
16243 #endif
16244 #ifdef X11SOCKETS
16245 case strmtype_x11socket:
16246 #endif
16247 #ifdef SOCKET_STREAMS
16248 case strmtype_socket:
16249 #endif
16250 if (TheStream(stream)->strmflags & strmflags_rd_ch_B) {
16251 if (ChannelStream_buffered(stream))
16252 return listen_char_buffered(stream);
16253 else
16254 return listen_char_unbuffered(stream);
16255 } else {
16256 return LISTEN_EOF; /* no READ-CHAR */
16257 }
16258 #ifdef KEYBOARD
16259 case strmtype_keyboard: return listen_char_keyboard(stream);
16260 #endif
16261 case strmtype_terminal:
16262 #if defined(UNIX) || defined(WIN32_NATIVE)
16263 terminalcase(stream,
16264 { return listen_char_terminal1(stream); },
16265 { return listen_char_terminal2(stream); },
16266 { return listen_char_terminal3(stream); });
16267 #endif
16268 NOTREACHED;
16269 #ifdef SCREEN
16270 case strmtype_window: return LISTEN_EOF; /* no READ-CHAR */
16271 #endif
16272 #ifdef PRINTER
16273 case strmtype_printer: return LISTEN_EOF; /* no READ-CHAR */
16274 #endif
16275 default: /* in general: query only for EOF */
16276 if (TheStream(stream)->strmflags & strmflags_rd_ch_B) {
16277 pushSTACK(stream);
16278 var object nextchar = peek_char(&STACK_0);
16279 skipSTACK(1);
16280 if (eq(nextchar,eof_value))
16281 return LISTEN_EOF; /* EOF reached */
16282 else
16283 return LISTEN_AVAIL;
16284 } else {
16285 return LISTEN_EOF; /* no READ-CHAR */
16286 }
16287 }
16288 }
16289 } else {
16290 /* Call the generic function (STREAM-READ-CHAR-WILL-HANG-P stream),
16291 then call (PEEK-CHAR NIL STREAM): */
16292 pushSTACK(stream);
16293 pushSTACK(stream); funcall(S(stream_read_char_will_hang_p),1);
16294 if (!nullp(value1)) {
16295 skipSTACK(1); return LISTEN_WAIT;
16296 }
16297 var object nextchar = peek_char(&STACK_0);
16298 skipSTACK(1);
16299 if (eq(nextchar,eof_value))
16300 return LISTEN_EOF;
16301 else
16302 return LISTEN_AVAIL;
16303 }
16304 }
16305
16306 /* UP: Deletes already entered interactive Input from a Stream stream.
16307 clear_input(stream)
16308 > stream: Stream
16309 < result: true if Input was deleted
16310 can trigger GC */
clear_input(object stream)16311 global maygc bool clear_input (object stream) {
16312 check_SP(); check_STACK();
16313 pushSTACK(stream); /* save Stream */
16314 /* call type-specific Routine (can trigger GC). */
16315 if (builtin_stream_p(stream)) {
16316 /* Only for Keyboard-Stream and Terminal-Stream something is done. */
16317 var bool result;
16318 switch (TheStream(stream)->strmtype) {
16319 case strmtype_synonym:
16320 result = clear_input_synonym(stream); break;
16321 case strmtype_concat:
16322 result = clear_input_concat(stream); break;
16323 case strmtype_twoway:
16324 case strmtype_echo:
16325 #ifdef SOCKET_STREAMS
16326 case strmtype_twoway_socket:
16327 #endif
16328 result = clear_input_twoway(stream); break;
16329 case strmtype_buff_in:
16330 result = clear_input_buff_in(stream); break;
16331 #ifdef GENERIC_STREAMS
16332 case strmtype_generic:
16333 result = clear_input_generic(stream); break;
16334 #endif
16335 case strmtype_file:
16336 #ifdef PIPES
16337 case strmtype_pipe_in:
16338 case strmtype_pipe_out:
16339 #endif
16340 #ifdef X11SOCKETS
16341 case strmtype_x11socket:
16342 #endif
16343 #ifdef SOCKET_STREAMS
16344 case strmtype_socket:
16345 #endif
16346 if (TheStream(stream)->strmflags & strmflags_rd_ch_B
16347 && !ChannelStream_buffered(stream))
16348 result = clear_input_unbuffered(stream);
16349 else
16350 result = clear_input_buffered(stream);
16351 break;
16352 #ifdef KEYBOARD
16353 case strmtype_keyboard:
16354 result = clear_input_keyboard(stream); break;
16355 #endif
16356 case strmtype_terminal:
16357 #if defined(UNIX) || defined(WIN32_NATIVE)
16358 terminalcase(stream,
16359 { result = clear_input_terminal1(stream); },
16360 { result = clear_input_terminal2(stream); },
16361 { result = clear_input_terminal3(stream); });
16362 #endif
16363 break;
16364 default:
16365 result = false; break;
16366 }
16367 stream = popSTACK();
16368 if (result) {
16369 /* Input was deleted -> also the Lastchar has to be deleted.
16370 An already seen EOF will be forgotten thereby. */
16371 TheStream(stream)->strm_rd_ch_last = NIL;
16372 TheStream(stream)->strmflags &= ~strmflags_unread_B;
16373 }
16374 return result;
16375 } else {
16376 /* Call the generic function (STREAM-CLEAR-INPUT stream): */
16377 funcall(S(stream_clear_input),1);
16378 return !nullp(value1);
16379 }
16380 }
16381
16382 /* UP: Determines whether a stream has a byte immediately available.
16383 listen_byte(stream)
16384 > stream: a stream with element-type ([UN]SIGNED-BYTE 8)
16385 < result: input availability
16386 can trigger GC */
listen_byte(object stream)16387 global maygc listen_t listen_byte (object stream) {
16388 if (builtin_stream_p(stream)) {
16389 if (TheStream(stream)->strmflags & strmflags_rd_B) { /* Input-Stream? */
16390 check_SP(); check_STACK();
16391 /* branch according to Streamtype.
16392 Each single routine can trigger GC. Except for Sockets
16393 this is a pure EOF-Test. */
16394 switch (TheStream(stream)->strmtype) {
16395 case strmtype_synonym: return listen_byte_synonym(stream);
16396 case strmtype_broad: return LISTEN_EOF; /* no READ-BYTE */
16397 case strmtype_concat: return listen_byte_concat(stream);
16398 case strmtype_twoway:
16399 case strmtype_echo:
16400 #ifdef SOCKET_STREAMS
16401 case strmtype_twoway_socket:
16402 #endif
16403 return listen_byte_twoway(stream);
16404 case strmtype_str_in:
16405 case strmtype_str_out:
16406 case strmtype_str_push:
16407 case strmtype_pphelp:
16408 case strmtype_buff_in:
16409 case strmtype_buff_out:
16410 #ifdef GENERIC_STREAMS
16411 case strmtype_generic: /* unsupported functionality */
16412 #endif
16413 #ifdef KEYBOARD
16414 case strmtype_keyboard:
16415 #endif
16416 case strmtype_terminal:
16417 #ifdef SCREEN
16418 case strmtype_window:
16419 #endif
16420 #ifdef PRINTER
16421 case strmtype_printer:
16422 #endif
16423 return LISTEN_EOF; /* no READ-BYTE */
16424 case strmtype_file:
16425 #ifdef PIPES
16426 case strmtype_pipe_in:
16427 case strmtype_pipe_out:
16428 #endif
16429 #ifdef X11SOCKETS
16430 case strmtype_x11socket:
16431 #endif
16432 #ifdef SOCKET_STREAMS
16433 case strmtype_socket:
16434 #endif
16435 if (TheStream(stream)->strmflags & strmflags_rd_by_B) {
16436 /* Only 8-bit element types. A general LISTEN-BYTE function
16437 would be hairy (at least the case where you want to know
16438 whether a multibyte integer is pending, and the stream is
16439 unbuffered). For CLX and most applications, it is sufficient
16440 to deal with a socket stream with 8-bit element types. */
16441 if (ChannelStream_buffered(stream))
16442 return listen_byte_ia8_buffered(stream);
16443 else
16444 return listen_byte_ia8_unbuffered(stream);
16445 } else {
16446 return LISTEN_EOF; /* no READ-BYTE */
16447 }
16448 default: NOTREACHED;
16449 }
16450 } else {
16451 return LISTEN_EOF; /* no READ-BYTE */
16452 }
16453 } else { /* Call the generic function (STREAM-READ-BYTE-LOOKAHEAD stream): */
16454 pushSTACK(stream); funcall(S(stream_read_byte_lookahead),1);
16455 if (nullp(value1))
16456 return LISTEN_WAIT;
16457 else if (eq(value1,S(Keof)))
16458 return LISTEN_EOF;
16459 else
16460 return LISTEN_AVAIL;
16461 }
16462 }
16463
16464 /* UP: Move the pending Output of a Stream to the destination.
16465 finish_output(stream);
16466 > stream: Stream
16467 can trigger GC */
finish_output(object stream)16468 global maygc void finish_output (object stream) {
16469 pushSTACK(stream);
16470 harden_elastic_newline(&STACK_0);
16471 stream = popSTACK();
16472 if (builtin_stream_p(stream)) {
16473 if (TheStream(stream)->strmflags & strmflags_wr_B) { /* Output-Stream? */
16474 /* no -> finished, yes -> branch according to Stream-Type: */
16475 switch (TheStream(stream)->strmtype) {
16476 case strmtype_synonym:
16477 finish_output_synonym(stream); break;
16478 case strmtype_broad:
16479 finish_output_broad(stream); break;
16480 case strmtype_twoway:
16481 case strmtype_echo:
16482 #ifdef SOCKET_STREAMS
16483 case strmtype_twoway_socket:
16484 #endif
16485 finish_output_twoway(stream); break;
16486 case strmtype_buff_out:
16487 finish_output_buff_out(stream); break;
16488 #ifdef GENERIC_STREAMS
16489 case strmtype_generic:
16490 finish_output_generic(stream); break;
16491 #endif
16492 case strmtype_file:
16493 #ifdef PIPES
16494 case strmtype_pipe_in:
16495 case strmtype_pipe_out:
16496 #endif
16497 #ifdef X11SOCKETS
16498 case strmtype_x11socket:
16499 #endif
16500 #ifdef SOCKET_STREAMS
16501 case strmtype_socket:
16502 #endif
16503 if (ChannelStream_buffered(stream))
16504 finish_output_buffered(stream);
16505 else
16506 finish_output_unbuffered(stream);
16507 break;
16508 case strmtype_terminal:
16509 finish_output_terminal(stream); break;
16510 default: /* do nothing */
16511 break;
16512 }
16513 }
16514 } else { /* Call the generic function (STREAM-FINISH-OUTPUT stream): */
16515 pushSTACK(stream); funcall(S(stream_finish_output),1);
16516 }
16517 }
16518
16519 /* UP: Move the pending Output of a Stream to the destination.
16520 force_output(stream);
16521 > stream: Stream
16522 can trigger GC */
force_output(object stream)16523 global maygc void force_output (object stream) {
16524 pushSTACK(stream);
16525 harden_elastic_newline(&STACK_0);
16526 stream = popSTACK();
16527 if (builtin_stream_p(stream)) {
16528 if (TheStream(stream)->strmflags & strmflags_wr_B) { /* Output-Stream? */
16529 /* no -> finished, yes -> branch according to Stream-Type: */
16530 switch (TheStream(stream)->strmtype) {
16531 case strmtype_synonym:
16532 force_output_synonym(stream); break;
16533 case strmtype_broad:
16534 force_output_broad(stream); break;
16535 case strmtype_twoway:
16536 case strmtype_echo:
16537 #ifdef SOCKET_STREAMS
16538 case strmtype_twoway_socket:
16539 #endif
16540 force_output_twoway(stream); break;
16541 case strmtype_buff_out:
16542 force_output_buff_out(stream); break;
16543 #ifdef GENERIC_STREAMS
16544 case strmtype_generic:
16545 force_output_generic(stream); break;
16546 #endif
16547 case strmtype_file:
16548 #ifdef PIPES
16549 case strmtype_pipe_in:
16550 case strmtype_pipe_out:
16551 #endif
16552 #ifdef X11SOCKETS
16553 case strmtype_x11socket:
16554 #endif
16555 #ifdef SOCKET_STREAMS
16556 case strmtype_socket:
16557 #endif
16558 if (ChannelStream_buffered(stream))
16559 force_output_buffered(stream);
16560 else
16561 force_output_unbuffered(stream);
16562 break;
16563 case strmtype_terminal:
16564 force_output_terminal(stream); break;
16565 default: /* do nothing */
16566 break;
16567 }
16568 }
16569 } else { /* Call the generic function (STREAM-FORCE-OUTPUT stream): */
16570 pushSTACK(stream); funcall(S(stream_force_output),1);
16571 }
16572 }
16573
16574 /* UP: Delete pending Output of a Stream.
16575 clear_output(stream);
16576 > stream: Stream
16577 can trigger GC */
clear_output(object stream)16578 global maygc void clear_output (object stream) {
16579 /* On DOS nothing actually has to be done for File- or Terminal-Streams,
16580 but we cannot take advantage of that, because clear_output on
16581 Buffered-Output-Streams always works. */
16582 if (builtin_stream_p(stream)) {
16583 if (TheStream(stream)->strmflags & strmflags_wr_B) { /* Output-Stream? */
16584 /* no -> finished, yes -> branch according to Stream-Type: */
16585 switch (TheStream(stream)->strmtype) {
16586 case strmtype_synonym:
16587 clear_output_synonym(stream); break;
16588 case strmtype_broad:
16589 clear_output_broad(stream); break;
16590 case strmtype_twoway:
16591 case strmtype_echo:
16592 #ifdef SOCKET_STREAMS
16593 case strmtype_twoway_socket:
16594 #endif
16595 clear_output_twoway(stream); break;
16596 case strmtype_buff_out:
16597 clear_output_buff_out(stream); break;
16598 #ifdef GENERIC_STREAMS
16599 case strmtype_generic:
16600 clear_output_generic(stream); break;
16601 #endif
16602 case strmtype_file:
16603 #ifdef PIPES
16604 case strmtype_pipe_in:
16605 case strmtype_pipe_out:
16606 #endif
16607 #ifdef X11SOCKETS
16608 case strmtype_x11socket:
16609 #endif
16610 #ifdef SOCKET_STREAMS
16611 case strmtype_socket:
16612 #endif
16613 if (ChannelStream_buffered(stream)) {
16614 /* File: do nothing (would disturb the File-Management) */
16615 } else {
16616 clear_output_unbuffered(stream);
16617 }
16618 break;
16619 case strmtype_terminal:
16620 #if defined(UNIX) || defined(WIN32_NATIVE)
16621 terminalcase(stream,
16622 { clear_output_terminal1(stream); },
16623 { clear_output_terminal2(stream); },
16624 { clear_output_terminal3(stream); });
16625 #endif
16626 break;
16627 default: /* do nothing */
16628 break;
16629 }
16630 }
16631 } else { /* Call the generic function (STREAM-CLEAR-OUTPUT stream): */
16632 pushSTACK(stream); funcall(S(stream_clear_output),1);
16633 }
16634 }
16635
16636 /* UP: Returns the Line-Position of a Stream.
16637 get_line_position(stream)
16638 > stream: Stream
16639 < result: Line-Position (Fixnum >=0 or NIL)
16640 can trigger GC */
get_line_position(object stream)16641 global maygc object get_line_position (object stream) {
16642 check_SP();
16643 start:
16644 if (builtin_stream_p(stream))
16645 switch (TheStream(stream)->strmtype) {
16646 case strmtype_synonym: /* Synonym-Stream: follow further */
16647 resolve_as_synonym(stream);
16648 goto start;
16649 case strmtype_broad: /* Broadcast-Stream: */
16650 /* Maximum of Line-Positions of the single Streams */
16651 {
16652 pushSTACK(TheStream(stream)->strm_broad_list);
16653 var uintV maximum = 0; /* previous Maximum := 0 */
16654 while (consp(STACK_0)) {
16655 var object next = /* Line-Position of the next substream */
16656 get_line_position(Car(STACK_0));
16657 if (nullp(next)) {
16658 skipSTACK(1); return NIL;
16659 }
16660 if (posfixnum_to_V(next) > maximum)
16661 maximum = posfixnum_to_V(next); /* take Maximum */
16662 STACK_0 = Cdr(STACK_0);
16663 }
16664 skipSTACK(1); return fixnum(maximum); /* Maximum as result */
16665 }
16666 case strmtype_twoway:
16667 case strmtype_echo:
16668 #ifdef SOCKET_STREAMS
16669 case strmtype_twoway_socket:
16670 #endif
16671 /* Two-Way-Stream or Echo-Stream: look at Output-Stream */
16672 stream = TheStream(stream)->strm_twoway_output;
16673 /* return get_line_position(stream); */ /* without recursion: */
16674 goto start;
16675 default: /* normal Stream */
16676 return TheStream(stream)->strm_wr_ch_lpos;
16677 }
16678 else {
16679 pushSTACK(stream);
16680 /* Test (SLOT-VALUE stream '$penl): */
16681 var object stream_forwarded = stream;
16682 instance_un_realloc(stream_forwarded);
16683 instance_update(stream,stream_forwarded);
16684 var object cv = TheInstance(stream_forwarded)->inst_class_version;
16685 var object clas = TheClassVersion(cv)->cv_class;
16686 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
16687 if (!nullp(TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)])) {
16688 /* A newline is pending. The line position is already 0. */
16689 skipSTACK(1);
16690 return Fixnum_0;
16691 } else {
16692 /* Call the generic function (STREAM-LINE-COLUMN stream): */
16693 funcall(S(stream_line_column),1);
16694 if (!(posfixnump(value1) || nullp(value1))) {
16695 pushSTACK(S(stream_line_column));
16696 pushSTACK(value1);
16697 error(error_condition,GETTEXT("Return value ~S of call to ~S is not a fixnum >= 0 or NIL."));
16698 }
16699 return value1;
16700 }
16701 }
16702 }
16703
16704 /* do the actual legwork of fresh_line
16705 fresh_line_low(stream)
16706 > stream: Stream
16707 < result: true if a newline has been output
16708 can trigger GC */
fresh_line_low(const gcv_object_t * stream_)16709 local maygc bool fresh_line_low (const gcv_object_t* stream_) {
16710 /* Test whether an elastic newline is pending, so that
16711 (ELASTIC-NEWLINE stream) followed by (FRESH-LINE stream) always leads
16712 to exactly one newline being output. */
16713 #define TERPRI_IF(cond) return cond ? (terpri(stream_), true) : false
16714 var object stream = *stream_;
16715 check_SP();
16716 start:
16717 if (builtin_stream_p(stream))
16718 switch (TheStream(stream)->strmtype) {
16719 case strmtype_synonym: /* Synonym-Stream: follow further */
16720 resolve_as_synonym(stream);
16721 goto start;
16722 case strmtype_broad: { /* Broadcast-Stream: */
16723 /* FRESH-LINE is a "control", not an "output" operation,
16724 so do it one by one on the individual constituent streams. */
16725 var bool ret = false;
16726 pushSTACK(TheStream(stream)->strm_broad_list);
16727 while (consp(STACK_0)) {
16728 pushSTACK(Car(STACK_0));
16729 ret = fresh_line_low(&STACK_0);
16730 skipSTACK(1);
16731 STACK_0 = Cdr(STACK_0);
16732 }
16733 skipSTACK(1);
16734 return ret;
16735 }
16736 case strmtype_twoway:
16737 case strmtype_echo:
16738 #ifdef SOCKET_STREAMS
16739 case strmtype_twoway_socket:
16740 #endif
16741 /* Two-Way-Stream or Echo-Stream: look at Output-Stream */
16742 stream = TheStream(stream)->strm_twoway_output;
16743 goto start;
16744 default: /* normal stream */
16745 TERPRI_IF(eq(TheStream(stream)->strm_wr_ch,P(wr_ch_pending_newline))
16746 || !eq(get_line_position(*stream_),Fixnum_0));
16747 }
16748 else { /* Test (SLOT-VALUE stream '$penl): */
16749 var object stream_forwarded = stream;
16750 instance_un_realloc(stream_forwarded);
16751 instance_update(stream,stream_forwarded);
16752 var object cv = TheInstance(stream_forwarded)->inst_class_version;
16753 var object clas = TheClassVersion(cv)->cv_class;
16754 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
16755 TERPRI_IF(!nullp(TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)])
16756 || !eq(get_line_position(stream_forwarded),Fixnum_0));
16757 }
16758 #undef TERPRI_IF
16759 }
16760
16761 /* Writes a newline on a stream, if it is not already positioned at column 0.
16762 fresh_line(&stream);
16763 > stream: Stream
16764 < stream: Stream
16765 < result: true if did output a newline
16766 can trigger GC */
fresh_line(const gcv_object_t * stream_)16767 global maygc bool fresh_line (const gcv_object_t* stream_) {
16768 { /* Special hack that acknowledges the fact that sometimes *standard-output* */
16769 /* and *error-output* go to the same device, although they are different.
16770 For example, in batch mode
16771 $ ./clisp -x '(progn (format *standard-output* "~&line1~.") (format *error-output* "~&line2~."))' | cat
16772 or on Cygwin in Windows2000, when clisp is launched from the "cmd" shell,
16773 the same_handle_p function fails to recognize the two outputs as
16774 identical.
16775 (unless (eq *standard-output* *error-output*)
16776 (cond ((eq stream *standard-output*) (finish-output *error-output*))
16777 ((eq stream *error-output*) (finish-output *standard-output*)))) */
16778 var object stream1 = Symbol_value(S(standard_output));
16779 var object stream2 = Symbol_value(S(error_output));
16780 if (!eq(stream1,stream2)) {
16781 if (eq(*stream_,stream1)) {
16782 if (output_stream_p(stream2)
16783 && (!builtin_stream_p(stream2)
16784 || (TheStream(stream2)->strmflags & strmflags_open_B) != 0))
16785 finish_output(stream2);
16786 } else if (eq(*stream_,stream2)) {
16787 if (output_stream_p(stream1)
16788 && (!builtin_stream_p(stream1)
16789 || (TheStream(stream1)->strmflags & strmflags_open_B) != 0))
16790 finish_output(stream1);
16791 }
16792 }
16793 }
16794 return fresh_line_low(stream_);
16795 }
16796
16797 /* Writes a newline on a stream, delayed and nullified if the next character
16798 written would be a newline anyway.
16799 elastic_newline(&stream);
16800 > stream: Stream
16801 < stream: Stream
16802 can trigger GC */
elastic_newline(const gcv_object_t * stream_)16803 global maygc void elastic_newline (const gcv_object_t* stream_) {
16804 check_SP();
16805 var object stream = *stream_;
16806 start:
16807 if (builtin_stream_p(stream))
16808 switch (TheStream(stream)->strmtype) {
16809 case strmtype_synonym: /* Synonym-Stream: follow further */
16810 resolve_as_synonym(stream);
16811 goto start;
16812 case strmtype_broad: /* Broadcast-Stream: dispatch */
16813 {
16814 pushSTACK(TheStream(stream)->strm_broad_list);
16815 pushSTACK(NIL);
16816 while (consp(STACK_1)) {
16817 STACK_0 = Car(STACK_1);
16818 elastic_newline(&STACK_0);
16819 STACK_1 = Cdr(STACK_1);
16820 }
16821 skipSTACK(2);
16822 break;
16823 }
16824 case strmtype_twoway:
16825 case strmtype_echo:
16826 #ifdef SOCKET_STREAMS
16827 case strmtype_twoway_socket:
16828 #endif
16829 /* Two-Way-Stream or Echo-Stream: look at Output-Stream */
16830 stream = TheStream(stream)->strm_twoway_output;
16831 goto start;
16832 default: /* normal stream */
16833 TheStream(stream)->strm_wr_ch = P(wr_ch_pending_newline);
16834 TheStream(stream)->strm_wr_ch_array = P(wr_ch_array_pending_newline);
16835 TheStream(stream)->strm_wr_ch_lpos = Fixnum_0;
16836 break;
16837 }
16838 else {
16839 /* (SETF (SLOT-VALUE stream '$penl) T): */
16840 var object stream_forwarded = stream;
16841 instance_un_realloc(stream_forwarded);
16842 instance_update(stream,stream_forwarded);
16843 var object cv = TheInstance(stream_forwarded)->inst_class_version;
16844 var object clas = TheClassVersion(cv)->cv_class;
16845 var object slotinfo = gethash(S(penl),TheClass(clas)->slot_location_table,false);
16846 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = T;
16847 }
16848 }
16849
16850 /* UP: Check an element-type for READ-INTEGER/WRITE-INTEGER.
16851 check_multiple8_eltype(&eltype);
16852 > eltype: Element-Type in decoded form */
check_multiple8_eltype(const decoded_el_t * eltype)16853 local void check_multiple8_eltype (const decoded_el_t* eltype) {
16854 if (!((eltype->size > 0) && ((eltype->size % 8) == 0))) {
16855 pushSTACK(canon_eltype(eltype));
16856 pushSTACK(S(Kelement_type));
16857 pushSTACK(TheSubr(subr_self)->name);
16858 error(error_condition,GETTEXT("~S needs an ~S with a bit size being a multiple of 8, not ~S"));
16859 }
16860 }
16861
16862 /* UP: Check an element-type for READ-FLOAT/WRITE-FLOAT.
16863 check_float_eltype(&eltype)
16864 > object eltype: argument (in the STACK)
16865 < result: sizeof(ffloatjanus) or sizeof(dfloatjanus) */
check_float_eltype(gcv_object_t * eltype_)16866 local uintL check_float_eltype (gcv_object_t* eltype_) {
16867 var object arg = *eltype_;
16868 if (eq(arg,S(single_float)))
16869 return sizeof(ffloatjanus);
16870 if (eq(arg,S(double_float)))
16871 return sizeof(dfloatjanus);
16872 var bool is_ffloat_subtype;
16873 var bool is_dfloat_subtype;
16874 /* First of all, make it a little more canonical (so then the different
16875 SUBTYPEP do not have to do the same thing twice): */
16876 pushSTACK(arg); funcall(S(canonicalize_type),1); /* (SYS::CANONICALIZE-TYPE arg) */
16877 pushSTACK(value1); /* save canon-arg */
16878 pushSTACK(STACK_0); pushSTACK(S(single_float)); funcall(S(subtypep),2); /* (SUBTYPEP canon-arg 'SINGLE-FLOAT) */
16879 is_ffloat_subtype = !nullp(value1);
16880 pushSTACK(S(double_float)); funcall(S(subtypep),2); /* (SUBTYPEP canon-arg 'DOUBLE-FLOAT) */
16881 is_dfloat_subtype = !nullp(value1);
16882 if (is_ffloat_subtype) {
16883 if (!is_dfloat_subtype)
16884 return sizeof(ffloatjanus);
16885 } else {
16886 if (is_dfloat_subtype)
16887 return sizeof(dfloatjanus);
16888 }
16889 error_illegal_arg(*eltype_,nullobj,S(Kelement_type));
16890 }
16891
16892 /* UP: Check an endianness argument.
16893 check_endianness_arg(arg)
16894 > arg: the argument
16895 < bool result: endianness (BIG = true, LITTLE = false)
16896 can trigger GC */
check_endianness_arg(object arg)16897 local bool maygc check_endianness_arg (object arg) {
16898 restart_check_endianness_arg:
16899 if (!boundp(arg) || eq(arg,S(Klittle)) || eq(arg,S(Kdefault)))
16900 return false;
16901 if (eq(arg,S(Kbig)))
16902 return true;
16903 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
16904 pushSTACK(O(type_endianness)); /* TYPE-ERROR slot EXPECTED-TYPE */
16905 pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name);
16906 check_value(type_error,GETTEXT("~S: illegal endianness argument ~S"));
16907 arg = value1;
16908 goto restart_check_endianness_arg;
16909 }
16910
16911
16912 /* UP: give away corresponding underlying handle
16913 making sure buffers were flushed. One can then use the
16914 handle outside of stream object as far as the latter
16915 is not used and not GCed.
16916 stream_lend_handle(stream, inputp, handletype)
16917 > stream_: stream for handle to extract
16918 > inputp: whether its input or output side is requested.
16919 < stream_: corrected stream (if the original argument was not a handle stream)
16920 < int * handletype 0:reserved, 1:file, 2:socket
16921 < Handle result - extracted handle
16922 can trigger GC */
stream_lend_handle(gcv_object_t * stream_,bool inputp,int * handletype)16923 modexp maygc Handle stream_lend_handle
16924 (gcv_object_t *stream_, bool inputp, int * handletype) {
16925 var int errkind = 0;
16926 var object stream = *stream_;
16927 restart_stream_lend_handle:
16928 /* TODO: use finish-output ? */
16929 if (builtin_stream_p(stream)) {
16930 switch (TheStream(stream)->strmtype) {
16931 #ifdef X11SOCKETS
16932 case strmtype_x11socket:
16933 #endif
16934 #ifdef SOCKET_STREAMS
16935 case strmtype_socket:
16936 #endif
16937 #if defined(X11SOCKETS) || defined(SOCKET_STREAMS)
16938 if (handletype) *handletype = 2;
16939 /* it is not clear that buffered sockets should be supported,
16940 cf strmtype_pipe_in below */
16941 if (ChannelStream_buffered(stream))
16942 return TheHandle(TheStream(stream)->strm_buffered_channel);
16943 else if (inputp) return TheHandle(TheStream(stream)->strm_ichannel);
16944 else return TheHandle(TheStream(stream)->strm_ochannel);
16945 #endif
16946 case strmtype_file:
16947 if (handletype) *handletype = 1;
16948 if (inputp && TheStream(stream)->strmflags & strmflags_rd_B) {
16949 if (ChannelStream_buffered(stream)) {
16950 sync_file_buffered(stream);
16951 return TheHandle(TheStream(*stream_)->strm_buffered_channel);
16952 }
16953 return TheHandle(TheStream(stream)->strm_ichannel);
16954 } else if (!inputp && TheStream(stream)->strmflags & strmflags_wr_B) {
16955 if (ChannelStream_buffered(stream)) {
16956 /* reposition index back to not yet read position */
16957 sync_file_buffered(stream);
16958 return TheHandle(TheStream(*stream_)->strm_buffered_channel);
16959 }
16960 return TheHandle(TheStream(stream)->strm_ochannel);
16961 } else {
16962 errkind = 2; /* wrong direction */
16963 goto show_error;
16964 }
16965 #ifdef SOCKET_STREAMS
16966 case strmtype_twoway_socket:
16967 stream = inputp ? TheStream(stream)->strm_twoway_socket_input
16968 : TheStream(stream)->strm_twoway_socket_output;
16969 goto restart_stream_lend_handle;
16970 #endif
16971 case strmtype_twoway:
16972 case strmtype_echo:
16973 stream = TheStream(stream)->strm_twoway_input;
16974 goto restart_stream_lend_handle;
16975 case strmtype_synonym:
16976 stream = resolve_synonym_stream(stream);
16977 goto restart_stream_lend_handle;
16978 #ifdef KEYBOARD
16979 case strmtype_keyboard:
16980 #if defined(UNIX) || defined(WIN32_NATIVE)
16981 if (inputp) {
16982 if (handletype) *handletype = 1;
16983 return TheHandle(TheStream(stream)->strm_keyboard_handle);
16984 } else {
16985 errkind = 2; /* wrong direction */
16986 goto show_error;
16987 }
16988 #endif
16989 break;
16990 #endif
16991 case strmtype_terminal:
16992 /* FIXME: no actual need to flush */
16993 if (handletype) *handletype = 1;
16994 return TheHandle(inputp?TheStream(stream)->strm_terminal_ihandle:
16995 TheStream(stream)->strm_terminal_ohandle);
16996 #ifdef PIPES
16997 case strmtype_pipe_in:
16998 if (inputp) {
16999 if (ChannelStream_buffered(stream)) {
17000 /* pipes doesn't support OS level repositioning so I see no way how
17001 to make interleaved input and lend to work correctly */
17002 errkind = 1; /* buffered pipe-input-stream is unsupported */
17003 goto show_error;
17004 } else {
17005 if (handletype) *handletype = 1;
17006 return TheHandle(TheStream(stream)->strm_ichannel);
17007 }
17008 } else {
17009 errkind = 2; /* wrong direction */
17010 goto show_error;
17011 }
17012 break;
17013 case strmtype_pipe_out:
17014 if (!inputp) {
17015 if (handletype) *handletype = 1;
17016 if (ChannelStream_buffered(stream)) {
17017 if (BufferedStream_modified(stream))
17018 buffered_flush(stream);
17019 return TheHandle(TheStream(stream)->strm_buffered_channel);
17020 } else
17021 return TheHandle(TheStream(stream)->strm_ochannel);
17022 } else {
17023 errkind = 2; /* wrong direction */
17024 goto show_error;
17025 }
17026 break;
17027 #endif
17028 default:
17029 break;
17030 }
17031 }
17032 show_error:
17033 pushSTACK(NIL); /* no PLACE */
17034 pushSTACK(stream); /* TYPE-ERROR slot DATUM */
17035 pushSTACK(O(type_open_file_stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
17036 pushSTACK(stream);
17037 pushSTACK(TheSubr(subr_self)->name);
17038 check_value(type_error,
17039 (errkind==0)?GETTEXT("~S: argument ~S does not contain a valid OS stream handle")
17040 :(errkind==1)?GETTEXT("~S: ~S: buffered pipe-input-streams are not supported")
17041 :GETTEXT("~S: ~S: stream of wrong direction"));
17042 *stream_ = stream = value1;
17043 goto restart_stream_lend_handle;
17044 }
17045
17046 /* (READ-BYTE stream [eof-error-p [eof-value]]), CLTL p. 382 */
17047 LISPFUN(read_byte,seclass_default,1,2,norest,nokey,0,NIL) {
17048 var object stream = check_stream(STACK_2);
17049 /* read Integer: */
17050 var object obj = read_byte(stream);
17051 if (eq(obj,eof_value)) { /* EOF-treatment */
17052 HANDLE_EOF(STACK_1, STACK_0, 3);
17053 } else {
17054 VALUES1(obj); skipSTACK(3); /* return obj */
17055 }
17056 }
17057
17058 /* (READ-BYTE-LOOKAHEAD stream) */
17059 LISPFUNN(read_byte_lookahead,1) {
17060 var object stream = check_stream(popSTACK());
17061 /* Query the status: */
17062 switch (listen_byte(stream)) {
17063 case LISTEN_WAIT: value1 = NIL; break;
17064 case LISTEN_EOF: value1 = S(Keof); break;
17065 case LISTEN_AVAIL: value1 = T; break;
17066 case LISTEN_ERROR: OS_filestream_error(stream);
17067 }
17068 mv_count=1;
17069 }
17070
17071 /* (READ-BYTE-WILL-HANG-P stream) */
17072 LISPFUNN(read_byte_will_hang_p,1) {
17073 var object stream = check_stream(popSTACK());
17074 /* Query the status: */
17075 VALUES_IF(LISTEN_WAIT == listen_byte(stream));
17076 }
17077
17078 /* (READ-BYTE-NO-HANG stream [eof-error-p [eof-value]]) */
17079 LISPFUN(read_byte_no_hang,seclass_default,1,2,norest,nokey,0,NIL) {
17080 var object stream = STACK_2 = check_stream(STACK_2);
17081 /* Query the status: */
17082 switch (listen_byte(stream)) {
17083 case LISTEN_WAIT: /* Return NIL. */
17084 VALUES1(NIL); skipSTACK(3);
17085 return;
17086 case LISTEN_EOF: HANDLE_EOF(STACK_1, STACK_0, 3); break;
17087 case LISTEN_AVAIL: { /* Read a byte: */
17088 var object obj = read_byte(stream);
17089 if (!eq(obj,eof_value)) {
17090 /* Return the read integer. */
17091 VALUES1(obj); skipSTACK(3);
17092 return;
17093 }
17094 }
17095 case LISTEN_ERROR: OS_filestream_error(STACK_2);
17096 }
17097 }
17098
17099 /* (READ-INTEGER stream element-type [endianness [eof-error-p [eof-value]]])
17100 is a generalized READ-BYTE. */
17101 LISPFUN(read_integer,seclass_default,2,3,norest,nokey,0,NIL) {
17102 /* check Element-Type */
17103 var decoded_el_t eltype;
17104 test_eltype_arg(&STACK_3,&eltype);
17105 check_multiple8_eltype(&eltype);
17106 var bool endianness = check_endianness_arg(STACK_2); /* check Endianness */
17107 STACK_4 = check_stream(STACK_4);
17108 var uintL bitsize = eltype.size;
17109 var uintL bytesize = bitsize/8;
17110 var DYNAMIC_8BIT_VECTOR(bitbuffer,bytesize);
17111 pushSTACK(bitbuffer);
17112 /* Stack layout: stream, element-type, endianness, eof-error-p, eof-value, bitbuffer.
17113 Read the data. */
17114 if (read_byte_array(&STACK_5,&STACK_0,0,bytesize,persev_full) != bytesize)
17115 goto eof;
17116 bitbuffer = STACK_0;
17117 if (endianness) /* byte swap */
17118 elt_nreverse(bitbuffer,0,bytesize);
17119 { /* The data is now in little-endian order. Convert it to an integer. */
17120 var object result;
17121 switch (eltype.kind) {
17122 case eltype_iu:
17123 result = bitbuff_iu_I(bitbuffer,bitsize,bytesize);
17124 break;
17125 case eltype_is:
17126 result = bitbuff_is_I(bitbuffer,bitsize,bytesize);
17127 break;
17128 default: NOTREACHED;
17129 }
17130 bitbuffer = STACK_0;
17131 FREE_DYNAMIC_8BIT_VECTOR(bitbuffer);
17132 VALUES1(result);
17133 skipSTACK(6);
17134 return;
17135 }
17136 eof: /* EOF-Treatment */
17137 HANDLE_EOF(STACK_2, STACK_1, 6);
17138 }
17139
17140 /* (READ-FLOAT stream element-type [endianness [eof-error-p [eof-value]]])
17141 reads a float in IEEE binary representation. */
17142 LISPFUN(read_float,seclass_default,2,3,norest,nokey,0,NIL) {
17143 var uintL bytesize = check_float_eltype(&STACK_3); /* check Element-Type */
17144 var bool endianness = check_endianness_arg(STACK_2); /* check Endianness */
17145 STACK_4 = check_stream(STACK_4);
17146 var DYNAMIC_8BIT_VECTOR(bitbuffer,bytesize);
17147 pushSTACK(bitbuffer);
17148 /* Stack layout: stream, element-type, endianness, eof-error-p, eof-value, bitbuffer.
17149 Read the data. */
17150 if (read_byte_array(&STACK_5,&STACK_0,0,bytesize,persev_full) != bytesize)
17151 goto eof;
17152 bitbuffer = STACK_0;
17153 if (BIG_ENDIAN_P ? !endianness : endianness) /* byte swap */
17154 elt_nreverse(bitbuffer,0,bytesize);
17155 /* The data is now in machine-dependent order. Convert it to a float. */
17156 switch (bytesize) {
17157 case sizeof(ffloatjanus):
17158 if (((varobject_alignment % alignof(ffloatjanus)) == 0)
17159 && ((offsetofa(sbvector_,data) % alignof(ffloatjanus)) == 0)) {
17160 value1 = c_float_to_FF((ffloatjanus*)&TheSbvector(bitbuffer)->data[0]);
17161 } else {
17162 var ffloatjanus tmp;
17163 copy_mem_b(&tmp,&TheSbvector(bitbuffer)->data[0],sizeof(ffloatjanus));
17164 value1 = c_float_to_FF(&tmp);
17165 }
17166 break;
17167 case sizeof(dfloatjanus):
17168 if (((varobject_alignment % alignof(dfloatjanus)) == 0)
17169 && ((offsetofa(sbvector_,data) % alignof(dfloatjanus)) == 0)) {
17170 value1 = c_double_to_DF((dfloatjanus*)&TheSbvector(bitbuffer)->data[0]);
17171 } else {
17172 var dfloatjanus tmp;
17173 copy_mem_b(&tmp,&TheSbvector(bitbuffer)->data[0],sizeof(dfloatjanus));
17174 value1 = c_double_to_DF(&tmp);
17175 }
17176 break;
17177 default: NOTREACHED;
17178 }
17179 bitbuffer = STACK_0;
17180 FREE_DYNAMIC_8BIT_VECTOR(bitbuffer);
17181 mv_count=1;
17182 skipSTACK(6);
17183 return;
17184 eof: /* EOF-Treatment */
17185 HANDLE_EOF(STACK_2, STACK_1, 6);
17186 }
17187
17188 /* (WRITE-BYTE integer stream), CLTL p. 385 */
17189 LISPFUNN(write_byte,2) {
17190 var object stream = check_stream(STACK_0);
17191 var object obj = STACK_1;
17192 ASSERT_wr_int(stream,obj);
17193 /* write Integer: */
17194 write_byte(stream,obj);
17195 VALUES1(STACK_1); skipSTACK(2); /* return obj */
17196 }
17197
17198 /* (WRITE-INTEGER integer stream element-type [endianness])
17199 is a generalized WRITE-BYTE. */
17200 LISPFUN(write_integer,seclass_default,3,1,norest,nokey,0,NIL) {
17201 /* check Element-Type */
17202 var decoded_el_t eltype;
17203 test_eltype_arg(&STACK_1,&eltype);
17204 check_multiple8_eltype(&eltype);
17205 var bool endianness = check_endianness_arg(STACK_0); /* check Endianness */
17206 STACK_2 = check_stream(STACK_2);
17207 /* check Integer: */
17208 var uintL bitsize = eltype.size;
17209 var uintL bytesize = bitsize/8;
17210 ASSERT_wr_int(STACK_2,STACK_3);
17211 var DYNAMIC_8BIT_VECTOR(bitbuffer,bytesize);
17212 pushSTACK(bitbuffer);
17213 /* Stack layout: obj, stream, element-type, endianness, bitbuffer. */
17214 /* Copy the integer's data into the buffer. */
17215 switch (eltype.kind) {
17216 case eltype_iu:
17217 bitbuff_ixu_sub(STACK_3,STACK_0,bitsize,STACK_4);
17218 break;
17219 case eltype_is:
17220 bitbuff_ixs_sub(STACK_3,STACK_0,bitsize,STACK_4);
17221 break;
17222 default: NOTREACHED;
17223 }
17224 /* The data is now in little-endian order. */
17225 if (endianness) /* byte swap */
17226 elt_nreverse(STACK_0,0,bytesize);
17227 /* Write the data. */
17228 write_byte_array(&STACK_3,&STACK_0,0,bytesize,persev_full);
17229 bitbuffer = STACK_0;
17230 FREE_DYNAMIC_8BIT_VECTOR(bitbuffer);
17231 VALUES1(STACK_4); /* return obj */
17232 skipSTACK(5);
17233 }
17234
17235 /* (WRITE-FLOAT float stream element-type [endianness])
17236 writes a float in IEEE binary representation. */
17237 LISPFUN(write_float,seclass_default,3,1,norest,nokey,0,NIL) {
17238 var uintL bytesize = check_float_eltype(&STACK_1); /* check Element-Type */
17239 var bool endianness = check_endianness_arg(STACK_0); /* check Endianness */
17240 STACK_2 = check_stream(STACK_2);
17241 /* check Float: */
17242 var object obj = STACK_3;
17243 switch (bytesize) {
17244 case sizeof(ffloatjanus):
17245 if (!single_float_p(obj)) {
17246 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
17247 pushSTACK(S(single_float)); /* TYPE-ERROR slot EXPECTED-TYPE */
17248 pushSTACK(STACK_(2+2));
17249 pushSTACK(S(single_float));
17250 pushSTACK(obj);
17251 error(type_error,GETTEXT("~S is not a ~S, cannot be output onto ~S"));
17252 }
17253 break;
17254 case sizeof(dfloatjanus):
17255 if (!double_float_p(obj)) {
17256 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
17257 pushSTACK(S(double_float)); /* TYPE-ERROR slot EXPECTED-TYPE */
17258 pushSTACK(STACK_(2+2));
17259 pushSTACK(S(double_float));
17260 pushSTACK(obj);
17261 error(type_error,GETTEXT("~S is not a ~S, cannot be output onto ~S"));
17262 }
17263 break;
17264 default: NOTREACHED;
17265 }
17266 var DYNAMIC_8BIT_VECTOR(bitbuffer,bytesize);
17267 pushSTACK(bitbuffer);
17268 /* Stack layout: obj, stream, element-type, endianness, bitbuffer. */
17269 obj = STACK_4;
17270 /* Copy the float's data into the buffer. */
17271 switch (bytesize) {
17272 case sizeof(ffloatjanus):
17273 if (((varobject_alignment % alignof(ffloatjanus)) == 0)
17274 && ((offsetofa(sbvector_,data) % alignof(ffloatjanus)) == 0)) {
17275 FF_to_c_float(obj,(ffloatjanus*)&TheSbvector(bitbuffer)->data[0]);
17276 } else {
17277 var ffloatjanus tmp;
17278 FF_to_c_float(obj,&tmp);
17279 memcpy(&TheSbvector(bitbuffer)->data[0],&tmp,sizeof(ffloatjanus));
17280 }
17281 break;
17282 case sizeof(dfloatjanus):
17283 if (((varobject_alignment % alignof(dfloatjanus)) == 0)
17284 && ((offsetofa(sbvector_,data) % alignof(dfloatjanus)) == 0)) {
17285 DF_to_c_double(obj,(dfloatjanus*)&TheSbvector(bitbuffer)->data[0]);
17286 } else {
17287 var dfloatjanus tmp;
17288 DF_to_c_double(obj,&tmp);
17289 copy_mem_b(&TheSbvector(bitbuffer)->data[0],&tmp,sizeof(dfloatjanus));
17290 }
17291 break;
17292 default: NOTREACHED;
17293 }
17294 /* The data is now in machine-dependent order. */
17295 if (BIG_ENDIAN_P ? !endianness : endianness) /* byte swap */
17296 elt_nreverse(bitbuffer,0,bytesize);
17297 /* Write the data. */
17298 write_byte_array(&STACK_3,&STACK_0,0,bytesize,persev_full);
17299 bitbuffer = STACK_0;
17300 FREE_DYNAMIC_8BIT_VECTOR(bitbuffer);
17301 VALUES1(STACK_4); /* return obj */
17302 skipSTACK(5);
17303 }
17304
17305 /* UP: Checks, if an Argument is an open File-Stream.
17306 check_open_file_stream(obj);
17307 > obj: Argument
17308 > permissive_p: return nullobj instead of signaling an error
17309 < result: open File-Stream (or maybe nullobj if permissive_p was true) */
check_open_file_stream(object obj,bool permissive_p)17310 local object check_open_file_stream (object obj, bool permissive_p) {
17311 check_open_file_stream_restart:
17312 obj = resolve_synonym_stream(obj);
17313 if (streamp(obj) && TheStream(obj)->strmtype == strmtype_broad) {
17314 var object last_stream = broadcast_stream_last(obj);
17315 if (eq(last_stream,nullobj)) {
17316 if (permissive_p) return nullobj;
17317 else return last_stream;
17318 } else obj = last_stream;
17319 goto check_open_file_stream_restart;
17320 }
17321 if (!builtin_stream_p(obj)) /* Stream ? */
17322 goto error_bad_obj;
17323 if (!(TheStream(obj)->strmtype == strmtype_file)) /* Streamtyp File-Stream ? */
17324 goto error_bad_obj;
17325 if ((TheStream(obj)->strmflags & strmflags_open_B) == 0) /* Stream open ? */
17326 goto error_bad_obj;
17327 if (nullp(BufferedStream_channel(obj))) /* and Handle /= NIL ? */
17328 goto error_bad_obj;
17329 return obj; /* yes -> OK */
17330 error_bad_obj:
17331 if (permissive_p) return nullobj;
17332 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
17333 pushSTACK(O(type_open_file_stream)); /* TYPE-ERROR slot EXPECTED-TYPE */
17334 pushSTACK(obj);
17335 pushSTACK(TheSubr(subr_self)->name);
17336 error(type_error,GETTEXT("~S: argument ~S is not an open file stream"));
17337 }
17338
17339 /* extract the OS file handle from the file stream
17340 > stream: open Lisp file stream
17341 < fd: OS file handle
17342 > permissive_p: return nullobj instead of signaling an error
17343 < result: either stream, or a corrected stream in case stream was invalid
17344 or nullobj if permissive_p was true and the stream was invalid
17345 for syscall module
17346 can trigger GC */
open_file_stream_handle(object stream,Handle * fd,bool permissive_p)17347 modexp maygc object open_file_stream_handle
17348 (object stream, Handle *fd, bool permissive_p) {
17349 stream = check_open_file_stream(stream,permissive_p);
17350 if (!eq(stream,nullobj))
17351 *fd = ChannelStream_ihandle(stream);
17352 return stream;
17353 }
17354
17355 /* return the OS's idea of the stream length for the file stream
17356 > stream_: for error reporting - point to GC safe location
17357 > fd: OS file handle
17358 < result: the length of the stream
17359 should be wrapped in begin_blocking_system_call()/end_blocking_system_call()
17360 for gdbm module */
handle_length(gcv_object_t * stream_,Handle fd)17361 modexp maygc off_t handle_length (gcv_object_t *stream_, Handle fd) {
17362 off_t len, pos;
17363 fd_lseek(stream_,fd,0,SEEK_CUR,pos=); /* save current location */
17364 fd_lseek(stream_,fd,0,SEEK_END,len=); /* get EOF location */
17365 /* if the above call fails, we may be screwed now:
17366 the file position was modified but not restored.
17367 However, this would indicate a bug in the underlying lseek()
17368 implementation, see the list of ERRORS in
17369 http://opengroup.org/onlinepubs/9699919799/functions/lseek.html */
17370 fd_lseek(stream_,fd,pos,SEEK_SET,); /* restore the original location */
17371 return len;
17372 }
17373
17374 typedef enum { POS_QUERY, POS_SET_START, POS_SET_END, POS_SET_OFF } pos_arg_t;
17375 LISPFUN(file_position,seclass_default,1,1,norest,nokey,0,NIL)
17376 { /* (FILE-POSITION stream [position]), CLTL p. 425 */
17377 var object position = STACK_0;
17378 var object stream = STACK_1;
17379 var uoff_t pos_off = 0;
17380 var pos_arg_t pos_type = POS_QUERY;
17381 if (boundp(position)) {
17382 if (eq(position,S(Kstart))) { /* set position to start: */
17383 pos_type = POS_SET_START;
17384 } else if (eq(position,S(Kend))) { /* set position to end: */
17385 pos_type = POS_SET_END;
17386 } else if (uoff_t_p(position)) { /* set position as specified: */
17387 pos_type = POS_SET_OFF;
17388 pos_off = I_to_uoff_t(position);
17389 } else { /* illegal Position-Argument */
17390 pushSTACK(position); /* TYPE-ERROR slot DATUM */
17391 pushSTACK(O(type_position)); /* TYPE-ERROR slot EXPECTED-TYPE */
17392 pushSTACK(position); pushSTACK(S(Kend)); pushSTACK(S(Kstart));
17393 pushSTACK(TheSubr(subr_self)->name);
17394 error(type_error,GETTEXT("~S: position argument should be ~S or ~S or a nonnegative integer, not ~S"));
17395 }
17396 }
17397 restart_file_position:
17398 if (builtin_stream_p(stream)) {
17399 switch (TheStream(stream)->strmtype) {
17400 case strmtype_synonym: /* Synonym-Stream: follow further */
17401 resolve_as_synonym(stream);
17402 goto restart_file_position;
17403 case strmtype_broad: /* Broadcast-Stream: */
17404 stream = broadcast_stream_last(stream);
17405 if (eq(stream,nullobj)) { /* empty BROADCAST-STREAM? */
17406 /* http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/syscla_broadcast-stream.html */
17407 VALUES1(Fixnum_0); break;
17408 }
17409 goto restart_file_position;
17410 case strmtype_str_in: {
17411 STACK_1 = stream;
17412 var stringarg arg;
17413 pushSTACK(TheStream(stream)->strm_str_in_string);
17414 switch (pos_type) {
17415 case POS_SET_END: { /* :END */
17416 pushSTACK(TheStream(stream)->strm_str_in_begindex);
17417 pushSTACK(TheStream(stream)->strm_str_in_endindex);
17418 test_string_limits_ro(&arg);
17419 stream = STACK_1; /* restore */
17420 TheStream(stream)->strm_str_in_index =
17421 TheStream(stream)->strm_str_in_endindex;
17422 value1 = fixnum(arg.len);
17423 } break;
17424 case POS_SET_START: { /* :START */
17425 TheStream(stream)->strm_str_in_index =
17426 TheStream(stream)->strm_str_in_begindex;
17427 value1 = Fixnum_0;
17428 skipSTACK(1);
17429 } break;
17430 case POS_SET_OFF: { /* OFFSET */
17431 pushSTACK(TheStream(stream)->strm_str_in_begindex);
17432 pushSTACK(fixnum_inc(STACK_0,pos_off));
17433 test_string_limits_ro(&arg);
17434 stream = STACK_1; /* restore */
17435 TheStream(stream)->strm_str_in_index = fixnum(arg.index+arg.len);
17436 value1 = fixnum(arg.len); /* == pos */
17437 } break;
17438 case POS_QUERY: { /* ask for position */
17439 pushSTACK(TheStream(stream)->strm_str_in_begindex);
17440 pushSTACK(TheStream(stream)->strm_str_in_index);
17441 test_string_limits_ro(&arg);
17442 stream = STACK_1; /* restore */
17443 pos_off = arg.len;
17444 } goto get_position_common;
17445 default: NOTREACHED;
17446 }
17447 set_position_common: /* value1 is pre-set! */
17448 TheStream(stream)->strm_rd_ch_last = NIL; /* Lastchar := NIL */
17449 TheStream(stream)->strmflags &= ~strmflags_unread_B;
17450 mv_count = 1;
17451 } break;
17452 case strmtype_str_out: {
17453 var object ssstring = TheStream(stream)->strm_str_out_string;
17454 switch (pos_type) {
17455 case POS_SET_END: /* :END */
17456 break; /* do nothing */
17457 case POS_SET_START: /* :START */
17458 TheIarray(ssstring)->dims[1] = 0; /* fill-pointer := 0 */
17459 break;
17460 case POS_SET_OFF: /* OFFSET */
17461 if (pos_off <= TheIarray(ssstring)->dims[1]) {
17462 TheIarray(ssstring)->dims[1] = pos_off;
17463 } else {
17464 pushSTACK(fixnum(pos_off));
17465 error_index_range(ssstring,TheIarray(ssstring)->dims[1]);
17466 }
17467 break;
17468 case POS_QUERY:
17469 pos_off = TheIarray(ssstring)->dims[1];
17470 goto get_position_common;
17471 default: NOTREACHED;
17472 }
17473 value1 = fixnum(TheIarray(ssstring)->dims[1]);
17474 goto set_position_common;
17475 } break;
17476 case strmtype_str_push: {
17477 var object string = TheStream(stream)->strm_str_push_string;
17478 switch (pos_type) {
17479 case POS_SET_END: { /* :END */
17480 /* Pretend that the "end" of the stream corresponds to the current
17481 fill-pointer. The array-dimension 0 wouldn't be the right choice
17482 because it depends on how the implementation increases the size
17483 during vector-push-extend. A slightly better choice would be
17484 the maximum value of the fill-pointer during the lifetime of the
17485 stream, but since the user can modify the fill-pointer directly,
17486 this is hairy to implement correctly. */
17487 value1 = fixnum(vector_length(string));
17488 /* No need to call set-fill-pointer because it would be a nop. */
17489 } break;
17490 case POS_SET_START: /* :START, pos_off==0 already */
17491 case POS_SET_OFF: { /* OFFSET */
17492 pushSTACK(string); pushSTACK(fixnum(pos_off)); C_set_fill_pointer();
17493 } break;
17494 case POS_QUERY: {
17495 pos_off = vector_length(string);
17496 } goto get_position_common;
17497 default: NOTREACHED;
17498 }
17499 goto set_position_common;
17500 } break;
17501 case strmtype_file:
17502 stream = check_open_file_stream(stream,false); /* check open */
17503 if (!ChannelStream_buffered(stream)) {
17504 var Handle fd = TheHandle(TheStream(stream)->strmflags & strmflags_wr_B
17505 ? ChannelStream_ochannel(stream)
17506 : ChannelStream_ichannel(stream));
17507 pushSTACK(stream);
17508 switch (pos_type) {
17509 case POS_SET_END: /* :END */
17510 begin_blocking_system_call();
17511 handle_lseek(&STACK_0,fd,0,SEEK_END,pos_off=);
17512 stream = popSTACK();
17513 end_blocking_system_call();
17514 goto get_position_pos_off;
17515 case POS_SET_START: /* :START */
17516 begin_blocking_system_call();
17517 handle_lseek(&STACK_0,fd,0,SEEK_SET,pos_off=);
17518 stream = popSTACK();
17519 end_blocking_system_call();
17520 goto get_position_pos_off;
17521 case POS_SET_OFF: /* OFFSET */
17522 begin_blocking_system_call();
17523 handle_lseek(&STACK_0,fd,pos_off,SEEK_SET,pos_off=);
17524 stream = popSTACK();
17525 end_blocking_system_call();
17526 get_position_pos_off:
17527 VALUES1(uoff_to_I(pos_off)); break;
17528 case POS_QUERY:
17529 begin_blocking_system_call();
17530 handle_lseek(&STACK_0,fd,0,SEEK_CUR,pos_off=);
17531 stream = popSTACK();
17532 end_blocking_system_call();
17533 goto get_position_common;
17534 default: NOTREACHED;
17535 }
17536 } else {
17537 pushSTACK(stream);
17538 switch (pos_type) {
17539 case POS_SET_END: /* :END */
17540 VALUES1(uoff_to_I(logical_position_file_end(stream)));
17541 stream = popSTACK();
17542 break;
17543 case POS_SET_START: /* :START */
17544 VALUES1(uoff_to_I(logical_position_file_start(stream)));
17545 stream = popSTACK();
17546 break;
17547 case POS_SET_OFF: /* OFFSET */
17548 VALUES1(uoff_to_I(logical_position_file(stream,pos_off)));
17549 stream = popSTACK();
17550 break;
17551 case POS_QUERY:
17552 pos_off = BufferedStream_position(stream);
17553 stream = popSTACK();
17554 /* if a character has been unread, decrement position
17555 so that PEEK-CHAR does not modify FILE-POSITION */
17556 get_position_common:
17557 VALUES1(uoff_to_I(pos_off - (TheStream(stream)->strmflags
17558 & strmflags_unread_B ? 1 : 0)));
17559 break;
17560 default: NOTREACHED;
17561 }
17562 }
17563 break;
17564 default: /* do not know what to do ==> NIL */
17565 VALUES1(NIL); break;
17566 }
17567 skipSTACK(2);
17568 } else { /* (GRAY:STREAM-POSITION stream position) */
17569 if (!boundp(STACK_0)) STACK_0 = NIL;
17570 funcall(S(stream_position),2);
17571 }
17572 }
17573
17574 LISPFUNNR(file_length,1)
17575 { /* (FILE-LENGTH file-stream), CLTL p. 425 */
17576 var object stream = STACK_0;
17577 stream = check_open_file_stream(stream,false); /* check stream */
17578 if (eq(stream,nullobj)) { /* empty BROADCAST-STREAM */
17579 /* http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/syscla_broadcast-stream.html */
17580 skipSTACK(1);
17581 VALUES1(Fixnum_0); return;
17582 }
17583 if (!ChannelStream_buffered(stream)) {
17584 off_t len;
17585 Handle fd=ChannelStream_ihandle(stream);
17586 begin_blocking_system_call();
17587 len = handle_length(&STACK_0,fd);
17588 end_blocking_system_call();
17589 VALUES1(off_to_I(len));
17590 } else {
17591 /* memorize Position: */
17592 var uoff_t position = BufferedStream_position(stream);
17593 /* set position to end and memorize End-Position: */
17594 var uoff_t endposition = logical_position_file_end(stream);
17595 stream = STACK_0;
17596 /* set back to old position: */
17597 logical_position_file(stream,position);
17598 VALUES1(uoff_to_I(endposition)); /* return End-Position */
17599 }
17600 skipSTACK(1);
17601 }
17602
17603 LISPFUNN(file_string_length,2)
17604 { /* (FILE-STRING-LENGTH stream object) */
17605 var object stream = check_open_file_stream(STACK_1,false); /* check stream */
17606 var object obj = STACK_0;
17607 skipSTACK(2);
17608 if (eq(stream,nullobj)) { /* empty BROADCAST-STREAM */
17609 /* http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/syscla_broadcast-stream.html */
17610 VALUES1(Fixnum_1); return;
17611 }
17612 if (!(TheStream(stream)->strmflags & strmflags_wr_ch_B))
17613 error_illegal_streamop(S(file_string_length),stream);
17614 var object encoding = TheStream(stream)->strm_encoding;
17615 #if defined(ENABLE_UNICODE) && defined(HAVE_GOOD_ICONV)
17616 if (simple_string_p(TheEncoding(encoding)->enc_charset)) {
17617 /* iconv-based encodings have state. Since we cannot duplicate an iconv_t
17618 we have no way to know for sure how many bytes the string will span. */
17619 if (stringp(obj)) {
17620 VALUES1(vector_length(obj) == 0 ? Fixnum_0 : NIL);
17621 } else if (charp(obj)) {
17622 VALUES1(NIL);
17623 } else
17624 error_write(stream,obj,S(character));
17625 return;
17626 }
17627 #endif
17628 #ifdef ENABLE_UNICODE
17629 if (TheEncoding(encoding)->min_bytes_per_char !=
17630 TheEncoding(encoding)->max_bytes_per_char) {
17631 /* Have to look at each character individually. */
17632 var const chart* charptr;
17633 var uintL len;
17634 var chart auxch;
17635 if (stringp(obj)) {
17636 var uintL offset;
17637 var object string = unpack_string_ro(obj,&len,&offset);
17638 unpack_sstring_alloca(string,len,offset, charptr=);
17639 } else if (charp(obj)) {
17640 auxch = char_code(obj); charptr = &auxch; len = 1;
17641 } else
17642 error_write(stream,obj,S(character));
17643 if (eq(TheEncoding(encoding)->enc_eol,S(Kunix))) {
17644 /* Treat all the characters all at once. */
17645 var uintL result = cslen(encoding,charptr,len);
17646 VALUES1(UL_to_I(result)); return;
17647 } else {
17648 /* Treat line-by-line. */
17649 var const chart* eol_charptr;
17650 var uintL eol_len;
17651 if (eq(TheEncoding(encoding)->enc_eol,S(Kmac))) {
17652 static const chart eol_mac[1] = { ascii(CR) };
17653 eol_charptr = &eol_mac[0]; eol_len = 1;
17654 } else if (eq(TheEncoding(encoding)->enc_eol,S(Kdos))) {
17655 static const chart eol_dos[2] = { ascii(CR), ascii(LF) };
17656 eol_charptr = &eol_dos[0]; eol_len = 2;
17657 } else {
17658 NOTREACHED;
17659 }
17660 var const chart* endptr = charptr+len;
17661 var uintL result = 0;
17662 while (charptr < endptr) {
17663 /* Search the next NL. */
17664 var const chart* ptr = charptr;
17665 while (!chareq(*ptr,ascii(NL))) {
17666 ptr++;
17667 if (ptr == endptr)
17668 break;
17669 }
17670 /* Count the bytes needed for the characters before the NL. */
17671 if (!(ptr == charptr))
17672 result += cslen(encoding,charptr,ptr-charptr);
17673 charptr = ptr;
17674 /* Count the bytes needed for the NL. */
17675 if (charptr < endptr) {
17676 /* *charptr is ascii(NL). */
17677 result += cslen(encoding,eol_charptr,eol_len);
17678 charptr++;
17679 }
17680 }
17681 VALUES1(UL_to_I(result)); return;
17682 }
17683 }
17684 /* Now the easy case: a fixed number of bytes per character. */
17685 var uintL bytes_per_char = TheEncoding(encoding)->min_bytes_per_char;
17686 #else
17687 #define bytes_per_char 1
17688 #endif
17689 if (eq(TheEncoding(encoding)->enc_eol,S(Kunix))
17690 || eq(TheEncoding(encoding)->enc_eol,S(Kmac))) {
17691 if (stringp(obj)) {
17692 var uintL result = vector_length(obj);
17693 VALUES1(UL_to_I(result*bytes_per_char)); return;
17694 } else if (charp(obj)) {
17695 VALUES1(fixnum(bytes_per_char)); return;
17696 } else
17697 error_write(stream,obj,S(character));
17698 }
17699 if (eq(TheEncoding(encoding)->enc_eol,S(Kdos))) {
17700 /* Take into account the NL -> CR/LF translation. */
17701 if (stringp(obj)) {
17702 var uintL len;
17703 var uintL offset;
17704 var object string = unpack_string_ro(obj,&len,&offset);
17705 var uintL result = len;
17706 if (len > 0) {
17707 SstringDispatch(string,X, {
17708 var const cintX* charptr = &((SstringX)TheVarobject(string))->data[offset];
17709 var uintL count;
17710 dotimespL(count,len, {
17711 if (chareq(as_chart(*charptr++),ascii(NL)))
17712 result++;
17713 });
17714 });
17715 }
17716 VALUES1(UL_to_I(result*bytes_per_char)); return;
17717 } else if (charp(obj)) {
17718 var uintL result = 1;
17719 if (chareq(char_code(obj),ascii(NL)))
17720 result++;
17721 VALUES1(fixnum(result*bytes_per_char)); return;
17722 } else
17723 error_write(stream,obj,S(character));
17724 }
17725 NOTREACHED;
17726 #undef bytes_per_char
17727 }
17728
17729 /* UP: Tells whether a stream is buffered.
17730 stream_isbuffered(stream)
17731 > stream: a channel or socket stream
17732 < avail: the number of bytes available in the input buffer
17733 < result: bit(1) set if input side is buffered,
17734 bit(0) set if output side is buffered */
stream_isbuffered_low(object stream,uintL * avail)17735 local uintB stream_isbuffered_low (object stream, uintL *avail) {
17736 switch (TheStream(stream)->strmtype) {
17737 case strmtype_file:
17738 #ifdef PIPES
17739 case strmtype_pipe_in:
17740 case strmtype_pipe_out:
17741 #endif
17742 #ifdef X11SOCKETS
17743 case strmtype_x11socket:
17744 #endif
17745 #ifdef SOCKET_STREAMS
17746 case strmtype_socket:
17747 #endif
17748 if (ChannelStream_buffered(stream)) {
17749 if (avail) *avail = BufferedStream_endvalid(stream)
17750 - BufferedStream_index(stream);
17751 return bit(1)|bit(0);
17752 } else return 0;
17753 #ifdef SOCKET_STREAMS
17754 case strmtype_twoway_socket:
17755 #endif
17756 case strmtype_twoway: {
17757 var object input = TheStream(stream)->strm_twoway_socket_input;
17758 var uintB input_b = 0;
17759 if (ChannelStream_buffered(input)) {
17760 input_b = bit(1);
17761 if (avail) *avail = BufferedStream_endvalid(input)
17762 - BufferedStream_index(input);
17763 }
17764 return input_b | (ChannelStream_buffered(TheStream(stream)->strm_twoway_socket_output) ? bit(0) : 0);
17765 }
17766 default:
17767 return 0;
17768 }
17769 }
stream_isbuffered(object stream)17770 global uintB stream_isbuffered (object stream)
17771 { return stream_isbuffered_low(stream,NULL); }
17772
17773 /* UP: Returns the current line number of a stream.
17774 stream_line_number(stream)
17775 > stream: a stream
17776 < result: an integer or NIL
17777 can trigger GC */
stream_line_number(object stream)17778 global maygc object stream_line_number (object stream) {
17779 return (builtin_stream_p(stream)
17780 && TheStream(stream)->strmtype == strmtype_file
17781 && eq(TheStream(stream)->strm_eltype,S(character))
17782 ? UL_to_I(ChannelStream_lineno(stream)) /* current line-number */
17783 : NIL); /* NIL if unknown */
17784 }
17785
17786 /* (SYS::LINE-NUMBER stream) returns the current line-number (if stream
17787 is a Character-File-Input-Stream, which was only used for reading). */
17788 LISPFUNN(line_number,1) {
17789 var object stream = check_stream(popSTACK());
17790 VALUES1(stream_line_number(stream));
17791 }
17792
17793 /* Function: Returns true if a stream is a FASL stream:
17794 "i/o consistency is more important than ANSI compliance"
17795 == read-eval is allowed regardless of *READ-EVAL*
17796 == #\Return in strings and symbols is printed as \r
17797 == #\Newline in strings and symbols is printed as \n
17798 == literal newline inside strings is ignored on input
17799 stream_get_read_eval(stream)
17800 > stream: a stream
17801 < result: true if read-eval is allowed from the stream, else false
17802 can trigger GC */
stream_get_fasl(object stream)17803 global maygc bool stream_get_fasl (object stream) {
17804 if (builtin_stream_p(stream)) {
17805 return ((TheStream(stream)->strmflags & strmflags_fasl_B) != 0);
17806 } else {
17807 /* (SLOT-VALUE stream '$fasl): */
17808 var object stream_forwarded = stream;
17809 instance_un_realloc(stream_forwarded);
17810 instance_update(stream,stream_forwarded);
17811 var object cv = TheInstance(stream_forwarded)->inst_class_version;
17812 var object clas = TheClassVersion(cv)->cv_class;
17813 var object slotinfo = gethash(S(fasl),TheClass(clas)->slot_location_table,false);
17814 var object value = TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)];
17815 return !nullp(value);
17816 }
17817 }
17818
17819 /* Function: Changes the FASL state of a stream.
17820 stream_set_read_eval(stream,value);
17821 > stream: a stream
17822 > value: true if the stream should be a FASL stream, else false
17823 can trigger GC */
stream_set_fasl(object stream,bool value)17824 global maygc void stream_set_fasl (object stream, bool value) {
17825 if (builtin_stream_p(stream)) {
17826 if (value)
17827 TheStream(stream)->strmflags |= strmflags_fasl_B;
17828 else
17829 TheStream(stream)->strmflags &= ~strmflags_fasl_B;
17830 } else {
17831 /* (SETF (SLOT-VALUE stream '$fasl) value): */
17832 var object stream_forwarded = stream;
17833 instance_un_realloc(stream_forwarded);
17834 instance_update(stream,stream_forwarded);
17835 var object cv = TheInstance(stream_forwarded)->inst_class_version;
17836 var object clas = TheClassVersion(cv)->cv_class;
17837 var object slotinfo = gethash(S(fasl),TheClass(clas)->slot_location_table,false);
17838 TheSrecord(stream_forwarded)->recdata[posfixnum_to_V(slotinfo)] = (value ? T : NIL);
17839 }
17840 }
17841
17842 /* (SYS::STREAM-FASL-P stream) returns the stream's FASL flag.
17843 (SYS::STREAM-FASL-P stream flag) sets the stream's FASL flag. */
17844 LISPFUN(stream_fasl_p,seclass_default,1,1,norest,nokey,0,NIL) {
17845 var object stream = check_stream(STACK_1);
17846 var object flag = STACK_0;
17847 if (!boundp(flag)) {
17848 value1 = (stream_get_fasl(stream) ? T : NIL);
17849 } else {
17850 if (nullp(flag)) {
17851 stream_set_fasl(stream,false); value1 = NIL;
17852 } else {
17853 stream_set_fasl(stream,true); value1 = T;
17854 }
17855 }
17856 skipSTACK(2); mv_count=1;
17857 }
17858
17859 /* (SYS::%DEFGRAY fundamental-stream-classes)
17860 Initializes O(class_fundamental*_stream). */
17861 LISPFUNN(defgray,1) {
17862 copy_mem_o(&O(class_fundamental_stream),&TheSvector(STACK_0)->data[0],
17863 Svector_length(STACK_0));
17864 VALUES0; skipSTACK(1);
17865 }
17866
17867 /* ====================================================================== */
17868
17869 /* table of all pseudo-functions */
17870 global struct pseudocode_tab_ pseudocode_tab = {
17871 #define PSEUDO PSEUDO_D
17872 #include "pseudofun.c"
17873 #undef PSEUDO
17874 };
17875 global struct pseudodata_tab_ pseudodata_tab = {
17876 #define PSEUDO PSEUDO_E
17877 #include "pseudofun.c"
17878 #undef PSEUDO
17879 #if defined(MICROSOFT) && !defined(ENABLE_UNICODE)
17880 (Pseudofun) NULL
17881 #endif
17882 };
17883
17884 /* ====================================================================== */
17885
17886 /* protect filestatus/if_file_exists, file_datetime by break_sem_4??
17887 Signal-Handling on EXECUTE, SHELL, MAKE-PIPE-INPUT-STREAM, MAKE-PIPE-OUTPUT-STREAM, MAKE-PIPE-IO-STREAM ??
17888 naming of file/handle/buffered/b_file/unbuffered stuff
17889 do not access strm_file_truename on pipe and socket streams
17890 implement FILE-POSITION for unbuffered file-streams (regular handle, direction != 5)
17891 LISTEN on unbuffered (non-regular) file and socket streams can cause the process to block */
17892