1 // print.cpp Copyright (C) 1990-2021 Codemist
2
3 //
4 // Printing, plus some file-related operations.
5 //
6
7 /**************************************************************************
8 * Copyright (C) 2021, Codemist. A C Norman *
9 * *
10 * Redistribution and use in source and binary forms, with or without *
11 * modification, are permitted provided that the following conditions are *
12 * met: *
13 * *
14 * * Redistributions of source code must retain the relevant *
15 * copyright notice, this list of conditions and the following *
16 * disclaimer. *
17 * * Redistributions in binary form must reproduce the above *
18 * copyright notice, this list of conditions and the following *
19 * disclaimer in the documentation and/or other materials provided *
20 * with the distribution. *
21 * *
22 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
23 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
24 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
25 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
26 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
27 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
28 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
29 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
30 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
31 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
32 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
33 * DAMAGE. *
34 *************************************************************************/
35
36 // $Id: print.cpp 5736 2021-03-16 10:41:22Z arthurcnorman $
37
38 #include "headers.h"
39
40 #ifdef SOCKETS
41 #include "sockhdr.h"
42 #endif
43
debugprint(const char * s,LispObject a)44 void debugprint(const char *s, LispObject a)
45 { std::printf("%s", s);
46 debugprint(a);
47 }
48
debugprint(const char * s)49 void debugprint(const char *s)
50 { std::printf("%s", s);
51 std::fflush(stdout);
52 }
53
debugprint1(LispObject a,int depth)54 void debugprint1(LispObject a, int depth)
55 { if (depth < 0)
56 { std::printf("...");
57 }
58 else if (a==nil)
59 { std::printf("nil");
60 }
61 else if (is_fixnum(a))
62 { std::printf("%" PRId64, (int64_t)int_of_fixnum(a));
63 }
64 else if (is_cons(a))
65 { const char *sep = "(";
66 while (is_cons(a) && depth > 0)
67 { depth--;
68 std::printf("%s", sep);
69 debugprint1(car(a), depth-1);
70 a = cdr(a);
71 sep = " ";
72 }
73 if (a != nil)
74 { if (depth > 0)
75 { std::printf(" . ");
76 debugprint1(a, depth-1);
77 }
78 }
79 std::printf(")");
80 }
81 else if (is_symbol(a))
82 { LispObject pn = qpname(a);
83 if (is_string(pn))
84 { unsigned int len = static_cast<unsigned int>(length_of_byteheader(
85 vechdr(pn)));
86 if (CELL<len &&
87 len < 64) std::printf("%.*s", static_cast<int>(len-CELL), &celt(pn,
88 0));
89 else std::printf("<symbol with pname hdr %p>",
90 reinterpret_cast<void *>(vechdr(pn)));
91 }
92 else std::printf("<symbol with odd pname>");
93 }
94 else if (is_vector(a) && type_of_vector(a) == TYPE_SIMPLE_VEC)
95 { size_t len = cells_in_vector(a);
96 const char *sep = "[";
97 for (size_t i=0; i<len; i++)
98 { std::printf("%s", sep);
99 debugprint1(elt(a, i), depth-1);
100 sep = " ";
101 }
102 std::printf("]");
103 }
104 else
105 { std::printf("@%p@", reinterpret_cast<void *>(a));
106 }
107 }
108
debugprint(LispObject a,int depth)109 void debugprint(LispObject a, int depth)
110 { std::printf("%p: ", reinterpret_cast<void *>(a));
111 debugprint1(a, depth);
112 std::printf("\n");
113 std::fflush(stdout);
114 }
115
116 //
117 // At present CSL is single threaded - at least as regards file IO - and
118 // using the unlocked versions of putc and getc can be a MAJOR saving.
119 // I put these macros here not in soem header to try to keep me reminded
120 // that if threads ever happened I would need to do my own buffering.
121 //
122
123 #ifdef HAVE_GETC_UNLOCKED
124 #define GETC(x) getc_unlocked((FILE *)(x))
125 #else
126 #ifdef HAVE__GETC_NOLOCK
127 #define GETC(x) _getc_nolock((FILE *)(x))
128 #else
129 #define GETC(x) getc((FILE *)(x))
130 #endif
131 #endif
132
133 #ifdef HAVE_PUTC_UNLOCKED
134 #define PUTC(x, y) putc_unlocked((x), (FILE *)(y))
135 #else
136 #ifdef HAVE__PUTC_NOLOCK
137 #define PUTC(x, y) _putc_nolock((x), (FILE *)(y))
138 #else
139 #define PUTC(x, y) putc((x), (FILE *)(y))
140 #endif
141 #endif
142
143 std::FILE *spool_file = nullptr;
144 char spool_file_name[128];
145
146 int32_t terminal_column = 0;
147
148 int32_t terminal_line_length = (int32_t)0x80000000;
149
150 #define default_terminal_line_length fwin_linelength
151
152 //
153 // The next line is a clue to the unsafe nature of a Standard C library!
154 // I want to implement "printf-like" functions of my own, but need to
155 // process the characters others than via a normal (FILE *) object. So I
156 // use vsprintf etc to place stuff in a buffer from where I can pass it on.
157 // however usage such as
158 // my_magic_printf("%s", ...)
159 // can oh so easily generate unbounded amounts of stuff to overflow any
160 // buffer I have. I allow space for VPRINTF_CHUNK chars so demand
161 // discipline of myself in all uses...
162 //
163 // The 1999 C standard introduced vsnprintf and solves this worry!
164 //
165 #define VPRINTF_CHUNK 2048
166
ensure_screen()167 void ensure_screen()
168 { fwin_ensure_screen();
169 if (spool_file != nullptr) std::fflush(spool_file);
170 }
171
term_printf(const char * fmt,...)172 void term_printf(const char *fmt, ...)
173 { std::va_list a;
174 char print_temp[VPRINTF_CHUNK], *p;
175 int n;
176 va_start(a, fmt);
177 n = std::vsprintf(print_temp, fmt, a);
178 p = print_temp;
179 while (n-- > 0) char_to_terminal(*p++, 0);
180 va_end(a);
181 }
182
stdout_printf(const char * fmt,...)183 void stdout_printf(const char *fmt, ...)
184 { std::va_list a;
185 char print_temp[VPRINTF_CHUNK], *p;
186 int n;
187 LispObject stream = qvalue(standard_output);
188 if (!is_stream(stream)) stream = qvalue(terminal_io);
189 if (!is_stream(stream)) stream = lisp_terminal_io;
190 va_start(a, fmt);
191 n = std::vsprintf(print_temp, fmt, a);
192 p = print_temp;
193 while (n-- > 0) putc_stream(*p++, stream);
194 va_end(a);
195 }
196
err_printf(const char * fmt,...)197 void err_printf(const char *fmt, ...)
198 { std::va_list a;
199 char print_temp[VPRINTF_CHUNK], *p;
200 int n;
201 LispObject stream = qvalue(error_output);
202 if (!is_stream(stream)) stream = qvalue(terminal_io);
203 if (!is_stream(stream)) stream = lisp_terminal_io;
204 va_start(a, fmt);
205 n = std::vsprintf(print_temp, fmt, a);
206 p = print_temp;
207 while (n-- > 0) putc_stream(*p++, stream);
208 va_end(a);
209 }
210
debug_printf(const char * fmt,...)211 void debug_printf(const char *fmt, ...)
212 { std::va_list a;
213 char print_temp[VPRINTF_CHUNK], *p;
214 int n;
215 LispObject stream = qvalue(debug_io);
216 if (!is_stream(stream)) stream = qvalue(terminal_io);
217 if (!is_stream(stream)) stream = lisp_terminal_io;
218 va_start(a, fmt);
219 n = std::vsprintf(print_temp, fmt, a);
220 p = print_temp;
221 while (n-- > 0) putc_stream(*p++, stream);
222 va_end(a);
223 }
224
trace_printf(const char * fmt,...)225 void trace_printf(const char *fmt, ...)
226 { std::va_list a;
227 char print_temp[VPRINTF_CHUNK], *p;
228 int n;
229 LispObject stream = qvalue(trace_output);
230 if (!is_stream(stream)) stream = qvalue(terminal_io);
231 if (!is_stream(stream)) stream = lisp_terminal_io;
232 va_start(a, fmt);
233 n = std::vsprintf(print_temp, fmt, a);
234 p = print_temp;
235 while (n-- > 0) putc_stream(*p++, stream);
236 va_end(a);
237 }
238
Ltyo(LispObject env,LispObject a)239 LispObject Ltyo(LispObject env, LispObject a)
240 {
241 //
242 // Print a character given its character code. NOTE that in earlier
243 // versions of CSL this always printed to the standard output regardless
244 // of what output stream was selected. Such a curious behaviour was
245 // provided for use when magic characters sent to the standard output had
246 // odd behaviour (eg caused graphics effects). Now tyo is a more
247 // sensible function for use across all systems. To be generous it
248 // accepts either a character or a numeric code.
249 //
250 int c;
251 LispObject stream = qvalue(standard_output);
252 if (a == CHAR_EOF || a == fixnum_of_int(-1)) return onevalue(a);
253 else if (is_char(a)) c = static_cast<int>(code_of_char(a));
254 else if (is_fixnum(a)) c = static_cast<int>(int_of_fixnum(a));
255 else return aerror1("tyo", a);
256 Save save(a);
257 if (!is_stream(stream)) stream = qvalue(terminal_io);
258 if (!is_stream(stream)) stream = lisp_terminal_io;
259 putc_stream(c, stream);
260 save.restore(a);
261 return onevalue(a);
262 }
263
char_to_illegal(int,LispObject f)264 int char_to_illegal(int, LispObject f)
265 { return aerror1("Attempt to write to an input stream or one that has been closed",
266 stream_type(f));
267 return 1;
268 }
269
char_from_illegal(LispObject f)270 int char_from_illegal(LispObject f)
271 { return aerror1("Attempt to read from an output stream or one that has been closed",
272 stream_type(f));
273 return EOF;
274 }
275
write_action_illegal(int32_t op,LispObject f)276 int32_t write_action_illegal(int32_t op, LispObject f)
277 { if (op == WRITE_GET_INFO+WRITE_IS_CONSOLE) return 0;
278 if (op != WRITE_CLOSE)
279 return aerror1("Illegal operation on stream",
280 cons_no_gc(fixnum_of_int(op >> 8), stream_type(f)));
281 return 0;
282 }
283
write_action_file(int32_t op,LispObject f)284 int32_t write_action_file(int32_t op, LispObject f)
285 { int32_t w;
286 switch (op & 0xf0000000)
287 { case WRITE_CLOSE:
288 if ((std::FILE *)stream_file(f) == nullptr) op = 0;
289 else op = std::fclose(stream_file(f));
290 set_stream_write_fn(f, char_to_illegal);
291 set_stream_write_other(f, write_action_illegal);
292 set_stream_read_fn(f, char_from_illegal);
293 set_stream_read_other(f, read_action_illegal);
294 set_stream_file(f, nullptr);
295 return op;
296 case WRITE_FLUSH:
297 return std::fflush(stream_file(f));
298 case WRITE_SET_LINELENGTH_DEFAULT:
299 op = 80; // drop through
300 case WRITE_SET_LINELENGTH:
301 w = stream_line_length(f);
302 stream_line_length(f) = op & 0x07ffffff;
303 return w;
304 case WRITE_SET_COLUMN:
305 w = stream_char_pos(f);
306 stream_char_pos(f) = op & 0x07ffffff;
307 return w;
308 case WRITE_GET_INFO:
309 switch (op & 0xff)
310 { case WRITE_GET_LINE_LENGTH: return stream_line_length(f);
311 case WRITE_GET_COLUMN: return stream_char_pos(f);
312 case WRITE_IS_CONSOLE: return 0;
313 default:return 0;
314 }
315 default:
316 return 0;
317 }
318 }
319
write_action_pipe(int32_t op,LispObject f)320 int32_t write_action_pipe(int32_t op, LispObject f)
321 { int32_t w;
322 if (op < 0) return -1;
323 else switch (op & 0xf0000000)
324 { case WRITE_CLOSE:
325 my_pclose(stream_file(f));
326 set_stream_write_fn(f, char_to_illegal);
327 set_stream_write_other(f, write_action_illegal);
328 set_stream_file(f, nullptr);
329 return 0;
330 case WRITE_FLUSH:
331 return my_pipe_flush(stream_file(f));
332 case WRITE_SET_LINELENGTH_DEFAULT:
333 op = 80; // drop through
334 case WRITE_SET_LINELENGTH:
335 w = stream_line_length(f);
336 stream_line_length(f) = op & 0x07ffffff;
337 return w;
338 case WRITE_SET_COLUMN:
339 w = stream_char_pos(f);
340 stream_char_pos(f) = op & 0x07ffffff;
341 return w;
342 case WRITE_GET_INFO:
343 switch (op & 0xff)
344 { case WRITE_GET_LINE_LENGTH: return stream_line_length(f);
345 case WRITE_GET_COLUMN: return stream_char_pos(f);
346 case WRITE_IS_CONSOLE: return 0;
347 default:return 0;
348 }
349 default:
350 return 0;
351 }
352 }
353
write_action_terminal(int32_t op,LispObject)354 int32_t write_action_terminal(int32_t op, LispObject)
355 { int32_t w;
356 if (op < 0) return -1;
357 else switch (op & 0xf0000000)
358 { case WRITE_CLOSE:
359 return 0; // I will never close the terminal stream
360 case WRITE_FLUSH:
361 ensure_screen();
362 return 0;
363 case WRITE_SET_LINELENGTH_DEFAULT:
364 w = terminal_line_length;
365 terminal_line_length = 0x80000000;
366 return w;
367 case WRITE_SET_LINELENGTH:
368 w = terminal_line_length;
369 terminal_line_length = op & 0x07ffffff;
370 return w;
371 case WRITE_SET_COLUMN:
372 w = terminal_column;
373 terminal_column = op & 0x07ffffff;
374 return w;
375 case WRITE_GET_INFO:
376 switch (op & 0xff)
377 { case WRITE_GET_LINE_LENGTH: w = terminal_line_length;
378 if (w == (int32_t)0x80000000)
379 w = default_terminal_line_length;
380 return w;
381 case WRITE_GET_COLUMN: return terminal_column;
382 case WRITE_IS_CONSOLE: return 1;
383 default:return 0;
384 }
385 default:
386 return 0;
387 }
388 }
389
390
391 #if defined HAVE_LIBFOX || defined HAVE_LIBWX
392
write_action_math(int32_t op,LispObject)393 int32_t write_action_math(int32_t op, LispObject)
394 { if (op < 0) return -1;
395 else switch (op & 0xf0000000)
396 { case WRITE_CLOSE:
397 return 0; // I will never close the math stream
398 case WRITE_FLUSH: // not flushed using the normal protocol
399 return 0;
400 case WRITE_SET_LINELENGTH_DEFAULT:
401 return 0x07ffffff; // essentially unlimited linelength
402 case WRITE_SET_LINELENGTH:
403 return 0x07ffffff;
404 case WRITE_SET_COLUMN: // operation not really supported
405 return 0;
406 case WRITE_GET_INFO:
407 switch (op & 0xff)
408 { case WRITE_GET_LINE_LENGTH: return 0x07ffffff;
409 case WRITE_GET_COLUMN: return 0;
410 case WRITE_IS_CONSOLE: return 1;
411 default:return 0;
412 }
413 default:
414 return 0;
415 }
416 }
417
write_action_spool(int32_t op,LispObject)418 int32_t write_action_spool(int32_t op, LispObject)
419 { int32_t w;
420 if (op < 0) return -1;
421 else switch (op & 0xf0000000)
422 { case WRITE_CLOSE:
423 return 0; // I will never close the spool stream this way
424 case WRITE_FLUSH:
425 if (spool_file != nullptr) std::fflush(spool_file);
426 return 0;
427 //
428 // In many respects this behaves just like terminal output.
429 //
430 case WRITE_SET_LINELENGTH_DEFAULT:
431 w = terminal_line_length;
432 terminal_line_length = 0x80000000;
433 return w;
434 case WRITE_SET_LINELENGTH:
435 w = terminal_line_length;
436 terminal_line_length = op & 0x07ffffff;
437 return w;
438 case WRITE_SET_COLUMN:
439 w = terminal_column;
440 terminal_column = op & 0x07ffffff;
441 return w;
442 case WRITE_GET_INFO:
443 switch (op & 0xff)
444 { case WRITE_GET_LINE_LENGTH: w = terminal_line_length;
445 if (w == (int32_t)0x80000000)
446 w = default_terminal_line_length;
447 return w;
448 case WRITE_GET_COLUMN: return terminal_column;
449 case WRITE_IS_CONSOLE: return 1;
450 default:return 0;
451 }
452 default:
453 return 0;
454 }
455 }
456
457 #endif
458
write_action_list(int32_t op,LispObject f)459 int32_t write_action_list(int32_t op, LispObject f)
460 { int32_t w;
461 if (op < 0) return -1;
462 else switch (op & 0xf0000000)
463 { case WRITE_CLOSE:
464 set_stream_write_fn(f, char_to_illegal);
465 set_stream_write_other(f, write_action_illegal);
466 set_stream_file(f, nullptr);
467 return 0;
468 case WRITE_FLUSH:
469 return 0;
470 case WRITE_SET_LINELENGTH_DEFAULT:
471 case WRITE_SET_LINELENGTH:
472 return 0x03ffffff;
473 case WRITE_SET_COLUMN:
474 w = stream_char_pos(f);
475 stream_char_pos(f) = op & 0x07ffffff;
476 return w;
477 case WRITE_GET_INFO:
478 switch (op & 0xff)
479 { case WRITE_GET_LINE_LENGTH: return 0x03ffffff;
480 case WRITE_GET_COLUMN: return stream_char_pos(f);
481 case WRITE_IS_CONSOLE: return 0;
482 default:return 0;
483 }
484 default:
485 return 0;
486 }
487 }
488
Lstreamp(LispObject env,LispObject a)489 LispObject Lstreamp(LispObject env, LispObject a)
490 { return onevalue(Lispify_predicate(is_stream(a)));
491 }
492
Lis_console(LispObject env,LispObject a)493 LispObject Lis_console(LispObject env, LispObject a)
494 { int r1, r2;
495 if (!is_stream(a)) return onevalue(nil);
496 r1 = other_write_action(WRITE_GET_INFO+WRITE_IS_CONSOLE, a);
497 r2 = other_read_action(READ_IS_CONSOLE, a);
498 return onevalue(Lispify_predicate(r1 || r2));
499 }
500
make_stream_handle()501 LispObject make_stream_handle()
502 { LispObject w = get_basic_vector(TAG_VECTOR, TYPE_STREAM, STREAM_SIZE);
503 errexit();
504 stream_type(w) = nil;
505 stream_write_data(w) = nil;
506 stream_read_data(w) = nil;
507 set_stream_file(w, 0);
508 set_stream_write_fn(w, char_to_illegal);
509 set_stream_write_other(w, write_action_illegal);
510 stream_line_length(w) = 80;
511 stream_byte_pos(w) = 0;
512 stream_char_pos(w) = 0;
513 set_stream_read_fn(w, char_from_illegal);
514 set_stream_read_other(w, read_action_illegal);
515 stream_pushed_char(w) = NOT_CHAR;
516 stream_spare(w) = 0; // Not used at present
517 return w;
518 }
519
Lmake_broadcast_stream_4up(LispObject env,LispObject a1,LispObject a2,LispObject a3,LispObject a4up)520 LispObject Lmake_broadcast_stream_4up(LispObject env,
521 LispObject a1, LispObject a2, LispObject a3, LispObject a4up)
522 { Save save(a1, a2);
523 if (a3 != SPID_NOARG) a4up = cons(a3, a4up);
524 errexit();
525 save.restore(a1, a2);
526 if (a2 != SPID_NOARG) a4up = cons(a2, a4up);
527 errexit();
528 save.restore(a1, a2);
529 if (a1 != SPID_NOARG) a4up = cons(a1, a4up);
530 errexit();
531 Save save1(a4up);
532 LispObject w = make_stream_handle();
533 errexit();
534 save1.restore(a4up);
535 set_stream_write_fn(w, char_to_broadcast);
536 set_stream_write_other(w, write_action_broadcast);
537 stream_write_data(w) = a4up;
538 return onevalue(w);
539 }
540
Lmake_broadcast_stream_0(LispObject env)541 LispObject Lmake_broadcast_stream_0(LispObject env)
542 { return Lmake_broadcast_stream_4up(env, SPID_NOARG, SPID_NOARG, SPID_NOARG, nil);
543 }
544
Lmake_broadcast_stream_1(LispObject env,LispObject a)545 LispObject Lmake_broadcast_stream_1(LispObject env, LispObject a)
546 { return Lmake_broadcast_stream_4up(env, a, SPID_NOARG, SPID_NOARG, nil);
547 }
548
Lmake_broadcast_stream_2(LispObject env,LispObject a,LispObject b)549 LispObject Lmake_broadcast_stream_2(LispObject env, LispObject a,
550 LispObject b)
551 { return Lmake_broadcast_stream_4up(env, a, b, SPID_NOARG, nil);
552 }
553
Lmake_broadcast_stream_3(LispObject env,LispObject a,LispObject b,LispObject c)554 LispObject Lmake_broadcast_stream_3(LispObject env, LispObject a,
555 LispObject b, LispObject c)
556 { return Lmake_broadcast_stream_4up(env, a, b, c, nil);
557 }
558
Lmake_concatenated_stream_4up(LispObject env,LispObject a1,LispObject a2,LispObject a3,LispObject a4up)559 LispObject Lmake_concatenated_stream_4up(LispObject env,
560 LispObject a1, LispObject a2, LispObject a3, LispObject a4up)
561 { Save save(a1, a2);
562 if (a3 != SPID_NOARG) a4up = cons(a3, a4up);
563 errexit();
564 save.restore(a1, a2);
565 if (a2 != SPID_NOARG) a4up = cons(a2, a4up);
566 errexit();
567 save.restore(a1, a2);
568 if (a1 != SPID_NOARG) a4up = cons(a1, a4up);
569 errexit();
570 Save save1(a4up);
571 LispObject w = make_stream_handle();
572 errexit();
573 save1.restore(a4up);
574 set_stream_read_fn(w, char_from_concatenated);
575 set_stream_read_other(w, read_action_concatenated);
576 stream_read_data(w) = a4up;
577 return onevalue(w);
578 }
579
Lmake_concatenated_stream_0(LispObject env)580 LispObject Lmake_concatenated_stream_0(LispObject env)
581 { return Lmake_concatenated_stream_4up(env, SPID_NOARG, SPID_NOARG, SPID_NOARG, nil);
582 }
583
Lmake_concatenated_stream_1(LispObject env,LispObject a)584 LispObject Lmake_concatenated_stream_1(LispObject env, LispObject a)
585 { return Lmake_concatenated_stream_4up(env, a, SPID_NOARG, SPID_NOARG, nil);
586 }
587
Lmake_concatenated_stream_2(LispObject env,LispObject a,LispObject b)588 LispObject Lmake_concatenated_stream_2(LispObject env, LispObject a,
589 LispObject b)
590 { return Lmake_concatenated_stream_4up(env, a, b, SPID_NOARG, nil);
591 }
592
Lmake_concatenated_stream_3(LispObject env,LispObject a,LispObject b,LispObject c)593 LispObject Lmake_concatenated_stream_3(LispObject env, LispObject a,
594 LispObject b, LispObject c)
595 { return Lmake_concatenated_stream_4up(env, a, b, c, nil);
596 }
597
Lmake_synonym_stream(LispObject env,LispObject a)598 LispObject Lmake_synonym_stream(LispObject env, LispObject a)
599 { LispObject w;
600 if (!is_symbol(a)) return aerror1("make-synonym-stream", a);
601 Save save(a);
602 w = make_stream_handle();
603 errexit();
604 save.restore(a);
605 set_stream_write_fn(w, char_to_synonym);
606 set_stream_write_other(w, write_action_synonym);
607 stream_write_data(w) = a;
608 set_stream_read_fn(w, char_from_synonym);
609 set_stream_read_other(w, read_action_synonym);
610 stream_read_data(w) = a;
611 return onevalue(w);
612 }
613
Lmake_two_way_stream(LispObject env,LispObject a,LispObject b)614 LispObject Lmake_two_way_stream(LispObject env, LispObject a,
615 LispObject b)
616 { LispObject w;
617 if (!is_symbol(a)) return aerror1("make-two-way-stream", a);
618 if (!is_symbol(b)) return aerror1("make-two-way-stream", b);
619 Save save(a, b);
620 w = make_stream_handle();
621 errexit();
622 save.restore(a, b);
623 set_stream_write_fn(w, char_to_synonym);
624 set_stream_write_other(w, write_action_synonym);
625 stream_write_data(w) = b;
626 set_stream_read_fn(w, char_from_synonym);
627 set_stream_read_other(w, read_action_synonym);
628 stream_read_data(w) = a;
629 return onevalue(w);
630 }
631
Lmake_echo_stream(LispObject env,LispObject a,LispObject b)632 LispObject Lmake_echo_stream(LispObject env, LispObject a,
633 LispObject b)
634 { LispObject w;
635 if (!is_symbol(a)) return aerror1("make-echo-stream", a);
636 if (!is_symbol(b)) return aerror1("make-echo-stream", b);
637 Save save(a, b);
638 w = make_stream_handle();
639 errexit();
640 save.restore(a, b);
641 set_stream_write_fn(w, char_to_synonym);
642 set_stream_write_other(w, write_action_synonym);
643 stream_write_data(w) = b;
644 set_stream_read_fn(w, char_from_echo);
645 set_stream_read_other(w, read_action_synonym);
646 stream_read_data(w) = a;
647 return onevalue(w);
648 }
649
650
651 // string input streams are not implemented yet, but I can read from a
652 // list so all I would need to do would be to use explodec to turn the
653 // string into a list of characters and then I have at least all the
654 // basic mechanisms necessary.
655
Lmake_string_input_stream_4up(LispObject env,LispObject a1,LispObject a2,LispObject a3,LispObject a4up)656 LispObject Lmake_string_input_stream_4up(LispObject env,
657 LispObject a1, LispObject a2, LispObject a3, LispObject a4up)
658 { return aerror("make-string-input-stream");
659 }
660
Lmake_string_input_stream_0(LispObject env)661 LispObject Lmake_string_input_stream_0(LispObject env)
662 { return Lmake_string_input_stream_4up(env, SPID_NOARG, SPID_NOARG, SPID_NOARG, nil);
663 }
664
Lmake_string_input_stream_1(LispObject env,LispObject a)665 LispObject Lmake_string_input_stream_1(LispObject env, LispObject a)
666 { return Lmake_string_input_stream_4up(env, a, SPID_NOARG, SPID_NOARG, nil);
667 }
668
Lmake_string_input_stream_2(LispObject env,LispObject a,LispObject b)669 LispObject Lmake_string_input_stream_2(LispObject env, LispObject a,
670 LispObject b)
671 { return Lmake_string_input_stream_4up(env, a, b, SPID_NOARG, nil);
672 }
673
Lmake_string_input_stream_3(LispObject env,LispObject a,LispObject b,LispObject c)674 LispObject Lmake_string_input_stream_3(LispObject env, LispObject a,
675 LispObject b, LispObject c)
676 { return Lmake_string_input_stream_4up(env, a, b, c, nil);
677 }
678
Lmake_string_output_stream(LispObject env)679 LispObject Lmake_string_output_stream(LispObject env)
680 { LispObject w;
681 w = make_stream_handle();
682 errexit();
683 set_stream_write_fn(w, code_to_list);
684 set_stream_write_other(w, write_action_list);
685 return onevalue(w);
686 }
687
Lget_output_stream_string(LispObject env,LispObject a)688 LispObject Lget_output_stream_string(LispObject env, LispObject a)
689 { LispObject w;
690 int32_t n, k;
691 if (!is_stream(a)) return aerror1("get-output-stream-string", a);
692 w = stream_write_data(a);
693 n = stream_byte_pos(a);
694 stream_write_data(a) = nil;
695 stream_char_pos(a) = stream_byte_pos(a) = 0;
696 Save save(w);
697 a = get_basic_vector(TAG_VECTOR, TYPE_STRING_4, CELL+n);
698 errexit();
699 save.restore(w);
700 k = (n + 3) & ~(int32_t)7;
701 *(int32_t *)(reinterpret_cast<char *>(a) + k + 4 - TAG_VECTOR) = 0;
702 if (k != 0) *(int32_t *)(reinterpret_cast<char *>
703 (a) + k - TAG_VECTOR) = 0;
704 while (n > 0)
705 { n--;
706 // /* The list can now contain big characters that need to re-expand to
707 // utf-8 form here.
708 //
709 celt(a, n) = int_of_fixnum(car(w));
710 w = cdr(w);
711 }
712 return a;
713 }
714
715 //
716 // (make-function-stream 'fn) makes a stream where output just passes
717 // characters to the given function.
718 //
719
Lmake_function_stream(LispObject env,LispObject a)720 LispObject Lmake_function_stream(LispObject env, LispObject a)
721 { LispObject w;
722 if (!is_symbol(a)) return aerror1("make-function-stream", a);
723 Save save(a);
724 w = make_stream_handle();
725 errexit();
726 save.restore(a);
727 set_stream_write_fn(w, char_to_function);
728 set_stream_write_other(w, write_action_list);
729 stream_write_data(w) = a;
730 return onevalue(w);
731 }
732
733 static int io_kilo = 0;
734
char_to_terminal(int c,LispObject)735 int char_to_terminal(int c, LispObject)
736 { if (++io_kilo >= 1024)
737 { io_kilo = 0;
738 io_now++;
739 }
740 if (c == '\n' || c == '\f') terminal_column = 0;
741 else if (c == '\b') terminal_column--;
742 else if (c == '\t') terminal_column = (terminal_column + 8) & ~7;
743 else if ((c & 0xc0) == 0x80) /* do nothing */;
744 else terminal_column++;
745 if (spool_file != nullptr)
746 { PUTC(c, spool_file);
747 #ifdef DEBUG
748 std::fflush(spool_file);
749 #endif
750 }
751 if (procedural_output != nullptr) return (*procedural_output)(c);
752 #ifdef WITH_GUI
753 // "alternative_stdout" is only relevant if there may be a GUI.
754 if (alternative_stdout != nullptr)
755 { PUTC(c, alternative_stdout);
756 return 0;
757 }
758 #endif // WITH_GUI
759 fwin_putchar(c);
760 return 0; // indicate success
761 }
762
763 #if defined HAVE_LIBFOX || defined HAVE_LIBWX
764
765 static int math_buffer_size, math_buffer_p;
766 static char *math_buffer = nullptr;
767
char_to_math(int c,LispObject stream)768 int char_to_math(int c, LispObject stream)
769 { if (++io_kilo >= 1024)
770 { io_kilo = 0;
771 io_now++;
772 }
773 if (math_buffer == nullptr)
774 { math_buffer_size = 500;
775 // I think that I fail to delete this when the program terminates.
776 math_buffer = new (std::nothrow) char[math_buffer_size];
777 math_buffer_p = 0;
778 if (math_buffer == nullptr) return 1; // failed
779 }
780 if (math_buffer_p == math_buffer_size-1)
781 { math_buffer_size += 500; // Grow the buffer
782 char *bigger = new (std::nothrow) char[math_buffer_size];
783 if (bigger == nullptr) return 1;
784 std::memcpy(bigger, math_buffer, math_buffer_size-500);
785 delete [] math_buffer;
786 math_buffer = bigger;
787 // If I fail to extend the buffer then I will lose some initial part of
788 // my output. Ugh! But (provided the memory situation improves!) things will
789 // correct themselves when I next try to display a smaller expression.
790 }
791 math_buffer[math_buffer_p++] = c;
792 math_buffer[math_buffer_p] = 0;
793 return 0;
794 }
795
char_to_spool(int c,LispObject stream)796 int char_to_spool(int c, LispObject stream)
797 { if (spool_file == nullptr) return 1;
798 if (c == '\n' || c == '\f') terminal_column = 0;
799 else if (c == '\t') terminal_column = (terminal_column + 8) & ~7;
800 else if ((c & 0xc0) == 0x80) /* do nothing */ ;
801 else terminal_column++;
802 PUTC(c, spool_file);
803 return 0;
804 }
805
806 #endif
807
808 //
809 // Note that characters come through this interface as a sequence of
810 // bytes, with ones whose code is over 0x7f sent as a sequence using utf-8.
811 //
char_to_file(int c,LispObject stream)812 int char_to_file(int c, LispObject stream)
813 { if (++io_kilo >= 1024)
814 { io_kilo = 0;
815 io_now++;
816 }
817 if (c == '\n' || c == '\f')
818 stream_char_pos(stream) = stream_byte_pos(stream) = 0;
819 else if (c == '\t')
820 { stream_char_pos(stream) = (static_cast<int>(stream_char_pos(
821 stream)) + 8) & ~7;
822 stream_byte_pos(stream)++;
823 }
824 else if ((c & 0xc0) == 0x80) stream_byte_pos(stream)++;
825 else
826 { stream_byte_pos(stream)++;
827 stream_char_pos(stream)++;
828 }
829 PUTC(c, stream_file(stream));
830 return 0; // indicate success
831 }
832
char_to_synonym(int c,LispObject f)833 int char_to_synonym(int c, LispObject f)
834 { f = qvalue(stream_write_data(f));
835 if (!is_stream(f)) return 1;
836 return putc_stream(c, f);
837 }
838
char_to_function(int c,LispObject f)839 int char_to_function(int c, LispObject f)
840 { f = stream_write_data(f); // name of the function to call
841 (*qfn1(f))(qenv(f), pack_char(0, c & 0xff));
842 return 0; // return 0 for success
843 }
844
char_to_broadcast(int c,LispObject f)845 int char_to_broadcast(int c, LispObject f)
846 { LispObject l = stream_write_data(f);
847 int r = 0;
848 while (consp(l))
849 { f = car(l);
850 l = cdr(l);
851 if (!is_symbol(f)) continue;
852 f = qvalue(f);
853 if (!is_stream(f)) continue;
854 Save save(l);
855 r = r | putc_stream(c, f);
856 save.restore(l);
857 }
858 return r;
859 }
860
write_action_synonym(int32_t c,LispObject f)861 int32_t write_action_synonym(int32_t c, LispObject f)
862 { int r;
863 LispObject f1 = qvalue(stream_write_data(f));
864 if (!is_stream(f1))
865 return aerror1("attempt to act on",
866 cons_no_gc(fixnum_of_int(c >> 8), f));
867 r = other_write_action(c, f1);
868 if (c == WRITE_CLOSE)
869 { set_stream_write_fn(f, char_to_illegal);
870 set_stream_write_other(f, write_action_illegal);
871 set_stream_file(f, nullptr);
872 }
873 return r;
874 }
875
write_action_broadcast(int32_t c,LispObject f)876 int32_t write_action_broadcast(int32_t c, LispObject f)
877 { int r = 0, r1;
878 LispObject l = stream_write_data(f), f1;
879 while (consp(l))
880 { f1 = car(l);
881 l = cdr(l);
882 if (!is_symbol(f1)) continue;
883 f1 = qvalue(f1);
884 if (!is_stream(f1)) continue;
885 Save save(l, f);
886 r1 = other_write_action(c, f1);
887 save.restore(l, f);
888 if (r == 0) r = r1;
889 }
890 if (c == WRITE_CLOSE)
891 { set_stream_write_fn(f, char_to_illegal);
892 set_stream_write_other(f, write_action_illegal);
893 set_stream_file(f, nullptr);
894 }
895 return r;
896 }
897
char_to_pipeout(int c,LispObject stream)898 int char_to_pipeout(int c, LispObject stream)
899 { if (++io_kilo >= 1024)
900 { io_kilo = 0;
901 io_now++;
902 }
903 if (c == '\n' || c == '\f')
904 stream_byte_pos(stream) = stream_char_pos(stream) = 0;
905 else if (c == '\t')
906 { stream_byte_pos(stream)++;
907 stream_char_pos(stream) = (static_cast<int>(stream_char_pos(
908 stream)) + 8) & ~7;
909 }
910 else if ((c & 0xc0) == 0x80) stream_byte_pos(stream)++;
911 else
912 { stream_byte_pos(stream)++;
913 stream_char_pos(stream)++;
914 }
915 my_pipe_putc(c, stream_file(stream));
916 return 0; // indicate success
917 }
918
char_from_pipe(LispObject stream)919 int char_from_pipe(LispObject stream)
920 { int ch = stream_pushed_char(stream);
921 if (ch == NOT_CHAR)
922 { if (++io_kilo >= 1024)
923 { io_kilo = 0;
924 io_now++;
925 }
926 ch = GETC(stream_file(stream));
927 if (ch == EOF
928 // || ch == CTRL_D
929 ) return EOF;
930 }
931 else stream_pushed_char(stream) = NOT_CHAR;
932 return ch;
933 }
934
read_action_pipe(int32_t op,LispObject f)935 int32_t read_action_pipe(int32_t op, LispObject f)
936 { if (op < -1) return 1;
937 else if (op <= 0xffff) return (stream_pushed_char(f) = op);
938 else switch (op)
939 { case READ_CLOSE:
940 if ((std::FILE *)stream_file(f) == nullptr) op = 0;
941 else my_pclose(stream_file(f));
942 set_stream_read_fn(f, char_from_illegal);
943 set_stream_read_other(f, read_action_illegal);
944 set_stream_file(f, nullptr);
945 return 0;
946 case READ_FLUSH:
947 stream_pushed_char(f) = NOT_CHAR;
948 return 0;
949 case READ_TELL:
950 return -1;
951 case READ_IS_CONSOLE:
952 return 0;
953 default:
954 return 0;
955 }
956 }
957
get_string_data(LispObject name,const char * why,size_t & len)958 const char *get_string_data(LispObject name, const char *why,
959 size_t &len)
960 { Header h;
961 #ifdef COMMON
962 if (complex_stringp(name))
963 { name = simplify_string(name);
964 if (exceptionPending()) return nullptr;
965 h = vechdr(name);
966 }
967 else
968 #endif
969 if (symbolp(name))
970 { name = get_pname(name);
971 h = vechdr(name);
972 }
973 else if (!is_vector(name))
974 return reinterpret_cast<const char *>(aerror1(why, name));
975 else if (!is_string_header(h = vechdr(name)))
976 return reinterpret_cast<const char *>(aerror1(why, name));
977 len = length_of_byteheader(h) - CELL;
978 return reinterpret_cast<const char *>(&celt(name, 0));
979 }
980
Lfiledate(LispObject env,LispObject name)981 static LispObject Lfiledate(LispObject env, LispObject name)
982 { char filename[LONGEST_LEGAL_FILENAME], tt[32];
983 size_t len = 0;
984 const char *w;
985 std::memset(filename, 0, sizeof(filename));
986 w = get_string_data(name, "filep", len);
987 if (len >= sizeof(filename)) len = sizeof(filename);
988 if (!file_exists(filename, w,
989 static_cast<size_t>(len), tt)) return onevalue(nil);
990 tt[24] = 0;
991 return onevalue(make_string(tt));
992 }
993
Lfilep(LispObject env,LispObject name)994 static LispObject Lfilep(LispObject env, LispObject name)
995 { name = Lfiledate(env, name);
996 if (name != nil) name = lisp_true;
997 return onevalue(name);
998 }
999
Ltmpnam1(LispObject env,LispObject extn)1000 LispObject Ltmpnam1(LispObject env, LispObject extn)
1001 //
1002 // Returns a string that is suitable for use as the name of a temporary
1003 // file and that has the given extension. Note that this is generally NOT
1004 // a fully secure thing to use, since after tmpnam() has generated the
1005 // name but before you get around to doing anything with the file
1006 // somebody else may do something that interferes.
1007 //
1008 { const char *suffix;
1009 const char *suffix1;
1010 size_t suffixlen = 0;
1011 LispObject r;
1012 suffix = get_string_data(extn, "tmpnam", suffixlen);
1013 suffix1 = CSLtmpnam(suffix, suffixlen);
1014 if (suffix1 == nullptr) return onevalue(nil);
1015 r = make_string(suffix1);
1016 return onevalue(r);
1017 }
1018
Ltmpnam(LispObject env)1019 LispObject Ltmpnam(LispObject env)
1020 //
1021 // Returns a string that is suitable for use as the name of a temporary
1022 // file. Note that this is generally NOT a comfortable thing to use,
1023 // since after tmpnam() has generated the name but before you get around
1024 // to doing anything with the file somebody else may do something that
1025 // interferes. As a result some C compilers issue a warning when they
1026 // see use of tmpnam() at all... Here the potential security issues are
1027 // just left for the user to think about! Well because the messages from
1028 // the GNU linker have been causing grief to some users, and because in their
1029 // arrogance the developers of that linker do not provide a way to switch
1030 // the messages off, and furher because I have legacy needs where the
1031 // risks associated with race conditions and really not a worry, I implement
1032 // my own approximation to tmpnam. My version may well be even less
1033 // respectable than the standard one, but using it avoids linker messages
1034 // that are clearly intended to be useful but which are in fact a nuisance.
1035 //
1036 { return onevalue(make_string(CSLtmpnam("tmp", 3)));
1037 }
1038
Ltmpdir(LispObject env)1039 LispObject Ltmpdir(LispObject env)
1040 //
1041 // Returns a string that is suitable for use as the name of a directory
1042 // to hold temporary files. Does not have a trailing "/", so will be
1043 // "/tmp" on Unix and something like "c:\xxx\yyy" on Windows. On Cygwin
1044 // it is in "mixed" mode, so the dircetory is indicated with "x:" but "/"
1045 // rather than "\" is used as the path separator.
1046 //
1047 { return onevalue(make_string(CSLtmpdir()));
1048 }
1049
1050 #ifdef DEBUG
myopen(const char * f,const char * m)1051 std::FILE *myopen(const char *f, const char *m)
1052 { std::FILE *s = std::fopen(f, m);
1053 trace_printf("fopen(%s, %s) = %p\n", f, m, s);
1054 return s;
1055 }
1056 #define fopen(a, b) myopen(a, b)
1057 #endif
1058
1059 //
1060 // The Common Lisp keywords for OPEN are a horrid mess. I arrange to decode
1061 // the syntax of the keywords in a Lisp-coded wrapper function, and in that
1062 // code I will also fill in default values for any that needs same. I then
1063 // pack all the information into a single integer, which has several
1064 // sub-fields
1065 //
1066 // x x xx xxx 00 direction PROBE
1067 // x x xx xxx 01 INPUT
1068 // x x xx xxx 10 OUTPUT
1069 // x x xx xxx 11 IO
1070 //
1071 // x x xx 000 xx if-exists NIL
1072 // x x xx 001 xx overwrite
1073 // x x xx 010 xx append
1074 // x x xx 011 xx rename
1075 // x x xx 100 xx error
1076 // x x xx 101 xx (new-version)
1077 // x x xx 110 xx (supersede)
1078 // x x xx 111 xx (rename-and-delete)
1079 //
1080 // x x 00 xxx xx if-does-not-exist NIL
1081 // x x 01 xxx xx create
1082 // x x 10 xxx xx error
1083 //
1084 // x 0 xx xxx xx regular text file
1085 // x 1 xx xxx xx open for binary access
1086 //
1087 // 0 x xx xxx xx regular file
1088 // 1 x xx xxx xx open as a pipe
1089 //
1090
1091 #define DIRECTION_MASK 0x3
1092 #define DIRECTION_PROBE 0x0
1093 #define DIRECTION_INPUT 0x1
1094 #define DIRECTION_OUTPUT 0x2
1095 #define DIRECTION_IO 0x3
1096 #define IF_EXISTS_MASK 0x1c
1097 #define IF_EXISTS_NIL 0x00
1098 #define IF_EXISTS_OVERWRITE 0x04
1099 #define IF_EXISTS_APPEND 0x08
1100 #define IF_EXISTS_RENAME 0x0c
1101 #define IF_EXISTS_ERROR 0x10
1102 #define IF_EXISTS_NEW_VERSION 0x14
1103 #define IF_EXISTS_SUPERSEDE 0x18
1104 #define IF_EXISTS_RENAME_AND_DELETE 0x1c
1105 #define IF_MISSING_MASK 0x60
1106 #define IF_MISSING_NIL 0x00
1107 #define IF_MISSING_CREATE 0x20
1108 #define IF_MISSING_ERROR 0x40
1109 #define OPEN_BINARY 0x80
1110 #define OPEN_PIPE 0x100
1111
Lopen(LispObject env,LispObject name,LispObject dir)1112 LispObject Lopen(LispObject env, LispObject name, LispObject dir)
1113 { std::FILE *file;
1114 LispObject r;
1115 char filename[LONGEST_LEGAL_FILENAME], fn1[LONGEST_LEGAL_FILENAME];
1116 size_t len = 0;
1117 const char *w;
1118 int d;
1119 std::memset(filename, 0, sizeof(filename));
1120 std::memset(fn1, 0, sizeof(fn1));
1121 if (!is_fixnum(dir)) return aerror1("open", dir);
1122 d = static_cast<int>(int_of_fixnum(dir));
1123 #ifdef DEBUG_OPENING_FILES
1124 trace_printf("Open file:");
1125 switch (d & DIRECTION_MASK)
1126 { case DIRECTION_PROBE: trace_printf(" probe"); break;
1127 case DIRECTION_INPUT: trace_printf(" input"); break;
1128 case DIRECTION_OUTPUT:trace_printf(" output"); break;
1129 case DIRECTION_IO: trace_printf(" io"); break;
1130 }
1131 switch (d & IF_EXISTS_MASK)
1132 { case IF_EXISTS_NIL: trace_printf(" if-exists-nil");
1133 break;
1134 case IF_EXISTS_OVERWRITE:
1135 trace_printf(" if-exists-overwrite"); break;
1136 case IF_EXISTS_APPEND: trace_printf(" if-exists-append");
1137 break;
1138 case IF_EXISTS_RENAME: trace_printf(" if-exists-rename");
1139 break;
1140 case IF_EXISTS_ERROR: trace_printf(" if-exists-error");
1141 break;
1142 case IF_EXISTS_NEW_VERSION:
1143 trace_printf(" if-exists-new-version"); break;
1144 case IF_EXISTS_SUPERSEDE:
1145 trace_printf(" if-exists-supersede"); break;
1146 case IF_EXISTS_RENAME_AND_DELETE: trace_printf(" if-exists-r-and-d");
1147 break;
1148 }
1149 switch (d & IF_MISSING_MASK)
1150 { case IF_MISSING_NIL:
1151 trace_printf(" if-missing-nil"); break;
1152 case IF_MISSING_CREATE:
1153 trace_printf(" if-missing-create"); break;
1154 case IF_MISSING_ERROR: trace_printf(" if-missing-error");
1155 break;
1156 }
1157 if (d & OPEN_BINARY) trace_printf(" binary");
1158 if (d & OPEN_PIPE) trace_printf(" pipe");
1159 trace_printf("\n");
1160 #endif
1161
1162 w = get_string_data(name, "open", len);
1163 if (len >= sizeof(filename)) len = sizeof(filename);
1164
1165 file = nullptr;
1166 switch (d & (DIRECTION_MASK | OPEN_PIPE))
1167 { case DIRECTION_PROBE: // probe file - can not be used with pipes
1168 file = open_file(filename, w, static_cast<size_t>(len), "r", nullptr);
1169 if (file == nullptr)
1170 { switch (d & IF_MISSING_MASK)
1171 { case IF_MISSING_NIL:
1172 return onevalue(nil);
1173 case IF_MISSING_ERROR:
1174 error(1, err_open_failed, name);
1175 case IF_MISSING_CREATE:
1176 //
1177 // I thing that people who go (open xxx :direction :probe
1178 // :if-does-not-exist :create)
1179 // are to be considered unduly enthusiastic, but I will still try to do what
1180 // they tell me to!
1181 //
1182 file = open_file(filename, w, static_cast<size_t>(len), "w", nullptr);
1183 if (file == nullptr) error(1, err_open_failed, name);
1184 std::fclose(file);
1185 file = nullptr;
1186 }
1187 }
1188 else
1189 { std::fclose(file);
1190 file = nullptr;
1191 }
1192 break; // Must then create a no-direction stream
1193
1194 case DIRECTION_INPUT:
1195 file = open_file(filename, w, static_cast<size_t>(len),
1196 (d & OPEN_BINARY ? "rb" : "r"),
1197 nullptr);
1198 if (file == nullptr)
1199 { switch (d & IF_MISSING_MASK)
1200 { case IF_MISSING_NIL:
1201 return onevalue(nil);
1202 case IF_MISSING_ERROR:
1203 error(1, err_open_failed, name);
1204 case IF_MISSING_CREATE:
1205 file = open_file(filename, w,
1206 static_cast<size_t>(len), "w", nullptr);
1207 if (file == nullptr) error(1, err_open_failed, name);
1208 std::fclose(file);
1209 //
1210 // I use fopen(xx,"w") to create the file, then close it again and re-open
1211 // for input, so that concurrent tasks can see the file now existing but
1212 // only open for reading. If opening the file I just created fails I will
1213 // give up.
1214 //
1215 file = open_file(filename, w, static_cast<size_t>(len),
1216 (d & OPEN_BINARY ? "rb" : "r"),
1217 nullptr);
1218 if (file == nullptr) error(1, err_open_failed, name);
1219 break;
1220
1221 }
1222 }
1223 report_file(filename);
1224 break; // if-exists ignored when opening for input
1225
1226 case DIRECTION_OUTPUT:
1227 case DIRECTION_IO:
1228 //
1229 // I will start by trying to open the file to see if it exists. By using
1230 // mode "r+" I will only open it if I am able to obtain write-access, and
1231 // in some cases I will then be able to make use of the file. The fact that
1232 // it will have been opened for IO not just output will not harm me.
1233 //
1234 file = open_file(filename, w, static_cast<size_t>(len),
1235 (d & OPEN_BINARY ? "r+b" : "r+"),
1236 nullptr);
1237 if (file == nullptr) switch (d & IF_MISSING_MASK)
1238 { case IF_MISSING_NIL:
1239 return onevalue(nil);
1240 case IF_MISSING_ERROR:
1241 error(1, err_open_failed, name);
1242 case IF_MISSING_CREATE:
1243 break; // usual case for output and IO files
1244 }
1245 else switch (d & IF_EXISTS_MASK)
1246 { case IF_EXISTS_NIL:
1247 std::fclose(file);
1248 return onevalue(nil);
1249 case IF_EXISTS_RENAME:
1250 //
1251 // When I open a file with :if-exists :rename I will always rename to
1252 // a fixed target, "oldfile.bak". If the rename fails I will not worry too
1253 // much. I imagine some people would rather that the name I renamed to was
1254 // based on the original file-name, but that seems excessive to me. And I
1255 // would have little sympathy for users who relied on it!
1256 //
1257 std::fclose(file);
1258 file = nullptr;
1259 rename_file(filename, w, static_cast<size_t>(len),
1260 fn1, "oldfile.bak", 11);
1261 break;
1262 case IF_EXISTS_ERROR:
1263 std::fclose(file);
1264 error(1, err_open_failed, name);
1265 //
1266 // Working through the standard C library the ideas of :new-version,
1267 // :supersede and :rename-and-delete seem rather odd, so I will just treat
1268 // them all as :new-version.
1269 //
1270 case IF_EXISTS_SUPERSEDE:
1271 case IF_EXISTS_RENAME_AND_DELETE:
1272 case IF_EXISTS_NEW_VERSION:
1273 std::fclose(file);
1274 delete_file(filename, w, static_cast<size_t>(len));
1275 file = nullptr;
1276 break;
1277 case IF_EXISTS_OVERWRITE:
1278 break;
1279 case IF_EXISTS_APPEND:
1280 std::fseek(file, 0L, SEEK_END);
1281 break;
1282 }
1283 if (file == nullptr)
1284 { file = open_file(filename, w,
1285 static_cast<size_t>(len),
1286 (d & OPEN_BINARY ? "w+b" : "w+"),
1287 nullptr);
1288 if (file == nullptr) error(1, err_open_failed, name);
1289 }
1290 break;
1291
1292
1293 case DIRECTION_OUTPUT | OPEN_PIPE:
1294 std::memcpy(filename, w, static_cast<size_t>(len));
1295 filename[len] = 0;
1296 file = my_popen(filename, "w");
1297 if (file == nullptr) error(1, err_pipe_failed, name);
1298 break;
1299
1300 case DIRECTION_INPUT | OPEN_PIPE:
1301 std::memcpy(filename, w, static_cast<size_t>(len));
1302 filename[len] = 0;
1303 file = my_popen(filename, "r");
1304 if (file == nullptr) error(1, err_pipe_failed, name);
1305 break;
1306
1307 case DIRECTION_IO | OPEN_PIPE:
1308 return aerror("reading and writing from pipes is not supported in CSL\n");
1309 }
1310
1311 { Save save(name);
1312 r = make_stream_handle();
1313 errexit();
1314 save.restore(name);
1315 }
1316 stream_type(r) = name;
1317 set_stream_file(r, file);
1318 switch (d & (DIRECTION_MASK | OPEN_PIPE))
1319 { case DIRECTION_INPUT | OPEN_PIPE:
1320 set_stream_read_fn(r, char_from_pipe);
1321 set_stream_read_other(r, read_action_pipe);
1322 break;
1323 case DIRECTION_INPUT:
1324 set_stream_read_fn(r, char_from_file);
1325 set_stream_read_other(r, read_action_file);
1326 break;
1327 case DIRECTION_OUTPUT | OPEN_PIPE:
1328 set_stream_write_fn(r, char_to_pipeout);
1329 set_stream_write_other(r, write_action_pipe);
1330 break;
1331 case DIRECTION_OUTPUT:
1332 set_stream_write_fn(r, char_to_file);
1333 set_stream_write_other(r, write_action_file);
1334 set_stream_read_other(r, read_action_output_file);
1335 break;
1336 case DIRECTION_IO:
1337 set_stream_read_fn(r, char_from_file);
1338 set_stream_read_other(r, read_action_output_file);
1339 set_stream_write_fn(r, char_to_file);
1340 set_stream_write_other(r, write_action_file);
1341 break;
1342 }
1343 return onevalue(r);
1344 }
1345
Lwrs(LispObject env,LispObject a)1346 LispObject Lwrs(LispObject env, LispObject a)
1347 { LispObject old = qvalue(standard_output);
1348 if (a == nil) a = qvalue(terminal_io);
1349 if (a == old) return onevalue(old);
1350 else if (!is_stream(a)) return aerror1("wrs", a);
1351 else if ((character_stream_writer *)stream_write_fn(
1352 a) == char_to_illegal)
1353 #ifdef COMMON
1354 a = qvalue(terminal_io);
1355 #else
1356 return aerror("wrs (closed or input file)"); // closed file or input file
1357 #endif
1358 setvalue(standard_output, a);
1359 return onevalue(old);
1360 }
1361
Lclose(LispObject env,LispObject a)1362 LispObject Lclose(LispObject env, LispObject a)
1363 {
1364 //
1365 // I will not allow anybody to close the terminal streams
1366 //
1367 if (a == nil ||
1368 a == lisp_terminal_io) return onevalue(nil);
1369 else if (!is_stream(a)) return aerror1("close", a);
1370 if (a == qvalue(standard_input))
1371 setvalue(standard_input, lisp_terminal_io);
1372 else if (a == qvalue(standard_output))
1373 setvalue(standard_output, lisp_terminal_io);
1374 other_read_action(READ_CLOSE, a);
1375 other_write_action(WRITE_CLOSE, a);
1376 #ifdef COMMON
1377 return onevalue(lisp_true);
1378 #else
1379 return onevalue(nil);
1380 #endif
1381 }
1382
1383 #if defined HAVE_LIBFOX
1384 namespace FX
1385 {
1386 extern void *text;
1387 }
1388 #define GUI_TEST FX::text
1389 #endif
1390 #if defined HAVE_LIBWX
1391 extern void *panel;
1392 #define GUI_TEST panel
1393 #endif
1394
Lmath_display(LispObject env,LispObject a)1395 LispObject Lmath_display(LispObject env, LispObject a)
1396 {
1397 //
1398 // In all cases where maths display is not supported (ie if output is
1399 // not directly to a window that has been built with SHOWMATH
1400 // option) this returns nil and does not do anything at all exciting. If there
1401 // is the possibility of maths output the cases supported here are:
1402 //
1403 // nil ) Enquire if maths display is available, return T if so;
1404 // or 0 )
1405 // 1 Enquire if a spool file is present;
1406 // 2 Clear out maths display buffer ready to start a new line;
1407 // 3 Indicate that local maths buffer is now complete and pass
1408 // its contents (which may be several lines) to the front end
1409 // display engine.
1410 //
1411 #if defined HAVE_LIBFOX || defined HAVE_LIBWX
1412 if (a == nil || a == fixnum_of_int(0)) // test if showmath available
1413 {
1414 //
1415 // Disable maths specials if output is NOT to the terminal. Observe that often
1416 // standard_output will be a synonym for direct terminal access.
1417 //
1418 LispObject std = qvalue(standard_output);
1419 //
1420 // GUI_TEST is the FXTerminal object, or corresponding wxWidgets object.
1421 // If it is nullptr that means that I had selected non-windowed mode....
1422 //
1423 if (GUI_TEST == nullptr) return onevalue(nil);
1424 //
1425 // With CSL I have all these curious ways of ending up with standard output
1426 // redirected to elsewhere! In any such case I want this code to report "not
1427 // directly to a maths-aware window".
1428 //
1429 if (alternative_stdout != nullptr ||
1430 procedural_output != nullptr) return onevalue(nil);
1431 //
1432 // I allow for synonym streams (which are probably only used in Common Lisp
1433 // mode). I do NOT allow for broadcast streams. I then check if the current
1434 // output stream would end up executing char_to_terminal to write a character.
1435 //
1436 while ((character_stream_writer *)stream_write_fn(
1437 std) == char_to_synonym)
1438 std = stream_write_data(std);
1439 if ((character_stream_writer *)stream_write_fn(std) !=
1440 char_to_terminal) return onevalue(nil);
1441 //
1442 // Now I believe I am attached to a screen that can display maths.
1443 //
1444 return onevalue(lisp_true);
1445 }
1446 else if (a == fixnum_of_int(1)) // test if spool file in use
1447 {
1448 //
1449 // Note that I let this say TRUE if a spool file is in use regardless
1450 // of whether maths display is to be used...
1451 //
1452 if (spool_file == nullptr) return onevalue(nil);
1453 else return onevalue(lisp_true);
1454 }
1455 else if (a == fixnum_of_int(2)) // clear out local buffer
1456 { math_buffer_p = 0;
1457 if (math_buffer != nullptr) math_buffer[0] = 0;
1458 return onevalue(lisp_true);
1459 }
1460 else if (a == fixnum_of_int(3)) // display local buffer
1461 { if (math_buffer == nullptr ||
1462 math_buffer[0]==0) return onevalue(nil);
1463 fwin_showmath(math_buffer);
1464 math_buffer_p = 0;
1465 math_buffer[0] = 0;
1466 return onevalue(lisp_true);
1467 }
1468 else
1469 #endif
1470 return onevalue(nil); // bad arg, but just return nil
1471 }
1472
Ltruename(LispObject env,LispObject name)1473 LispObject Ltruename(LispObject env, LispObject name)
1474 { char filename[LONGEST_LEGAL_FILENAME];
1475 LispObject truename;
1476 size_t len = 0;
1477 const char *w = get_string_data(name, "truename", len);
1478 char *w1;
1479 std::memset(filename, 0, sizeof(filename));
1480 if (len >= sizeof(filename)) len = sizeof(filename);
1481
1482 w1 = get_truename(filename,w,len);
1483 if (w1 == nullptr) return aerror0(filename);
1484
1485 truename = make_string(w1);
1486 std::free(w1);
1487
1488 return onevalue(truename);
1489 }
1490
Lcreate_directory(LispObject env,LispObject name)1491 LispObject Lcreate_directory(LispObject env, LispObject name)
1492 { char filename[LONGEST_LEGAL_FILENAME];
1493 size_t len = 0;
1494 const char *w;
1495 std::memset(filename, 0, sizeof(filename));
1496 if (name == unset_var) return onevalue(nil);
1497 w = get_string_data(name, "create-directory", len);
1498 if (len >= sizeof(filename)) len = sizeof(filename);
1499 len = create_directory(filename, w, static_cast<size_t>(len));
1500 return onevalue(Lispify_predicate(len == 0));
1501 }
1502
Lfile_readable(LispObject env,LispObject name)1503 LispObject Lfile_readable(LispObject env, LispObject name)
1504 { char filename[LONGEST_LEGAL_FILENAME];
1505 size_t len = 0;
1506 const char *w = get_string_data(name, "file-readable", len);
1507 std::memset(filename, 0, sizeof(filename));
1508 if (len >= sizeof(filename)) len = sizeof(filename);
1509
1510 len = file_readable(filename, w, static_cast<size_t>(len));
1511 return onevalue(Lispify_predicate(len));
1512 }
1513
Lchange_directory(LispObject env,LispObject name)1514 LispObject Lchange_directory(LispObject env, LispObject name)
1515 { char filename[LONGEST_LEGAL_FILENAME];
1516 size_t len = 0;
1517 const char *err;
1518 const char *w;
1519 std::memset(filename, 0, sizeof(filename));
1520 if (name == unset_var) return onevalue(nil);
1521 w = get_string_data(name, "change-directory", len);
1522 if (len >= sizeof(filename)) len = sizeof(filename);
1523 err = change_directory(filename, w, static_cast<size_t>(len));
1524 if (err != nullptr) return aerror0(err);
1525 return onevalue(Lispify_predicate(err == nullptr));
1526 }
1527
Lfile_writeable(LispObject env,LispObject name)1528 LispObject Lfile_writeable(LispObject env, LispObject name)
1529 { char filename[LONGEST_LEGAL_FILENAME];
1530 size_t len = 0;
1531 const char *w;
1532 std::memset(filename, 0, sizeof(filename));
1533
1534 // First check whether file exists
1535 if (Lfilep(env,name) == nil) return nil;
1536
1537 w = get_string_data(name, "file-writable", len);
1538 if (len >= sizeof(filename)) len = sizeof(filename);
1539
1540 len = file_writeable(filename, w, static_cast<size_t>(len));
1541 return onevalue(Lispify_predicate(len));
1542 }
1543
Ldelete_file(LispObject env,LispObject name)1544 LispObject Ldelete_file(LispObject env, LispObject name)
1545 { char filename[LONGEST_LEGAL_FILENAME];
1546 size_t len = 0;
1547 const char *w;
1548 std::memset(filename, 0, sizeof(filename));
1549 if (name == unset_var) return onevalue(nil);
1550 w = get_string_data(name, "delete-file", len);
1551 if (len >= sizeof(filename)) len = sizeof(filename);
1552 len = delete_file(filename, w, static_cast<size_t>(len));
1553 return onevalue(Lispify_predicate(len == 0));
1554 }
1555
Ldelete_wildcard(LispObject env,LispObject name)1556 LispObject Ldelete_wildcard(LispObject env, LispObject name)
1557 { char filename[LONGEST_LEGAL_FILENAME];
1558 size_t len = 0;
1559 const char *w;
1560 std::memset(filename, 0, sizeof(filename));
1561 if (name == unset_var) return onevalue(nil);
1562 w = get_string_data(name, "delete-wildcard", len);
1563 if (len >= sizeof(filename)) len = sizeof(filename);
1564 len = delete_wildcard(filename, w, static_cast<size_t>(len));
1565 return onevalue(Lispify_predicate(len == 0));
1566 }
1567
1568 // Returns the length of a file in bytes
Lfile_length(LispObject env,LispObject name)1569 LispObject Lfile_length(LispObject env, LispObject name)
1570 { char filename[LONGEST_LEGAL_FILENAME];
1571 size_t len = 0;
1572 int64_t size;
1573 const char *w = get_string_data(name, "file-length", len);
1574 std::memset(filename, 0, sizeof(filename));
1575 if (len >= sizeof(filename)) len = sizeof(filename);
1576 size = file_length(filename, w, static_cast<size_t>(len));
1577 if (size < 0) return nil;
1578 else return make_lisp_integer64((int64_t)size);
1579 }
1580
Ldirectoryp(LispObject env,LispObject name)1581 LispObject Ldirectoryp(LispObject env, LispObject name)
1582 { char filename[LONGEST_LEGAL_FILENAME];
1583 size_t len = 0;
1584 const char *w = get_string_data(name, "directoryp", len);
1585 std::memset(filename, 0, sizeof(filename));
1586 if (len >= sizeof(filename)) len = sizeof(filename);
1587 len = directoryp(filename, w, static_cast<size_t>(len));
1588 return onevalue(Lispify_predicate(len));
1589 }
1590
1591
Lget_current_directory(LispObject env)1592 LispObject Lget_current_directory(LispObject env)
1593 { char filename[LONGEST_LEGAL_FILENAME];
1594 int len;
1595 std::memset(filename, 0, sizeof(filename));
1596 len = get_current_directory(filename, LONGEST_LEGAL_FILENAME);
1597 if (len == 0) return onevalue(nil);
1598 return onevalue(make_string(filename));
1599 }
1600
Luser_homedir_pathname(LispObject env)1601 LispObject Luser_homedir_pathname(LispObject env)
1602 { char home[LONGEST_LEGAL_FILENAME];
1603 int len;
1604 std::memset(home, 0, sizeof(home));
1605 len = get_home_directory(home, LONGEST_LEGAL_FILENAME);
1606 if (len == 0) return onevalue(nil);
1607 return onevalue(make_string(home));
1608 }
1609
Lget_lisp_directory(LispObject env)1610 LispObject Lget_lisp_directory(LispObject env)
1611 { char filename[LONGEST_LEGAL_FILENAME];
1612 int len;
1613 std::memset(filename, 0, sizeof(filename));
1614 std::strcpy(filename, standard_directory);
1615 len = std::strlen(filename);
1616 while (len-- > 0 &&
1617 filename[len] != '/' &&
1618 filename[len] != '\\');
1619 if (len == 0) return onevalue(nil);
1620 filename[len] = 0;
1621 return onevalue(make_string(filename));
1622 }
1623
Lfind_gnuplot(LispObject env)1624 LispObject Lfind_gnuplot(LispObject env)
1625 { char filename[LONGEST_LEGAL_FILENAME];
1626 char *s;
1627 find_gnuplot(filename);
1628 s = filename;
1629 //
1630 // Because the path will be used in a command I will put quote marks
1631 // around it so that embedded whitespace does not cause a calamity.
1632 //
1633 while (*s != 0) s++;
1634 *s++ = '"';
1635 *s = 0;
1636 while (s != filename)
1637 { *(s+1) = *s;
1638 s--;
1639 }
1640 s[1] = s[0];
1641 s[0] = '"';
1642 return onevalue(make_string(filename));
1643 }
1644
Lgetpid(LispObject env)1645 LispObject Lgetpid(LispObject env)
1646 {
1647 #ifdef WIN32
1648 return onevalue(fixnum_of_int(windowsGetPid()));
1649 #else
1650 return onevalue(fixnum_of_int(getpid()));
1651 #endif
1652 }
1653
Lrename_file(LispObject env,LispObject from,LispObject to)1654 LispObject Lrename_file(LispObject env, LispObject from,
1655 LispObject to)
1656 { char from_name[LONGEST_LEGAL_FILENAME],
1657 to_name[LONGEST_LEGAL_FILENAME];
1658 size_t from_len = 0, to_len = 0;
1659 const char *from_w, *to_w;
1660 std::memset(from_name, 0, sizeof(from_name));
1661 std::memset(to_name, 0, sizeof(to_name));
1662 if (from == unset_var) return onevalue(nil);
1663 if (to == unset_var) return onevalue(nil);
1664 { Save save(to);
1665 from_w = get_string_data(from, "rename-file", from_len);
1666 save.restore(to);
1667 }
1668 if (from_len >= sizeof(from_name)) from_len = sizeof(from_name);
1669 from = reinterpret_cast<LispObject>(from_w + TAG_VECTOR - CELL);
1670
1671 { Save save(from);
1672 to_w = get_string_data(to, "rename-file", to_len);
1673 save.restore(from);
1674 }
1675 from_w = reinterpret_cast<const char *>(&celt(from, 0));
1676 if (to_len >= sizeof(to_name)) to_len = sizeof(to_name);
1677
1678 to_len = rename_file(from_name, from_w, static_cast<size_t>(from_len),
1679 to_name, to_w, static_cast<size_t>(to_len));
1680 return onevalue(Lispify_predicate(to_len == 0));
1681 }
1682
1683 //
1684 // This function is a call-back from the file-scanning routine.
1685 //
1686
make_dir_list(string name,string leafname,int why,long int size)1687 static void make_dir_list(string name, string leafname, int why, long int size)
1688 { LispObject w = make_string(leafname.c_str());
1689 w = cons(w, *stack);
1690 *stack = w;
1691 }
1692
Llist_directory(LispObject env,LispObject name)1693 LispObject Llist_directory(LispObject env, LispObject name)
1694 { LispObject result;
1695 char filename[LONGEST_LEGAL_FILENAME];
1696 size_t len = 0;
1697 const char *w = get_string_data(name, "list-directory", len);
1698 std::memset(filename, 0, sizeof(filename));
1699 if (len >= sizeof(filename)) len = sizeof(filename);
1700 *++stack = nil;
1701 list_directory_members(&filename[0], w, len, make_dir_list);
1702 result = *stack--;
1703 return onevalue(nreverse(result));
1704 }
1705
1706
1707 /*****************************************************************************/
1708 // Printing.
1709 /*****************************************************************************/
1710
1711 int escaped_printing;
1712
1713 //
1714 // I should make WRS save tmprint_flag so that it always refers to
1715 // a setting of the stream currently in use, ie active_stream. That should
1716 // not be hard but I will do it later. @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
1717 //
1718 int tmprint_flag = 0;
1719
outprefix(bool blankp,int32_t len)1720 static void outprefix(bool blankp, int32_t len)
1721 //
1722 // This function takes most of the responsibility for splitting lines.
1723 // when called we are about to print an item with (len) characters.
1724 // If blankp is true we need to display a blank or newline before
1725 // the item.
1726 //
1727 { int32_t line_length =
1728 other_write_action(WRITE_GET_INFO+WRITE_GET_LINE_LENGTH,
1729 active_stream);
1730 int32_t column =
1731 other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
1732 active_stream);
1733 if (blankp) len++;
1734 if (column+len > line_length &&
1735 (escaped_printing & escape_nolinebreak) == 0 &&
1736 !tmprint_flag)
1737 putc_stream('\n', active_stream);
1738 else if (blankp) putc_stream(' ', active_stream);
1739 }
1740
Lprint_precision(LispObject env,LispObject a)1741 static LispObject Lprint_precision(LispObject env, LispObject a)
1742 { int32_t old = print_precision;
1743 if (a == nil) return onevalue(fixnum_of_int(old));
1744 if (!is_fixnum(a)) return aerror1("print-precision", a);
1745 print_precision = int_of_fixnum(a);
1746 if (print_precision > 36) print_precision = 36;
1747 else if (print_precision < 1) print_precision = 15;
1748 return onevalue(fixnum_of_int(old));
1749 }
1750
Lget_precision(LispObject env)1751 static LispObject Lget_precision(LispObject env)
1752 { return onevalue(fixnum_of_int(print_precision));
1753 }
1754
prin_buf(char * buf,int blankp)1755 static void prin_buf(char *buf, int blankp)
1756 { int len = std::strlen(buf), i;
1757 outprefix(blankp, len);
1758 for (i=0; i<len; i++)
1759 { putc_stream(*buf++, active_stream);
1760 }
1761 }
1762
1763 //
1764 // I want the floating point print style that I use to match the
1765 // one used by PSL rather carefully. So here is some code so that
1766 // everything I do about it is in one place.
1767 //
1768
1769
1770 //
1771 // Two crummy little functions to delete and insert chars from strings.
1772 //
1773
char_del(char * s)1774 static void char_del(char *s)
1775 { while (*s != 0)
1776 { *s = *(s+1);
1777 s++;
1778 }
1779 }
1780
char_ins(char * s,int c)1781 static void char_ins(char *s, int c)
1782 { char *p = s;
1783 while (*p != 0) p++;
1784 while (p != s)
1785 { *(p+1) = *p;
1786 p--;
1787 }
1788 *(s+1) = *s;
1789 *s = c;
1790 // printf("After char_ins \"%s\"\n", s);
1791 }
1792
fp_sprint(char * buff,double x,int prec,int xmark)1793 static void fp_sprint(char *buff, double x, int prec, int xmark)
1794 {
1795 // Note that I am assuming IEEE arithmetic here so the tricks that I use
1796 // to detect -0.0, NaN and infinities ought to be OK. Just remember that
1797 // -0.0 is equal to 0.0 and not less than it, so the simple test
1798 // "x < 0.0" will not pick up the case of -0.0.
1799 if (x == 0.0)
1800 { if (xmark != 'e')
1801 { if (1.0/x < 0.0) std::sprintf(buff, "-0.0%c+00", xmark);
1802 else std::sprintf(buff, "0.0%c+00", xmark);
1803 }
1804 else if (1.0/x < 0.0) std::strcpy(buff, "-0.0");
1805 else std::strcpy(buff, "0.0");
1806 return;
1807 }
1808 if (x != x)
1809 { std::strcpy(buff,
1810 "NaN"); // The length of the NaN will not be visible
1811 return;
1812 }
1813 if (x == 2.0*x)
1814 { if (x < 0.0) std::strcpy(buff,
1815 "minusinf"); // Length of infinity not shown.
1816 else std::strcpy(buff, "inf");
1817 return;
1818 }
1819 // Limit the precision used for printing based on the type of float involved.
1820 switch (xmark)
1821 { case 's': case 'S':
1822 if (prec > 7) prec = 7;
1823 break;
1824 case 'f': case 'F':
1825 if (prec > 8) prec = 8;
1826 break;
1827 default:
1828 if (prec > 17) prec = 17;
1829 }
1830 if (x < 0.0)
1831 { *buff++ = '-';
1832 x = -x;
1833 }
1834 // Now I just have strictly positive values to worry about
1835 std::sprintf(buff, "%.*g", prec, x);
1836 // I will allow for pathologically bad versions of sprintf...
1837 if (*buff == '+') char_del(buff); // Explicit "+" not wanted
1838 if (*buff == '.') char_ins(buff, '0'); // turn .nn to 0.nn
1839 else if (*buff == 'e') // turn Ennn to 0.0Ennn
1840 { char_ins(buff, '0');
1841 char_ins(buff, '.');
1842 char_ins(buff, '0');
1843 }
1844 // I now have at lesst one digit before any "." or "E"
1845 while (*buff != 0 && *buff != '.' && *buff != 'e') buff++;
1846 if (*buff == 'e') *buff = xmark; // force style of exponent mark
1847 if (*buff == 0 || *buff == xmark) // ddd to ddd.0
1848 { char_ins(buff, '0'); // and dddEnnn to ddd.0Ennn
1849 char_ins(buff, '.');
1850 }
1851 // I now have a "." in there
1852 while (*buff != 0 && *buff != 'e' && *buff != xmark) buff++;
1853 if (*(buff-1) == '.') char_ins(buff++, '0');// ddd. to ddd.0
1854 while (*(buff-1) == '0' && // ddd.nnn0 to ddd.nnn
1855 *(buff-2) != '.') char_del(--buff);
1856 if (*buff == 0)
1857 { if (xmark != 'e')
1858 { *buff++ = xmark;
1859 *buff++ = '+';
1860 *buff++ = '0';
1861 *buff++ = '0';
1862 *buff = 0;
1863 }
1864 return; // no E present. Add exponent mark if not default type
1865 }
1866 if (xmark != 'e') *buff = xmark;
1867 buff++;
1868 // At this stage I am looking at the exponent part
1869 if (*buff == 0) std::strcpy(buff, "+00");
1870 else if (std::isdigit(static_cast<unsigned char>(*buff)))
1871 char_ins(buff, '+');
1872 // Exponent should now start with explicit + or - sign
1873 buff++;
1874 // Force exponent to have at least 2 digits
1875 if (*(buff+1) == 0) char_ins(buff, '0');
1876 // Three-digit exponent with leading zero gets trimmed here
1877 else if (*buff == '0' && *(buff+2) != 0) char_del(buff);
1878 }
1879
1880 #ifdef HAVE_SOFTFLOAT
fp_sprint128(char * buff,float128_t x,int prec,int xchar)1881 static void fp_sprint128(char *buff, float128_t x, int prec,
1882 int xchar)
1883 { if (f128M_eq(&x, &f128_0))
1884 { if (f128M_negative(&x)) std::strcpy(buff, "-0.0L+00");
1885 else std::strcpy(buff, "0.0L+00");
1886 return;
1887 }
1888 if (f128M_nan(&x))
1889 { std::strcpy(buff, "NaN");
1890 return;
1891 }
1892 if (f128M_infinite(&x))
1893 { if (f128M_negative(&x)) std::strcpy(buff, "minusinf");
1894 else std::strcpy(buff, "inf");
1895 return;
1896 }
1897 if (f128M_negative(&x))
1898 { *buff++ = '-';
1899 f128M_negate(&x);
1900 }
1901 if (prec > 36) prec = 36;
1902 f128M_sprint_G(buff, 0, prec, &x);
1903 // printf("Raw printing gives \"%s\"\n", buff);
1904 //
1905 // I rather hope that my own print routine is not degenerate so some of
1906 // these fix-ups are not necessary, but I will leave them in just to be
1907 // really safe.
1908 if (*buff == '+') char_del(buff); // Explicit "+" not wanted
1909 if (*buff == '.') char_ins(buff, '0'); // turn .nn to 0.nn
1910 // Common Lisp can use "l" or "L" as the exponent marker in a long float,
1911 // so in the processing here I will detect "l" just in case at a later
1912 // stage I move to adopting that as a print convention.
1913 #define exponent_mark(c) ((c)=='e' || (c)=='l')
1914 else if (exponent_mark(*buff)) // turn Ennn to 0.0Ennn
1915 { *buff = 'L';
1916 char_ins(buff, '0');
1917 char_ins(buff, '.');
1918 char_ins(buff, '0');
1919 }
1920 while (*buff != 0 && *buff != '.' && !exponent_mark(*buff)) buff++;
1921 if (*buff == 0 || exponent_mark(*buff)) // ddd to ddd.0
1922 { char_ins(buff, '0'); // and dddEnnn to ddd.0Ennn
1923 char_ins(buff, '.');
1924 }
1925 while (*buff != 0 && !exponent_mark(*buff)) buff++;
1926 if (*(buff-1) == '.') char_ins(buff++, '0');// ddd. to ddd.0
1927 while (*(buff-1) == '0' && // ddd.nnn0 to ddd.nnn
1928 *(buff-2) != '.') char_del(--buff);
1929 if (*buff == 0)
1930 { *buff++ = 'L';
1931 *buff++ = '+';
1932 *buff++ = '0';
1933 *buff++ = '0';
1934 *buff = 0;
1935 return; // no exponent mark present
1936 }
1937 *buff = 'L';
1938 buff++;
1939 if (*buff == 0) std::strcpy(buff, "+00");
1940 else if (std::isdigit(static_cast<unsigned char>(*buff)))
1941 char_ins(buff, '+');
1942 buff++;
1943 if (*(buff+1) == 0) char_ins(buff, '0');
1944 else if (*buff == '0' && *(buff+2) != 0) char_del(buff);
1945 }
1946 #endif // HAVE_SOFTFLOAT
1947
1948 static int32_t local_gensym_count;
1949
1950 //
1951 // This checks if the sequence in the string starting at offset k is
1952 // of the form "WORD;" where WORD is made up of just alphanumerics.
1953 //
maybemagic(LispObject v,int k,int len)1954 static int maybemagic(LispObject v, int k, int len)
1955 { while (k<len)
1956 { int c = celt(v, k) & 0xff;
1957 if (c == ';') return 1;
1958 else if ((c & 0x80) != 0 ||
1959 !std::isalnum(c)) return 0;
1960 k++;
1961 }
1962 return 0;
1963 }
1964
1965 static const char *hexdig = "0123456789abcdef";
1966
putc_utf8(int n)1967 static void putc_utf8(int n)
1968 { n &= 0x001fffff;
1969 if (n <= 0x7f)
1970 { putc_stream(n, active_stream);
1971 return;
1972 }
1973 else if (n <= 0x7ff)
1974 { putc_stream(0xc0 + (n>>6), active_stream);
1975 putc_stream(0x80 + (n & 0x3f), active_stream);
1976 }
1977 else if (n <= 0xffff)
1978 { putc_stream(0xe0 + (n>>12), active_stream);
1979 putc_stream(0x80 + ((n>>6) & 0x3f), active_stream);
1980 putc_stream(0x80 + (n & 0x3f), active_stream);
1981 }
1982 else
1983 { putc_stream(0xf0 + (n>>16), active_stream);
1984 putc_stream(0x80 + ((n>>12) & 0x3f), active_stream);
1985 putc_stream(0x80 + ((n>>6) & 0x3f), active_stream);
1986 putc_stream(0x80 + (n & 0x3f), active_stream);
1987 }
1988 }
1989
internal_prin(LispObject uu,int blankp)1990 LispObject internal_prin(LispObject uu, int blankp)
1991 { LispObject w;
1992 size_t len, lenchars, k;
1993 char my_buff[128];
1994 int bl = blankp & 2;
1995 RealSave save(uu);
1996 LispObject &u = save.val(1);
1997 #ifdef COMMON
1998 //
1999 // There is a fairly shameless FUDGE here. When I come to need to print
2000 // the package part of a symbol as in ppp:xxx (or even |)p(|::|.| if I
2001 // have names with silly characters in them) I will have a STRING that is the
2002 // name of the relevant package, but I want it displayed as if it was an
2003 // identifier. I achieve this by setting the "2" bit in blankp (which is
2004 // otherwise a simple boolean), and when this is detected I go and join the
2005 // code for printing symbols. But in that case I MUST have been passed
2006 // a (simple) string, or else things can collapse utterly.
2007 //
2008 blankp &= 1;
2009 if (bl != 0)
2010 { w = u;
2011 goto tag_symbol;
2012 }
2013 restart:
2014 #endif
2015 if (stack >= stackLimit) respond_to_stack_event();
2016 switch (static_cast<int>(u) & TAG_BITS)
2017 { case TAG_CONS:
2018 #ifdef COMMON
2019 if (u == nil) // BEWARE - nil is tagged as a cons cell
2020 { outprefix(blankp, 3);
2021 putc_stream('N', active_stream);
2022 putc_stream('I', active_stream);
2023 putc_stream('L', active_stream);
2024 return;
2025 }
2026 #endif
2027 if (u == 0)
2028 { outprefix(blankp, 2);
2029 putc_stream('?', active_stream);
2030 putc_stream('?', active_stream);
2031 return nil;
2032 }
2033 // This use of the stack is clumsy and when I have the conservative
2034 // GC stable I can clean it up. However for now the reyeared reference
2035 // to stack[0] makes it hard to clean away.
2036 outprefix(blankp, 1);
2037 putc_stream('(', active_stream);
2038 internal_prin(car(stack[0]), 0);
2039 w = u;
2040 while (is_cons(w = cdr(w)) && w != 0)
2041 {
2042 #ifdef COMMON
2043 if (w == nil) break; // Again BEWARE the tag code of NIL
2044 #endif
2045 u = w;
2046 internal_prin(car(w), 1);
2047 w = u;
2048 }
2049 if (w != nil)
2050 { u = w;
2051 outprefix(true, 1);
2052 putc_stream('.', active_stream);
2053 internal_prin(u, 1);
2054 }
2055 outprefix(false, 1);
2056 putc_stream(')', active_stream);
2057 return nil;
2058
2059 case TAG_FIXNUM:
2060 // The tag bits for a short float match those for a fixnum if I just look
2061 // at the low 3 bits. Yuk - that means I need an extra test here.
2062 if (is_sfloat(u))
2063 { Float_union uu;
2064 // The following passes the correct value for either 28 or 32-bit floats.
2065 int xmark = 's';
2066 if (SIXTY_FOUR_BIT)
2067 { uu.i = (int32_t)((int64_t)u>>32);
2068 if ((u & XTAG_FLOAT32) != 0) xmark = 'f';
2069 }
2070 else uu.i = u - XTAG_SFLOAT;
2071 if (escaped_printing & escape_hex)
2072 { std::sprintf(my_buff, "%.8x%c", uu.i, xmark);
2073 goto float_print_tidyup;
2074 }
2075 else if (escaped_printing & escape_octal)
2076 { std::sprintf(my_buff, "%.11o%c", uu.i, xmark);
2077 goto float_print_tidyup;
2078 }
2079 else if (escaped_printing & escape_binary)
2080 { char *cp = my_buff;
2081 for (int b=31; b>=0; b--)
2082 *cp++ = '0' + ((uu.i >> b) & 1);
2083 *cp++ = xmark;
2084 *cp = 0;
2085 goto float_print_tidyup;
2086 }
2087
2088 fp_sprint(my_buff, static_cast<double>(uu.f), print_precision, xmark);
2089 goto float_print_tidyup;
2090 }
2091 if (escaped_printing & escape_hex)
2092 { intptr_t v = int_of_fixnum(u);
2093 int width = escape_width(escaped_printing);
2094 uintptr_t mask;
2095 //
2096 // The printing style adopted here for negative numbers follows that used in
2097 // the big number printing code. A prefix "~" stands for an infinite initial
2098 // string of 'f' digits, and what follows will be exactly one 'f' (just to
2099 // remind you) and then the remaining hex digits. E.g. -2 should display
2100 //1;5q as ~fe. Note that any fixnum will start off with 0xf in the top 4 of
2101 // 32 bits. If an explicit width had been specified then I want that many
2102 // charcters to be displayed, with full leading zeros etc. A width is taken as
2103 // minimum number of chars to be displayed, so a width of zero (or in fact 1)
2104 // would have the effect of no constraint. The width-specification field
2105 // only allows for the range 0 to 63, and that is just as well since I put
2106 // characters in a buffer (my_buff) which would almost fill up at the
2107 // widest...
2108 //
2109 len = 0;
2110 if (v < 0)
2111 { mask = ((uintptr_t)0xf)<<(8*sizeof(intptr_t)-4);
2112 my_buff[len++] = '~';
2113 width--;
2114 while (((uintptr_t)v & mask) == mask && mask != 0)
2115 { v = v ^ (mask << 4);
2116 mask = mask >> 4;
2117 }
2118 k = 'f';
2119 }
2120 else k = '0';
2121 mask = 0xf;
2122 while (((uintptr_t)v & mask) != (uintptr_t)v)
2123 { width--;
2124 mask = (mask<<4) | 0xf;
2125 }
2126 while (--width > 0) my_buff[len++] = static_cast<char>(k);
2127 std::sprintf(&my_buff[len], "%" PRIx64,
2128 static_cast<int64_t>(v));
2129 }
2130 else if (escaped_printing & escape_octal)
2131 { intptr_t v = int_of_fixnum(u);
2132 int width = escape_width(escaped_printing);
2133 uintptr_t mask;
2134 len = 0;
2135 if (v < 0)
2136 { int sh = 8*sizeof(intptr_t)-3;
2137 sh = (sh/3)*3;
2138 mask = ((uintptr_t)0x7)<<sh;
2139 my_buff[len++] = '~';
2140 width--;
2141 while (((uintptr_t)v & mask) == mask && mask != 0)
2142 { v = v ^ (mask << 3);
2143 mask = mask >> 3;
2144 }
2145 k = '7';
2146 }
2147 else k = '0';
2148 mask = 0x7;
2149 while (((uintptr_t)v & mask) != (uintptr_t)v)
2150 { width--;
2151 mask = (mask<<3) | 0x7;
2152 }
2153 while (--width > 0) my_buff[len++] = static_cast<char>(k);
2154 std::sprintf(&my_buff[len], "%" PRIo64,
2155 static_cast<int64_t>(v));
2156 }
2157 else if (escaped_printing & escape_binary)
2158 { intptr_t v = int_of_fixnum(u);
2159 // int width = escape_width(escaped_printing);
2160 uint64_t mask = ((uint64_t)1)<<(8*sizeof(intptr_t)-1);
2161 len = 0;
2162 if (v < 0)
2163 { while (((uintptr_t)v & mask) == mask && mask != 0)
2164 { v = v ^ (mask << 1);
2165 mask = mask >> 1;
2166 }
2167 my_buff[len++] = '~';
2168 k = '1';
2169 }
2170 else k = '0';
2171 //
2172 // /* Width specifier not processed here (yet), sorry.
2173 //
2174 mask = ((uintptr_t)1)<<(8*sizeof(intptr_t)-1);
2175 while (((uintptr_t)v & mask) == 0 && mask != 1) mask = mask >> 1;
2176 while (mask != 0)
2177 { my_buff[len++] = ((uintptr_t)v & mask) ? '1' : '0';
2178 mask = mask >> 1;
2179 }
2180 my_buff[len] = 0;
2181 }
2182 else
2183 std::sprintf(my_buff, "%" PRId64,
2184 static_cast<int64_t>(int_of_fixnum(u)));
2185 break;
2186
2187 case TAG_HDR_IMMED:
2188 //
2189 // A SPID is an object used internally by CSL in various places, and the
2190 // rules of the system are that it ought never to be visible to the user.
2191 // I print it here in case it arises because of a bug, or while I am testing.
2192 // For instance if I display the internal components of a hash table or
2193 // values passed around when optional arguments are being handled some of
2194 // these may arise.
2195 if (is_spid(u))
2196 { switch (u & 0xffff)
2197 {
2198 //
2199 // The decoding of readable names for SPIDs here is somewhat over the top
2200 // except while somebdy is hard at work debugging....
2201 //
2202 case SPID_NIL: std::strcpy(my_buff, "SPID_NIL"); break;
2203 case SPID_FBIND: std::strcpy(my_buff, "SPID_FBIND"); break;
2204 case SPID_CATCH: std::strcpy(my_buff, "SPID_CATCH"); break;
2205 case SPID_PROTECT: std::strcpy(my_buff, "SPID_PROTECT"); break;
2206 case SPID_NOARG: std::strcpy(my_buff, "SPID_NOARG"); break;
2207 // SPID_HASHEMPTY and SPID_HASHTOMB should only appear within hash tables,
2208 // and I do not expect to be able to re-read those. I will use concise
2209 // representations for them.
2210 case SPID_HASHEMPTY:std::strcpy(my_buff, "~"); break;
2211 case SPID_HASHTOMB:std::strcpy(my_buff, "+"); break;
2212 case SPID_GCMARK: std::strcpy(my_buff, "SPID_GCMARK"); break;
2213 case SPID_NOINPUT: std::strcpy(my_buff, "SPID_NOINPUT"); break;
2214 case SPID_ERROR: u = (u >> 20) & 0xfff;
2215 std::sprintf(my_buff, "SPID_ERROR_%x",
2216 static_cast<int>(u));
2217 break;
2218 case SPID_PVBIND: std::strcpy(my_buff, "SPID_PVBIND"); break;
2219 case SPID_NOPROP: std::strcpy(my_buff, "SPID_NOPROP"); break;
2220 case SPID_LIBRARY: u = (u >> 20) & 0xfff;
2221 // When I print the name of a library I will truncate the displayed name
2222 // to 124 characters. This is somewhat arbitrary (but MUST relate to the
2223 // size of my_buff), but will tend to keep output more compact.
2224 if (fasl_files[u].name == nullptr)
2225 std::sprintf(my_buff, "#{%.124s}", "*unknown*");
2226 else std::sprintf(my_buff, "#{%.124s}",
2227 fasl_files[u].name);
2228 break;
2229 default: std::sprintf(my_buff, "SPID_%lx",
2230 static_cast<long>((u >> 8) & 0x00ffffff));
2231 break;
2232 }
2233 len = std::strlen(my_buff);
2234 outprefix(blankp, len);
2235 for (k=0; k<len; k++) putc_stream(my_buff[k], active_stream);
2236 return nil;
2237 }
2238 //
2239 // Assume if is a CHAR here. I may need to think hard about Unicode and utf8
2240 // here...
2241 //
2242 outprefix(blankp, escaped_printing & escape_yes ? 3 : 1);
2243 if (u != CHAR_EOF)
2244 // I know that a char is immediate data and so does not need GC protection
2245 { if (escaped_printing & escape_yes)
2246 putc_stream('#', active_stream), putc_stream('\\', active_stream);
2247 putc_stream(static_cast<int>(code_of_char(u)), active_stream);
2248 }
2249 return nil;
2250
2251 case TAG_VECTOR:
2252 { Header h = vechdr(u);
2253 len = length_of_header(h) - CELL; // counts in bytes
2254 #ifdef COMMON
2255 print_non_simple_string:
2256 #endif
2257 switch (type_of_header(h))
2258 { case TYPE_BPS_1:
2259 case TYPE_BPS_2:
2260 case TYPE_BPS_3:
2261 case TYPE_BPS_4:
2262 len = length_of_byteheader(h) - CELL;
2263 outprefix(blankp, 3+2*len);
2264 //
2265 // At some stage I should look at all the special notations that use "#"
2266 // and ensure that none clash. Well here we go...
2267 // #Gnnn gensym I note that no HTML5 entity names would clash!
2268 // #< closures etc
2269 // #[xxx] odds
2270 // #{...} SPID_LIBRARY
2271 // #\dd character
2272 // #P: structure
2273 // #S( another variant on structure
2274 // #H( hash table
2275 // #( simple vector
2276 // #F[ stream
2277 // #1[ mixed1
2278 // #2[ mixed2
2279 // #3[ mixed3
2280 // #V8( vec of bytes
2281 // #V16( vec of shorts
2282 // #V32( vec of 32-bit ints
2283 // #FS( vec of floats
2284 // #FD( vec of double
2285 // #* bit-vector
2286 // #: package info
2287 // #C( complex num
2288 // #word; )
2289 // #Udigits; ) extended input symbol
2290 // #hexdigs; )
2291 // #Xhexdigs; )
2292 //
2293 putc_stream('#', active_stream);
2294 putc_stream('[', active_stream);
2295 for (k = 0; k < len; k++)
2296 { int ch = celt(stack[0], k);
2297 //
2298 // Code vectors are not ever going to be re-readable (huh - I suppose there
2299 // is no big reason why they should not be!) so I split them across multiple
2300 // lines if that seems useful. Anyway a reader for them could understand to
2301 // expect that.
2302 //
2303 outprefix(false, 2);
2304 putc_stream(hexdig[(ch >> 4) & 0xf], active_stream);
2305 putc_stream(hexdig[ch & 0xf], active_stream);
2306 }
2307 putc_stream(']', active_stream);
2308 return nil;
2309
2310 case TYPE_STRING_1:
2311 case TYPE_STRING_2:
2312 case TYPE_STRING_3:
2313 case TYPE_STRING_4:
2314 len = length_of_byteheader(h) - CELL;
2315 { int32_t slen = 0;
2316 // /*
2317 // Getting the width of strings that contain tabs correct here is
2318 // something I have not yet attempted - the width to be accumulated in
2319 // slen has to depend on the column at which printing is to start
2320 // (including allowance for any pending blank that may be needed).
2321 // And while I consider this, what about a string that contains
2322 // a newline character?
2323 //
2324 if (escaped_printing & escape_yes)
2325 { for (k = 0; k < len; k++)
2326 { int ch = celt(stack[0], k) & 0xff;
2327 //
2328 // See later for an explanation of the extra lengths indicated here...
2329 // but in short they are for #xxxx; and #xxxxxx;
2330 // Under cygwin (and potentially on other platforms in certain locales)
2331 // case folding can change the number of utf-bytes or hex characters
2332 // needed to specify a character. To avoid potential pain I will
2333 // always display using at least 4 hex digits.
2334 //
2335 if ((ch & 0xc0) == 0x80) /* nothing */;
2336 else if ((ch & 0xe0) == 0xc0) slen += 6;
2337 else if ((ch & 0xf0) == 0xe0) slen += 6;
2338 else if ((ch & 0x80) == 0x80) slen += 8;
2339 else if (ch == '"') slen += 2;
2340 else if (ch == '#' &&
2341 maybemagic(stack[0], k+1, len))
2342 slen += 6; // render as #hash;WORD;
2343 #ifdef COMMON
2344 else if (ch == '\\') slen += 2;
2345 //
2346 // I now guard this with "#ifdef COMMON". It is associated with displaying
2347 // control characters within strings as escapes, as in a newline within a
2348 // string being printed as \0a. Unless the code that reads strings back in
2349 // understands the same conventions this is a mistake, and the Standard Lisp
2350 // reader (and the reader in Reduce) do not... However Reduce does now
2351 // understand things like #NewLine; and #0a; so I should use that notation!
2352 // Any character in the range u+00 to u+1f can be rendered as #xx;
2353 //
2354 else if (std::iscntrl(ch)) slen += 3;
2355 #else
2356 else if (ch <= 0x1f) slen += 4;
2357 #endif
2358 else slen += 1;
2359 }
2360 slen += 2;
2361 }
2362 else
2363 { for (k=0; k < len; k++)
2364 if ((celt(stack[0], k) & 0xc0) != 0x80) slen++;
2365 }
2366 outprefix(blankp, slen);
2367 //
2368 // I will write out the fast, easy, common case here, ie "princ" where
2369 // I do not have to do anything special with odd characters.
2370 //
2371 if (!(escaped_printing &
2372 (escape_yes | escape_fold_down |
2373 escape_fold_up | escape_capitalize)))
2374 { for (k = 0; k < len; k++)
2375 { int ch = celt(stack[0], k);
2376 putc_stream(ch, active_stream);
2377 }
2378 }
2379 else
2380 { if (escaped_printing & escape_yes)
2381 putc_stream('"', active_stream);
2382 for (k = 0; k < len; k++)
2383 { int ch = celt(stack[0], k) & 0xff;
2384 #ifdef COMMON
2385 //
2386 // In Common Lisp mode I do something special with '"' and '\', and
2387 // any control characters get mapped onto an escape sequence.
2388 //
2389 const char *hexdig = "0123456789abcdef";
2390 if ((escaped_printing & escape_yes) &&
2391 (ch == '"' || ch == '\\'))
2392 { putc_stream('\\', active_stream);
2393 putc_stream(ch, active_stream);
2394 }
2395 else if (ch <= 0xff && std::iscntrl(ch))
2396 { putc_stream('\\', active_stream);
2397 putc_stream(hexdig[(ch >> 4) & 0xf], active_stream);
2398 putc_stream(hexdig[ch & 0xf], active_stream);
2399 }
2400 #else
2401 //
2402 // In Standard Lisp mode when I get a '"' I print two doublequote. And that
2403 // will be the only special case! Well no - I will print control characters
2404 // in the form #xx; in escaped mode.
2405 //
2406 if ((escaped_printing & escape_yes) && ch == '"')
2407 { putc_stream('"', active_stream);
2408 putc_stream('"', active_stream);
2409 }
2410 #endif
2411 //
2412 // If a string contains text like "...#WORD;..." where WORD could possibly
2413 // be something decoded specially on re-input then the output here will
2414 // be rendered as "...#hash;WORD;..." which will defeat the #-introduced
2415 // sequence from being treated as something that represents an extended
2416 // character.
2417 //
2418 else if (ch == '#' &&
2419 maybemagic(stack[0], k+1, len))
2420 { putc_stream('#', active_stream);
2421 putc_stream('h', active_stream);
2422 putc_stream('a', active_stream);
2423 putc_stream('s', active_stream);
2424 putc_stream('h', active_stream);
2425 putc_stream(';', active_stream);
2426 }
2427 //
2428 // The first byte of any multi-byte utf-8 sequence will be a code that is
2429 // at least 0xc0. In such cases I will represent the wide character as
2430 // one of #xxx;, #xxxx; or #xxxxxx; depending on how many bytes were used.
2431 // in some cases that will leave a leading zero in the representation. Or
2432 // if I am not displaying with escape_yes I just need to case fold it.
2433 // Well if I am doing an EXPLODE then this adjustment is not called for.
2434 //
2435 else if (ch >= 0xc0)
2436 { int32_t n = 0;
2437 if ((ch & 0xe0) == 0xc0) // 2 byte
2438 { n = ch & 0x1f;
2439 k++;
2440 ch = celt(stack[0], k);
2441 n = (n << 6) | (ch & 0x3f);
2442 //
2443 // There is a portability issue here. ON some platforms (and perhaps with
2444 // some locales set) you may find (for instance) case conversion between
2445 // small; and large Greek letters (as in the TeX notation \gamma vd \Gamma),
2446 // while in others only basic Latin characters will get case converted. This
2447 // effect may show up in the utf8-in-list regression test.
2448 //
2449 if (escaped_printing & escape_fold_down)
2450 n = std::towlower(n);
2451 else if (escaped_printing & escape_fold_up)
2452 n = std::towupper(n);
2453 if ((escaped_printing & escape_yes) &&
2454 !(escaped_printing & escape_exploding))
2455 { putc_stream('#', active_stream);
2456 // This first digit is very often redundant here
2457 putc_stream(hexdig[(n>>12)&0xf], active_stream);
2458 putc_stream(hexdig[(n>>8)&0xf], active_stream);
2459 putc_stream(hexdig[(n>>4)&0xf], active_stream);
2460 putc_stream(hexdig[n&0xf], active_stream);
2461 putc_stream(';', active_stream);
2462 }
2463 else putc_utf8(n);
2464 }
2465 else if ((ch & 0xf0) == 0xe0) // 3 byte
2466 { n = ch & 0x0f;
2467 k++;
2468 ch = celt(stack[0], k);
2469 n = (n << 6) | (ch & 0x3f);
2470 k++;
2471 ch = celt(stack[0], k);
2472 n = (n << 6) | (ch & 0x3f);
2473 if (escaped_printing & escape_fold_down)
2474 n = std::towlower(n);
2475 else if (escaped_printing & escape_fold_up)
2476 n = std::towupper(n);
2477 if ((escaped_printing & escape_yes) &&
2478 !(escaped_printing & escape_exploding))
2479 { putc_stream('#', active_stream);
2480 putc_stream(hexdig[(n>>12)&0xf], active_stream);
2481 putc_stream(hexdig[(n>>8)&0xf], active_stream);
2482 putc_stream(hexdig[(n>>4)&0xf], active_stream);
2483 putc_stream(hexdig[n&0xf], active_stream);
2484 putc_stream(';', active_stream);
2485 }
2486 else putc_utf8(n);
2487 }
2488 else // assume 4 byte
2489 { n = ch & 0x07;
2490 k++;
2491 ch = celt(stack[0], k);
2492 n = (n << 6) | (ch & 0x3f);
2493 k++;
2494 ch = celt(stack[0], k);
2495 n = (n << 6) | (ch & 0x3f);
2496 k++;
2497 ch = celt(stack[0], k);
2498 n = (n << 6) | (ch & 0x3f);
2499 //
2500 // When case folding if the code-point is beyond U+ffff and I am on a machine
2501 // where sizeof(wchar_t) is 2 (eg Windows) I will not case fold. Gosh that
2502 // seems an obscure situation!
2503 //
2504 if (sizeof(wchar_t) == 4 || n < 0x10000)
2505 { if (escaped_printing & escape_fold_down)
2506 n = std::towlower(n);
2507 else if (escaped_printing & escape_fold_up)
2508 n = std::towupper(n);
2509 }
2510 if ((escaped_printing & escape_yes) &&
2511 !(escaped_printing & escape_exploding))
2512 { putc_stream('#', active_stream);
2513 putc_stream(hexdig[(n>>20)&0xf], active_stream);
2514 putc_stream(hexdig[(n>>16)&0xf], active_stream);
2515 putc_stream(hexdig[(n>>12)&0xf], active_stream);
2516 putc_stream(hexdig[(n>>8)&0xf], active_stream);
2517 putc_stream(hexdig[(n>>4)&0xf], active_stream);
2518 putc_stream(hexdig[n&0xf], active_stream);
2519 putc_stream(';', active_stream);
2520 }
2521 else putc_utf8(n);
2522 }
2523 }
2524 else
2525 //
2526 // Here I have a character in the range u+0000 to u+007f.
2527 //
2528 { if (escaped_printing & escape_fold_down)
2529 ch = std::tolower(ch);
2530 else if (escaped_printing & escape_fold_up)
2531 ch = std::toupper(ch);
2532 // Just For Now I Will Not Implement The Option To Capitalize Things
2533 putc_stream(ch, active_stream);
2534 }
2535 }
2536 }
2537 if (escaped_printing & escape_yes)
2538 putc_stream('"', active_stream);
2539 }
2540 return nil;
2541
2542 case TYPE_SP:
2543 std::sprintf(my_buff, "#<closure: %p>",
2544 reinterpret_cast<void *>(static_cast<LispObject>(elt(u, 0))));
2545 goto print_my_buff;
2546
2547 #if 0
2548 case TYPE_MAPLEREF:
2549 #endif
2550 case TYPE_FOREIGN:
2551 case TYPE_ENCAPSULATE:
2552 std::sprintf(my_buff, "#<encapsulated pointer: %p>",
2553 *(void **)&elt(u, 0));
2554 goto print_my_buff;
2555
2556 case TYPE_BITVEC_1: bl = 1; break;
2557 case TYPE_BITVEC_2: bl = 2; break;
2558 case TYPE_BITVEC_3: bl = 3; break;
2559 case TYPE_BITVEC_4: bl = 4; break;
2560 case TYPE_BITVEC_5: bl = 5; break;
2561 case TYPE_BITVEC_6: bl = 6; break;
2562 case TYPE_BITVEC_7: bl = 7; break;
2563 case TYPE_BITVEC_8: bl = 8; break;
2564 case TYPE_BITVEC_9: bl = 9; break;
2565 case TYPE_BITVEC_10: bl = 10; break;
2566 case TYPE_BITVEC_11: bl = 11; break;
2567 case TYPE_BITVEC_12: bl = 12; break;
2568 case TYPE_BITVEC_13: bl = 13; break;
2569 case TYPE_BITVEC_14: bl = 14; break;
2570 case TYPE_BITVEC_15: bl = 15; break;
2571 case TYPE_BITVEC_16: bl = 16; break;
2572 case TYPE_BITVEC_17: bl = 17; break;
2573 case TYPE_BITVEC_18: bl = 18; break;
2574 case TYPE_BITVEC_19: bl = 19; break;
2575 case TYPE_BITVEC_20: bl = 20; break;
2576 case TYPE_BITVEC_21: bl = 21; break;
2577 case TYPE_BITVEC_22: bl = 22; break;
2578 case TYPE_BITVEC_23: bl = 23; break;
2579 case TYPE_BITVEC_24: bl = 24; break;
2580 case TYPE_BITVEC_25: bl = 25; break;
2581 case TYPE_BITVEC_26: bl = 26; break;
2582 case TYPE_BITVEC_27: bl = 27; break;
2583 case TYPE_BITVEC_28: bl = 28; break;
2584 case TYPE_BITVEC_29: bl = 29; break;
2585 case TYPE_BITVEC_30: bl = 30; break;
2586 case TYPE_BITVEC_31: bl = 31; break;
2587 case TYPE_BITVEC_32: bl = 32; break;
2588 #ifdef COMMON
2589 case TYPE_STRUCTURE:
2590 if (elt(stack[0], 0) == package_symbol)
2591 { outprefix(blankp, 3);
2592 putc_stream('#', active_stream);
2593 putc_stream('P', active_stream);
2594 putc_stream(':', active_stream);
2595 u = elt(u, 8); // The name of the package
2596 blankp = 0;
2597 goto restart;
2598 }
2599 // Drop through
2600 #else
2601 case TYPE_STRUCTURE:
2602 std::sprintf(my_buff, "[e-vector:%.8lx]",
2603 static_cast<long>(static_cast<uint32_t>(u)));
2604 goto print_my_buff;
2605
2606 #endif
2607 case TYPE_ARRAY:
2608 #ifdef COMMON
2609 { LispObject dims = elt(stack[0], 1);
2610 //
2611 // I suppose that really I need to deal with non-simple bitvectors too.
2612 // And generally get Common Lisp style array printing "right".
2613 //
2614 if (consp(dims) && !consp(cdr(dims)) &&
2615 elt(stack[0], 0) == string_char_sym)
2616 { len = int_of_fixnum(car(dims));
2617 dims = elt(stack[0], 5); // Fill pointer
2618 if (is_fixnum(dims)) len = int_of_fixnum(dims);
2619 stack[0] = elt(stack[0], 2);
2620 //
2621 // The demand here is that the object within the non-simple-string was
2622 // a simple string, so I can restart printing to deal with it. This will
2623 // not support strings that were over-large so got represented in
2624 // chunks. Tough luck about that for now!
2625 //
2626 h = TYPE_STRING_1;
2627 goto print_non_simple_string;
2628 }
2629 }
2630 // Drop through
2631 #endif
2632 case TYPE_SIMPLE_VEC:
2633 case TYPE_OBJECT:
2634 // case TYPE_OLDHASH:
2635 case TYPE_HASH:
2636 case TYPE_HASHX:
2637 case TYPE_INDEXVEC:
2638 {
2639 #ifndef COMMON
2640 if (type_of_header(h) == TYPE_SIMPLE_VEC)
2641 { outprefix(blankp, 1);
2642 putc_stream('[', active_stream);
2643 }
2644 else
2645 #endif
2646 if (type_of_header(h) == TYPE_STRUCTURE)
2647 { outprefix(blankp, 3);
2648 putc_stream('#', active_stream); putc_stream('S', active_stream);
2649 putc_stream('(', active_stream);
2650 }
2651 else if (// type_of_header(h) == TYPE_OLDHASH ||
2652 type_of_header(h) == TYPE_HASH ||
2653 type_of_header(h) == TYPE_HASHX)
2654 { int ch = 'H';
2655 if (type_of_header(h) == TYPE_HASH) ch = 'H';
2656 else if (type_of_header(h) == TYPE_HASHX) ch = 'h';
2657 outprefix(blankp, 3);
2658 putc_stream('#', active_stream); putc_stream(ch, active_stream);
2659 putc_stream('(', active_stream);
2660 }
2661 else if (type_of_header(h) == TYPE_OBJECT)
2662 { outprefix(blankp, 3);
2663 putc_stream('#', active_stream); putc_stream('O', active_stream);
2664 putc_stream('(', active_stream);
2665 }
2666 else
2667 { outprefix(blankp, 2);
2668 putc_stream('#', active_stream); putc_stream('(', active_stream);
2669 }
2670 #ifdef COMMON
2671 if (qvalue(print_array_sym) == nil)
2672 { putc_stream('.', active_stream);
2673 putc_stream('.', active_stream);
2674 putc_stream('.', active_stream);
2675 }
2676 else
2677 #endif
2678 for (k=0; k<len; k+=CELL)
2679 { LispObject vv = *reinterpret_cast<LispObject *>(
2680 (reinterpret_cast<char *>(stack[0]) +
2681 (CELL - TAG_VECTOR) + k));
2682 internal_prin(vv, (k != 0) ? 1 : 0);
2683 }
2684 outprefix(false, 1);
2685 #ifndef COMMON
2686 if (type_of_header(h) == TYPE_SIMPLE_VEC) putc_stream(']',
2687 active_stream);
2688 else
2689 #endif
2690 putc_stream(')', active_stream);
2691 return nil;
2692 }
2693 case TYPE_MIXED1: // An experimental addition to CSL
2694 case TYPE_MIXED2:
2695 case TYPE_MIXED3:
2696 case TYPE_STREAM:
2697 { outprefix(blankp, 3);
2698 putc_stream('#', active_stream);
2699 if (type_of_header(h) == TYPE_STREAM)
2700 putc_stream('F', active_stream);
2701 else if (type_of_header(h) == TYPE_MIXED1)
2702 putc_stream('1', active_stream);
2703 else if (type_of_header(h) == TYPE_MIXED2)
2704 putc_stream('2', active_stream);
2705 else putc_stream('3', active_stream);
2706 putc_stream('[', active_stream);
2707 #ifdef COMMON
2708 if (qvalue(print_array_sym) == nil)
2709 { putc_stream('.', active_stream);
2710 putc_stream('.', active_stream);
2711 putc_stream('.', active_stream);
2712 }
2713 else
2714 #endif
2715 { internal_prin(elt(stack[0], 0), 0);
2716 outprefix(false, 1);
2717 internal_prin(elt(stack[0], 1), 1);
2718 outprefix(false, 1);
2719 internal_prin(elt(stack[0], 2), 1);
2720 }
2721 for (k=3*CELL; k<len; k+=CELL)
2722 { std::sprintf(my_buff, "%.8lx",
2723 static_cast<long>(
2724 *reinterpret_cast<LispObject *>(
2725 reinterpret_cast<char *>(stack[0]) +
2726 (CELL - TAG_VECTOR) + k)));
2727 prin_buf(my_buff, true);
2728 }
2729 outprefix(false, 1);
2730 putc_stream(']', active_stream);
2731 return nil;
2732 }
2733
2734 case TYPE_VEC8_1:
2735 case TYPE_VEC8_2:
2736 case TYPE_VEC8_3:
2737 case TYPE_VEC8_4:
2738 outprefix(blankp, 4);
2739 putc_stream('#', active_stream); putc_stream('V', active_stream);
2740 putc_stream('8', active_stream); putc_stream('(', active_stream);
2741 for (k=0; k<len; k++)
2742 { std::sprintf(my_buff, "%d", static_cast<int>(scelt(stack[0], k)));
2743 prin_buf(my_buff, k != 0);
2744 }
2745 outprefix(false, 1);
2746 putc_stream(')', active_stream);
2747 return nil;
2748 case TYPE_VEC16_1:
2749 case TYPE_VEC16_2:
2750 len = length_of_hwordheader(h);
2751 outprefix(blankp, 5);
2752 putc_stream('#', active_stream); putc_stream('V', active_stream);
2753 putc_stream('1', active_stream); putc_stream('6', active_stream);
2754 putc_stream('(', active_stream);
2755 for (k=0; k<len; k++)
2756 { std::sprintf(my_buff, "%d", static_cast<int>(helt(stack[0], k)));
2757 prin_buf(my_buff, k != 0);
2758 }
2759 outprefix(false, 1);
2760 putc_stream(')', active_stream);
2761 return nil;
2762 case TYPE_VEC32:
2763 outprefix(blankp, 5);
2764 putc_stream('#', active_stream); putc_stream('V', active_stream);
2765 putc_stream('3', active_stream); putc_stream('2', active_stream);
2766 putc_stream('(', active_stream);
2767 len = len >> 2;
2768 for (k=0; k<len; k++)
2769 { std::sprintf(my_buff, "%ld", static_cast<long>(ielt32(stack[0],
2770 k)));
2771 prin_buf(my_buff, k != 0);
2772 }
2773 outprefix(false, 1);
2774 putc_stream(')', active_stream);
2775 return nil;
2776 case TYPE_VECFLOAT32:
2777 outprefix(blankp, 4);
2778 putc_stream('#', active_stream); putc_stream('F', active_stream);
2779 putc_stream('S', active_stream); putc_stream('(', active_stream);
2780 len = len >> 2;
2781 for (k=0; k<len; k++)
2782 { fp_sprint(my_buff, static_cast<double>(felt(stack[0], k)),
2783 print_precision, 'f');
2784 prin_buf(my_buff, k != 0);
2785 }
2786 outprefix(false, 1);
2787 putc_stream(')', active_stream);
2788 return nil;
2789 case TYPE_VECFLOAT64:
2790 outprefix(blankp, 4);
2791 putc_stream('#', active_stream); putc_stream('F', active_stream);
2792 putc_stream('D', active_stream); putc_stream('(', active_stream);
2793 len = (len-CELL)/8;
2794 for (k=0; k<len; k++)
2795 { fp_sprint(my_buff, delt(stack[0], k),
2796 print_precision, 'e');
2797 prin_buf(my_buff, k != 0);
2798 }
2799 outprefix(false, 1);
2800 putc_stream(')', active_stream);
2801 return nil;
2802 default:goto error_case;
2803 }
2804 // Here for bit-vectors
2805 outprefix(blankp, 2+8*(len-1)+bl);
2806 putc_stream('#', active_stream), putc_stream('*', active_stream);
2807 { int z, q;
2808 for (k = 0; k < len-1; k++)
2809 { z = ucelt(stack[0], k);
2810 for (q=0; q<8; q++)
2811 { if (z & 1) putc_stream('1', active_stream);
2812 else putc_stream('0', active_stream);
2813 z >>= 1;
2814 }
2815 }
2816 if (len != 0) // Empty bitvec
2817 { z = ucelt(stack[0], len-1);
2818 for (q=0; q<bl; q++)
2819 { if (z & 1) putc_stream('1', active_stream);
2820 else putc_stream('0', active_stream);
2821 z >>= 1;
2822 }
2823 }
2824 }
2825 return nil;
2826 }
2827
2828 //
2829 // It seems probable that I could never get here, but this "return" is
2830 // just in case, as a safety measure.
2831 //
2832 return nil;
2833
2834 case TAG_SYMBOL:
2835 // When computing checksums with the "md5" function I count gensyms as being
2836 // purely local to the current expression. The strange effect is that
2837 // (md5 (gensym))
2838 // always gives the same result, even though the gensyms involved are
2839 // different. But it is REASONABLY compatible with a view that I am forming
2840 // a digest of a printed representation and is needed if digests are to
2841 // be acceptably consistent across lisp images.
2842 if (escaped_printing & escape_checksum)
2843 { if ((qheader(u) & (SYM_CODEPTR+SYM_ANY_GENSYM)) == SYM_ANY_GENSYM)
2844 { LispObject al = stream_write_data(active_stream);
2845 while (al != nil &&
2846 car(car(al)) != u) al = cdr(al);
2847 if (al == nil)
2848 { al = acons(u, fixnum_of_int(local_gensym_count),
2849 stream_write_data(active_stream));
2850 local_gensym_count++;
2851 stream_write_data(active_stream) = al;
2852 }
2853 al = cdr(car(al));
2854 std::sprintf(my_buff, "#G%lx", static_cast<long>(int_of_fixnum(al)));
2855 break;
2856 }
2857 }
2858 w = get_pname(u); // allocates name for gensym if needbe
2859 #ifdef COMMON
2860 tag_symbol:
2861 #endif
2862 { Header h = vechdr(w);
2863 int32_t slen = 0;
2864 int raised = 0;
2865 #ifdef COMMON
2866 int pkgid = 0; // No package marker needed
2867 //
2868 // 0 no package marker needed
2869 // 1 display as #:xxx (ie as a gensym)
2870 // 2 display as :xxx (ie in keyword package)
2871 // 3 display as ppp:xxx (external in its home package)
2872 // 4 display as ppp::xxx (internal in its home package)
2873 //
2874 if (escaped_printing & escape_yes)
2875 { if (!is_symbol(u)) pkgid = 0; // Support for a HACK
2876 else if (qpackage(u) == nil) pkgid = 1; // gensym
2877 else if (qpackage(u) == qvalue(keyword_package)) pkgid = 2;
2878 else if (qpackage(u) == CP) pkgid = 0; // home is current
2879 else
2880 { pkgid = 3;
2881 k = packflags_(CP);
2882 if (k != 0 && k <= SYM_IN_PKG_COUNT)
2883 { k = ((int32_t)1) << (k+SYM_IN_PKG_SHIFT-1);
2884 if (k & qheader(u)) pkgid = 0;
2885 }
2886 else k = 0;
2887 if (pkgid != 0)
2888 { RealSave save1(w);
2889 w = Lfind_symbol_1(env, w);
2890 errexit();
2891 if (mv_2 != nil && w == u)
2892 { pkgid = 0;
2893 //
2894 // Here I update the cache it that keeps telling me that the symbol is
2895 // is "available" in the package that is current at present. I guess that
2896 // I need to clear this bit if I unintern or otherwise mess around with
2897 // package structures.
2898 //
2899 qheader(u) |= k;
2900 }
2901 else if (qheader(u) & SYM_EXTERN_IN_HOME) pkgid = 3;
2902 else pkgid = 4;
2903 save1.restore(w);
2904 }
2905 }
2906 }
2907 #endif
2908 len = length_of_byteheader(h); // counts in bytes
2909 lenchars = 0;
2910 // Now see how many characters that is, allowing for utf-8 encoding
2911 for (k=0; k<(len-CELL); k++)
2912 if ((celt(w, k) & 0xc0) != 0x80) lenchars++;
2913 //
2914 // When I come to print things I will assume that I want them re-readable
2915 // with values of !*raise and !*lower as in effect when the printing took
2916 // place, and insert escape characters accordingly. I optimise the case
2917 // of printing without any effects...
2918 //
2919 if (!(escaped_printing &
2920 (escape_yes | escape_fold_down |
2921 escape_fold_up | escape_capitalize)))
2922 { stack[0] = w;
2923 len -= CELL;
2924 #ifdef COMMON
2925 switch (pkgid)
2926 { case 1: outprefix(blankp, lenchars+2);
2927 putc_stream('#', active_stream);
2928 putc_stream(':', active_stream);
2929 break;
2930 case 2: outprefix(blankp, lenchars+1);
2931 putc_stream(':', active_stream);
2932 break;
2933 case 3:
2934 case 4:
2935 //
2936 // The issue of line breaks is maybe horrid here! I probably need to
2937 // assess the print width of both the package name and the basic
2938 // part of the name somewhere around here.
2939 //
2940 internal_prin(packname_(qpackage(u)), blankp | 2);
2941 putc_stream(':', active_stream);
2942 if (pkgid == 4) putc_stream(':', active_stream);
2943 break;
2944 default:outprefix(blankp, lenchars);
2945 break;
2946 }
2947 #else
2948 outprefix(blankp, lenchars);
2949 #endif
2950 for (k = 0; k < len; k++)
2951 { int ch = ucelt(stack[0], k);
2952 //
2953 // Specially for the benefit of "tmprint.red" I arrange to switch off
2954 // line-wrapping if I have a "\x02" character but switch it back on after
2955 // "\x05". I should probably also restore things to a normal state on any
2956 // exception/backtrace.
2957 //
2958 if (ch == 2) tmprint_flag = 1;
2959 //
2960 // The next is pretty much a horrible fudge, but I believe that people
2961 // might only be using prin2 on an end-of-file character by accident and
2962 // my internal representation is not a valid utf-8 packing of a codepoint
2963 // in the Unicode range, so putting a textual form that people might
2964 // at least recognise is perhaps kinder.
2965 //
2966 if (ch == 0xf7 &&
2967 ucelt(stack[0], k+1) == 0xbf &&
2968 ucelt(stack[0], k+2) == 0xbf &&
2969 ucelt(stack[0], k+3) == 0xbf)
2970 { putc_stream('$', active_stream);
2971 putc_stream('E', active_stream);
2972 putc_stream('O', active_stream);
2973 putc_stream('F', active_stream);
2974 putc_stream('$', active_stream);
2975 k += 3;
2976 }
2977 else
2978 putc_stream(ch, active_stream);
2979 if (ch == 5) tmprint_flag = 0;
2980 }
2981 }
2982 else
2983 //
2984 // Now I have prin1 rather than prin2, or prin2 but with case folding.
2985 // thus the fun really begins.
2986 //
2987 { int extralen = 0;
2988 if (qvalue(lower_symbol) != nil) raised = -1;
2989 else if (qvalue(raise_symbol) != nil) raised = 1;
2990 stack[0] = w;
2991 len -= CELL;
2992 //
2993 // A horrid case here - digits are special at the start of names so need
2994 // escaping with a "!" there even though they do not within the body of the
2995 // symbol. In Stanndard Lisp the same is true for "_" and in Common Lisp
2996 // for ".".
2997 //
2998 if (len > 0)
2999 { int ch = celt(stack[0], 0);
3000 if (escaped_printing & escape_yes &&
3001 (std::isdigit(static_cast<unsigned char>(ch))
3002 #ifdef COMMON
3003 || (ch=='.')
3004 #else
3005 || (ch=='_')
3006 #endif
3007 )) extralen++;
3008 }
3009 // /*
3010 // Again here I should perhaps take a view about linelength and
3011 // symbols with tabs in their names... At present I do not. Anyway I need a
3012 // first scan of the material to assess how many character positions will
3013 // be needed when I print it.
3014 //
3015 for (k = 0; k < len; k++)
3016 { int ch = celt(stack[0], k);
3017 //
3018 // If I have escape_yes set then I will map multibyte sequences onto
3019 // #xxxx; or #xxxxxx; using 5 or 7 extra characters. If the only reason
3020 // I am here is because of case folding I will leave extended characters
3021 // alone.
3022 //
3023 if ((ch & 0xc0) == 0x80) continue;
3024 else if ((ch & 0xe0) == 0xc0 &&
3025 (escaped_printing & escape_yes)) slen += 5, extralen++;
3026 else if ((ch & 0xf0) == 0xe0 &&
3027 (escaped_printing & escape_yes)) slen += 5, extralen++;
3028 else if ((ch & 0x80) != 0 &&
3029 (escaped_printing & escape_yes)) slen += 7, extralen++;
3030 else if ((escaped_printing & escape_yes) &&
3031 !(escaped_printing &
3032 (escape_fold_down |
3033 escape_fold_up |
3034 escape_capitalize)) &&
3035 #ifdef COMMON
3036 (ch=='.' || ch=='\\' || ch=='|') ||
3037 #endif
3038 //
3039 // Here ch is certain to be in the range u+0000 to u+007f. Since I am
3040 // rendering all characters over u+007f as escape sequences and all have an
3041 // escape character prefix already there is no extra work needed to cover
3042 // case folding for any of them. Whew. Well that depends on it being the case
3043 // that case folding never moves something from the up to u+ffff up to
3044 // the u+10000 and above range (or vice versa).
3045 //
3046 (!is_constituent(ch) ||
3047 #ifdef COMMON
3048 (ch=='.' || ch=='\\' || ch=='|' || ch==':') ||
3049 #endif
3050 (raised < 0 && std::isupper(static_cast<unsigned char>(ch))) ||
3051 (raised > 0 &&
3052 std::islower(static_cast<unsigned char>(ch))))) extralen++;
3053 slen++;
3054 }
3055 #ifdef COMMON
3056 //
3057 // The |xxx| notation is where the "2" here comes from, but that does not
3058 // make full allowance for names with '\\' in them. Tough! But view that
3059 // as yet another place where the code could need upgrading.
3060 //
3061 // here slen is the number of characters that will be used to display the
3062 // printname itself, extralen is the number of "!" characters that Standard
3063 // Lisp mode would use. If extralen is non zero I will need to use "|"
3064 // notation here in Common Lisp mode.
3065 //
3066 if (extralen != 0) extralen = 2;
3067 switch (pkgid)
3068 { case 1: outprefix(blankp, slen+extralen+2);
3069 putc_stream('#', active_stream);
3070 putc_stream(':', active_stream);
3071 break;
3072 case 2: outprefix(blankp, slen+extralen+1);
3073 putc_stream(':', active_stream);
3074 break;
3075 case 3:
3076 case 4: internal_prin(packname_(qpackage(u)), blankp | 2);
3077 putc_stream(':', active_stream);
3078 if (pkgid == 4) putc_stream(':', active_stream);
3079 break;
3080 default:outprefix(blankp, len);
3081 break;
3082 }
3083 #else
3084 outprefix(blankp, slen+extralen);
3085 #endif
3086 #ifdef COMMON
3087 if (extralen != 0) putc_stream('|', active_stream);
3088 #endif
3089 //
3090 // I need to deal with the first character of the name specially... but
3091 // only if it is one of the magic characters that needs special escaping at
3092 // the start of a name but not otherwise! So I will detect such cases and
3093 // if necessary emit a "!" then the normal loop will do eveything else
3094 // happily. Note that in Common Lisp mode there are no special cases here
3095 // if I am going to display exotic names enclosed in vertical bars.
3096 // I am glad that none of "_" and "0" to "9" impact on case folding or
3097 // utf-8 encoding!
3098 //
3099 #ifndef COMMON
3100 if (len > 0)
3101 { int ch = celt(stack[0], 0);
3102 if (ch == '_' ||
3103 (ch >= '0' && ch <= '9'))
3104 putc_stream(ESCAPE_CHAR, active_stream);
3105 }
3106 #endif
3107 //
3108 // Now display the characters that make up the name.
3109 //
3110 for (k = 0; k < len; k++)
3111 { int ch = ucelt(stack[0], k);
3112 #ifdef COMMON
3113 if (ch == '\\' || ch=='|')
3114 putc_stream(ESCAPE_CHAR, active_stream);
3115 #else
3116 //
3117 // If I am case folding then I hope I am not also putting in escape
3118 // marks. Well at present I will NEVER combine escape_fold_xxx with
3119 // escape_yes, so I am safe here!
3120 //
3121 if (!(escaped_printing &
3122 (escape_fold_down | escape_fold_up |
3123 escape_capitalize)) &&
3124 (ch > 0x7f ||
3125 !is_constituent(ch) ||
3126 (raised < 0 && std::isupper(static_cast<unsigned char>(ch))) ||
3127 (raised > 0 && std::islower(static_cast<unsigned char>(ch)))))
3128 putc_stream(ESCAPE_CHAR, active_stream);
3129 #endif
3130 //
3131 // If I am case-folding I may need to extract an utf-8 multi-byte
3132 // sequence, case fold and then display it. And since I am doing
3133 // prin1 then if I am not exploding I need to display multi-byte
3134 // objects as escape sequences using "#".
3135 //
3136 if (ch >= 0xc0)
3137 { int32_t n = 0;
3138 if ((ch & 0xe0) == 0xc0) // 2 byte
3139 { n = ch & 0x1f;
3140 k++;
3141 ch = celt(stack[0], k);
3142 n = (n << 6) | (ch & 0x3f);
3143 if (escaped_printing & escape_fold_down)
3144 n = std::towlower(n);
3145 else if (escaped_printing & escape_fold_up)
3146 n = std::towupper(n);
3147 if ((escaped_printing & escape_yes) &&
3148 !(escaped_printing & escape_exploding))
3149 { putc_stream('#', active_stream);
3150 // This first digit is very often redundant here
3151 putc_stream(hexdig[(n>>12)&0xf], active_stream);
3152 putc_stream(hexdig[(n>>8)&0xf], active_stream);
3153 putc_stream(hexdig[(n>>4)&0xf], active_stream);
3154 putc_stream(hexdig[n&0xf], active_stream);
3155 putc_stream(';', active_stream);
3156 }
3157 else putc_utf8(n);
3158 }
3159 else if ((ch & 0xf0) == 0xe0) // 3 byte
3160 { n = ch & 0x0f;
3161 k++;
3162 ch = celt(stack[0], k);
3163 n = (n << 6) | (ch & 0x3f);
3164 k++;
3165 ch = celt(stack[0], k);
3166 n = (n << 6) | (ch & 0x3f);
3167 if (escaped_printing & escape_fold_down)
3168 n = std::towlower(n);
3169 else if (escaped_printing & escape_fold_up)
3170 n = std::towupper(n);
3171 if ((escaped_printing & escape_yes) &&
3172 !(escaped_printing & escape_exploding))
3173 { putc_stream('#', active_stream);
3174 putc_stream(hexdig[(n>>12)&0xf], active_stream);
3175 putc_stream(hexdig[(n>>8)&0xf], active_stream);
3176 putc_stream(hexdig[(n>>4)&0xf], active_stream);
3177 putc_stream(hexdig[n&0xf], active_stream);
3178 putc_stream(';', active_stream);
3179 }
3180 else putc_utf8(n);
3181 }
3182 else // assume 4 byte
3183 { n = ch & 0x07;
3184 k++;
3185 ch = celt(stack[0], k);
3186 n = (n << 6) | (ch & 0x3f);
3187 k++;
3188 ch = celt(stack[0], k);
3189 n = (n << 6) | (ch & 0x3f);
3190 k++;
3191 ch = celt(stack[0], k);
3192 n = (n << 6) | (ch & 0x3f);
3193 //
3194 // When case folding if the code-point is beyond U+ffff and I am on a machine
3195 // where sizeof(wchar_t) is 2 (eg Windows) I will not case fold. Gosh that
3196 // seems an obscure situation!
3197 //
3198 if (sizeof(wchar_t) == 4 || n < 0x10000)
3199 { if (escaped_printing & escape_fold_down)
3200 n = std::towlower(n);
3201 else if (escaped_printing & escape_fold_up)
3202 n = std::towupper(n);
3203 }
3204 if ((escaped_printing & escape_yes) &&
3205 !(escaped_printing & escape_exploding))
3206 { putc_stream('#', active_stream);
3207 putc_stream(hexdig[(n>>20)&0xf], active_stream);
3208 putc_stream(hexdig[(n>>16)&0xf], active_stream);
3209 putc_stream(hexdig[(n>>12)&0xf], active_stream);
3210 putc_stream(hexdig[(n>>8)&0xf], active_stream);
3211 putc_stream(hexdig[(n>>4)&0xf], active_stream);
3212 putc_stream(hexdig[n&0xf], active_stream);
3213 putc_stream(';', active_stream);
3214 }
3215 else putc_utf8(n);
3216 }
3217 }
3218 else
3219 { if (escaped_printing & escape_fold_down)
3220 ch = std::tolower(ch);
3221 else if (escaped_printing & escape_fold_up)
3222 ch = std::toupper(ch);
3223 putc_stream(ch, active_stream);
3224 }
3225 }
3226 #ifdef COMMON
3227 if (extralen != 0) putc_stream('|', active_stream);
3228 #endif
3229 }
3230 }
3231 return nil;
3232
3233 case TAG_BOXFLOAT:
3234 switch (type_of_header(flthdr(u)))
3235 { case TYPE_SINGLE_FLOAT:
3236 // The casts to "uint32_t *" here break the strict aliasing rules. If I was
3237 // more cautious I would use a union, which (I believe) would cause gcc (at
3238 // least) to guarantee to treat me kindly despite this. But even with that
3239 // I would be relying on behaviour not blessed by the current C++ standards.
3240 if (escaped_printing & escape_checksum)
3241 { int32_t v = intfloat32_t_val(u);
3242 std::sprintf(my_buff, "@F%.8x", v);
3243 }
3244 else if (escaped_printing & escape_hex)
3245 { uint32_t *p = (uint32_t *)&single_float_val(u);
3246 std::sprintf(my_buff, "{%.8" PRIx32 ":%#.8g}",
3247 p[0], static_cast<double>(single_float_val(u)));
3248 }
3249 else if (escaped_printing & escape_octal)
3250 { uint32_t *p = (uint32_t *)&double_float_val(u);
3251 std::sprintf(my_buff, "{%.11" PRIo32 ":%#.8g}",
3252 p[0], static_cast<double>(single_float_val(u)));
3253 }
3254 else fp_sprint(my_buff,
3255 static_cast<double>(single_float_val(u)), print_precision, 'f');
3256 break;
3257 case TYPE_DOUBLE_FLOAT:
3258 //
3259 // Hexadecimal printing of floating point numbers is only provided for
3260 // here to help with nasty low-level debugging. The output will not be
3261 // directly re-readable.
3262 //
3263 if (escaped_printing & escape_checksum)
3264 { int64_t v = intfloat64_t_val(u);
3265 std::sprintf(my_buff, "@F%.8" PRIx64, v);
3266 }
3267 else if (escaped_printing & escape_hex)
3268 { uint32_t *p = (uint32_t *)&double_float_val(u);
3269 std::sprintf(my_buff,
3270 "{%.8" PRIx32 "/%.8" PRIx32 ":%#.15g}",
3271 #ifdef LITTLEENDIAN
3272 p[1], p[0], static_cast<double>(double_float_val(u)));
3273 #else
3274 p[0], p[1], static_cast<double>(double_float_val(u)));
3275 #endif
3276 }
3277 else if (escaped_printing & escape_octal)
3278 { uint32_t *p = (uint32_t *)&double_float_val(u);
3279 std::sprintf(my_buff, "{%.11" PRIo32 "/%.11" PRIo32 ":%#.8g}",
3280 #ifdef LITTLEENDIAN
3281 p[1], p[0], static_cast<double>(double_float_val(u)));
3282 #else
3283 p[0], p[1], static_cast<double>(double_float_val(u)));
3284 #endif
3285 }
3286 else fp_sprint(my_buff, double_float_val(u),
3287 print_precision, 'e');
3288 break;
3289 #ifdef HAVE_SOFTFLOAT
3290 case TYPE_LONG_FLOAT:
3291 if (escaped_printing & escape_checksum)
3292 { int64_t v0 = intfloat128_t_val0(u);
3293 int64_t v1 = intfloat128_t_val1(u);
3294 #ifdef LITTLEENDIAN
3295 std::sprintf(my_buff, "@F%.8" PRIx64 "/%" PRIx64, v1, v0);
3296 #else
3297 std::sprintf(my_buff, "@F%.8" PRIx64 "/%" PRIx64, v0, v1);
3298 #endif
3299 }
3300 else if (escaped_printing & escape_hex)
3301 { uint32_t *p = (uint32_t *)&long_float_val(u);
3302 char *o = my_buff;
3303 #ifdef LITTLEENDIAN
3304 o += std::sprintf(o, "{%.8" PRIx32, p[3]);
3305 o += std::sprintf(o, "/%.8" PRIx32, p[2]);
3306 o += std::sprintf(o, "/%.8" PRIx32, p[1]);
3307 o += std::sprintf(o, "/%.8" PRIx32, p[0]);
3308 #else
3309 o += std::sprintf(o, "{%.8" PRIx32, p[0]);
3310 o += std::sprintf(o, "/%.8" PRIx32, p[1]);
3311 o += std::sprintf(o, "/%.8" PRIx32, p[2]);
3312 o += std::sprintf(o, "/%.8" PRIx32, p[3]);
3313 #endif
3314 *o++ = ':';
3315 o += f128M_sprint_G(o, 0, 34,
3316 reinterpret_cast<float128_t *>(
3317 &long_float_val(u)));
3318 *o++ = '}';
3319 *o = 0;
3320 }
3321 else if (escaped_printing & escape_octal)
3322 { uint32_t *p = (uint32_t *)&long_float_val(u);
3323 char *o = my_buff;
3324 #ifdef LITTLEENDIAN
3325 o += std::sprintf(o, "{%.11" PRIo32, p[3]);
3326 o += std::sprintf(o, "/%.11" PRIo32, p[2]);
3327 o += std::sprintf(o, "/%.11" PRIo32, p[1]);
3328 o += std::sprintf(o, "/%.11" PRIo32, p[0]);
3329 #else
3330 o += std::sprintf(o, "{%.11" PRIo32, p[0]);
3331 o += std::sprintf(o, "/%.11" PRIo32, p[1]);
3332 o += std::sprintf(o, "/%.11" PRIo32, p[2]);
3333 o += std::sprintf(o, "/%.11" PRIo32, p[3]);
3334 #endif
3335 *o++ = ':';
3336 o += f128M_sprint_G(o, 0, 34,
3337 reinterpret_cast<float128_t *>(
3338 &long_float_val(u)));
3339 *o++ = '}';
3340 *o = 0;
3341 }
3342 // I use an upper case "L" as an exponent marker in "long floats" because
3343 // a lower case "l" looks too much like a "1" (ell vs one).
3344 else fp_sprint128(my_buff, long_float_val(u),
3345 print_precision, 'L');
3346 break;
3347 #endif // HAVE_SOFTFLOAT
3348 default:
3349 std::sprintf(my_buff, "?%p?", reinterpret_cast<void *>(u));
3350 break;
3351 }
3352 float_print_tidyup: // label to join in from short float printing
3353 break;
3354
3355 case TAG_NUMBERS:
3356 if (is_bignum(u))
3357 { if (escaped_printing & escape_hex)
3358 print_bighexoctbin(u, 16, escape_width(escaped_printing),
3359 blankp,
3360 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3361 else if (escaped_printing & escape_octal)
3362 print_bighexoctbin(u, 8, escape_width(escaped_printing),
3363 blankp,
3364 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3365 else if (escaped_printing & escape_binary)
3366 print_bighexoctbin(u, 2, escape_width(escaped_printing),
3367 blankp,
3368 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3369 else
3370 print_bignum(u, blankp,
3371 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3372 return nil;
3373 }
3374 #ifdef ARITHLIB
3375 if (is_new_bignum(u))
3376 { if (escaped_printing & escape_hex)
3377 print_newbighexoctbin(u, 16, escape_width(escaped_printing),
3378 blankp,
3379 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3380 else if (escaped_printing & escape_octal)
3381 print_newbighexoctbin(u, 8, escape_width(escaped_printing),
3382 blankp,
3383 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3384 else if (escaped_printing & escape_binary)
3385 print_newbighexoctbin(u, 2, escape_width(escaped_printing),
3386 blankp,
3387 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3388 else
3389 print_newbignum(u, blankp,
3390 (escaped_printing & escape_nolinebreak) || tmprint_flag);
3391 return nil;
3392 }
3393 #endif
3394 else if (is_ratio(u))
3395 {
3396 // Here I have a line-break problem --- I do not measure the size of the
3397 // denominator, and hence may well split a line between numerator and
3398 // denominator. This would be HORRID. I guess that the correct recipe will
3399 // involve measuring the size of the denominator first... Let's not bother
3400 // just at the moment.
3401 internal_prin(numerator(u), blankp);
3402 outprefix(false, 1);
3403 putc_stream('/', active_stream);
3404 internal_prin(denominator(u), 0);
3405 return nil;
3406 }
3407 else if (is_complex(u))
3408 { outprefix(blankp, 3);
3409 putc_stream('#', active_stream), putc_stream('C', active_stream);
3410 putc_stream('(', active_stream);
3411 internal_prin(real_part(u), 0);
3412 internal_prin(imag_part(u), 1);
3413 outprefix(false, 1);
3414 putc_stream(')', active_stream);
3415 return nil;
3416 }
3417 // Else drop through to treat as an error
3418 default:
3419 error_case:
3420 std::sprintf(my_buff, "?%p?", reinterpret_cast<void *>(u));
3421 break;
3422 }
3423 print_my_buff:
3424 { const char *p = my_buff;
3425 int ch;
3426 outprefix(blankp, std::strlen(my_buff));
3427 while ((ch = *p++) != 0) putc_stream(ch, active_stream);
3428 }
3429 return nil;
3430 }
3431
prin(LispObject u)3432 LispObject prin(LispObject u)
3433 { escaped_printing = escape_yes;
3434 Save save(u);
3435 active_stream = qvalue(standard_output);
3436 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3437 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3438 internal_prin(u, 0);
3439 save.restore(u);
3440 return u;
3441 }
3442
prin_to_terminal(LispObject u)3443 LispObject prin_to_terminal(LispObject u)
3444 { escaped_printing = escape_yes;
3445 active_stream = qvalue(terminal_io);
3446 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3447 ignore_error(internal_prin(u, 0));
3448 ensure_screen();
3449 return nil;
3450 }
3451
prin_to_stdout(LispObject u)3452 LispObject prin_to_stdout(LispObject u)
3453 { escaped_printing = escape_yes;
3454 active_stream = qvalue(standard_output);
3455 if (!is_stream(active_stream)) active_stream = lisp_standard_output;
3456 ignore_error(internal_prin(u, 0));
3457 ensure_screen();
3458 return nil;
3459 }
3460
prin_to_error(LispObject u)3461 LispObject prin_to_error(LispObject u)
3462 { escaped_printing = escape_yes;
3463 active_stream = qvalue(error_output);
3464 if (!is_stream(active_stream)) active_stream = lisp_error_output;
3465 ignore_error(internal_prin(u, 0));
3466 ensure_screen();
3467 return nil;
3468 }
3469
prin_to_trace(LispObject u)3470 LispObject prin_to_trace(LispObject u)
3471 { escaped_printing = escape_yes;
3472 active_stream = qvalue(trace_output);
3473 if (!is_stream(active_stream)) active_stream = lisp_trace_output;
3474 ignore_error(internal_prin(u, 0));
3475 ensure_screen();
3476 return nil;
3477 }
3478
3479 // This is JUST for debugging. Itr prints a message then something (using
3480 // radix 16), then a newline.
prinhex_to_trace(const char * msg,LispObject u)3481 LispObject prinhex_to_trace(const char *msg, LispObject u)
3482 { int32_t c = other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
3483 qvalue(standard_output));
3484 escaped_printing = escape_yes+escape_hex;
3485 active_stream = qvalue(trace_output);
3486 if (!is_stream(active_stream)) active_stream = lisp_trace_output;
3487 if (c != 0) putc_stream('\n', active_stream);
3488 trace_printf("## %s: ", msg);
3489 ignore_error(internal_prin(u, escape_yes+escape_hex));
3490 putc_stream('\n', active_stream);
3491 ensure_screen();
3492 return nil;
3493 }
3494
prin_to_debug(LispObject u)3495 LispObject prin_to_debug(LispObject u)
3496 { escaped_printing = escape_yes;
3497 active_stream = qvalue(debug_io);
3498 if (!is_stream(active_stream)) active_stream = lisp_debug_io;
3499 ignore_error(internal_prin(u, 0));
3500 ensure_screen();
3501 return nil;
3502 }
3503
prin_to_query(LispObject u)3504 LispObject prin_to_query(LispObject u)
3505 { escaped_printing = escape_yes;
3506 active_stream = qvalue(query_io);
3507 if (!is_stream(active_stream)) active_stream = lisp_query_io;
3508 ignore_error(internal_prin(u, 0));
3509 ensure_screen();
3510 return nil;
3511 }
3512
loop_print_stdout(LispObject o)3513 LispObject loop_print_stdout(LispObject o)
3514 { int32_t sx = exit_reason;
3515 one_arg *f;
3516 LispObject lp = qvalue(traceprint_symbol);
3517 if (lp == nil || lp == unset_var) lp = prinl_symbol;
3518 // There is a potential delicacy around here if and when prinl gets compiled
3519 // into C. At the very start of a run when CSL does a cold start it could
3520 // have a definition but its vector-of-literals might not have been loaded.
3521 // If it gets called at that stage there could be a disaster, So as a small
3522 // amount of extra protection only relevant to me when I build initial images
3523 // based on a cold-start I will try to avoid calling it then and fall back
3524 // to using the simpler version of prin.
3525 if (!is_symbol(lp) ||
3526 (f = qfn1(lp)) == undefined_1 ||
3527 (f != bytecoded_1 && !is_vector(qenv(lp)))) prin_to_stdout(o);
3528 else (*f)(lp, o);
3529 exit_reason = sx;
3530 return nil;
3531 }
3532
loop_print_error(LispObject o)3533 LispObject loop_print_error(LispObject o)
3534 { LispObject w = qvalue(standard_output);
3535 Save save(w);
3536 if (is_stream(qvalue(error_output)))
3537 setvalue(standard_output, qvalue(error_output));
3538 loop_print_stdout(o);
3539 save.restore(w);
3540 setvalue(standard_output, w);
3541 #ifdef COMMON
3542 // This is to help me debug in the face of low level system crashes
3543 if (spool_file) std::fflush(spool_file);
3544 #endif
3545 return nil;
3546 }
3547
loop_print_trace(LispObject o)3548 LispObject loop_print_trace(LispObject o)
3549 { STACK_SANITY;
3550 LispObject w = qvalue(standard_output);
3551 Save save(w);
3552 if (is_stream(qvalue(trace_output)))
3553 setvalue(standard_output, qvalue(trace_output));
3554 loop_print_stdout(o);
3555 save.restore(w);
3556 setvalue(standard_output, w);
3557 #ifdef COMMON
3558 // This is to help me debug in the face of low level system crashes
3559 if (spool_file) std::fflush(spool_file);
3560 #endif
3561 return nil;
3562 }
3563
loop_print_debug(LispObject o)3564 LispObject loop_print_debug(LispObject o)
3565 { LispObject w = qvalue(standard_output);
3566 Save save(w);
3567 if (is_stream(qvalue(debug_io)))
3568 setvalue(standard_output, qvalue(debug_io));
3569 loop_print_stdout(o);
3570 save.restore(w);
3571 setvalue(standard_output, w);
3572 return nil;
3573 }
3574
loop_print_query(LispObject o)3575 LispObject loop_print_query(LispObject o)
3576 { LispObject w = qvalue(standard_output);
3577 Save save(w);
3578 if (is_stream(qvalue(query_io)))
3579 setvalue(standard_output, qvalue(query_io));
3580 loop_print_stdout(o);
3581 save.restore(w);
3582 setvalue(standard_output, w);
3583 return nil;
3584 }
3585
loop_print_terminal(LispObject o)3586 LispObject loop_print_terminal(LispObject o)
3587 { LispObject w = qvalue(standard_output);
3588 Save save(w);
3589 if (is_stream(qvalue(terminal_io)))
3590 setvalue(standard_output, qvalue(terminal_io));
3591 loop_print_stdout(o);
3592 save.restore(w);
3593 setvalue(standard_output, w);
3594 return nil;
3595 }
3596
prinraw(LispObject u)3597 LispObject prinraw(LispObject u)
3598 { Header h;
3599 int32_t len, i;
3600 char b[40], *p;
3601 Save save(u);
3602 active_stream = qvalue(standard_output);
3603 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3604 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3605 if (is_fixnum(u))
3606 {
3607 //
3608 // The following line wants to print a long-long 64-bit value but the
3609 // format specifier %.16llx is not universally available, so I use two 32-bit
3610 // chunks.
3611 //
3612 unsigned long long w = static_cast<unsigned long long>(u);
3613 unsigned long long hi = w >> 32, lo = w;
3614 std::sprintf(b, "%.8x%.8x", static_cast<int>(hi),
3615 static_cast<int>(lo));
3616 for (p=b; *p!=0; p++) putc_stream(*p, active_stream);
3617 }
3618 if (is_numbers(u) && type_of_header(h = numhdr(u)) == TYPE_BIGNUM)
3619 { len = length_of_header(h);
3620 for (i=CELL; i<len; i+=4)
3621 { std::sprintf(b, "%.8x ", (uint32_t)bignum_digits(u)[(i-CELL)/4]);
3622 for (p=b; *p!=0; p++) putc_stream(*p, active_stream);
3623 }
3624 }
3625 #ifdef ARITHLIB
3626 else if (is_numbers(u) && type_of_header(h) == TYPE_NEW_BIGNUM)
3627 { len = length_of_header(h);
3628 for (i=8; i<len; i+=8)
3629 { std::sprintf(b, "%.16" PRIx64 " ",
3630 *(uint64_t *)(reinterpret_cast<char *>(u) - TAG_NUMBERS + i));
3631 for (p=b; *p!=0; p++) putc_stream(*p, active_stream);
3632 }
3633 }
3634 #endif // ARITHLIB
3635 else
3636 { for (i=0; i<11; i++)
3637 putc_stream("<NotNumber>"[i], active_stream);
3638 }
3639 save.restore(u);
3640 return u;
3641 }
3642
prinhex(LispObject u,int n)3643 static LispObject prinhex(LispObject u, int n)
3644 { escaped_printing = escape_yes+escape_hex+((n & 0x3f)<<8);
3645 Save save(u);
3646 active_stream = qvalue(standard_output);
3647 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3648 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3649 internal_prin(u, 0);
3650 save.restore(u);
3651 return u;
3652 }
3653
prinoctal(LispObject u,int n)3654 static LispObject prinoctal(LispObject u, int n)
3655 { escaped_printing = escape_yes+escape_octal+((n & 0x3f)<<8);
3656 Save save(u);
3657 active_stream = qvalue(standard_output);
3658 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3659 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3660 internal_prin(u, 0);
3661 save.restore(u);
3662 return u;
3663 }
3664
prinbinary(LispObject u,int n)3665 static LispObject prinbinary(LispObject u, int n)
3666 { escaped_printing = escape_yes+escape_binary+((n & 0x3f)<<8);
3667 Save save(u);
3668 active_stream = qvalue(standard_output);
3669 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3670 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3671 internal_prin(u, 0);
3672 save.restore(u);
3673 return u;
3674 }
3675
princ(LispObject u)3676 LispObject princ(LispObject u)
3677 { escaped_printing = 0;
3678 Save save(u);
3679 active_stream = qvalue(standard_output);
3680 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3681 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3682 internal_prin(u, 0);
3683 save.restore(u);
3684 return u;
3685 }
3686
print(LispObject u)3687 LispObject print(LispObject u)
3688 { LispObject stream = qvalue(standard_output);
3689 Save save(u);
3690 escaped_printing = escape_yes;
3691 if (!is_stream(stream)) stream = qvalue(terminal_io);
3692 if (!is_stream(stream)) stream = lisp_terminal_io;
3693 active_stream = stream;
3694 putc_stream('\n', stream);
3695 internal_prin(u, 0);
3696 save.restore(u);
3697 return u;
3698 }
3699
printc(LispObject u)3700 LispObject printc(LispObject u)
3701 { LispObject stream = qvalue(standard_output);
3702 Save save(u);
3703 escaped_printing = 0;
3704 if (!is_stream(stream)) stream = qvalue(terminal_io);
3705 if (!is_stream(stream)) stream = lisp_terminal_io;
3706 active_stream = stream;
3707 putc_stream('\n', stream);
3708 internal_prin(u, 0);
3709 save.restore(u);
3710 return u;
3711 }
3712
freshline_trace()3713 LispObject freshline_trace()
3714 { if (other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
3715 qvalue(trace_output)) != 0)
3716 putc_stream('\n', qvalue(trace_output));
3717 return nil;
3718 }
3719
freshline_debug()3720 LispObject freshline_debug()
3721 { if (other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
3722 qvalue(debug_io)) != 0)
3723 putc_stream('\n', qvalue(debug_io));
3724 return nil;
3725 }
3726
3727 static int char_to_list_state = 0;
3728
char_to_list(int c,LispObject f)3729 int char_to_list(int c, LispObject f)
3730 { LispObject k;
3731 //
3732 // Codes that are large have to be converted back into utf-8 form.
3733 // Characters in the range 0 to u+00ff are kept cached in a vector
3734 // so that lookup is especially fast. Beyond that involves checking the
3735 // oblist and (if necessary) creating a fresh symbol.
3736 //
3737 c &= 0xff;
3738 if (c <= 0x7f); // Simple character
3739 else if ((c & 0xc0) == 0x80) // Continuation byte
3740 { char_to_list_state = (char_to_list_state << 6) | (c & 0x3f);
3741 if (char_to_list_state >= 0) return 0;
3742 c = char_to_list_state & 0x001fffff;
3743 }
3744 else if ((c & 0xe0) == 0xc0)
3745 { char_to_list_state = (0x80000000u >> 6) + (c & 0x1f);
3746 return 0;
3747 }
3748 else if ((c & 0xf0) == 0xe0)
3749 { char_to_list_state = (0x80000000u >> 12) + (c & 0x0f);
3750 return 0;
3751 }
3752 else
3753 { char_to_list_state = (0x80000000u >> 18) + (c & 0x07);
3754 return 0;
3755 }
3756 if (c > 0xff)
3757 { int len;
3758 if (c <= 0x7ff)
3759 { celt(boffo, 0) = 0xc0 + (c >> 6);
3760 celt(boffo, 1) = 0x80 + (c & 0x3f);
3761 len = 2;
3762 }
3763 else if (c <= 0xffff)
3764 { celt(boffo, 0) = 0xe0 + (c >> 12);
3765 celt(boffo, 1) = 0x80 + ((c >> 6) & 0x3f);
3766 celt(boffo, 2) = 0x80 + (c & 0x3f);
3767 len = 3;
3768 }
3769 else
3770 { celt(boffo, 0) = 0xf0 + (c >> 18);
3771 celt(boffo, 1) = 0x80 + ((c >> 12) & 0x3f);
3772 celt(boffo, 2) = 0x80 + ((c >> 6) & 0x3f);
3773 celt(boffo, 3) = 0x80 + (c & 0x3f);
3774 len = 4;
3775 }
3776 { Save save(f);
3777 k = iintern(boffo, len, lisp_package, 0);
3778 save.restore(f);
3779 }
3780 }
3781 else
3782 { k = elt(charvec, c);
3783 if (k == nil)
3784 { int len;
3785 if (c <= 0x7f)
3786 { celt(boffo, 0) = static_cast<char>(c);
3787 len = 1;
3788 }
3789 else
3790 { celt(boffo, 0) = 0xc0 + (c>>6);
3791 celt(boffo, 1) = 0x80 + (c & 0x3f);
3792 len = 2;
3793 }
3794 { Save save(f);
3795 // It could very well be that in Common Lisp I ought to generate a list of
3796 // character objects here. As it is I hand back symbols, but I do take care
3797 // that they are in the LISP package.
3798 k = iintern(boffo, len, lisp_package, 0);
3799 save.restore(f);
3800 }
3801 elt(charvec, c & 0xff) = k;
3802 }
3803 }
3804 { Save save(f);
3805 k = cons(k, stream_write_data(f));
3806 save.restore(f);
3807 }
3808 stream_write_data(f) = k;
3809 return 0;
3810 }
3811
explode(LispObject u)3812 static LispObject explode(LispObject u)
3813 { stream_write_data(lisp_work_stream) = nil;
3814 set_stream_write_fn(lisp_work_stream, char_to_list);
3815 set_stream_write_other(lisp_work_stream, write_action_list);
3816 active_stream = lisp_work_stream;
3817 internal_prin(u, 0);
3818 u = stream_write_data(lisp_work_stream);
3819 stream_write_data(lisp_work_stream) = nil;
3820 return nreverse(u);
3821 }
3822
3823 static unsigned char checksum_buffer[64];
3824 static int checksum_count;
3825
char_to_checksum(int c,LispObject)3826 int char_to_checksum(int c, LispObject)
3827 { checksum_buffer[checksum_count++] = static_cast<unsigned char>(c);
3828 if (checksum_count == sizeof(checksum_buffer))
3829 { CSL_MD5_Update(checksum_buffer, sizeof(checksum_buffer));
3830 checksum_count = 0;
3831 }
3832 return 0;
3833 }
3834
checksum(LispObject u)3835 void checksum(LispObject u)
3836 { escaped_printing = escape_yes+escape_nolinebreak+escape_checksum;
3837 set_stream_write_fn(lisp_work_stream, char_to_checksum);
3838 set_stream_write_other(lisp_work_stream, write_action_list); // sic
3839 active_stream = lisp_work_stream;
3840 CSL_MD5_Init();
3841 local_gensym_count = checksum_count = 0;
3842 internal_prin(u, 0);
3843 stream_write_data(lisp_work_stream) = nil;
3844 if (checksum_count != 0) CSL_MD5_Update(checksum_buffer, checksum_count);
3845 }
3846
3847 //
3848 // code_to_list is used by exploden and explodecn. Also by
3849 // make-string-output-stream. I want it to collect a list of codes
3850 // not bytes, but by the time I get here things have been utf-8 encoded,
3851 // so I need to unwind that. Ugh.
3852 //
3853
3854 static int32_t code_to_list_state = 0;
3855
code_to_list(int c,LispObject f)3856 int code_to_list(int c, LispObject f)
3857 { LispObject k;
3858 stream_byte_pos(f)++;
3859 c &= 0xff;
3860 if (c <= 0x7f) k = c; // Simple character
3861 else if ((c & 0xc0) == 0x80) // Continuation byte
3862 { code_to_list_state = (code_to_list_state << 6) | (c & 0x3f);
3863 if (code_to_list_state >= 0) return 0;
3864 k = code_to_list_state & 0x001fffff;
3865 }
3866 else if ((c & 0xe0) == 0xc0)
3867 { code_to_list_state = (0x80000000u >> 6) + (c & 0x1f);
3868 return 0;
3869 }
3870 else if ((c & 0xf0) == 0xe0)
3871 { code_to_list_state = (0x80000000u >> 12) + (c & 0x0f);
3872 return 0;
3873 }
3874 else
3875 { code_to_list_state = (0x80000000u >> 18) + (c & 0x07);
3876 return 0;
3877 }
3878 { Save save(f);
3879 k = cons(fixnum_of_int(k), stream_write_data(f));
3880 save.restore(f);
3881 }
3882 stream_write_data(f) = k;
3883 //
3884 // In this case the "position" must not pay attention to
3885 // tabs or newlines.
3886 //
3887 stream_char_pos(f)++;
3888 return 0;
3889 }
3890
exploden(LispObject u)3891 static LispObject exploden(LispObject u)
3892 { stream_write_data(lisp_work_stream) = nil;
3893 set_stream_write_fn(lisp_work_stream, code_to_list);
3894 set_stream_write_other(lisp_work_stream, write_action_list);
3895 active_stream = lisp_work_stream;
3896 internal_prin(u, 0);
3897 u = stream_write_data(lisp_work_stream);
3898 stream_write_data(lisp_work_stream) = nil;
3899 return nreverse(u);
3900 }
3901
3902 //
3903 // To cope with the needs of windowed implementations I am (unilaterally)
3904 // altering the specification of the LINELENGTH function that I implement.
3905 // The new rules are:
3906 // (linelength nil) returns current width, always an integer
3907 // (linelength n) sets new with to n, returns old
3908 // (linelength T) sets new width to default for current stream,
3909 // and returns old.
3910 // the "old" value returned in the last two cases will often be the current
3911 // linelength as returnd by (linelength nil), but it CAN be the value T.
3912 // On some windowed systems after (linelength T) the value of (linelength nil)
3913 // will track changes that the user makes by re-sizing the main output
3914 // window on their screen. The linelength function inspects and sets
3915 // information for the current standard output stream, and separate
3916 // record is kept of the linelength associated with each stream.
3917 //
3918
Llinelength(LispObject env,LispObject a)3919 LispObject Llinelength(LispObject env, LispObject a)
3920 { int32_t oll;
3921 LispObject stream = qvalue(standard_output);
3922 if (!is_stream(stream)) stream = qvalue(terminal_io);
3923 if (!is_stream(stream)) stream = lisp_terminal_io;
3924 if (a == nil)
3925 oll = other_write_action(WRITE_GET_INFO+WRITE_GET_LINE_LENGTH,
3926 stream);
3927 else if (a == lisp_true)
3928 oll = other_write_action(WRITE_SET_LINELENGTH_DEFAULT, stream);
3929 else if (!is_fixnum(a)) return aerror1("linelength", a);
3930 else
3931 { oll = int_of_fixnum(a);
3932 if (oll < 10) oll = 10;
3933 oll = other_write_action(WRITE_SET_LINELENGTH | oll, stream);
3934 }
3935 if (oll == (int32_t)0x80000000) return onevalue(lisp_true);
3936 else return onevalue(fixnum_of_int(oll));
3937 }
3938
Llinelength0(LispObject env)3939 static LispObject Llinelength0(LispObject env)
3940 { return Llinelength(env, nil);
3941 }
3942
internal_check(LispObject original_a,LispObject a,int depth,uint64_t path)3943 static void internal_check(LispObject original_a, LispObject a,
3944 int depth, uint64_t path)
3945 { if (!is_cons(a)) return;
3946 if ((a & 0x7ffffff0) == 0)
3947 { std::printf("Zero cons pointer at depth %d\n", depth);
3948 std::printf("Original a = %" PRIx64 " path = %" PRIx64 "\n",
3949 static_cast<int64_t>(original_a), path);
3950 *reinterpret_cast<char *>(-1) = 0;
3951 }
3952 internal_check(original_a, car(a), depth+1, path<<1);
3953 internal_check(original_a, cdr(a), depth+1, (path<<1)+1);
3954 }
3955
Lcheck_list(LispObject env,LispObject a)3956 LispObject Lcheck_list(LispObject env, LispObject a)
3957 { Save save(a);
3958 internal_check(a, a, 0, 0);
3959 save.restore(a);
3960 return onevalue(a);
3961 }
3962
Lprin(LispObject env,LispObject a)3963 LispObject Lprin(LispObject env, LispObject a)
3964 { Save save(a);
3965 escaped_printing = escape_yes;
3966 active_stream = qvalue(standard_output);
3967 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
3968 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
3969 internal_prin(a, 0);
3970 save.restore(a);
3971 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
3972 return onevalue(a);
3973 }
3974
Lprinraw(LispObject env,LispObject a)3975 static LispObject Lprinraw(LispObject env, LispObject a)
3976 { Save save(a);
3977 prinraw(a);
3978 save.restore(a);
3979 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
3980 return onevalue(a);
3981 }
3982
Lprinhex(LispObject env,LispObject a)3983 static LispObject Lprinhex(LispObject env, LispObject a)
3984 { Save save(a);
3985 prinhex(a, 0);
3986 save.restore(a);
3987 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
3988 return onevalue(a);
3989 }
3990
Lprinoctal(LispObject env,LispObject a)3991 static LispObject Lprinoctal(LispObject env, LispObject a)
3992 { Save save(a);
3993 prinoctal(a, 0);
3994 save.restore(a);
3995 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
3996 return onevalue(a);
3997 }
3998
Lprinbinary(LispObject env,LispObject a)3999 static LispObject Lprinbinary(LispObject env, LispObject a)
4000 { Save save(a);
4001 prinbinary(a, 0);
4002 save.restore(a);
4003 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4004 return onevalue(a);
4005 }
4006
Lprinhex2(LispObject env,LispObject a,LispObject b)4007 static LispObject Lprinhex2(LispObject env, LispObject a,
4008 LispObject b)
4009 { if (!is_fixnum(b)) return aerror1("prinhex", b);
4010 Save save(a);
4011 prinhex(a, int_of_fixnum(b));
4012 save.restore(a);
4013 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4014 return onevalue(a);
4015 }
4016
Lprinoctal2(LispObject env,LispObject a,LispObject b)4017 static LispObject Lprinoctal2(LispObject env, LispObject a,
4018 LispObject b)
4019 { if (!is_fixnum(b)) return aerror1("prinoctal", b);
4020 Save save(a);
4021 prinoctal(a, int_of_fixnum(b));
4022 save.restore(a);
4023 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4024 return onevalue(a);
4025 }
4026
Lprinbinary2(LispObject env,LispObject a,LispObject b)4027 static LispObject Lprinbinary2(LispObject env, LispObject a,
4028 LispObject b)
4029 { if (!is_fixnum(b)) return aerror1("prinbinary", b);
4030 Save save(a);
4031 prinbinary(a, int_of_fixnum(b));
4032 save.restore(a);
4033 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4034 return onevalue(a);
4035 }
4036
Lposn(LispObject)4037 LispObject Lposn(LispObject)
4038 { return onevalue(
4039 fixnum_of_int((int32_t)
4040 other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
4041 qvalue(standard_output))));
4042 }
4043
Lposn_1(LispObject,LispObject stream)4044 LispObject Lposn_1(LispObject, LispObject stream)
4045 { if (!is_stream(stream)) stream = qvalue(terminal_io);
4046 if (!is_stream(stream)) stream = lisp_terminal_io;
4047 return onevalue(fixnum_of_int(
4048 (int32_t)other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
4049 stream)));
4050 }
4051
Llposn(LispObject)4052 LispObject Llposn(LispObject)
4053 { return onevalue(fixnum_of_int(0));
4054 }
4055
4056 // This does not do anything!
Lpagelength(LispObject,LispObject a)4057 LispObject Lpagelength(LispObject, LispObject a)
4058 { return onevalue(a);
4059 }
4060
Lprinc_upcase(LispObject env,LispObject a)4061 LispObject Lprinc_upcase(LispObject env, LispObject a)
4062 { Save save(a);
4063 escaped_printing = escape_fold_up;
4064 active_stream = qvalue(standard_output);
4065 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
4066 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
4067 internal_prin(a, 0);
4068 save.restore(a);
4069 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4070 return onevalue(a);
4071 }
4072
Lprinc_downcase(LispObject env,LispObject a)4073 LispObject Lprinc_downcase(LispObject env, LispObject a)
4074 { Save save(a);
4075 escaped_printing = escape_fold_down;
4076 active_stream = qvalue(standard_output);
4077 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
4078 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
4079 internal_prin(a, 0);
4080 save.restore(a);
4081 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4082 return onevalue(a);
4083 }
4084
Lprinc(LispObject env,LispObject a)4085 LispObject Lprinc(LispObject env, LispObject a)
4086 { Save save(a);
4087 escaped_printing = 0;
4088 active_stream = qvalue(standard_output);
4089 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
4090 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
4091 internal_prin(a, 0);
4092 save.restore(a);
4093 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4094 return onevalue(a);
4095 }
4096
Lprin2a(LispObject env,LispObject a)4097 LispObject Lprin2a(LispObject env, LispObject a)
4098 { Save save(a);
4099 escaped_printing = escape_nolinebreak;
4100 active_stream = qvalue(standard_output);
4101 if (!is_stream(active_stream)) active_stream = qvalue(terminal_io);
4102 if (!is_stream(active_stream)) active_stream = lisp_terminal_io;
4103 internal_prin(a, 0);
4104 save.restore(a);
4105 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4106 return onevalue(a);
4107 }
4108
4109 char memory_print_buffer[MAX_PROMPT_LENGTH];
4110
count_character(int c,LispObject f)4111 int count_character(int c, LispObject f)
4112 { int n = stream_byte_pos(f);
4113 //
4114 // In bad cases the memory_print_buffer will expire part way through
4115 // a multi-byte character. I will tidy that up somewhere else!
4116 //
4117 if (n < MAX_PROMPT_LENGTH-1)
4118 { memory_print_buffer[n] = static_cast<char>(c);
4119 memory_print_buffer[n+1] = 0;
4120 }
4121 stream_byte_pos(f) = n+1;
4122 if ((c & 0xc0) != 0x80) stream_char_pos(f)++;
4123 return 0; // indicate success
4124 }
4125
Llengthc(LispObject env,LispObject a)4126 LispObject Llengthc(LispObject env, LispObject a)
4127 {
4128 //
4129 // This counts a TAB as having width 1. It counts the number of bytes
4130 // used to print the argument.
4131 //
4132 escaped_printing = escape_nolinebreak;
4133 set_stream_write_fn(lisp_work_stream, count_character);
4134 memory_print_buffer[0] = 0;
4135 set_stream_write_other(lisp_work_stream, write_action_list);
4136 stream_byte_pos(lisp_work_stream) = 0;
4137 stream_char_pos(lisp_work_stream) = 0;
4138 active_stream = lisp_work_stream;
4139 internal_prin(a, 0);
4140 return onevalue(fixnum_of_int(stream_byte_pos(lisp_work_stream)));
4141 }
4142
4143
Lwidelengthc(LispObject env,LispObject a)4144 LispObject Lwidelengthc(LispObject env, LispObject a)
4145 {
4146 //
4147 // Like lengthc but counts characters (by ignoring bytes that
4148 //& are 10xxxxxx in binary).
4149 //
4150 escaped_printing = escape_nolinebreak;
4151 set_stream_write_fn(lisp_work_stream, count_character);
4152 memory_print_buffer[0] = 0;
4153 set_stream_write_other(lisp_work_stream, write_action_list);
4154 stream_byte_pos(lisp_work_stream) = 0;
4155 stream_char_pos(lisp_work_stream) = 0;
4156 active_stream = lisp_work_stream;
4157 internal_prin(a, 0);
4158 return onevalue(fixnum_of_int(stream_char_pos(lisp_work_stream)));
4159 }
4160
4161
Ldebug_print(LispObject env,LispObject a)4162 LispObject Ldebug_print(LispObject env, LispObject a)
4163 { LispObject stream = qvalue(standard_output);
4164 Header h;
4165 size_t i, len;
4166 const char *p;
4167 if (!is_stream(stream)) stream = qvalue(terminal_io);
4168 if (!is_stream(stream)) stream = lisp_terminal_io;
4169 if (symbolp(a)) a = get_pname(a);
4170 if (!is_vector(a)) return Lprint(env, a);
4171 h = vechdr(a);
4172 if (!is_string_header(h)) return Lprint(env, a);
4173 len = length_of_byteheader(h) - CELL;
4174 p = reinterpret_cast<const char *>(&celt(a, 0));
4175 for (i=0; i<len; i++)
4176 { Save save(a);
4177 putc_stream(p[i], stream);
4178 save.restore(a);
4179 p = (const char *)&celt(a, 0);
4180 }
4181 { Save save(a);
4182 putc_stream(':', stream);
4183 save.restore(a);
4184 }
4185 p = reinterpret_cast<const char *>(&celt(a, 0));
4186 for (; i<doubleword_align_up(len+CELL)-CELL; i++)
4187 { int c = p[i] & 0xff;
4188 Save save(a);
4189 if (c >= 0x80)
4190 { putc_stream('+', stream);
4191 c &= 0x7f;
4192 }
4193 if (c < 0x20)
4194 { putc_stream('^', stream);
4195 c += 0x40;
4196 }
4197 putc_stream(c, stream);
4198 save.restore(a);
4199 p = reinterpret_cast<const char *>(&celt(a, 0));
4200 }
4201 putc_stream('\n', stream);
4202 return onevalue(nil);
4203 }
4204
Lprint(LispObject env,LispObject a)4205 LispObject Lprint(LispObject env, LispObject a)
4206 { LispObject stream = qvalue(standard_output);
4207 if (!is_stream(stream)) stream = qvalue(terminal_io);
4208 if (!is_stream(stream)) stream = lisp_terminal_io;
4209 Save save(a);
4210 #ifdef COMMON
4211 escaped_printing = escape_yes;
4212 active_stream = stream;
4213 putc_stream('\n', stream);
4214 internal_prin(a, 0);
4215 #else
4216 escaped_printing = escape_yes;
4217 active_stream = stream;
4218 internal_prin(a, 0);
4219 putc_stream('\n', active_stream);
4220 #endif
4221 save.restore(a);
4222 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4223 return onevalue(a);
4224 }
4225
Lprintc(LispObject env,LispObject a)4226 LispObject Lprintc(LispObject env, LispObject a)
4227 { LispObject stream = qvalue(standard_output);
4228 if (!is_stream(stream)) stream = qvalue(terminal_io);
4229 if (!is_stream(stream)) stream = lisp_terminal_io;
4230 Save save(a);
4231 #ifdef COMMON
4232 escaped_printing = 0;
4233 active_stream = stream;
4234 putc_stream('\n', stream);
4235 internal_prin(a, 0);
4236 #else
4237 escaped_printing = 0;
4238 active_stream = stream;
4239 internal_prin(a, 0);
4240 putc_stream('\n', active_stream);
4241 #endif
4242 save.restore(a);
4243 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4244 return onevalue(a);
4245 }
4246
Lterpri(LispObject env)4247 LispObject Lterpri(LispObject env)
4248 { LispObject stream = qvalue(standard_output);
4249 if (!is_stream(stream)) stream = qvalue(terminal_io);
4250 if (!is_stream(stream)) stream = lisp_terminal_io;
4251 putc_stream('\n', stream);
4252 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4253 return onevalue(nil);
4254 }
4255
Lflush(LispObject env)4256 LispObject Lflush(LispObject env)
4257 { LispObject stream = qvalue(standard_output);
4258 if (!is_stream(stream)) stream = qvalue(terminal_io);
4259 if (!is_stream(stream)) stream = lisp_terminal_io;
4260 other_write_action(WRITE_FLUSH, stream);
4261 return onevalue(nil);
4262 }
4263
Lflush1(LispObject env,LispObject stream)4264 LispObject Lflush1(LispObject env, LispObject stream)
4265 { if (!is_stream(stream)) stream = qvalue(terminal_io);
4266 if (!is_stream(stream)) stream = lisp_terminal_io;
4267 other_write_action(WRITE_FLUSH, stream);
4268 return onevalue(nil);
4269 }
4270
Lttab(LispObject env,LispObject a)4271 LispObject Lttab(LispObject env, LispObject a)
4272 { int32_t n;
4273 LispObject stream = qvalue(standard_output);
4274 if (!is_fixnum(a)) return aerror1("ttab", a);
4275 n = int_of_fixnum(a);
4276 if (!is_stream(stream)) stream = qvalue(terminal_io);
4277 if (!is_stream(stream)) stream = lisp_terminal_io;
4278 active_stream = stream;
4279 while (other_write_action(WRITE_GET_INFO+WRITE_GET_COLUMN,
4280 stream) < n)
4281 putc_stream(' ', active_stream);
4282 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4283 return onevalue(nil);
4284 }
4285
Lxtab(LispObject env,LispObject a)4286 LispObject Lxtab(LispObject env, LispObject a)
4287 { int32_t n;
4288 LispObject stream = qvalue(standard_output);
4289 if (!is_fixnum(a)) return aerror1("xtab", a);
4290 n = int_of_fixnum(a);
4291 if (!is_stream(stream)) stream = qvalue(terminal_io);
4292 if (!is_stream(stream)) stream = lisp_terminal_io;
4293 active_stream = stream;
4294 while (n-- > 0) putc_stream(' ', active_stream);
4295 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4296 return onevalue(nil);
4297 }
4298
Leject(LispObject env)4299 LispObject Leject(LispObject env)
4300 { LispObject stream = qvalue(standard_output);
4301 if (!is_stream(stream)) stream = qvalue(terminal_io);
4302 if (!is_stream(stream)) stream = lisp_terminal_io;
4303 putc_stream('\f', stream);
4304 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4305 return onevalue(nil);
4306 }
4307
Lexplode(LispObject env,LispObject a)4308 LispObject Lexplode(LispObject env, LispObject a)
4309 { escaped_printing = escape_yes+escape_nolinebreak+escape_exploding;
4310 return onevalue(explode(a));
4311 }
4312
Lexplodehex(LispObject env,LispObject a)4313 LispObject Lexplodehex(LispObject env, LispObject a)
4314 { escaped_printing = escape_yes+escape_hex+escape_nolinebreak
4315 +escape_exploding;
4316 return onevalue(explode(a));
4317 }
4318
Lexplodeoctal(LispObject env,LispObject a)4319 LispObject Lexplodeoctal(LispObject env, LispObject a)
4320 { escaped_printing = escape_yes+escape_octal+escape_nolinebreak
4321 +escape_exploding;
4322 return onevalue(explode(a));
4323 }
4324
Lexplodebinary(LispObject env,LispObject a)4325 LispObject Lexplodebinary(LispObject env, LispObject a)
4326 { escaped_printing = escape_yes+escape_binary+escape_nolinebreak
4327 +escape_exploding;
4328 return onevalue(explode(a));
4329 }
4330
Lexplodec(LispObject env,LispObject a)4331 LispObject Lexplodec(LispObject env, LispObject a)
4332 { escaped_printing = escape_nolinebreak+escape_exploding;
4333 return onevalue(explode(a));
4334 }
4335
Lexplode2lc(LispObject env,LispObject a)4336 LispObject Lexplode2lc(LispObject env, LispObject a)
4337 { escaped_printing = escape_fold_down+escape_nolinebreak
4338 +escape_exploding;
4339 return onevalue(explode(a));
4340 }
4341
Lexplode2uc(LispObject env,LispObject a)4342 LispObject Lexplode2uc(LispObject env, LispObject a)
4343 { escaped_printing = escape_fold_up+escape_nolinebreak
4344 +escape_exploding;
4345 return onevalue(explode(a));
4346 }
4347
Lexploden(LispObject env,LispObject a)4348 LispObject Lexploden(LispObject env, LispObject a)
4349 { escaped_printing = escape_yes+escape_nolinebreak+escape_exploding;
4350 return onevalue(exploden(a));
4351 }
4352
Lexplodecn(LispObject env,LispObject a)4353 LispObject Lexplodecn(LispObject env, LispObject a)
4354 { escaped_printing = escape_nolinebreak+escape_exploding;
4355 return onevalue(exploden(a));
4356 }
4357
Lexplode2lcn(LispObject env,LispObject a)4358 LispObject Lexplode2lcn(LispObject env, LispObject a)
4359 { escaped_printing = escape_fold_down+escape_nolinebreak
4360 +escape_exploding;
4361 return onevalue(exploden(a));
4362 }
4363
Lexplode2ucn(LispObject env,LispObject a)4364 LispObject Lexplode2ucn(LispObject env, LispObject a)
4365 { escaped_printing = escape_fold_up+escape_nolinebreak
4366 +escape_exploding;
4367 return onevalue(exploden(a));
4368 }
4369
4370 //
4371 // Now a bunch of binary file access code, as required for the RAND simulation
4372 // package. Note that these are NOT smoothly integrated with the use of
4373 // variables like *standard-output* to hold file handles, but I will leave them
4374 // pending until other things are more stable... or until they are needed!
4375 //
4376
4377 static std::FILE *binary_outfile, *binary_infile;
4378
binary_open(LispObject env,LispObject name,const char * dir,const char * e)4379 static std::FILE *binary_open(LispObject env, LispObject name,
4380 const char *dir, const char *e)
4381 { std::FILE *file;
4382 char filename[LONGEST_LEGAL_FILENAME];
4383 size_t len = 0;
4384 const char *w = get_string_data(name, e, len);
4385 std::memset(filename, 0, sizeof(filename));
4386 if (len >= sizeof(filename)) len = sizeof(filename);
4387 file = open_file(filename, w,
4388 static_cast<size_t>(len), dir, nullptr);
4389 if (file == nullptr)
4390 { error(1, err_open_failed, name);
4391 return nullptr;
4392 }
4393 return file;
4394 }
4395
Lbinary_open_output(LispObject env,LispObject name)4396 static LispObject Lbinary_open_output(LispObject env, LispObject name)
4397 { binary_outfile = binary_open(env, name, "wb",
4398 "binary_open_output");
4399 return onevalue(nil);
4400 }
4401
binary_outchar(int c,LispObject)4402 int binary_outchar(int c, LispObject)
4403 { if (binary_outfile == nullptr) return 1;
4404 PUTC(c, binary_outfile);
4405 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4406 return 0; // indicate success
4407 }
4408
Lbinary_prin1(LispObject env,LispObject a)4409 static LispObject Lbinary_prin1(LispObject env, LispObject a)
4410 { Save save(a);
4411 escaped_printing = escape_yes;
4412 set_stream_write_fn(lisp_work_stream, binary_outchar);
4413 set_stream_write_other(lisp_work_stream, write_action_file);
4414 set_stream_file(lisp_work_stream, binary_outfile);
4415 active_stream = lisp_work_stream;
4416 internal_prin(a, 0);
4417 save.restore(a);
4418 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4419 return onevalue(a);
4420 }
4421
Lbinary_princ(LispObject,LispObject a)4422 static LispObject Lbinary_princ(LispObject, LispObject a)
4423 { escaped_printing = 0;
4424 Save save(a);
4425 set_stream_write_fn(lisp_work_stream, binary_outchar);
4426 set_stream_write_other(lisp_work_stream, write_action_file);
4427 set_stream_file(lisp_work_stream, binary_outfile);
4428 active_stream = lisp_work_stream;
4429 internal_prin(a, 0);
4430 save.restore(a);
4431 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4432 return onevalue(a);
4433 }
4434
Lbinary_prinbyte(LispObject env,LispObject a)4435 static LispObject Lbinary_prinbyte(LispObject env, LispObject a)
4436 { int x;
4437 if (binary_outfile == nullptr) return onevalue(nil);
4438 if (!is_fixnum(a)) return aerror1("binary_prinbyte", a);
4439 x = static_cast<int>(int_of_fixnum(a));
4440 PUTC(x, binary_outfile);
4441 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4442 return onevalue(nil);
4443 }
4444
Lbinary_prin2(LispObject env,LispObject a)4445 static LispObject Lbinary_prin2(LispObject env, LispObject a)
4446 { uint32_t x;
4447 if (binary_outfile == nullptr) return onevalue(nil);
4448 if (!is_fixnum(a)) return aerror1("binary_prin2", a);
4449 x = int_of_fixnum(a);
4450 PUTC(static_cast<int>(x >> 8), binary_outfile);
4451 PUTC(static_cast<int>(x), binary_outfile);
4452 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4453 return onevalue(nil);
4454 }
4455
Lbinary_prin3(LispObject env,LispObject a)4456 static LispObject Lbinary_prin3(LispObject env, LispObject a)
4457 { uint32_t x;
4458 if (binary_outfile == nullptr) return onevalue(nil);
4459 if (!is_fixnum(a)) return aerror1("binary_prin3", a);
4460 x = int_of_fixnum(a);
4461 PUTC(static_cast<int>(x >> 16), binary_outfile);
4462 PUTC(static_cast<int>(x >> 8), binary_outfile);
4463 PUTC(static_cast<int>(x), binary_outfile);
4464 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4465 return onevalue(nil);
4466 }
4467
Lbinary_prinfloat(LispObject env,LispObject a)4468 static LispObject Lbinary_prinfloat(LispObject env, LispObject a)
4469 { uint32_t *w, x;
4470 if (binary_outfile == nullptr) return onevalue(nil);
4471 if (!is_float(a)) return aerror1("binary_prinfloat", a);
4472 w = (uint32_t *)&double_float_val(a);
4473 x = w[0];
4474 PUTC(static_cast<int>(x >> 24), binary_outfile);
4475 PUTC(static_cast<int>(x >> 16), binary_outfile);
4476 PUTC(static_cast<int>(x >> 8), binary_outfile);
4477 PUTC(static_cast<int>(x), binary_outfile);
4478 x = w[1];
4479 PUTC(static_cast<int>(x >> 24), binary_outfile);
4480 PUTC(static_cast<int>(x >> 16), binary_outfile);
4481 PUTC(static_cast<int>(x >> 8), binary_outfile);
4482 PUTC(static_cast<int>(x), binary_outfile);
4483 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4484 return onevalue(nil);
4485 }
4486
Lbinary_terpri(LispObject env)4487 static LispObject Lbinary_terpri(LispObject env)
4488 { if (binary_outfile != nullptr) PUTC('\n', binary_outfile);
4489 if (io_limit >= 0 && io_now > io_limit) resource_exceeded();
4490 return onevalue(nil);
4491 }
4492
Lbinary_close_output(LispObject env)4493 static LispObject Lbinary_close_output(LispObject env)
4494 { if (binary_outfile != nullptr)
4495 { std::fclose(binary_outfile);
4496 binary_outfile = nullptr;
4497 }
4498 return onevalue(nil);
4499 }
4500
Lbinary_open_input(LispObject env,LispObject name)4501 static LispObject Lbinary_open_input(LispObject env, LispObject name)
4502 { LispObject r;
4503 std::FILE *fh = binary_open(env, name, "rb", "binary_open_input");
4504 r = make_stream_handle();
4505 errexit();
4506 set_stream_read_fn(r, char_from_file);
4507 set_stream_read_other(r, read_action_file);
4508 set_stream_file(r, fh);
4509 return onevalue(r);
4510 }
4511
Lbinary_select_input(LispObject env,LispObject a)4512 static LispObject Lbinary_select_input(LispObject env, LispObject a)
4513 { if (!is_stream(a) ||
4514 (std::FILE *)stream_file(a) == nullptr ||
4515 (character_stream_writer *)stream_write_fn(a) != 0)
4516 return aerror1("binary-select-input", a); // closed file or output file
4517
4518 binary_infile = stream_file(a);
4519 return onevalue(nil);
4520 }
4521
Lbinary_readbyte(LispObject)4522 static LispObject Lbinary_readbyte(LispObject)
4523 { if (binary_infile == nullptr) return onevalue(fixnum_of_int(-1));
4524 if (++io_kilo >= 1024)
4525 { io_kilo = 0;
4526 io_now++;
4527 }
4528 return onevalue(fixnum_of_int((int32_t)GETC(binary_infile) & 0xff));
4529 }
4530
Lbinary_read2(LispObject)4531 static LispObject Lbinary_read2(LispObject)
4532 { if (binary_infile == nullptr) return onevalue(fixnum_of_int(-1));
4533 { int32_t c1 = (int32_t)GETC(binary_infile) & 0xff;
4534 int32_t c2 = (int32_t)GETC(binary_infile) & 0xff;
4535 ++io_kilo;
4536 if (++io_kilo >= 1024)
4537 { io_kilo = 0;
4538 io_now++;
4539 }
4540 return onevalue(fixnum_of_int((c1<<8) | c2));
4541 }
4542 }
4543
Lbinary_read3(LispObject)4544 static LispObject Lbinary_read3(LispObject)
4545 { if (binary_infile == nullptr) return onevalue(fixnum_of_int(-1));
4546 { int32_t c1 = (int32_t)GETC(binary_infile) & 0xff;
4547 int32_t c2 = (int32_t)GETC(binary_infile) & 0xff;
4548 int32_t c3 = (int32_t)GETC(binary_infile) & 0xff;
4549 io_kilo += 2;
4550 if (++io_kilo >= 1024)
4551 { io_kilo = 0;
4552 io_now++;
4553 }
4554 return onevalue(fixnum_of_int((c1<<16) | (c2<<8) | c3));
4555 }
4556 }
4557
Lbinary_read4(LispObject)4558 static LispObject Lbinary_read4(LispObject)
4559 { if (binary_infile == nullptr) return onevalue(fixnum_of_int(-1));
4560 { int32_t c1 = (int32_t)GETC(binary_infile) & 0xff;
4561 int32_t c2 = (int32_t)GETC(binary_infile) & 0xff;
4562 int32_t c3 = (int32_t)GETC(binary_infile) & 0xff;
4563 int32_t c4 = (int32_t)GETC(binary_infile) & 0xff;
4564 int32_t r = (c1 << 24) | (c2 << 16) | (c3 << 8) | c4;
4565 io_kilo += 3;
4566 if (++io_kilo >= 1024)
4567 { io_kilo = 0;
4568 io_now++;
4569 }
4570 return onevalue(fixnum_of_int(r));
4571 }
4572 }
4573
Lbinary_readfloat(LispObject env)4574 static LispObject Lbinary_readfloat(LispObject env)
4575 { LispObject r = make_boxfloat(0.0, TYPE_DOUBLE_FLOAT);
4576 uint32_t w;
4577 if (binary_infile == nullptr) return onevalue(r);
4578 // Note that the code here treats the float as binary data so infinities and
4579 // NaNs are never anything special.
4580 w = (int32_t)GETC(binary_infile) & 0xff;
4581 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4582 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4583 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4584 ((uint32_t *)&double_float_val(r))[0] = w;
4585 w = (int32_t)GETC(binary_infile) & 0xff;
4586 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4587 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4588 w = (w<<8) | ((int32_t)GETC(binary_infile) & 0xff);
4589 ((uint32_t *)&double_float_val(r))[1] = w;
4590 io_kilo += 7;
4591 if (++io_kilo >= 1024)
4592 { io_kilo = 0;
4593 io_now++;
4594 }
4595 return onevalue(r);
4596 }
4597
Lbinary_close_input(LispObject env)4598 static LispObject Lbinary_close_input(LispObject env)
4599 { if (binary_infile != nullptr)
4600 { std::fclose(binary_infile);
4601 binary_infile = nullptr;
4602 }
4603 return onevalue(nil);
4604 }
4605
4606 //
4607 // (open-library "file" dirn) opens a new library (for use with the
4608 // fasl mechanism etc). If dirn=nil (or not specified) the library is
4609 // opened for input only. If dirn is non-nil an attempt is made to open
4610 // the library so that it can be updated, and if it does not exist to start
4611 // with it is created. The resulting handle can be passed to close-library
4612 // or used in the variables input-libraries or output-library.
4613 //
4614
4615 std::vector<faslFileRecord> fasl_files;
4616
Lopen_library(LispObject env,LispObject file,LispObject dirn)4617 static LispObject Lopen_library(LispObject env, LispObject file,
4618 LispObject dirn)
4619 { char filename[LONGEST_LEGAL_FILENAME];
4620 size_t len = 0;
4621 bool forinput = (dirn==nil);
4622 size_t i;
4623 const char *w = get_string_data(file, "open-library", len);
4624 char *w1;
4625 std::memset(filename, 0, sizeof(filename));
4626 if (len >= sizeof(filename)) len = sizeof(filename)-1;
4627 std::memcpy(filename, w, len);
4628 filename[len] = 0;
4629 // If one of the libraries I had opened earlier has now been closed there
4630 // may be an empty slot in fasl_files[], and so I will scan and look for
4631 // that and if I find such then I will use it.
4632 for (i=0; i<fasl_files.size(); i++)
4633 { if (!fasl_files[i].inUse) goto found;
4634 }
4635 // If not I append a new slot on the end of the std::vector. By using
4636 // std::vector I can at least pretend that there is no limit to the number of
4637 // libraries that I can have open at once. However the cost of that is that
4638 // it can need to allocate memory and that allocation may fail. If it does
4639 // that will be abruptly fatal.
4640 fasl_files.push_back(faslFileRecord(nullptr, !forinput));
4641 i = fasl_files.size()-1;
4642 found:
4643 fasl_files[i].inUse = true;
4644 w1 = new (std::nothrow) char[std::strlen(filename)+1];
4645 if (w1 != nullptr) std::strcpy(w1, filename);
4646 // The name field contains either nullptr or a newly allocated C string.
4647 fasl_files[i].name = w1;
4648 fasl_files[i].dir = open_pds(filename,
4649 forinput ? PDS_INPUT : PDS_OUTPUT);
4650 fasl_files[i].isOutput = !forinput;
4651 return onevalue(SPID_LIBRARY + (((int32_t)i)<<20));
4652 }
4653
Lopen_library_1(LispObject env,LispObject file)4654 static LispObject Lopen_library_1(LispObject env, LispObject file)
4655 { return Lopen_library(env, file, nil);
4656 }
4657
Lclose_library(LispObject env,LispObject lib)4658 static LispObject Lclose_library(LispObject env, LispObject lib)
4659 { if (!is_library(lib)) return aerror1("close-library", lib);
4660 finished_with(library_number(lib));
4661 return onevalue(nil);
4662 }
4663
Llibrary_name(LispObject env,LispObject lib)4664 static LispObject Llibrary_name(LispObject env, LispObject lib)
4665 { LispObject a;
4666 if (!is_library(lib)) return aerror1("library-name", lib);
4667 const char *s = fasl_files[library_number(lib)].name;
4668 if (s == nullptr) s = "*unknown*";
4669 a = make_string(s);
4670 return onevalue(a);
4671 }
4672
4673 #ifdef SOCKETS
4674
4675 //
4676 // If a Winsock function fails it leaves an error code that
4677 // WSAGetLastError() can retrieve. This function converts the numeric
4678 // codes to some printable text. Still cryptic, but maybe better than
4679 // the raw numbers!
4680 //
4681
4682 #ifndef WIN32
4683
WSAErrName(int i)4684 static char error_name[32];const char *WSAErrName(int i)
4685 { switch (i)
4686 { default: std::sprintf(error_name,
4687 "Socket error %d", i);
4688 return error_name;
4689 // When I run under Unix I display both the Unix and Windows form of the
4690 // error code. I guess that shows you which of those platforms is the one
4691 // I am doing initial development on!
4692 case EINTR: return "WSAEINTR/EINTR";
4693 case EBADF: return "WSAEBADF/EBADF";
4694 case EACCES: return "WSAEACCES/EACCES";
4695 case EFAULT: return "WSAEFAULT/EFAULT";
4696 case EINVAL: return "WSAEINVAL/EINVAL";
4697 case EMFILE: return "WSAEMFILE/EMFILE";
4698 case EWOULDBLOCK: return "WSAEWOULDBLOCK/EWOULDBLOCK";
4699 case EINPROGRESS: return "WSAEINPROGRESS/EINPROGRESS";
4700 case EALREADY: return "WSAEALREADY/EALREADY";
4701 case ENOTSOCK: return "WSAENOTSOCK/ENOTSOCK";
4702 case EDESTADDRREQ: return "WSAEDESTADDRREQ/EDESTADDRREQ";
4703 case EMSGSIZE: return "WSAEMSGSIZE/EMSGSIZE";
4704 case EPROTOTYPE: return "WSAEPROTOTYPE/EPROTOTYPE";
4705 case ENOPROTOOPT: return "WSAENOPROTOOPT/ENOPROTOOPT";
4706 case EPROTONOSUPPORT: return "WSAEPROTONOSUPPORT/EPROTONOSUPPORT";
4707 case ESOCKTNOSUPPORT: return "WSAESOCKTNOSUPPORT/ESOCKTNOSUPPORT";
4708 case EOPNOTSUPP: return "WSAEOPNOTSUPP/EOPNOTSUPP";
4709 case EPFNOSUPPORT: return "WSAEPFNOSUPPORT/EPFNOSUPPORT";
4710 case EAFNOSUPPORT: return "WSAEAFNOSUPPORT/EAFNOSUPPORT";
4711 case EADDRINUSE: return "WSAEADDRINUSE/EADDRINUSE";
4712 case EADDRNOTAVAIL: return "WSAEADDRNOTAVAIL/EADDRNOTAVAIL";
4713 case ENETDOWN: return "WSAENETDOWN/ENETDOWN";
4714 case ENETUNREACH: return "WSAENETUNREACH/ENETUNREACH";
4715 case ENETRESET: return "WSAENETRESET/ENETRESET";
4716 case ECONNABORTED: return "WSAECONNABORTED/ECONNABORTED";
4717 case ECONNRESET: return "WSAECONNRESET/ECONNRESET";
4718 case ENOBUFS: return "WSAENOBUFS/ENOBUFS";
4719 case EISCONN: return "WSAEISCONN/EISCONN";
4720 case ENOTCONN: return "WSAENOTCONN/ENOTCONN";
4721 case ESHUTDOWN: return "WSAESHUTDOWN/ESHUTDOWN";
4722 case ETOOMANYREFS: return "WSAETOOMANYREFS/ETOOMANYREFS";
4723 case ETIMEDOUT: return "WSAETIMEDOUT/ETIMEDOUT";
4724 case ECONNREFUSED: return "WSAECONNREFUSED/ECONNREFUSED";
4725 case ELOOP: return "WSAELOOP/ELOOP";
4726 case ENAMETOOLONG: return "WSAENAMETOOLONG/ENAMETOOLONG";
4727 case EHOSTDOWN: return "WSAEHOSTDOWN/EHOSTDOWN";
4728 case EHOSTUNREACH: return "WSAEHOSTUNREACH/EHOSTUNREACH";
4729 case HOST_NOT_FOUND: return "WSAHOST_NOT_FOUND/HOST_NOT_FOUND";
4730 case TRY_AGAIN: return "WSATRY_AGAIN/TRY_AGAIN";
4731 case NO_RECOVERY: return "WSANO_RECOVERY/NO_RECOVERY";
4732 #ifdef never
4733 //
4734 // Duplicated EINTR, at least on Linux.
4735 //
4736 case NO_DATA: return "WSANO_DATA/NO_DATA";
4737 #endif
4738 }
4739 }
4740
4741 #endif // WIN32
4742
4743
4744 bool sockets_ready = false;
4745
ensure_sockets_ready()4746 int ensure_sockets_ready()
4747 { if (!sockets_ready)
4748 {
4749 #ifdef WIN32
4750 if (windowsPrepareSockets() != 0) return 1;
4751 #endif
4752 sockets_ready = true;
4753 }
4754 return 0;
4755 }
4756
4757 #define SOCKET_BUFFER_SIZE 256
4758
4759 //
4760 // A stream attached to a socket is represented by putting the socket handle
4761 // into the field that would otherwise hold a FILE. The stream_read_data
4762 // field then holds a string. The first 4 characters of this contain
4763 // two packed integers saying how much buffered data is available,
4764 // and then there is just a chunk of buffered text.
4765 //
4766
char_from_socket(LispObject stream)4767 int char_from_socket(LispObject stream)
4768 { int ch = stream_pushed_char(stream);
4769 if (ch == NOT_CHAR)
4770 { LispObject w = stream_read_data(stream);
4771 int32_t sb_data = ielt32(w, 0);
4772 int sb_start = sb_data & 0xffff, sb_end = (sb_data >> 16) & 0xffff;
4773 //
4774 // Note use of ucelt in the next line even if char is a signed type. This
4775 // is because getc() etc are expected to return an UNSIGNED char cast to
4776 // an int.
4777 //
4778 if (sb_start != sb_end) ch = ucelt(w, sb_start++);
4779 else
4780 { ch = recv((SOCKET)(intptr_t)(std::FILE *)stream_file(stream),
4781 reinterpret_cast<char *>(&celt(w, 4)), SOCKET_BUFFER_SIZE, 0);
4782 if (ch == 0) return EOF;
4783 if (ch == SOCKET_ERROR)
4784 { err_printf("socket read error (%s)\n",
4785 WSAErrName(WSAGetLastError()));
4786 return EOF;
4787 }
4788 sb_start = 5;
4789 sb_end = ch + 4;
4790 ch = ucelt(w, 4);
4791 }
4792 sb_data = sb_start | (sb_end << 16);
4793 ielt32(w, 0) = sb_data;
4794 return ch;
4795 }
4796 else stream_pushed_char(stream) = NOT_CHAR;
4797 return ch;
4798 }
4799
4800 //
4801 // Seek and tell will be just quiet no-ops on socket streams.
4802 //
4803
read_action_socket(int32_t op,LispObject f)4804 int32_t read_action_socket(int32_t op, LispObject f)
4805 { if (op < -1) return 0;
4806 else if (op <= 0xff) return (stream_pushed_char(f) = op);
4807 else switch (op)
4808 { case READ_CLOSE:
4809 if ((std::FILE *)stream_file(f) == nullptr) op = 0;
4810 else
4811 #ifdef SOCKETS
4812 op = closesocket(
4813 (SOCKET)(intptr_t)(std::FILE *)stream_file(f));
4814 #else
4815 op = 0;
4816 #endif
4817 set_stream_read_fn(f, char_from_illegal);
4818 set_stream_read_other(f, read_action_illegal);
4819 set_stream_file(f, nullptr);
4820 stream_read_data(f) = nil;
4821 return op;
4822 case READ_FLUSH:
4823 stream_pushed_char(f) = NOT_CHAR;
4824 return 0;
4825 default:
4826 return 0;
4827 }
4828 }
4829
4830
fetch_response(char * buffer,LispObject r)4831 int fetch_response(char *buffer, LispObject r)
4832 { int i;
4833 for (i = 0; i < LONGEST_LEGAL_FILENAME; i++)
4834 { int ch = char_from_socket(r);
4835 if (ch == EOF) return 1;
4836 buffer[i] = static_cast<char>(ch);
4837 if (ch == 0x0a)
4838 { buffer[i] = 0;
4839 //
4840 // The keys returned at the start of a response line are supposed to be
4841 // case insensitive, so I fold things to lower case right here.
4842 //
4843 for (i=0; buffer[i]!=0 && buffer[i]!=' '; i++)
4844 buffer[i] = static_cast<char>(std::tolower(static_cast<unsigned char>
4845 (buffer[i])));
4846 return 0;
4847 }
4848 }
4849 return 1; // fail if response was over-long
4850 }
4851
4852
Lopen_url(LispObject env,LispObject url)4853 static LispObject Lopen_url(LispObject env, LispObject url)
4854 { char filename[LONGEST_LEGAL_FILENAME],
4855 filename1[LONGEST_LEGAL_FILENAME], *p;
4856 const char *user, *pass, *proto, *hostaddr, *port, *path;
4857 size_t nuser, npass, nproto, nhostaddr, nport, npath;
4858 size_t len = 0;
4859 struct hostent *host;
4860 unsigned long int hostnum;
4861 SOCKET s;
4862 size_t i;
4863 int retcode, retry_count=0;
4864 LispObject r;
4865 const char *w = get_string_data(url, "open-url", len);
4866 std::memset(filename, 0, sizeof(filename));
4867 std::memset(filename1, 0, sizeof(filename1));
4868
4869 start_again:
4870
4871 if (len >= sizeof(filename)) len = sizeof(filename)-1;
4872 std::memcpy(filename, w, len);
4873 filename[len] = 0;
4874 //
4875 // I want to parse the URL. I leave the result as a collection of
4876 // pointers (usually to the start of text within the URL itself, but
4877 // sometimes elsewhere, together with lengths of the substrings as found.
4878 //
4879 user = pass = proto = hostaddr = port = path = " ";
4880 nuser = npass = nproto = nhostaddr = nport = npath = 0;
4881 p = filename;
4882 //
4883 // If the start of the URL is of the form "xyz:" with xyz alphanumeric
4884 // then that is a protocol name, and I will force it into lower case.
4885 //
4886 for (i=0; i<len; i++)
4887 if (!std::isalnum(static_cast<unsigned char>(p[i]))) break;
4888 if (p[i] == ':')
4889 { char *oldp = p;
4890 proto = p;
4891 nproto = i; // Could still be zero!
4892 p += i+1;
4893 len -= i+1;
4894 for (i=0; i<nproto; i++)
4895 oldp[i] = static_cast<char>(std::tolower(static_cast<unsigned char>
4896 (oldp[i])));
4897 }
4898 //
4899 // After any protocol specification I may have a host name, introduced
4900 // by "//".
4901 //
4902 if (p[0] == '/' && p[1] == '/')
4903 { p += 2;
4904 len -= 2;
4905 //
4906 // If the URL (sans protocol) contains a "@" then I will take it to be
4907 // in the form
4908 // user:password@hostaddr/...
4909 // and will split the user bit off. This will be particularly used in the
4910 // case of FTP requests. The password will be allowed to contain ":" and
4911 // "@" characters. Furthermore I will also allow the password to be
4912 // enclosed in quote marks ("), although since I scan for the "@" from
4913 // the right and for the ":" from the left these are not needed at all,
4914 // so if I notice them here all I have to do is to discard them!
4915 //
4916 for (i=len; i>0; i--)
4917 if (p[i-1] == '@') break;
4918 if (i > 0)
4919 { i--;
4920 user = p;
4921 p += i+1;
4922 len -= i+1;
4923 while (user[nuser] != ':' && user[nuser] != '@') nuser++;
4924 if (user[nuser] == ':')
4925 { pass = user+nuser+1;
4926 npass = i - nuser - 1;
4927 if (pass[0] == '"' && pass[npass-1] == '"')
4928 pass++, npass -= 2;
4929 }
4930 }
4931 //
4932 // Now what is left is a host, port number and path, written as
4933 // hostaddr:port/... but note that the "/" should be treated as
4934 // part of the path-name.
4935 //
4936 hostaddr = p;
4937 for (;;)
4938 { switch (hostaddr[nhostaddr])
4939 { default:
4940 nhostaddr++;
4941 continue;
4942 case '/':
4943 p += nhostaddr;
4944 len -= nhostaddr;
4945 break;
4946 case 0: len = 0;
4947 break;
4948 case ':': // port number given
4949 port = hostaddr+nhostaddr+1;
4950 for (;;)
4951 { switch (port[nport])
4952 { default:
4953 nport++;
4954 continue;
4955 case '/':
4956 p += nhostaddr + nport + 1;
4957 len -= nhostaddr + nport + 1;
4958 break;
4959 case 0: len = 0;
4960 break;
4961 }
4962 break;
4963 }
4964 break;
4965 }
4966 break;
4967 }
4968 }
4969 path = p;
4970 npath = len;
4971 if (npath == 0) path = "/", npath = 1; // Default path
4972 //
4973 // If a protocol was not explicitly given I will try to deduce one from the
4974 // start of the name of the hostaddr. Failing that I will just use a default.
4975 //
4976 if (nproto == 0)
4977 { if (std::strncmp(hostaddr, "www.", 4) == 0 ||
4978 std::strncmp(hostaddr, "wwwcgi.", 7) == 0)
4979 { proto = "http";
4980 nproto = 4;
4981 }
4982 else
4983 { proto = "ftp";
4984 nproto = 3;
4985 }
4986 }
4987 //
4988 // If the user gave an explicit port number I will try to use it. If the
4989 // port was not numeric I ignore it and drop down to trying to use
4990 // a default port based on the selected protocol.
4991 //
4992 if (nport != 0)
4993 { int w;
4994 std::memcpy(filename1, port, nport);
4995 filename1[nport] = 0;
4996 if (std::sscanf(filename1, "%d", &w) == 1) nport = w;
4997 else nport = 0;
4998 }
4999 if (nport == 0)
5000 { if (nproto == 3 && std::memcmp(proto, "ftp", 3) == 0) nport = 21;
5001 else if (nproto == 4 &&
5002 std::memcmp(proto, "http", 4) == 0) nport = 80;
5003 //
5004 // Elsewhere I have code that can call on an external "scp" program to support
5005 // a secure-fetch scheme, but I will NOT include that here.
5006 //
5007 else return aerror("Unknown protocol");
5008 }
5009 //
5010 // If no host-name was given then the object concerned is on the
5011 // local machine. This is a funny case maybe, but I will just chain
5012 // through and open it as an ordinary file (without regard to
5013 // protocol etc).
5014 //
5015 if (nhostaddr == 0)
5016 { std::FILE *file = open_file(filename1, path, static_cast<size_t>(npath), "r",
5017 nullptr);
5018 if (file == nullptr) return onevalue(nil);
5019 { Save save(url);
5020 r = make_stream_handle();
5021 errexit();
5022 save.restore(url);
5023 }
5024 stream_type(r) = url;
5025 set_stream_file(r, file);
5026 set_stream_read_fn(r, char_from_file);
5027 set_stream_read_other(r, read_action_file);
5028 return onevalue(r);
5029 }
5030 if (nproto == 3 && std::strcmp(proto, "ftp") == 0 && nuser == 0)
5031 { user = "anonymous";
5032 nuser = std::strlen(user);
5033 if (npass == 0)
5034 { pass = "acn1@cam.ac.uk";
5035 npass = std::strlen(pass);
5036 }
5037 }
5038 #ifdef DEBUG
5039 //
5040 // The trace print here is not needed in the long term but certainly
5041 // helps while I am doing initial tests.
5042 //
5043 trace_printf(
5044 "User <%.*s> Pass <%.*s> Proto <%.*s>\n"
5045 "Host <%.*s> Port <%d> Path <%.*s>\n",
5046 nuser, user, npass, pass, nproto, proto,
5047 nhostaddr, hostaddr, nport, npath, path);
5048 #endif
5049 if (ensure_sockets_ready() != 0) return nil;
5050 std::memcpy(filename1, hostaddr, nhostaddr);
5051 filename1[nhostaddr] = 0;
5052 // I try to accept either "." form or named host specifications
5053 hostnum = inet_addr(filename1);
5054 if (hostnum == INADDR_NONE)
5055 { host = gethostbyname(filename1);
5056 if (host != nullptr)
5057 hostnum = ((struct in_addr *)host->h_addr)->s_addr;
5058 }
5059 if (hostnum == INADDR_NONE)
5060 { err_printf("Host not found (%s)\n",
5061 WSAErrName(WSAGetLastError()));
5062 return onevalue(nil);
5063 }
5064 s = socket(PF_INET, SOCK_STREAM, 0); // Make a new socket
5065 { struct sockaddr_in sockin;
5066 std::memset(&sockin, 0, sizeof(sockin));
5067 sockin.sin_family = AF_INET;
5068 sockin.sin_port = htons(nport);
5069 sockin.sin_addr.s_addr = hostnum;
5070 //
5071 // Because there can be quite tedious delays in network fetches I will
5072 // log that I am trying to make contact.
5073 //
5074 trace_printf("Contacting %.*s...\n", nhostaddr, hostaddr);
5075 ensure_screen();
5076 if (connect(s, (struct sockaddr *)&sockin,
5077 sizeof(sockin)) == SOCKET_ERROR)
5078 { err_printf("connect failed %s\n", WSAErrName(WSAGetLastError()));
5079 closesocket(s);
5080 return onevalue(nil);
5081 }
5082 trace_printf("Connection created\n");
5083 }
5084 std::sprintf(filename1, "GET %.*s HTTP/1.0\x0d\x0a\x0d\x0a",
5085 static_cast<int>(npath), path);
5086
5087 // MD addition from webcore.c
5088 i = std::strlen(filename1);
5089 //
5090 // Certainly if the Web server I am accessing is the one that comes as
5091 // standard with Windows NT I need to reassure it that I want the document
5092 // returned to me WHATEVER its media type is. If I do not add in the
5093 // line "Accept: *|*" the GET request will only allow me to fetch simple
5094 // text (?)
5095 // Note that above I write "*|*" where I only really mean a "/" in the
5096 // middle but where C comment conventions intrude!
5097 //
5098 std::sprintf(&filename1[i], "Accept: */*\x0d\x0a\x0d\x0a");
5099
5100 if (send(s, filename1, std::strlen(filename1), 0) == SOCKET_ERROR)
5101 { err_printf("Send error (%s)\n", WSAErrName(WSAGetLastError()));
5102 closesocket(s);
5103 return onevalue(nil);
5104 }
5105
5106 { Save save(url);
5107 r = make_stream_handle();
5108 errexit();
5109 save.restore(url);
5110 }
5111 stream_type(r) = url;
5112 { Save save(r);
5113 url = get_basic_vector(TAG_VECTOR, TYPE_STRING_4,
5114 CELL+4+SOCKET_BUFFER_SIZE);
5115 errexit();
5116 save.restore(r);
5117 }
5118 ielt32(url, 0) = 0;
5119 stream_read_data(r) = url;
5120 set_stream_file(r, (std::FILE *)(intptr_t)s);
5121 set_stream_read_fn(r, char_from_socket);
5122 set_stream_read_other(r, read_action_socket);
5123
5124 // Now fetch the status line.
5125 if (fetch_response(filename1, r))
5126 { err_printf("Error fetching status line from the server\n");
5127 Lclose(env,r);
5128 return onevalue(nil);
5129 }
5130
5131 //
5132 // I check if the first line returned is in the form "HTTP/n.n nnn " and if
5133 // it is not I assume that I have reached an HTTP/0.9 server and all the
5134 // text that comes back will be the body.
5135 //
5136 { int major, minor;
5137 //
5138 // I will not worry much about just which version of HTTP the system reports
5139 // that it is using, provided it says something! I expect to see the return
5140 // code as a three digit number. I verify that it is in the range 0 to 999 but
5141 // do not check for (and thus reject) illegal responses such as 0000200.
5142 //
5143 if (std::sscanf(filename1,
5144 "http/%d.%d %d", &major, &minor, &retcode) != 3 ||
5145 retcode < 0 || retcode > 999)
5146 { err_printf("Bad protocol specification returned\n");
5147 err_printf(filename1); // So I can see what did come back
5148 Lclose(env,r);
5149 return onevalue(nil);
5150 }
5151 }
5152 //
5153 // In this code I treat all unexpected responses as errors and I do not
5154 // attempt to continue. This is sometimes going to be overly pessimistic
5155 // and RFC1945 tells me that I should treat unidentified codes as the
5156 // n00 variant thereupon.
5157 //
5158 switch (retcode)
5159 { default:retcode = 0;
5160 break;
5161 case 200:
5162 break; // A success code for GET requests
5163 case 301: // Redirection request
5164 case 302:
5165 do
5166 { if (fetch_response(filename1, r))
5167 { err_printf("Unexpected response from the server\n");
5168 retcode = 0;
5169 break;
5170 }
5171 if (filename1[0] == 0)
5172 { err_printf("Document has moved, but I can not trace it\n");
5173 retcode = 0;
5174 break;
5175 }
5176 }
5177 while (std::memcmp(filename1, "location: ", 10) != 0);
5178 if (retcode == 0) break;
5179 //
5180 // At present I take a somewhat simplistic view of redirection, and just
5181 // look for the first alternative URL and start my entire unpicking
5182 // process afresh from there.
5183 //
5184 for (i = 10; filename1[i] == ' '; i++);
5185 w = &filename1[i];
5186 while (filename1[i]!=' ' && filename1[i]!=0) i++;
5187 filename1[i] = 0;
5188 len = std::strlen(w);
5189 closesocket(s);
5190 if (++retry_count > 5)
5191 { err_printf("Apparent loop in redirection information\n");
5192 retcode = 0;
5193 break;
5194 }
5195 goto start_again;
5196 break;
5197 case 401:
5198 err_printf("Authorisation required for this access\n");
5199 retcode = 0;
5200 break;
5201 case 404:
5202 err_printf("Object not found\n");
5203 retcode = 0;
5204 break;
5205 }
5206
5207 if (retcode == 0)
5208 { Lclose(env,r);
5209 return onevalue(nil);
5210 }
5211
5212 //
5213 // Skip further information returned by the server until a line containing
5214 // just the end-of-line marker is fetched
5215 //
5216 do
5217 { for (i = 0; i < LONGEST_LEGAL_FILENAME; i++)
5218 { int ch = char_from_socket(r);
5219 if (ch == EOF)
5220 { err_printf("Error fetching additional info from the server\n");
5221 Lclose(env,r);
5222 return onevalue(nil);
5223 }
5224 if (ch == 0x0a) break;
5225 }
5226 }
5227 while (i > 1);
5228
5229 return onevalue(r);
5230 }
5231
5232 #endif // SOCKETS
5233
5234 int window_heading = 0;
5235
5236 char saveright[32];
5237
Lwindow_heading2(LispObject env,LispObject a,LispObject b)5238 LispObject Lwindow_heading2(LispObject env, LispObject a,
5239 LispObject b)
5240 {
5241 #ifndef EMBEDDED
5242 int32_t n, bit;
5243 const char *s;
5244 char txt[32];
5245 txt[0] = 0;
5246 if (is_fixnum(b)) n = int_of_fixnum(b);
5247 else n = 2; // default to setting the right section
5248 if (is_vector(a) && is_string(a))
5249 { int32_t l = length_of_byteheader(vechdr(a)) - CELL;
5250 if (l > 30) l = 30;
5251 std::memcpy(txt, &celt(a, 0), l);
5252 txt[l] = 0;
5253 s = txt;
5254 }
5255 else if (b == 2) s = "";
5256 else s = nullptr;
5257 switch (n)
5258 { case 0: fwin_report_left(s); bit = 1; break;
5259 case 1: fwin_report_mid(s); bit = 2; break;
5260 default:
5261 #ifdef WITH_GUI
5262 if (alternative_stdout != nullptr)
5263 { if (std::strcmp(txt, saveright) != 0 && s != nullptr)
5264 { std::fprintf(stderr, "Info: %s\n", txt);
5265 #ifdef __CYGWIN__
5266 std::putc('\r', stderr);
5267 #endif
5268 std::fflush(stderr);
5269 }
5270 std::strcpy(saveright, txt);
5271 }
5272 #else
5273 if (std::strcmp(txt, saveright) != 0 && s != nullptr)
5274 { std::fprintf(stderr, "Info: %s\n", txt);
5275 #ifdef __CYGWIN__
5276 std::putc('\r', stderr);
5277 #endif
5278 std::fflush(stderr);
5279 }
5280 std::strcpy(saveright, txt);
5281 #endif // WITH_GUI
5282 fwin_report_right(s); bit = 4; break;
5283 }
5284 if (s == nullptr || *s == 0) window_heading &= ~bit;
5285 else window_heading |= bit;
5286 #endif // !EMBEDDED
5287 return onevalue(nil);
5288 }
5289
Lwindow_heading1(LispObject env,LispObject a)5290 LispObject Lwindow_heading1(LispObject env, LispObject a)
5291 { return Lwindow_heading2(env, a, nil);
5292 }
5293
5294 setup_type const print_setup[] =
5295 {
5296 #ifdef SOCKETS
5297 DEF_1("open-url", Lopen_url),
5298 #endif
5299 DEF_1("check-list", Lcheck_list),
5300 {"window-heading", G0Wother, Lwindow_heading1, Lwindow_heading2, G3Wother, G4Wother},
5301 DEF_0("eject", Leject),
5302 DEF_1("filep", Lfilep),
5303 DEF_1("filedate", Lfiledate),
5304 {"flush", Lflush, Lflush1, G2Wother, G3Wother, G4Wother},
5305 DEF_1("streamp", Lstreamp),
5306 DEF_1("is-console", Lis_console),
5307 DEF_1("lengthc", Llengthc),
5308 DEF_1("widelengthc", Lwidelengthc),
5309 {"linelength", Llinelength0, Llinelength, G2Wother, G3Wother, G4Wother},
5310 DEF_0("lposn", Llposn),
5311 DEF_2("internal-open", Lopen),
5312 {"open-library", G0Wother, Lopen_library_1, Lopen_library, G3W2, G4W2},
5313 DEF_1("close-library", Lclose_library),
5314 DEF_1("library-name", Llibrary_name),
5315 DEF_1("create-directory", Lcreate_directory),
5316 DEF_1("delete-file", Ldelete_file),
5317 DEF_1("delete-wildcard", Ldelete_wildcard),
5318 DEF_2("rename-file", Lrename_file),
5319 DEF_1("file-readablep", Lfile_readable),
5320 DEF_1("file-writeablep", Lfile_writeable),
5321 DEF_1("directoryp", Ldirectoryp),
5322 DEF_1("file-length", Lfile_length),
5323 DEF_1("truename", Ltruename),
5324 DEF_1("list-directory", Llist_directory),
5325 DEF_1("chdir", Lchange_directory),
5326 DEF_1("make-function-stream", Lmake_function_stream),
5327 DEF_0("make-string-output-stream", Lmake_string_output_stream),
5328 DEF_1("get-output-stream-string", Lget_output_stream_string),
5329 DEF_0("get-current-directory", Lget_current_directory),
5330 DEF_0("user-homedir-pathname", Luser_homedir_pathname),
5331 DEF_0("get-lisp-directory", Lget_lisp_directory),
5332 DEF_0("find-gnuplot", Lfind_gnuplot),
5333 DEF_0("getpid", Lgetpid),
5334 DEF_1("pagelength", Lpagelength),
5335 {"posn", Lposn, Lposn_1, G2Wother, G3Wother, G4Wother},
5336 DEF_1("spaces", Lxtab),
5337 DEF_0("terpri", Lterpri),
5338 DEF_0("tmpdir", Ltmpdir),
5339 {"tmpnam", Ltmpnam, Ltmpnam1, G2Wother, G3Wother, G4Wother},
5340 DEF_1("ttab", Lttab),
5341 DEF_1("wrs", Lwrs),
5342 DEF_1("xtab", Lxtab),
5343 DEF_1("princ-upcase", Lprinc_upcase),
5344 DEF_1("princ-downcase", Lprinc_downcase),
5345 DEF_1("binary_open_output", Lbinary_open_output),
5346 DEF_1("binary_prin1", Lbinary_prin1),
5347 DEF_1("binary_princ", Lbinary_princ),
5348 DEF_1("binary_prinbyte", Lbinary_prinbyte),
5349 DEF_1("binary_prin2", Lbinary_prin2),
5350 DEF_1("binary_prin3", Lbinary_prin3),
5351 DEF_1("binary_prinfloat", Lbinary_prinfloat),
5352 DEF_0("binary_terpri", Lbinary_terpri),
5353 DEF_0("binary_close_output", Lbinary_close_output),
5354 DEF_1("binary_open_input", Lbinary_open_input),
5355 DEF_1("binary_select_input", Lbinary_select_input),
5356 DEF_0("binary_readbyte", Lbinary_readbyte),
5357 DEF_0("binary_read2", Lbinary_read2),
5358 DEF_0("binary_read3", Lbinary_read3),
5359 DEF_0("binary_read4", Lbinary_read4),
5360 DEF_0("binary_readfloat", Lbinary_readfloat),
5361 DEF_0("binary_close_input", Lbinary_close_input),
5362 DEF_1("prinraw", Lprinraw),
5363 {"prinhex", G0Wother, Lprinhex, Lprinhex2, G3Wother, G4Wother},
5364 {"prinoctal", G0Wother, Lprinoctal, Lprinoctal2, G3Wother, G4Wother},
5365 {"prinbinary", G0Wother, Lprinbinary, Lprinbinary2, G3Wother, G4Wother},
5366 DEF_1("math-display", Lmath_display),
5367 DEF_1("debug-print", Ldebug_print),
5368 DEF_1("set-print-precision", Lprint_precision),
5369 DEF_1("setprintprecision", Lprint_precision),
5370 DEF_0("getprintprecision", Lget_precision),
5371 DEF_1("close", Lclose),
5372 DEF_1("explode", Lexplode),
5373 DEF_1("explodec", Lexplodec),
5374 DEF_1("explode2", Lexplodec),
5375 DEF_1("explode2lc", Lexplode2lc),
5376 DEF_1("explode2uc", Lexplode2uc),
5377 DEF_1("exploden", Lexploden),
5378 DEF_1("explodecn", Lexplodecn),
5379 DEF_1("explode2n", Lexplodecn),
5380 DEF_1("explode2lcn", Lexplode2lcn),
5381 DEF_1("explode2ucn", Lexplode2ucn),
5382 DEF_1("explodehex", Lexplodehex),
5383 DEF_1("explodeoctal", Lexplodeoctal),
5384 DEF_1("explodebinary", Lexplodebinary),
5385 DEF_1("prin", Lprin),
5386 DEF_1("prin1", Lprin),
5387 DEF_1("princ", Lprinc),
5388 DEF_1("prin2", Lprinc),
5389 DEF_1("prin2a", Lprin2a),
5390 DEF_1("print", Lprint),
5391 DEF_1("printc", Lprintc),
5392 DEF_1("tyo", Ltyo),
5393 // The next few are Common Lisp-isms but I will stick them in here anyway.
5394 {"charpos", Lposn, Lposn_1, G2Wother, G3Wother, G4Wother},
5395 {"finish-output", Lflush, Lflush1, G2Wother, G3Wother, G4Wother},
5396 DEF_1("make-synonym-stream", Lmake_synonym_stream),
5397 {"make-broadcast-stream", Lmake_broadcast_stream_0, Lmake_broadcast_stream_1, Lmake_broadcast_stream_2, Lmake_broadcast_stream_3, Lmake_broadcast_stream_4up},
5398 {"make-concatenated-stream", Lmake_concatenated_stream_0, Lmake_concatenated_stream_1, Lmake_concatenated_stream_2, Lmake_concatenated_stream_3, Lmake_concatenated_stream_4up},
5399 DEF_2("make-two-way-stream", Lmake_two_way_stream),
5400 DEF_2("make-echo-stream", Lmake_echo_stream),
5401 {"make-string-input-stream", Lmake_string_input_stream_0, Lmake_string_input_stream_1, Lmake_string_input_stream_2, Lmake_string_input_stream_3, Lmake_string_input_stream_4up},
5402 DEF_1("~tyo", Ltyo),
5403 {nullptr, nullptr, nullptr, nullptr, nullptr, nullptr}
5404 };
5405
5406 // end of print.cpp
5407