1 /* cslread.c Copyright (C) 1990-2010 Codemist Ltd */
2
3 /*
4 * Reading and symbol-table support.
5 */
6
7 /**************************************************************************
8 * Copyright (C) 2010, Codemist Ltd. 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
37
38 /* Signature: 6082f884 20-Aug-2010 */
39
40 #include "headers.h"
41
42 #ifdef COMMON
43 #include "clsyms.h"
44 #endif
45
46 #ifdef SOCKETS
47 #include "sockhdr.h"
48 #endif
49
50 #ifdef WIN32
51 #include <windows.h>
52 #endif
53
54 #define CTRL_C 3
55 #define CTRL_D 4
56
57 #ifdef Kanji
58 #define ISalpha(a) iswalpha(a)
59 #define ISdigit(a) iswdigit(a)
60 #define ISspace(a) iswspace(a)
61 #define TOupper(a) towupper(a)
62 #define TOlower(a) towlower(a)
63
first_char(Lisp_Object ch)64 int first_char(Lisp_Object ch)
65 { /* ch is a symbol. Get the first character of its name. */
66 int n;
67 intptr_t l;
68 ch = qpname(ch);
69 l = length_of_header(vechdr(ch)) - CELL;
70 if (l == 0) return 0;
71 n = celt(ch, 0);
72 if (is2byte(n) && l != 1)
73 n = (n << 8) + ucelt(ch, 1);
74 return n;
75 }
76
77 #else /* Kanji */
78 #define ISalpha(a) isalpha(a)
79 #define ISdigit(a) isdigit(a)
80 #define ISspace(a) isspace(a)
81 #define TOupper(a) toupper(a)
82 #define TOlower(a) tolower(a)
83 #define first_char(ch) ucelt(qpname(ch), 0)
84 #endif /* Kanji */
85
86
87 /*
88 * Basic version of Lisp reader.
89 */
90
91 static int curchar = NOT_CHAR;
92 FILE *non_terminal_input;
93
94 int boffop;
95 #define boffo_char(i) ucelt(boffo, i)
96
97
make_string(const char * b)98 Lisp_Object make_string(const char *b)
99 /*
100 * Given a C string, create a Lisp (simple-) string.
101 */
102 {
103 int32_t n = strlen(b);
104 Lisp_Object r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
105 char *s = (char *)r - TAG_VECTOR;
106 int32_t k = (n + 3) & ~(int32_t)7;
107 Lisp_Object nil;
108 errexit();
109 /* Here I go to some trouble to zero out the last doubleword of the vector */
110 if (SIXTY_FOUR_BIT)
111 { if (k != 0)
112 { *(int32_t *)(s + k + 4) = 0;
113 *(int32_t *)(s + k) = 0;
114 }
115 }
116 else
117 { *(int32_t *)(s + k + 4) = 0;
118 if (k != 0) *(int32_t *)(s + k) = 0;
119 }
120 memcpy(s + CELL, b, (size_t)n);
121 validate_string(r);
122 return r;
123 }
124
validate_string_fn(Lisp_Object s,char * file,int line)125 void validate_string_fn(Lisp_Object s, char *file, int line)
126 {
127 if (is_vector(s) &&
128 type_of_header(vechdr(s)) == TYPE_STRING)
129 { int len = length_of_header(vechdr(s));
130 int len1 = doubleword_align_up(len);
131 while (len < len1)
132 { if (celt(s, len-CELL) != 0)
133 { fprintf(stderr, "\n+++ Bad string at %s %d\n", file, line);
134 fflush(stderr);
135 *(int *)(Lisp_Object)(-1) = 0x55555555; /* I hope this aborts */
136 }
137 len++;
138 }
139 return;
140 }
141 fprintf(stderr, "\n+++ Not even a string at %s %d\n", file, line);
142 fflush(stderr);
143 *(int *)(Lisp_Object)(-1) = 0x55555555; /* I hope this aborts */
144 }
145
copy_string(Lisp_Object str,int32_t n)146 static Lisp_Object copy_string(Lisp_Object str, int32_t n)
147 /*
148 * Given a Lisp string, plus its length, create a Lisp (simple-) string.
149 * NOTE that the "string" passed in may not in fact have the length
150 * you think it has - it may be boffo which is used as a string buffer.
151 */
152 {
153 Lisp_Object nil, r;
154 char *s;
155 int32_t k;
156 push(str);
157 r = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
158 pop(str);
159 s = (char *)r - TAG_VECTOR;
160 k = (n + 3) & ~(int32_t)7;
161 errexit();
162 /* Here I go to some trouble to zero out the last doubleword of the vector */
163 if (SIXTY_FOUR_BIT)
164 { if (k != 0)
165 { *(int32_t *)(s + k + 4) = 0;
166 *(int32_t *)(s + k) = 0;
167 }
168 }
169 else
170 { *(int32_t *)(s + k + 4) = 0;
171 if (k != 0) *(int32_t *)(s + k) = 0;
172 }
173 memcpy(s + CELL, (char *)str + (CELL-TAG_VECTOR), (size_t)n);
174 validate_string(r);
175 return r;
176 }
177
Lbatchp(Lisp_Object nil,int nargs,...)178 Lisp_Object MS_CDECL Lbatchp(Lisp_Object nil, int nargs, ...)
179 {
180 CSL_IGNORE(nil);
181 argcheck(nargs, 0, "batchp");
182 #ifdef SOCKETS
183 /*
184 * If CSL is being run as a service (ie accessed via a socket) then I will
185 * deem it to be in "interactive" mode. This leaves responsibility for stopping
186 * after errors (if that is what is wanted) with the other end of the
187 * communications link.
188 */
189 if (socket_server != 0) return onevalue(nil);
190 #endif
191 /*
192 * If the user had specified input files on the command line I will say that
193 * we are in batch mode even if there is a terminal present somewhere. So
194 * a run of the form
195 * csl inputfile.lsp
196 * is a "batch" run, while
197 * csl < inputfile.lsp
198 * will MAYBE also be noticed as batch, but do not count on it!
199 */
200 if (non_terminal_input != NULL)
201 return onevalue(batch_flag ? nil : lisp_true);
202 /*
203 * "sysxxx.c" now decides if we are in "batch processing" context,
204 * in general by asking "isatty(fileno(stdin))" to see if stdin is
205 * attached to an interactive terminal. Ideally this will say we are in
206 * batch mode if the user has redirected input from a file, as in
207 * csl < xxx.lsp
208 * but catching such cases may be HARD with some operating systems.
209 * With some operating systems we will NEVER report ourselves as "batch".
210 */
211 return onevalue(Lispify_predicate(batch_flag ? !batchp() : batchp()));
212 }
213
Lgetenv(Lisp_Object nil,Lisp_Object a)214 Lisp_Object Lgetenv(Lisp_Object nil, Lisp_Object a)
215 {
216 char parmname[LONGEST_LEGAL_FILENAME];
217 Header h;
218 Lisp_Object r;
219 int32_t len;
220 char *w;
221 #ifdef COMMON
222 if (complex_stringp(a))
223 { a = simplify_string(a);
224 errexit();
225 }
226 #endif
227 if (symbolp(a))
228 { a = get_pname(a);
229 errexit();
230 h = vechdr(a);
231 }
232 else if (!is_vector(a) ||
233 type_of_header(h = vechdr(a)) != TYPE_STRING)
234 return aerror1("getenv", a);
235 len = length_of_header(h) - CELL;
236 memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len);
237 parmname[len] = 0;
238 w = my_getenv(parmname);
239 if (w == NULL) return onevalue(nil); /* not available */
240 r = make_string(w);
241 errexit();
242 return onevalue(r);
243 }
244
Lsystem(Lisp_Object nil,Lisp_Object a)245 Lisp_Object Lsystem(Lisp_Object nil, Lisp_Object a)
246 {
247 char parmname[LONGEST_LEGAL_FILENAME];
248 Header h;
249 int32_t len;
250 int w;
251 #ifdef SOCKETS
252 /*
253 * Security measure - remote client can not do "system"
254 */
255 if (socket_server != 0) return onevalue(nil);
256 #endif
257 if (a == nil) /* enquire if command processor is available */
258 { w = my_system(NULL);
259 return onevalue(Lispify_predicate(w != 0));
260 }
261 #ifdef COMMON
262 if (complex_stringp(a))
263 { a = simplify_string(a);
264 errexit();
265 }
266 #endif
267 if (symbolp(a))
268 { a = get_pname(a);
269 errexit();nil = C_nil;
270 h = vechdr(a);
271 }
272 else if (!is_vector(a) ||
273 type_of_header(h = vechdr(a)) != TYPE_STRING)
274 return aerror1("system", a);
275 len = length_of_header(h) - CELL;
276 memcpy(parmname, (char *)a + (CELL-TAG_VECTOR), (size_t)len);
277 parmname[len] = 0;
278 ensure_screen();
279 w = my_system(parmname);
280 ensure_screen();
281 return onevalue(fixnum_of_int((int32_t)w));
282 }
283
284 #ifdef WIN32
285 /*
286 * On Windows this version takes the trouble to avoid letting the
287 * application that you are running pop up a visible console window.
288 */
289
Lsilent_system(Lisp_Object nil,Lisp_Object a)290 static Lisp_Object Lsilent_system(Lisp_Object nil, Lisp_Object a)
291 {
292 char cmd[LONGEST_LEGAL_FILENAME];
293 #ifdef SHELL_EXECUTE
294 char args[LONGEST_LEGAL_FILENAME];
295 #endif
296 Header h;
297 int32_t len;
298 int i;
299 #ifdef SOCKETS
300 /*
301 * Security measure - remote client can not do "system"
302 */
303 if (socket_server != 0) return onevalue(nil);
304 #endif
305 if (a == nil) /* enquire if command processor is available */
306 return onevalue(lisp_true); /* always is on Windows! */
307 ensure_screen();
308 #ifdef COMMON
309 if (complex_stringp(a))
310 { a = simplify_string(a);
311 errexit();
312 }
313 #endif
314 if (symbolp(a))
315 { a = get_pname(a);
316 errexit();nil = C_nil;
317 h = vechdr(a);
318 }
319 else if (!is_vector(a) ||
320 type_of_header(h = vechdr(a)) != TYPE_STRING)
321 return aerror1("system", a);
322 ensure_screen();
323 len = length_of_header(h) - CELL;
324 memcpy(cmd, (char *)a + (CELL-TAG_VECTOR), (size_t)len);
325 cmd[len] = 0;
326 #ifdef SHELL_EXECUTE
327 /*
328 * ShellExecute works for me and allows me to launch an application with
329 * its console hidden - but it does not give an opportunity to wait until
330 * the command that was executed has completed. I will leave this code
331 * here for now since I may find I want to re-use it (eg for opening
332 * documents). But the code bwlow that explicitly creates a process is
333 * what I reaaly need here.
334 */
335 i = 0;
336 while (cmd[i]!=' ' && cmd[i]!=0) i++;
337 if (cmd[i]==0) args[0] = 0;
338 else
339 { cmd[i] = 0;
340 strcpy(args, &cmd[i+1]);
341 }
342 i = (int)ShellExecute(NULL,
343 "open",
344 cmd,
345 args,
346 ".",
347 SW_HIDE);
348 #else
349 { STARTUPINFO startup;
350 PROCESS_INFORMATION process;
351 DWORD rc;
352 memset(&startup, 0, sizeof(startup));
353 startup.cb = sizeof(startup);
354 startup.dwFlags = STARTF_USESHOWWINDOW;
355 startup.wShowWindow = SW_HIDE;
356 memset(&process, 0, sizeof(process));
357 if (!CreateProcess(NULL, cmd, NULL, NULL, FALSE,
358 CREATE_NEW_CONSOLE,
359 NULL, NULL, &startup, &process))
360 { return onevalue(nil);
361 }
362 WaitForSingleObject(process.hProcess, INFINITE);
363 /*
364 * If I fail to retrieve a true exit code I will return the value 1000. This
365 * is pretty arbitrary, but I expect 0 to denote success and 1000 to be an
366 * unusual "genuine" return code
367 */
368 if (!GetExitCodeProcess(process.hProcess, &rc)) rc = 1000;
369 CloseHandle(process.hProcess);
370 CloseHandle(process.hThread);
371 i = (int)rc;
372 }
373 #endif
374 ensure_screen();
375 return onevalue(fixnum_of_int(i));
376 }
377
378 #else
379
Lsilent_system(Lisp_Object nil,Lisp_Object a)380 static Lisp_Object Lsilent_system(Lisp_Object nil, Lisp_Object a)
381 {
382 /*
383 * Other than on Windows I do not see any risk of "consoles" getting created
384 * when I do not want them, so this just does what the normal execution code
385 * does.
386 */
387 return Lsystem(nil, a);
388 }
389
390 #endif
391
hash_lisp_string_with_length(Lisp_Object s,int32_t n)392 static uint32_t hash_lisp_string_with_length(Lisp_Object s, int32_t n)
393 {
394 /*
395 * I start off the hash calculation with something that depends on the
396 * length of the string n. Hmmm - I want hash values to end up the same
397 * on 32 and 64-bit machines and the length I pass down here includes the
398 * length of the string header, so I adjust for that. The way I do that here
399 * preserves the hash values that I historically used on 32-bit machines
400 * and so 32-bit image files should remain valid.
401 */
402 uint32_t hh = 0x01000000 + n - CELL + 4;
403 uint32_t *b = (uint32_t *)((char *)s + (CELL-TAG_VECTOR));
404 char *b1;
405 while (n >= CELL+4) /* Do as much as is possible word at a time */
406 {
407 uint32_t temp;
408 /*
409 * The next few lines take a 32-bit value with digits PQRS and for a value
410 * with digits Q^R and P^Q^R^S. Note that this is invariant under the change
411 * to SRQP, and thus even though I fetched a whole word and the order of bytes
412 * in that word is hard to know the hash value will not depend on the byte
413 * order involved. By that time I have done all this and thereby lost any
414 * chance of ABCD and DCBA not clashing maybe a simple byte at a time hash
415 * procedure would have been more sense? Some day I should take comparative
416 * timings and measurements of hash-table conflicts.
417 */
418 uint32_t a = *b++; /* P Q R S */
419 a = a ^ (a << 8); /* P^Q Q^R R^S S */
420 a = a ^ (a >> 16); /* P^Q Q^R P^Q^R^S Q^R^S */
421 a = a << 8; /* Q^R P^Q^R^S Q^R^S 0 */
422 /*
423 * And now compute a hash value using a CRC that has a period of
424 * 0x7fffffff (i.e. maximum period in 31 bits). And at least if shift
425 * operations are cheap on your computer it can be evaluated rapidly as well.
426 */
427 temp = hh << 7;
428 hh = ((hh >> 25) ^
429 (temp >> 1) ^
430 (temp >> 4) ^
431 (a >> 16)) & 0x7fffffff;
432 n -= 4;
433 }
434 b1 = (char *)b;
435 /*
436 * Finish off the hash value byte-at-a-time. If I could be certain that
437 * strings being hashed would always be zero-padded in their last word I
438 * could avoid the need for this, but at present I can not.
439 */
440 while (n > CELL)
441 { uint32_t temp;
442 temp = hh << 7;
443 hh = ((hh >> 25) ^
444 (temp >> 1) ^
445 (temp >> 4) ^
446 (uint32_t)*b1++) & 0x7fffffff;
447 n -= 1;
448 }
449 /*
450 * At the end I multiply by 139 so that at least symbols that differ
451 * by just having adjacent last letters will be better spread out.
452 */
453 return ((139*hh) & 0x7fffffff);
454 }
455
hash_lisp_string(Lisp_Object s)456 uint32_t hash_lisp_string(Lisp_Object s)
457 /*
458 * Argument is a (lisp) string. Return a 31 bit hash value.
459 */
460 {
461 return hash_lisp_string_with_length(s, length_of_header(vechdr(s)));
462 }
463
value_in_radix(int c,int radix)464 static int value_in_radix(int c, int radix)
465 {
466 if (ISdigit(c)) c = c - '0'; /* Assumes digit codes are consecutive */
467 /*
468 * The next section tries hard not to depend on any particular character
469 * code - this may slow it down a little bit but reading numbers that
470 * have an explicit radix will not usually matter that much.
471 */
472 else if (ISalpha(c))
473 { char *v = "abcdefghijklmnopqrstuvwxyz";
474 int n = 0;
475 c = tolower(c);
476 while (*v++ != c)
477 if (++n >= 26) return -1; /* break on unrecognized letter */
478 c = n + 10;
479 }
480 else return -1;
481 if (c < radix) return c;
482 else return -1;
483 }
484
intern(int len,CSLbool escaped)485 Lisp_Object intern(int len, CSLbool escaped)
486 /*
487 * This takes whatever is in the first len characters of
488 * the Lisp string boffo, and maps it into a number, string
489 * or symbol as relevant.
490 */
491 {
492 int i, numberp = escaped ? -1 : 0;
493 #ifdef COMMON
494 int fplength = 2, explicit_fp_format = 0;
495 #endif
496 Lisp_Object nil = C_nil;
497 stackcheck0(0);
498 for (i=0; i<len; i++)
499 { int c = boffo_char(i);
500 switch (numberp)
501 {
502 default:
503 break;
504 case 0:
505 if (c == '+' || c == '-')
506 { numberp = 1;
507 continue;
508 }
509 /* drop through */
510 case 1:
511 if (c == '.')
512 { numberp = 6;
513 continue;
514 }
515 if (ISdigit(c)) /* Really wants to inspect *read-base* */
516 { numberp = 2;
517 continue;
518 }
519 numberp = -1;
520 break;
521 case 2:
522 if (ISdigit(c)) continue; /* *read-base* */
523 switch (c)
524 {
525 #ifdef COMMON
526 case '/': numberp = 3; continue;
527 #endif
528 case '.': numberp = 5; continue;
529 case 'e': case 'E':
530 /*
531 * in CSL mode I will read all floating point numbers as if they had been
532 * double-precision, so I disable recognition of s,f,d and l exponent
533 * markers and force the length. In Common Lisp mode I have to look at the
534 * value of *read-default-float-format* to see what to do.
535 */
536 numberp = 9;
537 continue;
538 #ifdef COMMON
539 case 's': case 'S':
540 boffo_char(i) = 'e';
541 explicit_fp_format = 1;
542 fplength = 0;
543 numberp = 9;
544 continue;
545 case 'f': case 'F':
546 boffo_char(i) = 'e';
547 explicit_fp_format = 1;
548 fplength = 1;
549 numberp = 9;
550 continue;
551 case 'd': case 'D':
552 boffo_char(i) = 'e';
553 explicit_fp_format = 1;
554 numberp = 9;
555 continue;
556 case 'l': case 'L':
557 boffo_char(i) = 'e';
558 explicit_fp_format = 1;
559 fplength = 3;
560 numberp = 9;
561 continue;
562 #endif
563 default:
564 numberp = -1;
565 break;
566 }
567 break;
568 #ifdef COMMON
569 case 3:
570 case 4:
571 if (ISdigit(c)) /* *read-base* */
572 { numberp = 4;
573 continue;
574 }
575 numberp = -1;
576 break;
577 #endif
578 case 5:
579 case 8:
580 if (ISdigit(c))
581 { numberp = 8;
582 continue;
583 }
584 switch (c)
585 {
586 case 'e': case 'E':
587 numberp = 9;
588 continue;
589 #ifdef COMMON
590 case 's': case 'S':
591 /* Clobbering the string is a DISASTER if it is not in fact numeric */
592 boffo_char(i) = 'e';
593 explicit_fp_format = 1;
594 fplength = 0;
595 numberp = 9;
596 continue;
597 case 'f': case 'F':
598 boffo_char(i) = 'e';
599 explicit_fp_format = 1;
600 fplength = 1;
601 numberp = 9;
602 continue;
603 case 'd': case 'D':
604 boffo_char(i) = 'e';
605 explicit_fp_format = 1;
606 numberp = 9;
607 continue;
608 case 'l': case 'L':
609 boffo_char(i) = 'e';
610 explicit_fp_format = 1;
611 fplength = 3;
612 numberp = 9;
613 continue;
614 #endif
615 default:
616 numberp = -1;
617 break;
618 }
619 break;
620 case 6:
621 if (ISdigit(c))
622 { numberp = 8;
623 continue;
624 }
625 numberp = -1;
626 break;
627 case 9:
628 if (c == '+' || c == '-')
629 { numberp = 10;
630 continue;
631 }
632 /* Drop through */
633 case 10:
634 case 11:
635 if (ISdigit(c))
636 { numberp = 11;
637 continue;
638 }
639 numberp = -1;
640 break;
641 }
642 break;
643 }
644 /* Here the item has been scanned, and it is known if it is numeric! */
645 switch (numberp)
646 {
647 default:
648 /* Not a number... look up in package system */
649 #ifdef COMMON
650 if (!escaped && boffo_char(0) == ':')
651 { int i = 0;
652 for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1);
653 boffop--;
654 return iintern(boffo, (int32_t)boffop, qvalue(keyword_package), 0);
655 }
656 #endif
657 return iintern(boffo, (int32_t)boffop, CP, 0);
658
659
660 case 5: /* Integer written as 12345. (note trailing ".") */
661 boffo_char(--boffop) = 0; /* ... trim off the trailing dot */
662 /* drop through */
663 case 2:
664 /*
665 * I speed up reading by working 7 digits at a time (using C integer
666 * arithmetic to gobble them) and only resorting to Lisp generic
667 * arithmetic to combine the chunks.
668 */
669 if (boffo_char(0) == '+')
670 { int i = 0;
671 for (i = 0; i<boffop; i++) boffo_char(i) = boffo_char(i+1);
672 boffop--;
673 }
674 { Lisp_Object v = fixnum_of_int(0);
675 CSLbool sign = NO;
676 int32_t d = 0, d1 = 10;
677 for (i=0; i<boffop; i++)
678 { if (i==0 && boffo_char(i) == '-') sign = YES;
679 else if (d1 == 10000000 || i == boffop-1)
680 { d = 10*d + (int32_t)value_in_radix(boffo_char(i), 10);
681 v = times2(v, fixnum_of_int(d1));
682 errexit();
683 v = plus2(v, fixnum_of_int(d));
684 d = 0;
685 d1 = 10;
686 errexit();
687 }
688 else
689 { d = 10*d + (int32_t)value_in_radix(boffo_char(i), 10);
690 d1 = 10*d1;
691 }
692 }
693 if (sign) v = negate(v);
694 return v;
695 }
696
697 #ifdef COMMON
698 case 4:
699 { int p, q, g;
700 Lisp_Object r;
701 /* Beware bignum issue here... but take view that ratios are not used! */
702 boffo_char(boffop) = 0;
703 /* p and q were made int not int32_t to match up with the %d in scanf ... */
704 sscanf((char *)&boffo_char(0), "%d/%d", &p, &q);
705 /* Limit myself to fixnums here */
706 g = (int)int_of_fixnum(gcd(fixnum_of_int((int32_t)p),
707 fixnum_of_int((int32_t)q)));
708 p /= g;
709 q /= g;
710 if (q < 0)
711 { p = -p;
712 q = -q;
713 }
714 r = getvector(TAG_NUMBERS, TYPE_RATNUM, sizeof(Rational_Number));
715 errexit();
716 numerator(r) = fixnum_of_int((int32_t)p);
717 denominator(r) = fixnum_of_int((int32_t)q);
718 return r;
719 }
720 #endif
721 case 8:
722 case 11:
723 { double d;
724 Lisp_Object r;
725 #ifdef COMMON
726 float f;
727 if (!explicit_fp_format && is_symbol(read_float_format))
728 { Lisp_Object w = qvalue(read_float_format);
729 if (w == short_float) fplength = 0;
730 else if (w == single_float) fplength = 1;
731 /* else if (w == double_float) fplength = 2; */
732 else if (w == long_float) fplength = 3;
733 }
734 #endif
735 boffo_char(boffop) = 0;
736 d = atof((char *)&boffo_char(0));
737 #ifdef COMMON
738 switch (fplength)
739 {
740 case 0:
741 { Float_union ff;
742 ff.f = (float)d;
743 return TAG_SFLOAT + (ff.i & ~(int32_t)0xf);
744 }
745 case 1:
746 f = (float)d;
747 r = getvector(TAG_BOXFLOAT, TYPE_SINGLE_FLOAT,
748 sizeof(Single_Float));
749 errexit();
750 single_float_val(r) = f;
751 return r;
752 default:
753 /* case 2: case 3: */
754 r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT,
755 SIZEOF_DOUBLE_FLOAT);
756 errexit();
757 double_float_val(r) = d;
758 return r;
759 }
760 #else
761 /*
762 * Only support double precision in CSL mode
763 */
764 r = getvector(TAG_BOXFLOAT, TYPE_DOUBLE_FLOAT,
765 SIZEOF_DOUBLE_FLOAT);
766 errexit();
767 double_float_val(r) = d;
768 return r;
769 #endif
770 }
771 }
772 }
773
make_undefined_symbol(char const * s)774 Lisp_Object make_undefined_symbol(char const *s)
775 {
776 return make_symbol(s, 0, undefined1, undefined2, undefinedn);
777 }
778
make_symbol(char const * s,int restartp,one_args * f1,two_args * f2,n_args * fn)779 Lisp_Object make_symbol(char const *s, int restartp,
780 one_args *f1, two_args *f2, n_args *fn)
781 /*
782 * Used from the startup code to create an interned symbol and (maybe)
783 * put something in its function cell.
784 */
785 {
786 Lisp_Object v, v0 = C_nil, nil = C_nil;
787 int first_try = 1;
788 /*
789 * Here I blandly assume that boffo is long enough to hold the string
790 * that I am about to copy into it. All is guaranteed well for
791 * symbols predefined in Lisp in the normal way, but ones established
792 * using command-line options like -Dname could cause trouble?
793 */
794 #ifdef COMMON
795 /*
796 * For COMMON Lisp I will make all the built-in symbols upper case, unless
797 * the "2" bit of restartp is set...
798 */
799 char const *p1 = s;
800 char *p2 = (char *)&boffo_char(0);
801 int c;
802 if ((restartp & 2) == 0)
803 { while ((c = *p1++) != 0)
804 { c = toupper(c);
805 *p2++ = c;
806 }
807 *p2 = 0;
808 }
809 else
810 #endif
811 strcpy((char *)&boffo_char(0), s);
812 start_again:
813 v = iintern(boffo, (int32_t)strlen((char *)&boffo_char(0)), CP, 0);
814 errexit();
815 if (first_try) v0 = v;
816 /*
817 * I instate the definition given if (a) the definition is a real
818 * one (ie not for an undefined function) and if (b) either I am doing a cold
819 * start or the name is still marked as having a definition in the form
820 * of C code (or if I gace first_try false which is when I am going round
821 * again and doing rather curious things...)
822 */
823 if (f1 != undefined1)
824 { if ((restartp & 1)==0 || (qheader(v) & SYM_C_DEF) != 0 || !first_try)
825 { if (qenv(v) == v) qenv(v) = nil;
826 /* only set env field to nil if it was otherwise not in use */
827 ifn1(v) = (intptr_t)f1; ifn2(v) = (intptr_t)f2; ifnn(v) = (intptr_t)fn;
828 qheader(v) |= SYM_C_DEF;
829 }
830 else
831 { int l = strlen((char *)&boffo_char(0));
832 /*
833 * Another piece of curious behaviour here, intend to make it easier to
834 * survive when the CSL/CCL kernel is extended. If a function that the
835 * (new) kernel would like to define as a C-coded thing is already in
836 * the current image either as undefined or with some other (byte-coded)
837 * definition, I map the name of the new function, and XYZ goes to ~XYZ etc
838 * by prefixing a '~'. The image as loaded can then access the new C coded
839 * function by this name, and possibly transfer it across to the normal
840 * name it was originally expected to have. Since this is a symptom of
841 * somebody having done either a curious over-riding redefinition of something
842 * in the kernel or not having re-build to get new symbols properly available,
843 * I print a message about it. Note also that I only rename once, so if there
844 * were to be existing symbols with names that started with "~" that could
845 * make my attempts here less than fully effective.
846 */
847 if (init_flags & INIT_VERBOSE)
848 term_printf(
849 "+++ Built-in \"%s\" clashes with image file: => \"~%s\"\n",
850 &boffo_char(0), &boffo_char(0));
851 while (l >= 0) boffo_char(l+1) = boffo_char(l), l--;
852 boffo_char(0) = '~';
853 first_try = 0;
854 goto start_again;
855 }
856 /*
857 * All things that have been set up as copies of this symbol must be
858 * initialised with the definition too. This happens even if the original
859 * symbol has been redefined and is not longer nice C code...
860 */
861 if ((restartp & 1) != 0)
862 {
863 /*
864 * Note that I want to scan based on the ORIGINAL name of the function
865 * not on any version that has been renamed with a "~".
866 */
867 #ifdef COMMON
868 Lisp_Object v1 = get(v0, work_symbol, nil);
869 #else
870 Lisp_Object v1 = get(v0, work_symbol);
871 #endif
872 while (consp(v1))
873 { Lisp_Object w = qcar(v1);
874 v1 = qcdr(v1);
875 ifn1(w) = (intptr_t)f1; ifn2(w) = (intptr_t)f2; ifnn(w) = (intptr_t)fn;
876 qenv(w) = qenv(v); /* Copy across environment too */
877 qheader(w) |= SYM_C_DEF;
878 }
879 }
880 }
881 return v;
882 }
883
add_to_hash(Lisp_Object s,Lisp_Object vector,uint32_t hash)884 static CSLbool add_to_hash(Lisp_Object s, Lisp_Object vector, uint32_t hash)
885 /*
886 * Adds an item into a hash table given that it is known that it is not
887 * already there.
888 */
889 {
890 Header h = vechdr(vector);
891 int32_t size = (length_of_header(h) - CELL)/CELL;
892 int32_t i = (int32_t)(hash & (size-1));
893 /*
894 * I have arranged (elsewhere) that the hash table will be a power of two
895 * in size, so I can avoid primary clustering by stepping on by any odd
896 * number. Furthermore I might replace the (perhaps expensive) remaindering
897 * operations by (perhaps cheap) bitwise "AND" when I reduce my hash value
898 * to the right range to be an index into the table.
899 *
900 * I might make a few remarks here about sizes. Each hash table segment
901 * may have 128K cells. hash is a 32-bit value, so hash>>10 is a 22-bit
902 * value (ie up to 4M). So all the bits that might end up in the step I
903 * take are available.
904 */
905 int32_t step = 1 | ((hash >> 10) & (size - 1));
906 int32_t probes = 0;
907 /*
908 * size is expected to be a power of 2 here.
909 */
910 while (++probes <= size)
911 { if (is_fixnum(elt(vector, i)))
912 { elt(vector, i) = s;
913 return YES; /* Success */
914 }
915 i = i + step;
916 if (i >= size) i -= size;
917 }
918 return NO; /* Table is totally full */
919 }
920
921 static int32_t number_of_chunks;
922
923 #define CHUNK_SIZE (CELL*(PAGE_POWER_OF_TWO/32))
924
rehash(Lisp_Object v,Lisp_Object chunks,int grow)925 static Lisp_Object rehash(Lisp_Object v, Lisp_Object chunks, int grow)
926 {
927 /*
928 * If (grow) is +1 this enlarges the table. If -1 it shrinks it. In the
929 * case that the table is to shrink I should guarantee that the next smaller
930 * table size down will have enough space for the number of active items
931 * present. grow=0 leaves the table size alone but still rehashes.
932 */
933 int32_t h = CHUNK_SIZE, i;
934 Lisp_Object new_obvec, nil;
935 number_of_chunks = int_of_fixnum(chunks);
936 /*
937 * Now I decide how to format the new structure. To grow, If I had a single
938 * vector at present I try to double its size. If that would give something
939 * too big I rearrange as multiple blocks in a chain, trying to roughly
940 * increase by a factor of 1.5 each time.
941 */
942 if (grow > 0)
943 { if (number_of_chunks == 1)
944 {
945 /*
946 * Here I am going to allow the hash table size to double until trying to
947 * double it again would go beyond the proper size that vectors are limited
948 * to by the page size I use. The limit size ll I establish here first
949 * MUST be within the size permitted for a vector. To allow 32- and 64-
950 * bit images to be compatible I also want it to correspond to the same
951 * number of entries in the table in either case. The size I select is
952 * such that on a 32-bit machine each table is about 1/8 of the page size
953 * and on a 64-bit one each is about 1/4. With 4 Mbyte pages this makes
954 * each table hold 128K items - a feature of this is that Reduce will
955 * generally not go into the overflow mechanism! By making the table size
956 * 1/4 of my allocation page size I will end up fitting 3 tables per page
957 * and leaving just the final quarter to be fille dup otherwise. If I
958 * went further and used yet larger hash table segments I could suffer
959 * much more badly because of fragmentation.
960 */
961 int32_t ll = CHUNK_SIZE;
962 h = length_of_header(vechdr(v)) - CELL;
963 if (h >= ll)
964 { h = ll;
965 number_of_chunks = 3;
966 }
967 else h = 2*h;
968 }
969 else number_of_chunks = (3*number_of_chunks + 1)/2;
970 /*
971 * The hash table will use 1, 3, 5, 8, 12, 18, 27, 41, 62, 93, 140, 210...
972 * chunks. This geometric growth should lead to the cost of rehashing
973 * ending up as a roughly constant factor of hash table access while
974 * avoiding utterly undue waste of space.
975 */
976 }
977 else if (grow < 0)
978 { if (number_of_chunks == 1)
979 { h = length_of_header(vechdr(v)) - CELL;
980 /*
981 * When shrinking, I will not permit the hash table to have room for
982 * less than 8 entries.
983 */
984 if (h > 64) h = h / 2;
985 }
986 else if (number_of_chunks <= 2)
987 { h = CHUNK_SIZE;
988 number_of_chunks = 1;
989 }
990 /*
991 * While I expand the hash table in a geometric progression I will
992 * only shrink it linearly (at least for now) since I think I believe that
993 * shrinking will not happen often, and if there had been one temporary
994 * huge growth I might predict the possibility of another one soon. The
995 * effect of shrinking slowly is that space is wasted but speed is if
996 * anything improved.
997 */
998 else number_of_chunks--;
999 }
1000 nil = C_nil;
1001 stackcheck1(0, v);
1002 push(v);
1003 try_again:
1004 if (number_of_chunks == 1)
1005 { new_obvec = getvector_init(h+CELL, fixnum_of_int(0));
1006 errexitn(1);
1007 }
1008 else
1009 { new_obvec = nil;
1010 for (i=0; i<number_of_chunks; i++)
1011 { Lisp_Object w;
1012 push(new_obvec);
1013 w = getvector_init(h+CELL, fixnum_of_int(0));
1014 errexitn(2);
1015 pop(new_obvec);
1016 new_obvec = cons(w, new_obvec);
1017 errexitn(1);
1018 }
1019 }
1020 v = stack[0];
1021 while (v != nil)
1022 { Lisp_Object vv;
1023 if (is_vector(v))
1024 { vv = v;
1025 v = nil;
1026 }
1027 else
1028 { vv = qcar(v);
1029 v = qcdr(v);
1030 }
1031 h = (length_of_header(vechdr(vv)) - CELL)/CELL;
1032 while (h != 0)
1033 { Lisp_Object s, p, n = new_obvec;
1034 uint32_t hash;
1035 h--;
1036 s = elt(vv, h);
1037 if (is_fixnum(s)) continue;
1038 p = qpname(s);
1039 validate_string(p);
1040 hash = hash_lisp_string(p);
1041 if (number_of_chunks != 1)
1042 { int32_t i = (hash ^ (hash >> 16)) % number_of_chunks;
1043 while (i-- != 0) n = qcdr(n);
1044 n = qcar(n);
1045 }
1046 if (!add_to_hash(s, n, hash))
1047 { number_of_chunks++;
1048 /*
1049 * In the grossly improbable case that clustering leads to one of the
1050 * sub-vectors overflowing I will go back and re-start the expansion
1051 * process but with yet more space available. This can ONLY happen
1052 * if I already had multiple sub-hash-tables.
1053 */
1054 goto try_again;
1055 }
1056 }
1057 }
1058 popv(1);
1059 return new_obvec;
1060 }
1061
1062 #ifdef COMMON
1063
add_to_externals(Lisp_Object s,Lisp_Object p,uint32_t hash)1064 static Lisp_Object add_to_externals(Lisp_Object s,
1065 Lisp_Object p, uint32_t hash)
1066 {
1067 Lisp_Object n = packnext_(p);
1068 Lisp_Object v = packext_(p);
1069 Lisp_Object nil = C_nil;
1070 uint32_t used = int_of_fixnum(packvext_(p));
1071 /*
1072 * I guess the next line would overflow when around 4G ends up used just
1073 * in symbol hash table. This can only possibly be approached on a 64-bit
1074 * machine and I think that would happen when there were about 300 million
1075 * symbols. For now at least I view that as beyond plausibility. Maybe in a
1076 * few years it will seem routine!
1077 */
1078 if (used == 1) used = length_of_header(vechdr(v)) - CELL;
1079 else used = CHUNK_SIZE*used;
1080 /*
1081 * n is (16*sym_count+1) [Lisp fixnum for sym_count]
1082 * used = CELL*(spaces+1)
1083 * The effect is that I trigger a re-hash if the table reaches 62%
1084 * loading. For small vectors when I re-hash I will double the
1085 * table size, for large ones I will roughly multipoly the amount of
1086 * allocated space by 1.5.
1087 * The effect will be that small packages will often be fairly lightly
1088 * loaded (down to 31% just after an expansion) while very large ones will
1089 * be kept at least a bit closer to the 62% mark.
1090 */
1091 try_again:
1092 if ((uint32_t)n/10u > used/CELL)
1093 { stackcheck3(0, s, p, v);
1094 push2(s, p);
1095 v = rehash(v, packvext_(p), 1);
1096 pop2(p, s);
1097 errexit();
1098 packext_(p) = v;
1099 packvext_(p) = fixnum_of_int(number_of_chunks);
1100 }
1101 if (n == 0xfffffff1) return aerror("too many symbols"); /* long stop */
1102 packnext_(p) = n + (1<<4); /* increment as a Lisp fixnum */
1103 { int32_t nv = int_of_fixnum(packvext_(p));
1104 if (nv == 1) add_to_hash(s, v, hash);
1105 else
1106 { nv = (hash ^ (hash >> 16)) % nv;
1107 /*
1108 * There is a systematic nasty problem here that I maybe ought to deal with
1109 * some time. Large packages are represented as a collection of smaller
1110 * hash tables, and part of the hash value of a symbol decides which of these
1111 * sub-tables any particular string will be placed in. I enlarge the whole
1112 * system when the set of tables (treated as a whole) is 70% full. But
1113 * clustering COULD potentially lead to one of the sub-tables becoming
1114 * totally full before then, and that would give a loop here if I was not
1115 * careful. To avoid the possibility I make add_to_hash() report any
1116 * trouble and if I have difficulty I go back and re-enlarge the tables.
1117 * This is not guaranteed safe, but I will be VERY unlucky if it ever bites
1118 * me! Specifically it can provoke early expansion of the hash table
1119 * so that clustering leads to ending up with a lighter loading on the
1120 * whole table. It wastes space but should in the end be safe.
1121 *
1122 * For HUGE tables the current segmented scheme is parhaps not very
1123 * satisfactory and I may need to move to a model that represents a single
1124 * large table in multiple hunks. Indeed for HUGE tables the fact that I
1125 * only compute a 32-bit hash value could be unsatisfactory too.
1126 */
1127 while (nv-- != 0) v = qcdr(v);
1128 if (!add_to_hash(s, qcar(v), hash))
1129 { used = 0; /* so table will be expanded */
1130 goto try_again;
1131 }
1132 }
1133 }
1134 return nil;
1135 }
1136
1137 #endif
1138
add_to_internals(Lisp_Object s,Lisp_Object p,uint32_t hash)1139 static Lisp_Object add_to_internals(Lisp_Object s,
1140 Lisp_Object p, uint32_t hash)
1141 {
1142 Lisp_Object n = packnint_(p);
1143 Lisp_Object v = packint_(p);
1144 Lisp_Object nil = C_nil;
1145 uint32_t used = int_of_fixnum(packvint_(p));
1146 if (used == 1) used = length_of_header(vechdr(v)) - CELL;
1147 else used = CHUNK_SIZE*used;
1148 try_again:
1149 if ((uint32_t)n/10u > used/CELL)
1150 { stackcheck3(0, s, p, v);
1151 push2(s, p);
1152 v = rehash(v, packvint_(p), 1);
1153 pop2(p, s);
1154 errexit();
1155 packint_(p) = v;
1156 packvint_(p) = fixnum_of_int(number_of_chunks);
1157 }
1158 if (n == 0xfffffff1) return aerror("too many symbols"); /* long stop */
1159 packnint_(p) = (Lisp_Object)((int32_t)n + (1<<4));
1160 /* increment as a Lisp fixnum */
1161 { int32_t nv = int_of_fixnum(packvint_(p));
1162 if (nv == 1) add_to_hash(s, v, hash);
1163 else
1164 { nv = (hash ^ (hash >> 16)) % nv;
1165 while (nv-- != 0) v = qcdr(v);
1166 if (!add_to_hash(s, qcar(v), hash))
1167 { used = 0;
1168 goto try_again;
1169 }
1170 }
1171 }
1172 return nil;
1173 }
1174
1175 static CSLbool rehash_pending = NO;
1176
lookup(Lisp_Object str,int32_t strsize,Lisp_Object v,Lisp_Object nv,uint32_t hash)1177 static Lisp_Object lookup(Lisp_Object str, int32_t strsize,
1178 Lisp_Object v, Lisp_Object nv, uint32_t hash)
1179 /*
1180 * Searches a hash table for a symbol with name matching the given string,
1181 * and NOTE that the string passed down here is to be treated as having
1182 * just strsize characters in it. Return Lisp number 0 if not found.
1183 * Sets rehash_pending if the number of probes used to find the item is
1184 * at least half the size of the table. This case might arise in the following
1185 * way:
1186 * insert items into the table until it is just under 70% full.
1187 * remob (eg via EXPORT) items until the table is just over 25% full.
1188 * note that so far there will have been no need to rehash
1189 * insert more items, but select them so that thir hash values are all
1190 * different from the ones used before. You should be able to end up
1191 * with 70% of the table full of valid symbols and 30% left as the value
1192 * fixnum_of_int(1) which represents a place where a deleted symbol used
1193 * to be. There is now NO really empty space.
1194 * Now looking up symbols must keep searching past tombstones, and hence
1195 * here it will be necessary to scan the entire table before it is
1196 * possible to assert that a symbol is not present. Inserting new symbols
1197 * does not suffer in this way - only lookup. To help with this horror I set
1198 * rehash_pending if the lookup uses a number of probes > 75% of the table
1199 * size. This should only arise in degenerate cases!
1200 */
1201 {
1202 Header h;
1203 int32_t size;
1204 uint32_t i = int_of_fixnum(nv), step, n;
1205 if (i != 1)
1206 { i = (hash ^ (hash >> 16)) % i; /* Segmented - find correct segment */
1207 while (i-- != 0) v = qcdr(v);
1208 v = qcar(v);
1209 }
1210 h = vechdr(v);
1211 size = (length_of_header(h) - CELL)/CELL;
1212 i = (int32_t)(hash & (size - 1));
1213 step = 1 | ((hash >> 10) & (size - 1));
1214 /*
1215 * I count the probes that I make here and if there are as many as the size
1216 * of the hash table then I allow the lookup to report that the symbol is not
1217 * present. But at least I do not get stuck in a loop.
1218 */
1219 for (n=0; n<size; n++)
1220 { Lisp_Object w = elt(v, i);
1221 Lisp_Object pn;
1222 if (w == fixnum_of_int(0))
1223 { if (4*n > 3*size) rehash_pending = YES;
1224 return w; /* Not found */
1225 }
1226 if (w != fixnum_of_int(1))
1227 { pn = qpname(w);
1228 validate_string(pn);
1229 /* v comes out of a package so has a proper pname */
1230 if (memcmp((char *)str + (CELL-TAG_VECTOR),
1231 (char *)pn + (CELL-TAG_VECTOR),
1232 (size_t)strsize) == 0 &&
1233 (uint32_t)length_of_header(vechdr(pn)) == strsize+CELL)
1234 { if (4*n > 3*size) rehash_pending = YES;
1235 return w;
1236 }
1237 }
1238 i = i + step;
1239 if (i >= size) i -= size;
1240 }
1241 rehash_pending = YES;
1242 return fixnum_of_int(0);
1243 }
1244
ordersymbol(Lisp_Object v1,Lisp_Object v2)1245 static int ordersymbol(Lisp_Object v1, Lisp_Object v2)
1246 /*
1247 * Compare two symbols to see if they are in alphabetic order.
1248 * Returns 0 is the symbols have the same name, otherwise
1249 * the comparison is a lexical one on their names, with -ve if
1250 * v1 comes alphabetically before v2. Deals with gensyms, and in so
1251 * doing has to allocate names for them, which seems a great misery
1252 * since it means that this procedure can provoke garbage collection..
1253 *
1254 * Note that the ordering here is based on the bit-patterns that
1255 * represent the names, so Kanji (etc) symbols may not come out in
1256 * an order that is especially useful.
1257 */
1258 {
1259 Lisp_Object pn1 = qpname(v1), pn2 = qpname(v2);
1260 int c;
1261 int32_t l1, l2;
1262 #ifndef COMMON
1263 if (qheader(v1) & SYM_UNPRINTED_GENSYM)
1264 { Lisp_Object nil;
1265 push(v2);
1266 pn1 = get_pname(v1);
1267 pop(v2);
1268 nil = C_nil;
1269 if (exception_pending()) return 0;
1270 pn2 = qpname(v2);
1271 }
1272 if (qheader(v2) & SYM_UNPRINTED_GENSYM)
1273 { Lisp_Object nil;
1274 push(pn1);
1275 pn2 = get_pname(v2);
1276 pop(pn1);
1277 nil = C_nil;
1278 if (exception_pending()) return 0;
1279 }
1280 #endif
1281 validate_string(pn1);
1282 validate_string(pn2);
1283 l1 = length_of_header(vechdr(pn1)) - CELL;
1284 l2 = length_of_header(vechdr(pn2)) - CELL;
1285 c = memcmp((char *)pn1 + (CELL-TAG_VECTOR),
1286 (char *)pn2 + (CELL-TAG_VECTOR),
1287 (size_t)(l1 < l2 ? l1 : l2));
1288 if (c == 0) c = (int)(l1 - l2);
1289 return c;
1290 }
1291
1292 /*
1293 * This has been coded so that it provides the behavious that Reduce expects
1294 * of ordp(). This is the REDUCE 3.6/3.7 version - it will need re-work
1295 * if REDUCE is altered. Note the curious situation that symbols are
1296 * alphabetically ordered, EXCEPT that "nil" comes before everything else!
1297 *
1298 *
1299 *
1300 * symbolic procedure ordp(u,v);
1301 * if null u then null v
1302 * else if null v then t
1303 * else if vectorp u then if vectorp v then ordpv(u,v) else atom v
1304 * else if atom u
1305 * then if atom v
1306 * then if numberp u then numberp v and not (u<v)
1307 * else if idp v then orderp(u,v)
1308 * else numberp v
1309 * else nil
1310 * else if atom v then t
1311 * else if car u=car v then ordpl(cdr u, cdr v) *** 8 Feb 1999
1312 * else if flagp(car u,'noncom)
1313 * then if flagp(car v,'noncom) then ordp(car u,car v) else t
1314 * else if flagp(car v,'noncom) then nil
1315 * else ordp(car u,car v);
1316 *
1317 * symbolic procedure ordpl(u,v)
1318 * if atom u then ordp(u,v)
1319 * else if atom v then t
1320 * else if car u=car v then ordpl(cdr u,cdr v)
1321 * else ordp(car u, car v);
1322 *
1323 */
1324
1325 static int orderp(Lisp_Object u, Lisp_Object v);
1326
ordpv(Lisp_Object u,Lisp_Object v)1327 static int ordpv(Lisp_Object u, Lisp_Object v)
1328 {
1329 Header hu = vechdr(u), hv = vechdr(v);
1330 int32_t lu = length_of_header(hu), lv = length_of_header(hv), n = CELL;
1331 if (type_of_header(hu) != type_of_header(hv))
1332 return (type_of_header(hu) < type_of_header(hv) ? -1 : 1);
1333 if (vector_holds_binary(hu))
1334 { while (n < lu && n < lv)
1335 { unsigned int eu = *(unsigned char *)(u - TAG_VECTOR + n),
1336 ev = *(unsigned char *)(v - TAG_VECTOR + n);
1337 if (eu != ev) return (eu < ev ? -1 : 1);
1338 n += 1;
1339 }
1340 return (lu == lv ? 0 : lu < lv ? -1 : 1);
1341 }
1342 /*
1343 * At present it is an ERROR to include mixed vectors in structures passed
1344 * to ordering functions, and if it is done the system may crash. Note that
1345 * stream objects count as mixed for these purposes. I will get around to
1346 * fixing things sometime...
1347 */
1348 else
1349 { while (n < lu && n < lv)
1350 { Lisp_Object eu = *(Lisp_Object *)(u - TAG_VECTOR + n),
1351 ev = *(Lisp_Object *)(v - TAG_VECTOR + n),
1352 nil = C_nil;
1353 int w;
1354 push2(u, v);
1355 if (--countdown < 0) deal_with_tick();
1356 if (stack >= (Lisp_Object *)stacklimit)
1357 { push(ev);
1358 eu = reclaim(eu, "stack", GC_STACK, 0);
1359 pop(ev);
1360 nil = C_nil;
1361 /* stackcheck expanded by hand here to return an int, not nil, in bad case */
1362 if (exception_pending()) { popv(2); return 0; }
1363 }
1364 w = orderp(eu, ev);
1365 pop2(v, u);
1366 nil = C_nil;
1367 if (exception_pending()) return 0;
1368 if (w != 0) return w;
1369 n += CELL;
1370 }
1371 return (lu == lv ? 0 : lu < lv ? -1 : 1);
1372 }
1373 }
1374
ordpl(Lisp_Object u,Lisp_Object v)1375 static int ordpl(Lisp_Object u, Lisp_Object v)
1376 {
1377 #ifdef COMMON
1378 Lisp_Object nil = C_nil;
1379 #endif
1380 for (;;)
1381 { int w = orderp(qcar(u), qcar(v));
1382 if (w != 0) return w;
1383 u = qcdr(u);
1384 v = qcdr(v);
1385 if (!consp(u)) return orderp(u, v);
1386 if (!consp(v)) return -1;
1387 }
1388 }
1389
1390 #define flagged_noncom(v) \
1391 ((fv = qfastgets(v)) != nil && elt(fv, 0) != SPID_NOPROP)
1392
orderp(Lisp_Object u,Lisp_Object v)1393 static int orderp(Lisp_Object u, Lisp_Object v)
1394 {
1395 Lisp_Object nil = C_nil;
1396 for (;;)
1397 { if (u == nil) return v == nil ? 0 : 1;
1398 else if (v == nil) return -1; /* Special cases of NIL done */
1399 else if (u == v) return 0; /* useful optimisation? */
1400 /*
1401 * I migrate the vectorp test inside where I have tested for atoms, since
1402 * I expect vectors to be a somewhat uncommon case
1403 */
1404 else if (!consp(u))
1405 { if (!consp(v))
1406 { if (is_vector(u))
1407 { if (is_vector(v)) return ordpv(u, v);
1408 else return -1;
1409 }
1410 else if (is_number(u))
1411 { if (is_number(v)) return lessp2(u, v) ? 1 :
1412 eql(u, v) ? 0 : -1;
1413 else return 1;
1414 }
1415 else if (is_number(v)) return -1;
1416 else if (is_symbol(u))
1417 { if (is_symbol(v)) return ordersymbol(u, v);
1418 else return 1;
1419 }
1420 else if (is_symbol(v)) return -1;
1421 /*
1422 * Now the objects are not symbols, vectors or numbers. That maybe
1423 * leaves character objects. I compare representations to give a
1424 * rather arbitrary ordering. Note that any comparisons that get
1425 * down here are yielding non portable results.
1426 */
1427 else return (u == v) ? 0 : (u < v) ? 1 : -1;
1428 }
1429 else return 1;
1430 }
1431 else if (!consp(v)) return -1;
1432 else
1433 { Lisp_Object cu = qcar(u), cv = qcar(v);
1434 Lisp_Object fv; /* used by flagged_noncom */
1435 int w;
1436 push2(u, v);
1437 /* stackcheck2(2, cu, cv); */
1438 if (--countdown < 0) deal_with_tick();
1439 if (stack >= (Lisp_Object *)stacklimit)
1440 { push(cv);
1441 cu = reclaim(cu, "stack", GC_STACK, 0);
1442 pop(cv);
1443 nil = C_nil;
1444 /* stackcheck expanded by hand here to return an int, not nil, in bad case */
1445 if (exception_pending()) { popv(2); return 0; }
1446 }
1447 w = orderp(cu, cv);
1448 pop2(v, u);
1449 nil = C_nil;
1450 if (exception_pending()) return 0;
1451 if (w != 0)
1452 { cu = qcar(u);
1453 if (is_symbol(cu) && flagged_noncom(cu))
1454 { cv = qcar(v);
1455 if (is_symbol(cv) && flagged_noncom(cv)) return w;
1456 else return -1;
1457 }
1458 else
1459 { cv = qcar(v);
1460 if (is_symbol(cv) && flagged_noncom(cv)) return 1;
1461 else return w;
1462 }
1463 }
1464 /*
1465 * here car u = car v
1466 */
1467 u = qcdr(u);
1468 v = qcdr(v);
1469 if (!consp(u)) continue;
1470 if (!consp(v)) return -1;
1471 /*
1472 * The function I call ordpl here has the atom tests lifted out from
1473 * its top...
1474 */
1475 return ordpl(u, v);
1476 }
1477 }
1478 }
1479
Lorderp(Lisp_Object nil,Lisp_Object a,Lisp_Object b)1480 Lisp_Object Lorderp(Lisp_Object nil,
1481 Lisp_Object a, Lisp_Object b)
1482 {
1483 int w;
1484 w = orderp(a, b);
1485 errexit();
1486 return onevalue(Lispify_predicate(w <= 0));
1487 }
1488
1489 static uint32_t removed_hash;
1490
remob(Lisp_Object sym,Lisp_Object v,Lisp_Object nv)1491 static CSLbool remob(Lisp_Object sym, Lisp_Object v, Lisp_Object nv)
1492 /*
1493 * Searches a hash table for a symbol with name matching the given string,
1494 * and remove it.
1495 */
1496 {
1497 Lisp_Object str = qpname(sym);
1498 Header h;
1499 uint32_t hash;
1500 uint32_t i = int_of_fixnum(nv), size, step, n;
1501 if (qheader(sym) & SYM_ANY_GENSYM) return NO; /* gensym case is easy! */
1502 validate_string(str);
1503 #ifdef COMMON
1504 /* If not in any package it has no home & is not available */
1505 qheader(sym) &= ~SYM_EXTERN_IN_HOME & ~(0xffffffff<<SYM_IN_PKG_SHIFT);
1506 #endif
1507 removed_hash = hash = hash_lisp_string(str);
1508 /*
1509 * The search procedure used here MUST match that coded in lookup().
1510 */
1511 if (i != 1)
1512 { i = (hash ^ (hash >> 16)) % i;
1513 while (i-- != 0) v = qcdr(v);
1514 v = qcar(v);
1515 }
1516 h = vechdr(v);
1517 size = (length_of_header(h) - CELL)/CELL;
1518 i = (int32_t)(hash & (size - 1));
1519 step = 1 | ((hash >> 10) & (size - 1));
1520 for (n=0; n<size; n++)
1521 { Lisp_Object w = elt(v, i);
1522 if (w == fixnum_of_int(0)) return NO; /* Not found */
1523 if (w == sym)
1524 { elt(v, i) = fixnum_of_int(1);
1525 /*
1526 * I will shrink the hash table if it becomes less than 25% full,
1527 * but not in this bit of code... because I want this internal
1528 * remob() function to avoid any possible failure or garbage collection
1529 * so I can call it from C code without any formality. Thus I should do
1530 * any tidying up afterwards.
1531 */
1532 return YES;
1533 }
1534 i = i + step;
1535 if (i >= size) i -= size;
1536 }
1537 return NO;
1538 }
1539
1540 #ifdef COMMON
1541
Lmake_symbol(Lisp_Object nil,Lisp_Object str)1542 static Lisp_Object Lmake_symbol(Lisp_Object nil, Lisp_Object str)
1543 /*
1544 * Lisp function (make-symbol ..) creates an uninterned symbol.
1545 */
1546 {
1547 Lisp_Object s;
1548 stackcheck1(0, str);
1549 /*
1550 * Common Lisp wants a STRING passed here, but as a matter of generosity and
1551 * for the benefit of some of my system code I support symbols too.
1552 */
1553 if (symbolp(str))
1554 { str = get_pname(str);
1555 errexit();
1556 }
1557 else if (!is_vector(str)) return aerror1("make-symbol", str);
1558 else if (complex_stringp(str))
1559 { str = simplify_string(str);
1560 errexit();
1561 }
1562 else if (type_of_header(vechdr(str)) != TYPE_STRING)
1563 return aerror1("make-symbol", str);
1564 push(str);
1565 s = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
1566 errexitn(1);
1567 pop(str);
1568 qheader(s) = TAG_ODDS+TYPE_SYMBOL;
1569 qvalue(s) = unset_var;
1570 if (is_vector(str)) validate_string(str);
1571 qpname(s) = str;
1572 qplist(s) = nil;
1573 qfastgets(s) = nil;
1574 qpackage(s) = nil;
1575 qenv(s) = s;
1576 ifn1(s) = (intptr_t)undefined1;
1577 ifn2(s) = (intptr_t)undefined2;
1578 ifnn(s) = (intptr_t)undefinedn;
1579 qcount(s) = 0; /* set counts to zero to be tidy */
1580 return onevalue(s);
1581 }
1582
1583 #endif
1584
Lgensym(Lisp_Object nil,int nargs,...)1585 Lisp_Object MS_CDECL Lgensym(Lisp_Object nil, int nargs, ...)
1586 /*
1587 * Lisp function (gensym) creates an uninterned symbol with odd name.
1588 */
1589 {
1590 Lisp_Object id;
1591 #ifdef COMMON
1592 Lisp_Object pn;
1593 char genname[64];
1594 #endif
1595 argcheck(nargs, 0, "gensym");
1596 stackcheck0(0);
1597 nil = C_nil;
1598 #ifdef COMMON
1599 sprintf(genname, "G%lu", (long unsigned)(uint32_t)gensym_ser++);
1600 pn = make_string(genname);
1601 errexit();
1602 push(pn);
1603 #endif
1604 id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
1605 #ifdef COMMON
1606 pop(pn);
1607 #endif
1608 errexit();
1609 #ifdef COMMON
1610 qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
1611 qpname(id) = pn;
1612 #else
1613 qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM;
1614 qpname(id) = gensym_base;
1615 #endif
1616 qvalue(id) = unset_var;
1617 qplist(id) = nil;
1618 qfastgets(id) = nil;
1619 #ifdef COMMON
1620 qpackage(id) = nil; /* Marks it as a uninterned */
1621 #endif
1622 qenv(id) = id;
1623 ifn1(id) = (intptr_t)undefined1;
1624 ifn2(id) = (intptr_t)undefined2;
1625 ifnn(id) = (intptr_t)undefinedn;
1626 qcount(id) = 0; /* to be tidy */
1627
1628 return onevalue(id);
1629 }
1630
Lgensym1(Lisp_Object nil,Lisp_Object a)1631 Lisp_Object Lgensym1(Lisp_Object nil, Lisp_Object a)
1632 /*
1633 * Lisp function (gensym1 base) creates an uninterned symbol with odd name.
1634 * The case (gensym <number>) is DEPRECATED by the Common Lisp standards
1635 * committee and so I will not implement it at least for now.
1636 */
1637 {
1638 Lisp_Object id, genbase;
1639 #ifdef COMMON
1640 uint32_t len;
1641 char genname[64];
1642 if (complex_stringp(a))
1643 { a = simplify_string(a);
1644 errexit();
1645 }
1646 #endif
1647 if (is_vector(a) &&
1648 type_of_header(vechdr(a)) == TYPE_STRING) genbase = a;
1649 else if (symbolp(a)) genbase = qpname(a); /* copy gensym base */
1650 else return aerror1("gensym1", a);
1651 push(genbase);
1652 stackcheck0(0);
1653 #ifdef COMMON
1654 len = length_of_header(vechdr(genbase)) - CELL;
1655 if (len > 60) len = 60; /* Unpublished truncation of the string */
1656 sprintf(genname, "%.*s%lu", (int)len,
1657 (char *)genbase + (CELL-TAG_VECTOR),
1658 (long unsigned)(uint32_t)gensym_ser++);
1659 stack[0] = make_string(genname);
1660 errexitn(1);
1661 #endif
1662 id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
1663 errexitn(1);
1664 pop(genbase);
1665 #ifdef COMMON
1666 qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
1667 #else
1668 qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_UNPRINTED_GENSYM+SYM_ANY_GENSYM;
1669 #endif
1670 qvalue(id) = unset_var;
1671 qpname(id) = genbase;
1672 qplist(id) = nil;
1673 qfastgets(id) = nil;
1674 #ifdef COMMON
1675 qpackage(id) = nil; /* Marks it as a uninterned */
1676 #endif
1677 qenv(id) = id;
1678 ifn1(id) = (intptr_t)undefined1;
1679 ifn2(id) = (intptr_t)undefined2;
1680 ifnn(id) = (intptr_t)undefinedn;
1681 qcount(id) = 0; /* to be tidy */
1682 return onevalue(id);
1683 }
1684
Lgensym2(Lisp_Object nil,Lisp_Object a)1685 Lisp_Object Lgensym2(Lisp_Object nil, Lisp_Object a)
1686 /*
1687 * Lisp function (gensym2 base) whose name is exactly that given by the
1688 * argument. This might be UNHELPFUL if one tried to print the value
1689 * concerned, but seems to be what the Common Lisp syntax #:ggg expects
1690 * to achieve!
1691 */
1692 {
1693 Lisp_Object id, genbase;
1694 uint32_t len;
1695 #ifdef COMMON
1696 if (complex_stringp(a))
1697 { a = simplify_string(a);
1698 errexit();
1699 }
1700 #endif
1701 if (is_vector(a) &&
1702 type_of_header(vechdr(a)) == TYPE_STRING) genbase = a;
1703 else if (symbolp(a)) genbase = qpname(a);
1704 else return aerror1("gensym2", a);
1705 push(genbase);
1706 stackcheck0(0);
1707 len = length_of_header(vechdr(genbase)) - CELL;
1708 stack[0] = copy_string(genbase, len);
1709 errexitn(1);
1710 id = getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
1711 errexitn(1);
1712 pop(genbase);
1713 qheader(id) = TAG_ODDS+TYPE_SYMBOL+SYM_ANY_GENSYM;
1714 qvalue(id) = unset_var;
1715 qpname(id) = genbase;
1716 qplist(id) = nil;
1717 qfastgets(id) = nil;
1718 #ifdef COMMON
1719 qpackage(id) = nil; /* Marks it as a uninterned */
1720 #endif
1721 qenv(id) = id;
1722 ifn1(id) = (intptr_t)undefined1;
1723 ifn2(id) = (intptr_t)undefined2;
1724 ifnn(id) = (intptr_t)undefinedn;
1725 qcount(id) = 0; /* to be tidy */
1726 return onevalue(id);
1727 }
1728
Lgensymp(Lisp_Object nil,Lisp_Object a)1729 static Lisp_Object Lgensymp(Lisp_Object nil, Lisp_Object a)
1730 {
1731 if (is_symbol(a) &&
1732 (qheader(a) & SYM_CODEPTR) == 0 &&
1733 (qheader(a) & SYM_ANY_GENSYM) != 0) return onevalue(lisp_true);
1734 else return onevalue(nil);
1735 }
1736
1737 /*
1738 * Normally gensyms are displayed as G0, G1, ... in sequence.
1739 * After (reset!=gensym 1234) thet go on from G1234.
1740 * The function returns the previous gensym counter. So (reset!-gensym nil)
1741 * will read that but not reset the sequence.
1742 */
1743
Lreset_gensym(Lisp_Object nil,Lisp_Object a)1744 static Lisp_Object Lreset_gensym(Lisp_Object nil, Lisp_Object a)
1745 {
1746 Lisp_Object n = 0, old = gensym_ser;
1747 if (is_fixnum(a) && a >= 0) gensym_ser = int_of_fixnum(a) & 0x7fffffff;
1748 return fixnum_of_int(old);
1749 }
1750
iintern(Lisp_Object str,int32_t h,Lisp_Object p,int str_is_ok)1751 Lisp_Object iintern(Lisp_Object str, int32_t h, Lisp_Object p, int str_is_ok)
1752 /*
1753 * Look up the first h chars of the string str with respect to the package p.
1754 * The last arg is a boolean that allows me to decide if (when a new symbol
1755 * has to be created) the string must be copied. If h differs from the
1756 * real number of characters in arg1 then a copy MUST be made.
1757 * If non-zero, the last arg is 1 for intern, 2 for extern, 3
1758 * for find-symbol and 4 for "find-external-symbol" as in reader syntax p:x.
1759 * NB in CSL mode only one value is returned.
1760 */
1761 {
1762 Lisp_Object r, nil = C_nil;
1763 uint32_t hash;
1764 stackcheck2(0, str, p);
1765 hash = hash_lisp_string_with_length(str, h+CELL);
1766 /* find-external-symbol will not look at the internals */
1767 if (str_is_ok != 4)
1768 { r = lookup(str, h, packint_(p), packvint_(p), hash);
1769 /*
1770 * rehash_pending is intended to deal with horrible cases that involve
1771 * lots of remobs. But in the worst possible scenario one could have
1772 * a symbol table where all symbols clashed on hashing, and then by
1773 * restricting further use to just the last few symbols entered it would be
1774 * possible for all lookup operations to take a number of probes that
1775 * was almost 70% of the table size. In such cases rehashing (without
1776 * expanding the table size at the same time) would leave the table
1777 * unaltered and would not mend things. To avoid such repeated fruitless
1778 * rehashing I only set rehash_pending if the number of probes was over
1779 * 75% of the table size, and this should be impossible if there are no
1780 * tombstones present.
1781 */
1782 if (rehash_pending)
1783 { Lisp_Object v = packint_(p);
1784 push2(p, r);
1785 v = rehash(v, packvint_(p), 0);
1786 pop2(r, p);
1787 errexit();
1788 packint_(p) = v;
1789 packvint_(p) = fixnum_of_int(number_of_chunks);
1790 rehash_pending = NO;
1791 }
1792 nil = C_nil;
1793 if (r != fixnum_of_int(0))
1794 {
1795 #ifdef COMMON
1796 mv_2 = internal_symbol;
1797 #endif
1798 return nvalues(r, 2);
1799 }
1800 }
1801 #ifdef COMMON
1802 r = lookup(str, h, packext_(p), packvext_(p), hash);
1803 if (rehash_pending)
1804 { Lisp_Object v = packext_(p);
1805 push2(p, r);
1806 v = rehash(v, packvext_(p), 0);
1807 pop2(r, p);
1808 errexit();
1809 packext_(p) = v;
1810 packvext_(p) = fixnum_of_int(number_of_chunks);
1811 rehash_pending = NO;
1812 }
1813 if (r != fixnum_of_int(0))
1814 {
1815 mv_2 = external_symbol;
1816 return nvalues(r, 2);
1817 }
1818 if (str_is_ok == 4)
1819 {
1820 #ifdef COMMON
1821 mv_2 = nil;
1822 #endif
1823 return nvalues(nil, 2);
1824 }
1825 for (r = packuses_(p); r!=nil; r=qcdr(r))
1826 { Lisp_Object w = qcar(r);
1827 w = lookup(str, h, packext_(w), packvext_(w), hash);
1828 if (rehash_pending)
1829 { Lisp_Object v = packext_(p);
1830 push2(p, r);
1831 v = rehash(v, packvext_(p), 0);
1832 pop2(r, p);
1833 errexit();
1834 packext_(p) = v;
1835 packvext_(p) = fixnum_of_int(number_of_chunks);
1836 rehash_pending = NO;
1837 }
1838 if (w != fixnum_of_int(0))
1839 {
1840 mv_2 = inherited_symbol;
1841 return nvalues(w, 2);
1842 }
1843 }
1844 #endif
1845 if (str_is_ok == 3)
1846 {
1847 #ifdef COMMON
1848 mv_2 = nil;
1849 #endif
1850 return nvalues(nil, 2);
1851 }
1852 { Lisp_Object s;
1853 push2(str, p);
1854 s = (Lisp_Object)getvector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length);
1855 pop(p);
1856 errexit();
1857 qheader(s) = TAG_ODDS+TYPE_SYMBOL;
1858 #ifdef COMMON
1859 if (p == qvalue(keyword_package) && keyword_package != nil)
1860 { qvalue(s) = (Lisp_Object)s;
1861 qheader(s) |= SYM_SPECIAL_VAR;
1862 }
1863 else
1864 #endif
1865 qvalue(s) = unset_var;
1866 qpname(s) = qpname(nil); /* At this stage the pname is a dummy */
1867 qplist(s) = nil;
1868 qfastgets(s) = nil;
1869 #ifdef COMMON
1870 qpackage(s) = p;
1871 #endif
1872 qenv(s) = (Lisp_Object)s;
1873 ifn1(s) = (intptr_t)undefined1;
1874 ifn2(s) = (intptr_t)undefined2;
1875 ifnn(s) = (intptr_t)undefinedn;
1876 qcount(s) = 0;
1877 push(s);
1878 #ifdef COMMON
1879 if ((p == qvalue(keyword_package) && keyword_package != nil) ||
1880 str_is_ok == 2)
1881 { add_to_externals(s, p, hash);
1882 errexitn(2);
1883 qheader(s) |= SYM_EXTERN_IN_HOME;
1884 }
1885 else
1886 #endif
1887 add_to_internals(s, p, hash);
1888 pop(s); pop(str);
1889 errexit();
1890 /* Now the symbol-head is safe enough that I can let the GC look at it */
1891 if (str_is_ok != 0) qpname(s) = str;
1892 else
1893 { Lisp_Object pn;
1894 push(s);
1895 pn = copy_string(str, h);
1896 pop(s);
1897 qpname(s) = pn;
1898 }
1899 errexit();
1900 #ifdef COMMON
1901 mv_2 = nil;
1902 #endif
1903 return nvalues((Lisp_Object)s, 2);
1904 }
1905 }
1906
1907 #ifdef COMMON
1908 static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name);
1909
Lintern_2(Lisp_Object nil,Lisp_Object str,Lisp_Object pp)1910 Lisp_Object Lintern_2(Lisp_Object nil, Lisp_Object str, Lisp_Object pp)
1911 #else
1912 Lisp_Object Lintern(Lisp_Object nil, Lisp_Object str)
1913 #endif
1914 /*
1915 * Lisp entrypoint for (intern ..)
1916 */
1917 {
1918 Header h;
1919 Lisp_Object p;
1920 #ifdef COMMON
1921 push(str);
1922 p = Lfind_package(nil, pp);
1923 pop(str);
1924 errexit();
1925 #else
1926 p = CP;
1927 #endif
1928 #ifdef COMMON
1929 if (complex_stringp(str))
1930 { push(p);
1931 str = simplify_string(str);
1932 pop(p);
1933 errexit();
1934 }
1935 #endif
1936 /*
1937 * For COMMON it is perhaps undue generosity to permit a symbol here
1938 * rather than just a string. However it will make life a bit easier for
1939 * me in porting existing code. Note that the Common Lisp book says quite
1940 * explicitly that symbols are NOT allowed here.
1941 */
1942 if (symbolp(str))
1943 { str = get_pname(str);
1944 errexit();
1945 }
1946 if (!is_vector(str) ||
1947 type_of_header(h = vechdr(str)) != TYPE_STRING)
1948 return aerror1("intern (not a string)", str);
1949 return iintern(str, length_of_header(h) - CELL, p, 1);
1950 }
1951
1952 #ifdef COMMON
1953
Lintern(Lisp_Object nil,Lisp_Object a)1954 Lisp_Object Lintern(Lisp_Object nil, Lisp_Object a)
1955 {
1956 return Lintern_2(nil, a, CP);
1957 }
1958
Lfind_symbol(Lisp_Object nil,Lisp_Object str,Lisp_Object pp)1959 static Lisp_Object Lfind_symbol(Lisp_Object nil,
1960 Lisp_Object str, Lisp_Object pp)
1961 {
1962 Header h;
1963 Lisp_Object p;
1964 push(str);
1965 p = Lfind_package(nil, pp);
1966 pop(str);
1967 errexit();
1968 if (symbolp(str))
1969 { push(p);
1970 str = get_pname(str);
1971 pop(p);
1972 errexit();
1973 }
1974 if (complex_stringp(str))
1975 { push(p);
1976 str = simplify_string(str);
1977 pop(p);
1978 errexit();
1979 }
1980 if (!is_vector(str) ||
1981 type_of_header(h = vechdr(str)) != TYPE_STRING)
1982 {
1983 return aerror1("find-symbol (not a string)", str);
1984 }
1985 return iintern(str, length_of_header(h) - CELL, p, 3);
1986 }
1987
Lfind_symbol_1(Lisp_Object nil,Lisp_Object str)1988 Lisp_Object Lfind_symbol_1(Lisp_Object nil, Lisp_Object str)
1989 {
1990 return Lfind_symbol(nil, str, CP);
1991 }
1992
Lextern(Lisp_Object nil,Lisp_Object sym,Lisp_Object package)1993 static Lisp_Object Lextern(Lisp_Object nil,
1994 Lisp_Object sym, Lisp_Object package)
1995 /*
1996 * If sym is internal in given package make it external - the inside parts
1997 * of the export function. Note that the second argument must be a real
1998 * package object, not a package name. Higher level code must have done
1999 * a find-package as necessary.
2000 */
2001 {
2002 if (!is_symbol(sym)) return onevalue(nil);
2003 if (remob(sym, packint_(package), packvint_(package)))
2004 { Lisp_Object n = packnint_(package);
2005 Lisp_Object v = packint_(package);
2006 int32_t used = int_of_fixnum(packvint_(package));
2007 if (used == 1) used = length_of_header(vechdr(v)) - CELL;
2008 else used = CHUNK_SIZE*used;
2009 /*
2010 * I will shrink a hash table if a sequence of remob-style operations,
2011 * which will especially include the case where a symbol ceases to be
2012 * internal to a package so that it can be external, leaves the table
2013 * less than 25% full. Note that normal growth is supposed to leave these
2014 * tables between 35 and 70% full, so the activity here will not be
2015 * triggered frivolously. However note the following oddity: if a package
2016 * is of minimum size (8 entries in the hash table) then rehashing will not
2017 * cause it to shrink (but it will rehash and hence tidy it up). Hence
2018 * every remob on such a table will cause it to be re-hashed.
2019 */
2020 if ((int32_t)n < used && used>(CELL*INIT_OBVECI_SIZE+CELL))
2021 { stackcheck3(0, sym, package, v);
2022 push2(sym, package);
2023 v = rehash(v, packvint_(package), -1);
2024 pop2(package, sym);
2025 errexit();
2026 packint_(package) = v;
2027 packvint_(package) = fixnum_of_int(number_of_chunks);
2028 }
2029 packnint_(package) -= (1<<4); /* decrement as fixnum */
2030 /*
2031 * removed_hash was left set up by remob, and it is known that the symbol
2032 * was not already external, since it had been internal.
2033 */
2034 if (qpackage(sym) == package) qheader(sym) |= SYM_EXTERN_IN_HOME;
2035 add_to_externals(sym, package, removed_hash);
2036 errexit();
2037 return onevalue(lisp_true);
2038 }
2039 return onevalue(nil);/* no action if it was not internal in this package */
2040 }
2041
Lextern_1(Lisp_Object nil,Lisp_Object str)2042 static Lisp_Object Lextern_1(Lisp_Object nil, Lisp_Object str)
2043 {
2044 return Lextern(nil, str, CP);
2045 }
2046
Limport(Lisp_Object nil,Lisp_Object sym,Lisp_Object package)2047 static Lisp_Object Limport(Lisp_Object nil,
2048 Lisp_Object sym, Lisp_Object package)
2049 /*
2050 * The internal part of the IMPORT and SHADOWING-IMPORT functions.
2051 * makes sym internal in package. The symbol MUST NOT be present there
2052 * before this function is called. The second argument must be a real
2053 * package object, not just the name of one.
2054 */
2055 {
2056 uint32_t hash;
2057 Lisp_Object pn;
2058 if (!is_symbol(sym)) return onevalue(nil);
2059 push2(sym, package);
2060 pn = get_pname(sym);
2061 errexitn(2);
2062 hash = hash_lisp_string(pn);
2063 add_to_internals(stack[-1], stack[0], hash);
2064 pop2(package, sym);
2065 errexit();
2066 if (qpackage(sym) == nil) qpackage(sym) = package;
2067 return onevalue(nil);
2068 }
2069
Limport_1(Lisp_Object nil,Lisp_Object str)2070 static Lisp_Object Limport_1(Lisp_Object nil, Lisp_Object str)
2071 {
2072 return Limport(nil, str, CP);
2073 }
2074
2075 #endif
2076
ndelete(Lisp_Object a,Lisp_Object l)2077 Lisp_Object ndelete(Lisp_Object a, Lisp_Object l)
2078 /*
2079 * Probably useful in various places throughout the system...
2080 */
2081 {
2082 #ifdef COMMON
2083 Lisp_Object nil = C_nil;
2084 #endif
2085 if (!consp(l)) return l;
2086 if (a == qcar(l)) return qcdr(l);
2087 { Lisp_Object z1 = l, z2 = qcdr(l);
2088 while (consp(z2))
2089 { if (a == qcar(z2))
2090 { qcdr(z1) = qcdr(z2);
2091 return l;
2092 }
2093 else
2094 { z1 = z2;
2095 z2 = qcdr(z2);
2096 }
2097 }
2098 }
2099 return l;
2100 }
2101
Lunintern_2(Lisp_Object nil,Lisp_Object sym,Lisp_Object pp)2102 Lisp_Object Lunintern_2(Lisp_Object nil, Lisp_Object sym, Lisp_Object pp)
2103 {
2104 Lisp_Object package;
2105 #ifdef COMMON
2106 push(sym);
2107 package = Lfind_package(nil, pp);
2108 pop(sym);
2109 errexit();
2110 #else
2111 package = pp;
2112 #endif
2113 if (!is_symbol(sym)) return onevalue(nil);
2114 #ifdef COMMON
2115 if (qpackage(sym) == package) qpackage(sym) = nil;
2116 packshade_(package) = ndelete(sym, packshade_(package));
2117 #endif
2118 if ((qheader(sym) & SYM_C_DEF) != 0)
2119 return aerror1("remob on function with kernel definition", sym);
2120 if (remob(sym, packint_(package), packvint_(package)))
2121 { Lisp_Object n = packnint_(package);
2122 Lisp_Object v = packint_(package);
2123 int32_t used = int_of_fixnum(packvint_(package));
2124 if (used == 1) used = length_of_header(vechdr(v)) - CELL;
2125 else used = CHUNK_SIZE*used;
2126 if ((int32_t)n < used && used>(CELL*INIT_OBVECI_SIZE+CELL))
2127 { stackcheck2(0, package, v);
2128 push(package);
2129 v = rehash(v, packvint_(package), -1);
2130 pop(package);
2131 errexit();
2132 packint_(package) = v;
2133 packvint_(package) = fixnum_of_int(number_of_chunks);
2134 }
2135 packnint_(package) -= (1<<4); /* decrement as fixnum */
2136 return onevalue(lisp_true);
2137 }
2138 #ifdef COMMON
2139 if (remob(sym, packext_(package), packvext_(package)))
2140 { Lisp_Object n = packnext_(package);
2141 Lisp_Object v = packext_(package);
2142 int32_t used = int_of_fixnum(packvext_(package));
2143 if (used == 1) used = length_of_header(vechdr(v)) - CELL;
2144 else used = CHUNK_SIZE*used;
2145 if ((int32_t)n < used && used>(CELL*INIT_OBVECX_SIZE+CELL))
2146 { stackcheck2(0, package, v);
2147 push(package);
2148 v = rehash(v, packvext_(package), -1);
2149 pop(package);
2150 errexit();
2151 packext_(package) = v;
2152 packvext_(package) = fixnum_of_int(number_of_chunks);
2153 }
2154 packnext_(package) -= (1<<4); /* decrement as fixnum */
2155 return onevalue(lisp_true);
2156 }
2157 #endif
2158 return onevalue(nil);
2159 }
2160
Lunintern(Lisp_Object nil,Lisp_Object str)2161 Lisp_Object Lunintern(Lisp_Object nil, Lisp_Object str)
2162 {
2163 return Lunintern_2(nil, str, CP);
2164 }
2165
2166 #ifdef COMMON
2167
Lkeywordp(Lisp_Object nil,Lisp_Object a)2168 static Lisp_Object Lkeywordp(Lisp_Object nil, Lisp_Object a)
2169 {
2170 if (!symbolp(a)) return onevalue(nil);
2171 return onevalue(Lispify_predicate(qpackage(a) == qvalue(keyword_package)));
2172 }
2173
2174 #endif
2175
2176 /*
2177 * If I have a window system then getting characters from the keyboard
2178 * is deemed a system-dependent activity. On non-windowed systems I still
2179 * do rather more than just getchar(), although under typical Unix what I
2180 * do here may count as over-kill.
2181 */
2182
2183 int tty_count;
2184 #define TTYBUF_SIZE 256
2185 #ifdef Kanji
2186 static kchar_t tty_buffer[TTYBUF_SIZE];
2187 static kchar_t *tty_pointer;
2188 #else
2189 /*
2190 * Note: I should never have an END_OF_FILE in the buffere here: if I see
2191 * this condition I pack in the character CTRL-D instead.
2192 */
2193 static char tty_buffer[TTYBUF_SIZE];
2194 static char *tty_pointer;
2195 #endif
2196
2197 #if !defined HAVE_FWIN || defined EMBEDDED
2198 static CSLbool int_nest = NO;
2199 #endif
2200
2201 #ifndef HAVE_FWIN
2202 static int prevchar = '\n';
2203 #endif
2204
2205 int terminal_pushed = NOT_CHAR;
2206
2207 static int kilo = 0;
2208
char_from_terminal(Lisp_Object dummy)2209 int char_from_terminal(Lisp_Object dummy)
2210 /*
2211 * "What ..." you might ask, "is the meaning of this mess?". Well the answer
2212 * is that when input is directly from the terminal I buffer up to 256
2213 * characters in a private buffer, and I discount the time spent filling this
2214 * buffer. On some miserable systems this will succeed in ensuring that the
2215 * time reported at the end of a run reflects time that CSL spends computing
2216 * and not time it spends waiting for the user to type something at it. Note
2217 * that it is only stdin input that I intercept in this way, so the full cost
2218 * of getting characters from disc files will be accounted. I also (rather
2219 * improperly) map EOF onto a code (4) which will fit in a byte-sized buffer.
2220 * I fill by buffer up as far as a newline or a vertical tab (or end of file),
2221 * and hope that that will not seriously hurt any interactions with CSL.
2222 * After all the operating system may well line-buffer input anyway, so that
2223 * it can deal with the delete key on your keyboard for you.
2224 *
2225 * Furthermore here is where I display prompt strings to the user -
2226 * in a way that Standard Lisp does not define, but PSL implements and
2227 * some REDUCE programmers have come to expect... (in some cases I will
2228 * let lower level code deal with prompts).
2229 *
2230 * If the user provokes an interrupt (^C, or ESC or whatever) while I am
2231 * in here I will try to return promptly with an empty buffer and
2232 * some indication of an exception.
2233 */
2234 {
2235 /*
2236 * I have a hook here for cases where I want to call CSL from other C
2237 * code. In that case the variable used here points at a function that
2238 * reads a single character. When I use this option I will NOT generate
2239 * prompts.
2240 */
2241 int c;
2242 Lisp_Object nil = C_nil;
2243 CSL_IGNORE(dummy);
2244 if (++kilo >= 1024)
2245 { kilo = 0;
2246 io_now++;
2247 }
2248 if (terminal_pushed != NOT_CHAR)
2249 { c = terminal_pushed;
2250 terminal_pushed = NOT_CHAR;
2251 return c;
2252 }
2253 if (procedural_input != NULL) c = (*procedural_input)();
2254 else if (non_terminal_input != NULL)
2255 {
2256 #ifdef Kanji
2257 c = getwc(non_terminal_input);
2258 #else
2259 c = getc(non_terminal_input);
2260 #endif
2261 }
2262 else
2263 { if (tty_count == 0)
2264 {
2265 /*
2266 * Time spent waiting for keyboard input is not counted against the user.
2267 */
2268 push_clock();
2269 #ifdef HAVE_FWIN
2270 /* Under FWIN I will arrange prompts at a lower level. */
2271 #else
2272 if (prevchar == '\n')
2273 { escaped_printing = 0;
2274 if (prompt_thing != nil)
2275 { push(active_stream);
2276 active_stream = qvalue(terminal_io);
2277 if (!is_stream(active_stream))
2278 active_stream = lisp_terminal_io;
2279 internal_prin(prompt_thing, NO);
2280 nil = C_nil;
2281 if (exception_pending()) flip_exception();
2282 pop(active_stream);
2283 }
2284 }
2285 ensure_screen();
2286 if (exception_pending())
2287 { pop_clock();
2288 return EOF;
2289 }
2290 #endif
2291 #ifdef WINDOW_SYSTEM
2292 #ifndef HAVE_FWIN
2293 if (use_wimp)
2294 #endif
2295 { tty_count = wimpget(tty_buffer);
2296 #ifdef HAVE_FWIN
2297 /*
2298 * With FWIN, wimpget() always returns, but sometimes it will have set
2299 * a stack overflow condition to mark that the user has tried to
2300 * signal an exception via ^C or ^G. In which case I just want to
2301 * return promptly.
2302 */
2303 if (stack >= stacklimit)
2304 { reclaim(nil, "stack", GC_STACK, 0);
2305 nil = C_nil;
2306 if (exception_pending())
2307 { pop_clock();
2308 return (0x1f & 'C');
2309 }
2310 }
2311 }
2312 #else /* HAVE_FWIN */
2313 if (exception_pending())
2314 { pop_clock();
2315 return EOF;
2316 }
2317 if (interrupt_pending)
2318 { interrupt_pending = 0;
2319 if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
2320 err_printf("+++ Interrupted\n");
2321 exit_reason =
2322 (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ?
2323 UNWIND_ERROR : UNWIND_UNWIND;
2324 exit_value = exit_tag = nil;
2325 exit_count = 0;
2326 flip_exception();
2327 }
2328 }
2329 else
2330 #endif /* HAVE_FWIN */
2331 #endif /* WINDOW_SYSTEM */
2332 #if !defined HAVE_FWIN || defined EMBEDDED
2333 /*
2334 * Here I either do not have a window system or I have elected not to use it.
2335 * but note that with fwin I am simplifying things and always do the calls
2336 * as if windowing was going on even when it is not!
2337 */
2338 fflush(stdout);
2339 fflush(stderr);
2340 for (;;) /* The while loop is so I can restart after ^C */
2341 {
2342 /*
2343 * The setjmp here can not mask any bindings of fluid variables...
2344 */
2345 errorset_msg = NULL;
2346 #ifdef __cplusplus
2347 try
2348 #else
2349 #ifdef USE_SIGALTSTACK
2350 if (!sigsetjmp(sigint_buf, -1))
2351 #else
2352 if (!setjmp(sigint_buf))
2353 #endif
2354 #endif
2355 { while (tty_count<TTYBUF_SIZE && !interrupt_pending)
2356 { int c;
2357 sigint_must_longjmp = YES;
2358 #ifdef Kanji
2359 c = getwc(stdin);
2360 #else
2361 c = getchar();
2362 #endif
2363 sigint_must_longjmp = NO;
2364 if (c == EOF)
2365 { clearerr(stdin); /* Believed to be what is wanted */
2366 c = CTRL_D; /* Use ASCII ^D as EOF marker */
2367 }
2368 tty_buffer[tty_count++] = (char)c;
2369 if (c == '\n' || c == '\v' || c == CTRL_D) break;
2370 }
2371 if (interrupt_pending)
2372 { push_clock();
2373 /*
2374 * Time spent in the interrupt handler here will not be counted as CPU
2375 * time used.
2376 */
2377 interrupt_pending = NO;
2378 if (int_nest)
2379 { err_printf("\n+++ Nested interrupt ignored\n");
2380 tty_count = 0;
2381 break;
2382 }
2383 else
2384 { int_nest = YES;
2385 interrupted(nil);
2386 int_nest = NO;
2387 }
2388 pop_clock();
2389 tty_count = 0;
2390 nil = C_nil;
2391 if (!exception_pending()) continue;
2392 }
2393 break;
2394 }
2395 #ifdef __cplusplus
2396 catch (int *)
2397 #else
2398 else
2399 #endif
2400 { if (errorset_msg != NULL)
2401 { term_printf("\n%s detected\n", errorset_msg);
2402 errorset_msg = NULL;
2403 }
2404 sigint_must_longjmp = NO;
2405 interrupt_pending = YES;
2406 tty_count = 0;
2407 }
2408 }
2409 #endif /* HAVE_FWIN */
2410 pop_clock();
2411 tty_pointer = tty_buffer;
2412 }
2413 if (tty_count == 0) c = '\n'; /* ^C odd case */
2414 else
2415 { tty_count--;
2416 c = *tty_pointer++;
2417 #ifndef Kanji
2418 c &= 0xff;
2419 #endif
2420 }
2421 }
2422 inject_randomness(c);
2423 if (c == EOF || c == CTRL_D) return EOF;
2424 if (qvalue(echo_symbol) != nil)
2425 { Lisp_Object stream = qvalue(standard_output);
2426 if (!is_stream(stream)) stream = qvalue(terminal_io);
2427 if (!is_stream(stream)) stream = lisp_terminal_io;
2428 putc_stream(c, stream);
2429 if (exception_pending()) flip_exception();
2430 }
2431 else if (spool_file != NULL) putc(c, spool_file);
2432 return c;
2433 }
2434
2435
Lrds(Lisp_Object nil,Lisp_Object a)2436 Lisp_Object Lrds(Lisp_Object nil, Lisp_Object a)
2437 {
2438 Lisp_Object old = qvalue(standard_input);
2439 if (a == nil) a = qvalue(terminal_io);
2440 if (a == old) return onevalue(old);
2441 else if (!is_stream(a)) return aerror1("rds", a);
2442 else if (stream_read_fn(a) == char_from_illegal)
2443 return aerror("rds"); /* closed stream or output stream */
2444 qvalue(standard_input) = a;
2445 return onevalue(old);
2446 }
2447
Lrtell_1(Lisp_Object nil,Lisp_Object stream)2448 Lisp_Object Lrtell_1(Lisp_Object nil, Lisp_Object stream)
2449 {
2450 int32_t n;
2451 if (!is_stream(stream)) return onevalue(nil);
2452 n = other_read_action(READ_TELL, stream);
2453 if (n == -1) return onevalue(nil);
2454 else return onevalue(fixnum_of_int(n));
2455 }
2456
Lrtell(Lisp_Object nil,int nargs,...)2457 Lisp_Object MS_CDECL Lrtell(Lisp_Object nil, int nargs, ...)
2458 /*
2459 * RTELL returns an integer that indicates the position of the current
2460 * input stream (as selected by RDS). If the position is not available
2461 * (as would be the case for an interactive stream) then NIL is returned.
2462 * Otherwise the result is an integer suitable for use with rseek. In the
2463 * case that the file was opened in binary mode the number returned is a
2464 * direct indication of the position in the file and arithmetic will
2465 * behave predictably - for text streams the value returned should be
2466 * thought of as an abstract position-tag.
2467 */
2468 {
2469 argcheck(nargs, 0, "rtell");
2470 return Lrtell_1(nil, qvalue(standard_input));
2471 }
2472
Lrseekend(Lisp_Object nil,Lisp_Object stream)2473 Lisp_Object Lrseekend(Lisp_Object nil, Lisp_Object stream)
2474 {
2475 if (!is_stream(stream)) stream = qvalue(terminal_io);
2476 if (!is_stream(stream)) stream = lisp_terminal_io;
2477 other_read_action(READ_FLUSH, stream);
2478 if (other_read_action(READ_END, stream) != 0) return onevalue(nil);
2479 else return onevalue(lisp_true);
2480 }
2481
Lrseek_2(Lisp_Object nil,Lisp_Object stream,Lisp_Object a)2482 Lisp_Object Lrseek_2(Lisp_Object nil, Lisp_Object stream, Lisp_Object a)
2483 {
2484 int32_t n;
2485 if (!is_stream(stream)) stream = qvalue(terminal_io);
2486 if (!is_stream(stream)) stream = lisp_terminal_io;
2487 if (is_fixnum(a)) n = (int32_t)int_of_fixnum(a);
2488 else return aerror("rseek");
2489 other_read_action(READ_FLUSH, stream);
2490 if (other_read_action(n | 0x80000000, stream) != 0) return onevalue(nil);
2491 else return onevalue(lisp_true);
2492 }
2493
Lrseek(Lisp_Object nil,Lisp_Object a)2494 Lisp_Object Lrseek(Lisp_Object nil, Lisp_Object a)
2495 /*
2496 * If the current input stream supports random access this re-positions
2497 * it to a place indicated by the argument a. If the file was opened in
2498 * binary mode then a can be an integer indicating how far down the file
2499 * to set the position. For text files arguments to RSEEK should only be
2500 * values returned by previous calls to RTELL. RSEEK returns nil if it
2501 * failed (and if it noticed that fact) or T if it succeeded.
2502 */
2503 {
2504 return Lrseek_2(nil, qvalue(standard_input), a);
2505 }
2506
2507 /*
2508 * The getc_stream() method must NEVER be able to cause garbage collection,
2509 * since I code the reader here on the assumption that file control blocks
2510 * do not move while individual characters are read.
2511 */
2512
2513
2514 /*
2515 * While I am in the middle of reading a whole expression the variable
2516 * curchar will hold the most recent character (or NOT_CHAR if there is none),
2517 * but between expressions I will push that back into the stream header.
2518 */
2519
skip_whitespace(Lisp_Object stream)2520 static void skip_whitespace(Lisp_Object stream)
2521 {
2522 Lisp_Object nil;
2523 for (;;)
2524 { switch (curchar)
2525 {
2526 case NOT_CHAR:
2527 case 0: case '\v': case '\f':
2528 case ' ': case '\t': case '\n':
2529 case '\r': case CTRL_C:
2530 curchar = getc_stream(stream);
2531 errexitv();
2532 continue;
2533
2534 #ifndef COMMON
2535 case '%':
2536 #else
2537 case ';':
2538 #endif
2539 while (curchar != '\n' &&
2540 curchar != EOF &&
2541 curchar != CTRL_D)
2542 { curchar = getc_stream(stream);
2543 errexitv();
2544 }
2545 continue;
2546
2547 default:
2548 return;
2549 }
2550 }
2551 }
2552
2553 static Lisp_Object read_s(Lisp_Object stream);
2554
2555 #ifdef COMMON
2556 static Lisp_Object read_hash(Lisp_Object stream);
2557 #endif
2558
read_list(Lisp_Object stream)2559 static Lisp_Object read_list(Lisp_Object stream)
2560 /*
2561 * There is no code here to do anything about general read-macros,
2562 * and it will be awkward to fit it in here because of the reliance
2563 * that the Common Lisp readmacro scheme puts on the ability to return
2564 * no values at all using (values). I implement ' and ; and ` since
2565 * they seem very useful, but only simple cases of #.
2566 * I require that when this function is called I have already done
2567 * a skip_whitespace(), and as a result curchar will not be NOT_CHAR.
2568 */
2569 {
2570 Lisp_Object l, w, nil = C_nil;
2571 stackcheck0(0);
2572 if (curchar == ')')
2573 { curchar = NOT_CHAR;
2574 return C_nil;
2575 }
2576 push(stream);
2577 #ifdef COMMON
2578 if (curchar == '#')
2579 { l = read_hash(stream);
2580 if (l == SPID_NOINPUT)
2581 { pop(stream);
2582 return read_list(stream);
2583 }
2584 }
2585 else
2586 #endif
2587 l = read_s(stream);
2588 errexitn(1);
2589 l = ncons(l);
2590 errexitn(1);
2591 push(l); /* this will be the final result */
2592 for (;;)
2593 { skip_whitespace(stack[-1]);
2594 switch (curchar)
2595 {
2596
2597 #ifndef COMMON
2598 case ']':
2599 #endif
2600 case ')':
2601 curchar = NOT_CHAR;
2602 pop2(l, stream);
2603 return l;
2604
2605 case EOF:
2606 case CTRL_D:
2607 pop2(l, stream);
2608 return l;
2609
2610 /* This code treats '.' as a special lexical marker, while the */
2611 /* full version of the reader has to be more subtle. */
2612 case '.':
2613 curchar = NOT_CHAR;
2614 push(l);
2615 w = read_s(stack[-2]);
2616 pop(l);
2617 errexitn(2);
2618 qcdr(l) = w;
2619 skip_whitespace(stack[-1]);
2620 if (curchar == ')') curchar = NOT_CHAR;
2621 /* else error("missing rpar or bad dot"); */
2622 pop2(l, stream);
2623 return l;
2624 #ifdef COMMON
2625 case '#':
2626 push(l);
2627 w = read_hash(stack[-2]);
2628 errexitn(3);
2629 if (w == SPID_NOINPUT)
2630 { pop(l);
2631 continue;
2632 }
2633 w = ncons(w);
2634 errexitn(3);
2635 pop(l);
2636 qcdr(l) = w;
2637 l = w;
2638 continue;
2639 #endif
2640 default:
2641 push(l);
2642 w = read_s(stack[-2]);
2643 errexitn(3);
2644 w = ncons(w);
2645 errexitn(3);
2646 pop(l);
2647 qcdr(l) = w;
2648 l = w;
2649 continue;
2650 }
2651 }
2652 }
2653
list_to_vector(Lisp_Object l)2654 static Lisp_Object list_to_vector(Lisp_Object l)
2655 {
2656 int32_t len = 0;
2657 Lisp_Object p = l, nil = C_nil;
2658 while (consp(p)) len++, p = qcdr(p);
2659 push(l);
2660 p = getvector_init(CELL*(len+1), nil);
2661 pop(l);
2662 errexit();
2663 len = 0;
2664 while (consp(l))
2665 { elt(p, len) = qcar(l);
2666 len++;
2667 l = qcdr(l);
2668 }
2669 return p;
2670 }
2671
2672 #ifdef COMMON
2673
evalfeature(Lisp_Object u)2674 static CSLbool evalfeature(Lisp_Object u)
2675 {
2676 Lisp_Object w, nil = C_nil;
2677 if (consp(u))
2678 { Lisp_Object fn = qcar(u);
2679 u = qcdr(u);
2680 if (!consp(u)) return NO;
2681 if (fn == not_symbol) return !evalfeature(qcar(u));
2682 else if (fn == and_symbol)
2683 { while (consp(u))
2684 { if (!evalfeature(qcar(u))) return NO;
2685 nil = C_nil;
2686 if (exception_pending()) return NO;
2687 u = qcdr(u);
2688 }
2689 return YES;
2690 }
2691 else if (fn == or_symbol)
2692 { while (consp(u))
2693 { if (evalfeature(qcar(u))) return YES;
2694 nil = C_nil;
2695 if (exception_pending()) return NO;
2696 u = qcdr(u);
2697 }
2698 return NO;
2699 }
2700 else return NO;
2701 }
2702 w = qvalue(features_symbol);
2703 while (consp(w))
2704 { if (u == qcar(w)) return YES;
2705 w = qcdr(w);
2706 }
2707 return NO;
2708 }
2709
read_hash(Lisp_Object stream)2710 static Lisp_Object read_hash(Lisp_Object stream)
2711 {
2712 /*
2713 * A small subset of the # escaped read-macros will be supported here.
2714 * curchar must already be set to the character that follows the '#'
2715 */
2716 int32_t v, w = -1;
2717 int radix;
2718 Lisp_Object nil = C_nil;
2719 Lisp_Object p;
2720 curchar = getc_stream(stream);
2721 errexit();
2722 if (ISdigit(curchar))
2723 { w = 0;
2724 do
2725 { w = 10*w + curchar - '0';
2726 /*
2727 * Observe that I do not do long arithmetic here!
2728 */
2729 curchar = getc_stream(stream);
2730 errexit();
2731 } while (ISdigit(curchar));
2732 }
2733 switch (curchar)
2734 {
2735 default:
2736 /* error("Unknown # escape"); */
2737 return pack_char(0, 0, '#');
2738 #ifdef COMMON
2739 case '#':
2740 curchar = NOT_CHAR;
2741 p = reader_workspace;
2742 while (p != nil)
2743 { Lisp_Object k = qcar(p);
2744 if (fixnum_of_int(w) == qcar(k)) return qcdr(k);
2745 p = qcdr(p);
2746 }
2747 return aerror1("Label not found with #n# syntax", fixnum_of_int(w));
2748 case '=':
2749 curchar = NOT_CHAR;
2750 push(stream);
2751 /*
2752 * Hmmm - is it necessary for #nn# to refer back to the label here from
2753 * within the value about to be read?
2754 */
2755 p = read_s(stream);
2756 pop(stream);
2757 errexit();
2758 push(p);
2759 p = acons(fixnum_of_int(w), p, reader_workspace);
2760 errexitn(1);
2761 reader_workspace = p;
2762 pop(p);
2763 return p;
2764 #endif
2765 case ':': /* #:XXX reads in a gensym... */
2766 curchar = NOT_CHAR;
2767 { Lisp_Object base = read_s(stream), al; /* The XXX bit unadorned */
2768 errexit();
2769 /*
2770 * This keeps an association list of gensyms present in this call to READ.
2771 * Note that if you use #.(read) [or other clever things] you may get
2772 * muddled about contexts. Note that this is sometimes helpful with
2773 * Standard Lisp but that for Common Lisp the more general #= and ##
2774 * mechanism should be used and this behaviour here would count as
2775 * WRONG.
2776 */
2777 al = reader_workspace;
2778 while (al != nil)
2779 { Lisp_Object k = qcar(al);
2780 if (base == qcar(k)) return qcdr(k);
2781 al = qcdr(al);
2782 }
2783 push(base);
2784 /*
2785 * Beware that #:ggg has just ggg as its name, with no numeric suffix.
2786 */
2787 al = Lgensym2(nil, base);
2788 pop(base);
2789 errexit();
2790 al = acons(base, al, reader_workspace);
2791 errexit();
2792 reader_workspace = al;
2793 return qcdr(qcar(al));
2794 }
2795
2796 case '(': /* Simple vector */
2797 curchar = getc_stream(stream);
2798 errexit();
2799 skip_whitespace(stream);
2800 errexit();
2801 { Lisp_Object l = read_list(stream);
2802 errexit();
2803 return list_to_vector(l);
2804 }
2805 case '\'':
2806 curchar = NOT_CHAR;
2807 p = read_s(stream);
2808 errexit();
2809 return list2(function_symbol, p);
2810 case '\\':
2811 /*
2812 * The character just after "#\" is read without any case folding
2813 */
2814 curchar = getc_stream(stream);
2815 errexit();
2816 w = curchar;
2817 #ifdef COMMON
2818 /*
2819 * The word after "#\" is always spelt in regular ASCII so Kanji support
2820 * does not cut in here.
2821 */
2822 if (isalpha(w))
2823 { char buffer[32];
2824 int bp = 0, w0 = w;
2825 while (isalpha(w) && bp < 30)
2826 { buffer[bp++] = toupper(w); /* Force word to upper case */
2827 curchar = getc_stream(stream);
2828 errexit();
2829 w = curchar;
2830 }
2831 if (bp == 1)
2832 #ifdef Kanji
2833 return pack_char(0, 0, w0 & 0xffff);
2834 #else
2835 return pack_char(0, 0, w0 & 0xff);
2836 #endif
2837 buffer[bp] = 0;
2838 p = make_string(buffer);
2839 errexit();
2840 p = Lintern_2(nil, p, qvalue(keyword_package));
2841 errexit();
2842 p = get(p, named_character, nil);
2843 errexit();
2844 return p;
2845 }
2846 #endif
2847 curchar = NOT_CHAR;
2848 errexit();
2849 #ifdef Kanji
2850 return pack_char(0, 0, w & 0xffff);
2851 #else
2852 return pack_char(0, 0, w & 0xff);
2853 #endif
2854 case '.':
2855 curchar = NOT_CHAR;
2856 p = read_s(stream);
2857 errexit();
2858 /*
2859 * The next is in case the expression evaluated involves reading from
2860 * this or another stream.
2861 */
2862 if (curchar != NOT_CHAR)
2863 { other_read_action(curchar, stream);
2864 curchar = NOT_CHAR;
2865 }
2866 p = eval(p, nil);
2867 errexit();
2868 return onevalue(p);
2869 case '+':
2870 case '-':
2871 v = (curchar == '-');
2872 curchar = NOT_CHAR;
2873 /*
2874 * In March 1988 X3J13 voted that feature names read here should be in
2875 * the keyword package unless explicily otherwise qualified, but (I guess)
2876 * the AND, OR and NOT operators applying to them are NOT in the keyword
2877 * package. Thus I can not just rebind *package* here in any simple way.
2878 * Oh dear - I hope nobody relies on what those kind experts decided!
2879 * Meanwhile REMEMBER to go #+ :whatever please.
2880 */
2881 push(stream);
2882 p = read_s(stream);
2883 errexitn(1);
2884 w = evalfeature(p);
2885 pop(stream);
2886 errexit();
2887 if (w == v)
2888 { read_s(stream);
2889 errexit();
2890 }
2891 /*
2892 * The following flag-value shows that read_hash() has not actually read
2893 * anything - but it may have skipped over some unwanted stuff.
2894 */
2895 return onevalue(SPID_NOINPUT);
2896
2897 case 'r': case 'R':
2898 radix = (w>=2 && w<=36) ? (int)w : 10;
2899 break;
2900 case 'b': case 'B':
2901 radix = 2;
2902 break;
2903 case 'o': case 'O':
2904 radix = 8;
2905 break;
2906 case 'x': case 'X':
2907 radix = 16;
2908 break;
2909 }
2910 /* Here I have a number specified in some unusual radix */
2911 w = fixnum_of_int(0);
2912 curchar = getc_stream(stream);
2913 errexit();
2914 while ((v = value_in_radix(curchar, radix)) >= 0)
2915 { w = times2(w, fixnum_of_int((int32_t)radix));
2916 errexit();
2917 w = plus2(w, fixnum_of_int(v));
2918 errexit();
2919 curchar = getc_stream(stream);
2920 errexit();
2921 }
2922 return w;
2923 }
2924
2925 #endif /* COMMON */
2926
is_constituent(int c)2927 CSLbool is_constituent(int c)
2928 {
2929 if (c == EOF) return NO;
2930 if (c & ESCAPED_CHAR) return YES; /* escaped */
2931 switch (c)
2932 {
2933 /* The following characters terminate symbols */
2934 case ' ': case '\n': case '\t': case '\v': case '\f': case 0:
2935 case '(': case ')': case '\'': case ';': case '"': case '`':
2936 case ',': case '\r':
2937 case CTRL_D: /* character 4 is EOF in ASCII */
2938 #ifndef COMMON
2939 case '+': case '-': case '*': case '/': case '~': case '\\':
2940 case '@': case '#': case '$': case '%': case '^': case '&':
2941 case '=': case '{': case '}': case '[': case ']': case ':':
2942 case '<': case '>': case '?': case '!': case '|':
2943 /*
2944 * case '_': In OLD Standard Lisp underscore was a break character -
2945 * these days it is classified rather oddly, in that it does not terminate
2946 * a symbol but behaves specially if it starts one.
2947 * What about '.', which may need to be treated specially?
2948 */
2949 case '.':
2950 #endif
2951 return NO;
2952 default:
2953 return YES;
2954 }
2955 }
2956
backquote_expander(Lisp_Object a)2957 static Lisp_Object backquote_expander(Lisp_Object a)
2958 /*
2959 * ClTl (edition 2) seems to suggest that nested backquotes are a disgusting
2960 * morass - this code does not worry about the fine details!
2961 */
2962 {
2963 Lisp_Object w1, f, nil = C_nil;
2964 if (a == nil) return a;
2965 if (!consp(a)) return list2(quote_symbol, a);
2966 stackcheck1(0, a);
2967 nil = C_nil;
2968 f = qcar(a);
2969 if (f == comma_symbol) return qcar(qcdr(a));
2970 if (consp(f) && qcar(f) == comma_at_symbol)
2971 { w1 = qcar(qcdr(f));
2972 push(w1);
2973 a = backquote_expander(qcdr(a));
2974 errexit();
2975 pop(w1);
2976 w1 = list2(w1, a);
2977 errexit();
2978 return cons(append_symbol, w1);
2979 }
2980 /*
2981 * There is noticable scope for further optimisation here, with the
2982 * introduction of uses of list, list* as well as just cons and append.
2983 * It is also probably useful to worry about ,. as well as ,@ but for
2984 * now I defer that until the full version of the reader is installed.
2985 */
2986 push(a);
2987 f = backquote_expander(f);
2988 pop(a);
2989 errexit();
2990 push(f);
2991 a = backquote_expander(qcdr(a));
2992 pop(f);
2993 errexit();
2994 a = list2(f, a);
2995 errexit();
2996 return cons(cons_symbol, a);
2997 }
2998
2999 static CSLbool read_failure;
3000
packbyte(int c)3001 void packbyte(int c)
3002 {
3003 Lisp_Object nil = C_nil;
3004 int32_t boffo_size = length_of_header(vechdr(boffo));
3005 /*
3006 * I expand boffo (maybe) several characters earlier than you might
3007 * consider necessary. Some of that is to be extra certain about having
3008 * space in it when I pack a multi-byte (eg Kanji) character.
3009 */
3010 if (boffop >= (int)boffo_size-(int)CELL-8)
3011 { Lisp_Object new_boffo =
3012 getvector(TAG_VECTOR, TYPE_STRING, 2*boffo_size);
3013 nil = C_nil;
3014 if (exception_pending())
3015 { flip_exception();
3016 /*
3017 * What should I do if I fail to expand boffo - for present I silently
3018 * truncate the object I am reading. But I set a flag that will be checked
3019 * on the way out of read/compress, so the user will know.
3020 */
3021 read_failure = YES;
3022 return;
3023 }
3024 memcpy((void *)((char *)new_boffo + (CELL-TAG_VECTOR)),
3025 &boffo_char(0), boffop);
3026 boffo = new_boffo;
3027 }
3028 #ifdef Kanji
3029 if (iswchar(c)) boffo_char(boffop++) = c >> 8;
3030 #endif
3031 boffo_char(boffop) = (char)c;
3032 boffop++;
3033 }
3034
3035 #ifdef COMMON
3036 static char package_name[32];
3037 #endif
3038
read_s(Lisp_Object stream)3039 static Lisp_Object read_s(Lisp_Object stream)
3040 {
3041 Lisp_Object w, nil = C_nil;
3042 for (;;)
3043 { skip_whitespace(stream);
3044 errexit();
3045 switch (curchar)
3046 {
3047 case EOF:
3048 case CTRL_D:
3049 return CHAR_EOF;
3050
3051 case '(':
3052 curchar = NOT_CHAR;
3053 skip_whitespace(stream);
3054 errexit();
3055 return read_list(stream);
3056
3057 #ifndef COMMON
3058 case '[':
3059 curchar = NOT_CHAR;
3060 skip_whitespace(stream);
3061 errexit();
3062 w = read_list(stream);
3063 errexit();
3064 return list_to_vector(w);
3065
3066 case ']':
3067 #endif
3068 case ')':
3069 curchar = NOT_CHAR;
3070 continue; /* Ignore spurious rpar */
3071
3072 case '\'':
3073 curchar = NOT_CHAR;
3074 w = read_s(stream);
3075 errexit();
3076 return list2(quote_symbol, w);
3077
3078 case '`':
3079 curchar = NOT_CHAR;
3080 w = read_s(stream);
3081 errexit();
3082 return backquote_expander(w);
3083
3084 case ',':
3085 curchar = getc_stream(stream);
3086 errexit();
3087 if (curchar == '@')
3088 { curchar = NOT_CHAR;
3089 w = read_s(stream);
3090 errexit();
3091 return list2(comma_at_symbol, w);
3092 }
3093 else
3094 { w = read_s(stream);
3095 errexit();
3096 return list2(comma_symbol, w);
3097 }
3098
3099 /*
3100 * Neither Standard nor Common Lisp make stray dots very welcome. In Common
3101 * Lisp multiple adjacent dots are supposed to be an error. Here I just ignore
3102 * stray dots, and hope that nobody is silly enough to have them in their code.
3103 */
3104 case '.':
3105 /* error("Bad dot"); */
3106 curchar = NOT_CHAR;
3107 continue; /* Ignore spurious dot */
3108
3109 #ifdef COMMON
3110 case '#':
3111 push(stream);
3112 w = read_hash(stream);
3113 pop(stream);
3114 if (w != SPID_NOINPUT) return w;
3115 else return read_s(stream);
3116 #endif
3117 case '"':
3118 boffop = 0;
3119 { for (;;) /* Used to cope with "abc""def" */
3120 { curchar = getc_stream(stream);
3121 errexit();
3122 #ifdef COMMON
3123 if (curchar == ESCAPE_CHAR)
3124 { curchar = getc_stream(stream);
3125 errexit();
3126 if (curchar!=EOF) curchar |= ESCAPED_CHAR;
3127 }
3128 #endif
3129 if (curchar == EOF || curchar == CTRL_D)
3130 return CHAR_EOF;
3131 while (curchar != '"' &&
3132 curchar != EOF &&
3133 curchar != CTRL_D)
3134 { push(stream);
3135 packbyte(curchar);
3136 pop(stream);
3137 curchar = getc_stream(stream);
3138 errexit();
3139 #ifdef COMMON
3140 if (curchar == ESCAPE_CHAR)
3141 { curchar = getc_stream(stream);
3142 errexit();
3143 if (curchar!=EOF) curchar |= ESCAPED_CHAR;
3144 }
3145 #endif
3146 }
3147 #ifndef COMMON
3148 curchar = getc_stream(stream);
3149 errexit();
3150 if (curchar == '"')
3151 { push(stream);
3152 packbyte(curchar);
3153 pop(stream);
3154 continue; /* Handle "abc""def" for Standard Lisp */
3155 }
3156 #else
3157 curchar = NOT_CHAR;
3158 #endif
3159 return copy_string(boffo, boffop);
3160 }
3161 }
3162
3163 #ifndef COMMON
3164 case '+': case '-':
3165 case '0': case '1': case '2': case '3': case '4':
3166 case '5': case '6': case '7': case '8': case '9':
3167 /*
3168 * I treat numbers specially here since I want to allow '.' within
3169 * numbers, but NOT within symbols. Common Lisp views '.' as a
3170 * constituent character and so does not need quite so much effort
3171 * just here.
3172 */
3173 { boffop = 0;
3174 if (curchar == '+' || curchar == '-')
3175 { push(stream);
3176 packbyte(curchar);
3177 pop(stream);
3178 curchar = getc_stream(stream);
3179 errexit();
3180 /* + or - not followed by a digit will be read as a symbol */
3181 if (!ISdigit(curchar)) return intern(boffop, NO);
3182 }
3183 while (ISdigit(curchar))
3184 { push(stream);
3185 packbyte(curchar);
3186 pop(stream);
3187 curchar = getc_stream(stream);
3188 errexit();
3189 }
3190 /* accept possible decimal point */
3191 if (curchar == '.')
3192 { push(stream);
3193 packbyte(curchar);
3194 pop(stream);
3195 curchar = getc_stream(stream);
3196 errexit();
3197 while (ISdigit(curchar))
3198 { push(stream);
3199 packbyte(curchar);
3200 pop(stream);
3201 curchar = getc_stream(stream);
3202 errexit();
3203 }
3204 }
3205 /* accept possible exponent */
3206 if (curchar == 'e' || curchar == 'E')
3207 { push(stream);
3208 packbyte('e');
3209 pop(stream);
3210 curchar = getc_stream(stream);
3211 errexit();
3212 if (curchar == '+' || curchar == '-')
3213 { push(stream);
3214 packbyte(curchar);
3215 pop(stream);
3216 curchar = getc_stream(stream);
3217 errexit();
3218 }
3219 while (ISdigit(curchar))
3220 { push(stream);
3221 packbyte(curchar);
3222 pop(stream);
3223 curchar = getc_stream(stream);
3224 errexit();
3225 }
3226 }
3227 return intern(boffop, NO);
3228 }
3229
3230 case '_': /* This seems to have to be a funny case for REDUCE */
3231 boffop = 0;
3232 push(stream);
3233 packbyte(curchar);
3234 pop(stream);
3235 curchar = getc_stream(stream);
3236 errexit();
3237 return intern(boffop, NO);
3238 #endif
3239
3240 default:
3241 { CSLbool escaped = NO;
3242 #ifdef COMMON
3243 CSLbool within_vbars = NO;
3244 int colon = -1, double_colon = -1, i;
3245 #endif
3246 boffop = 0;
3247 #ifdef COMMON
3248 while (curchar == '|')
3249 { nil = C_nil;
3250 stackcheck0(0);
3251 curchar = getc_stream(stream);
3252 errexit();
3253 within_vbars = !within_vbars;
3254 /*
3255 * A funny thought arises here - maybe the characters ||123 are a potential
3256 * number, since there are no characters inside the vertical bars to show
3257 * otherwise! Hence I need to set escaped only when I find a genuine character
3258 * within the vertical-bar protected region. Hence this coded as a while
3259 * loop not a simple IF statement. Another horrid issue is that the input
3260 * "|| " (where there are two initial vertical bars and then a terminating
3261 * character) ought to parse as an identifier with an empty name. Thus
3262 * if I read ahead here and find whitespace etc I need to exit here.
3263 */
3264 if (!within_vbars && !is_constituent(curchar))
3265 return intern(0, YES);
3266 }
3267 #endif
3268 if (curchar == ESCAPE_CHAR)
3269 { nil = C_nil;
3270 stackcheck0(0);
3271 curchar = getc_stream(stream);
3272 errexit();
3273 /* However, any character escaped with '\' means we do not have a number */
3274 escaped = YES;
3275 }
3276 else
3277 #ifdef COMMON
3278 if (!within_vbars)
3279 { if (curchar == ':') colon = boffop, escaped = YES;
3280 #else
3281 {
3282 #endif
3283 if (curchar != EOF)
3284 { if (qvalue(lower_symbol) != nil)
3285 curchar = TOlower(curchar);
3286 else if (qvalue(raise_symbol) != nil)
3287 curchar = TOupper(curchar);
3288 #ifdef Kanji
3289 if (qvalue(hankaku_symbol) != nil)
3290 is (iszenkaku(curchar))
3291 curchar = tohankaku(curchar);
3292 #endif
3293 }
3294 }
3295
3296 /*
3297 * Here is the main loop that reads an identifier. Observe the extra
3298 * complication that Common Lisp generates with the need to support
3299 * package markers and '|' style escapes...
3300 */
3301 do
3302 { push(stream);
3303 packbyte(curchar);
3304 pop(stream);
3305 curchar = getc_stream(stream);
3306 errexit();
3307 #ifdef COMMON
3308 if (within_vbars) escaped = YES;
3309 while (curchar == '|')
3310 { nil = C_nil;
3311 stackcheck0(0);
3312 curchar = getc_stream(stream);
3313 errexit();
3314 within_vbars = !within_vbars;
3315 }
3316 #endif
3317 if (curchar == EOF) break;
3318 else if (curchar == ESCAPE_CHAR)
3319 { nil = C_nil;
3320 stackcheck0(0);
3321 curchar = getc_stream(stream);
3322 errexit();
3323 curchar |= ESCAPED_CHAR;
3324 escaped = YES;
3325 }
3326 #ifdef COMMON
3327 else if (!within_vbars)
3328 { if (curchar == ':')
3329 { if (colon >= 0) double_colon = boffop;
3330 else colon = boffop, escaped = YES;
3331 }
3332 #endif
3333 else if (qvalue(lower_symbol) != nil)
3334 curchar = TOlower(curchar);
3335 else if (qvalue(raise_symbol) != nil)
3336 curchar = TOupper(curchar);
3337 #ifdef Kanji
3338 if (qvalue(hankaku_symbol) != nil)
3339 is (iszenkaku(curchar))
3340 curchar = tohankaku(curchar);
3341 #endif
3342 #ifdef COMMON
3343 }
3344 } while (within_vbars || is_constituent(curchar));
3345 #else
3346 } while (is_constituent(curchar));
3347 #endif
3348 #ifdef COMMON
3349 /*
3350 * If there are no colons present, or if there are two but they
3351 * are not consecutive, or of there are three or more, or if the last
3352 * character of the symbol was a colon, I will just look it up in
3353 * the current package.
3354 */
3355 if (colon < 0 || colon+1==boffop)
3356 return intern(boffop, escaped);
3357 if ((double_colon >= 0 && double_colon != colon+1) ||
3358 double_colon+1==boffop)
3359 return intern(boffop, escaped);
3360 /*
3361 * If the first character was a colon I use the keyword package.
3362 */
3363 memset(package_name, 0, sizeof(package_name));
3364 strncpy(package_name, &celt(boffo, 0), (size_t)colon);
3365 package_name[sizeof(package_name)-1] = 0;
3366 /* term_printf("Package lookup <%.*s>\n", (int)colon, &celt(boffo, 0)); */
3367 if (colon == 0) w = qvalue(keyword_package);
3368 else w = find_package(&celt(boffo, 0), colon);
3369 /*
3370 * Here I rely on find_package never raising an exception and never giving
3371 * a possible entry into a break loop (etc), since I need boffo[] intact
3372 * after the call.
3373 */
3374 if (w == nil)
3375 { err_printf(
3376 "+++ Package %s not found: using current package\n",
3377 package_name);
3378 /*
3379 * Similarly I assume, unreasonably, that boffo can not be disturbed by
3380 * printing this warning message.
3381 */
3382 w = CP; /* default behaviour: unknown package */
3383 }
3384 if (double_colon >= 0) colon = double_colon;
3385 i = 0;
3386 colon++;
3387 while (colon < boffop)
3388 boffo_char(i++) = boffo_char(colon++);
3389 boffop = i;
3390 /* term_printf("Name within package <%.*s>\n", (int)boffop, &celt(boffo, 0)); */
3391 if (double_colon < 0 && w != qvalue(keyword_package))
3392 { /* In the case ppp:sss it MUST be external in ppp */
3393 Lisp_Object wx;
3394 push(w);
3395 wx = iintern(boffo, (int32_t)boffop, w, 4);
3396 pop(w);
3397 errexit();
3398 if (mv_2 == nil)
3399 { err_printf("+++ Symbol %.*s not external in %s\n",
3400 (int)boffop, &celt(boffo, 0), package_name);
3401 err_printf("+++ Treating as internal symbol...\n");
3402 }
3403 else return wx;
3404 }
3405 /*
3406 * Curiously I will always take keywords (as in :kkk) through the path
3407 * that corresponds to looking up an internal symbol, ie ::kkk, since that
3408 * way I allow the reader to create a new symbol. If I handled the keyword
3409 * case in the usual external symbol way it would demand that the keyword
3410 * already existed (since in all other packages nothing is external unless
3411 * it already exists and has been exported).
3412 */
3413 return iintern(boffo, (int32_t)boffop, w, 0);
3414 #else
3415 return intern(boffop, escaped);
3416 #endif
3417 }
3418 }
3419 }
3420 }
3421
char_from_synonym(Lisp_Object stream)3422 int char_from_synonym(Lisp_Object stream)
3423 {
3424 stream = qvalue(stream_read_data(stream));
3425 if (!is_stream(stream)) return aerror1("bad synonym stream", stream);
3426 return getc_stream(stream);
3427 }
3428
char_from_concatenated(Lisp_Object stream)3429 int char_from_concatenated(Lisp_Object stream)
3430 {
3431 Lisp_Object l = stream_read_data(stream), s1;
3432 Lisp_Object nil = C_nil;
3433 int c;
3434 while (consp(l))
3435 { s1 = qcar(l);
3436 if (!is_symbol(s1))
3437 { l = qcdr(l);
3438 stream_read_data(stream) = l;
3439 continue;
3440 }
3441 s1 = qvalue(s1);
3442 if (!is_stream(s1))
3443 { l = qcdr(l);
3444 stream_read_data(stream) = l;
3445 continue;
3446 }
3447 push2(l, stream);
3448 c = getc_stream(s1);
3449 pop2(stream, l);
3450 errexit();
3451 if (c == EOF)
3452 { l = qcdr(l);
3453 stream_read_data(stream) = l;
3454 continue;
3455 }
3456 }
3457 return EOF;
3458 }
3459
char_from_echo(Lisp_Object stream)3460 int char_from_echo(Lisp_Object stream)
3461 {
3462 int c;
3463 Lisp_Object stream1 = qvalue(stream_read_data(stream));
3464 if (!is_stream(stream1)) return aerror1("bad synonym stream", stream1);
3465 c = getc_stream(stream1);
3466 char_to_synonym(c, stream);
3467 return c;
3468 }
3469
char_from_file(Lisp_Object stream)3470 int char_from_file(Lisp_Object stream)
3471 {
3472 Lisp_Object nil = C_nil;
3473 int ch = stream_pushed_char(stream);
3474 if (ch == NOT_CHAR)
3475 {
3476 if (++kilo >= 1024)
3477 { kilo = 0;
3478 io_now++;
3479 }
3480 #ifdef Kanji
3481 ch = getwc(stream_file(stream));
3482 #else
3483 ch = getc(stream_file(stream));
3484 #endif
3485 if (ch == EOF
3486 /* || ch == CTRL_D */
3487 ) return EOF;
3488 if (qvalue(echo_symbol) != nil)
3489 { Lisp_Object stream1 = qvalue(standard_output);
3490 if (!is_stream(stream1)) stream1 = qvalue(terminal_io);
3491 if (!is_stream(stream1)) stream1 = lisp_terminal_io;
3492 putc_stream(ch, stream1);
3493 if (exception_pending()) flip_exception();
3494 }
3495 }
3496 else stream_pushed_char(stream) = NOT_CHAR;
3497 return ch;
3498 }
3499
read_action_illegal(int32_t op,Lisp_Object f)3500 int32_t read_action_illegal(int32_t op, Lisp_Object f)
3501 {
3502 CSL_IGNORE(f);
3503 if (op != READ_CLOSE && op != READ_IS_CONSOLE)
3504 aerror1("Illegal operation on stream",
3505 cons_no_gc(fixnum_of_int(op), stream_type(f)));
3506 return 0;
3507 }
3508
read_action_file(int32_t op,Lisp_Object f)3509 int32_t read_action_file(int32_t op, Lisp_Object f)
3510 {
3511 if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET);
3512 else if (op <= 0xffff) return (stream_pushed_char(f) = op);
3513 else switch (op)
3514 {
3515 case READ_CLOSE:
3516 if (stream_file(f) == NULL) op = 0;
3517 else op = fclose(stream_file(f));
3518 set_stream_read_fn(f, char_from_illegal);
3519 set_stream_read_other(f, read_action_illegal);
3520 set_stream_file(f, NULL);
3521 return op;
3522 case READ_FLUSH:
3523 stream_pushed_char(f) = NOT_CHAR;
3524 return 0;
3525 case READ_TELL:
3526 if ((op = stream_pushed_char(f)) != NOT_CHAR)
3527 { ungetc(op, stream_file(f));
3528 stream_pushed_char(f) = NOT_CHAR;
3529 }
3530 return (int32_t)ftell(stream_file(f));
3531 case READ_END:
3532 return fseek(stream_file(f), 0L, SEEK_END);
3533 case READ_IS_CONSOLE:
3534 return 0;
3535 default:
3536 return 0;
3537 }
3538 }
3539
read_action_output_file(int32_t op,Lisp_Object f)3540 int32_t read_action_output_file(int32_t op, Lisp_Object f)
3541 {
3542 if (op < -1) return fseek(stream_file(f), op & 0x7fffffff, SEEK_SET);
3543 else if (op <= 0xffff) return 0;
3544 else switch (op)
3545 {
3546 case READ_TELL:
3547 op = ftell(stream_file(f));
3548 return op;
3549 case READ_END:
3550 return fseek(stream_file(f), 0L, SEEK_END);
3551 default:
3552 return 0;
3553 }
3554 }
3555
read_action_terminal(int32_t op,Lisp_Object f)3556 int32_t read_action_terminal(int32_t op, Lisp_Object f)
3557 {
3558 CSL_IGNORE(f);
3559 if (op < -1) return 1;
3560 else if (op <= 0xffff) return (terminal_pushed = op);
3561 else switch (op)
3562 {
3563 case READ_CLOSE:
3564 return 0;
3565 case READ_FLUSH:
3566 terminal_pushed = NOT_CHAR;
3567 tty_count = 0;
3568 return 0;
3569 case READ_TELL:
3570 return -1;
3571 case READ_IS_CONSOLE:
3572 return 1;
3573 default:
3574 return 0;
3575 }
3576 }
3577
read_action_synonym(int32_t c,Lisp_Object f)3578 int32_t read_action_synonym(int32_t c, Lisp_Object f)
3579 {
3580 int32_t r;
3581 Lisp_Object f1;
3582 f1 = qvalue(stream_read_data(f));
3583 if (!is_stream(f1)) return aerror1("bad synonym stream", f1);
3584 r = other_read_action(c, f1);
3585 if (c == READ_CLOSE)
3586 { set_stream_read_fn(f, char_from_illegal);
3587 set_stream_read_other(f, read_action_illegal);
3588 set_stream_file(f, NULL);
3589 }
3590 return r;
3591 }
3592
read_action_concatenated(int32_t c,Lisp_Object f)3593 int32_t read_action_concatenated(int32_t c, Lisp_Object f)
3594 {
3595 int32_t r = 0, r1;
3596 Lisp_Object l, f1;
3597 #ifdef COMMON
3598 Lisp_Object nil = C_nil;
3599 #endif
3600 l = stream_read_data(f);
3601 while (consp(l))
3602 { f1 = qcar(l);
3603 l = qcdr(l);
3604 if (!is_symbol(f1)) continue;
3605 f1 = qvalue(f1);
3606 if (!is_stream(f1)) continue;
3607 push2(l, f);
3608 r1 = other_read_action(c, f1);
3609 pop2(f, l);
3610 if (r == 0) r = r1;
3611 }
3612 if (c == READ_CLOSE)
3613 { set_stream_read_fn(f, char_from_illegal);
3614 set_stream_read_other(f, read_action_illegal);
3615 set_stream_file(f, NULL);
3616 }
3617 return r;
3618 }
3619
read_action_list(int32_t op,Lisp_Object f)3620 int32_t read_action_list(int32_t op, Lisp_Object f)
3621 {
3622 if (op < -1) return 1;
3623 else if (op <= 0xffff) return (stream_pushed_char(f) = op);
3624 else switch (op)
3625 {
3626 case READ_CLOSE:
3627 set_stream_read_fn(f, char_from_illegal);
3628 set_stream_read_other(f, read_action_illegal);
3629 set_stream_file(f, NULL);
3630 stream_read_data(f) = C_nil;
3631 return 0;
3632 case READ_FLUSH:
3633 stream_pushed_char(f) = NOT_CHAR;
3634 return 0;
3635 case READ_TELL:
3636 return -1;
3637 case READ_IS_CONSOLE:
3638 return 0;
3639 default:
3640 return 0;
3641 }
3642 }
3643
read_action_vector(int32_t op,Lisp_Object f)3644 int32_t read_action_vector(int32_t op, Lisp_Object f)
3645 {
3646 if (op < -1) return 1;
3647 else if (op <= 0xffff) return (stream_pushed_char(f) = op);
3648 else switch (op)
3649 {
3650 case READ_CLOSE:
3651 set_stream_read_fn(f, char_from_illegal);
3652 set_stream_read_other(f, read_action_illegal);
3653 set_stream_file(f, NULL);
3654 stream_read_data(f) = C_nil;
3655 return 0;
3656 case READ_FLUSH:
3657 stream_pushed_char(f) = NOT_CHAR;
3658 return 0;
3659 case READ_TELL:
3660 return -1;
3661 case READ_IS_CONSOLE:
3662 return 0;
3663 default:
3664 return 0;
3665 }
3666 }
3667
3668 static int most_recent_read_point = 0;
3669
Lread(Lisp_Object nil,int nargs,...)3670 Lisp_Object MS_CDECL Lread(Lisp_Object nil, int nargs, ...)
3671 /*
3672 * The full version of read_s() has to support extra optional args
3673 * that deal with error and eof returns... and a recursive-p arg!
3674 */
3675 {
3676 Lisp_Object w, stream = qvalue(standard_input);
3677 int cursave = curchar;
3678 argcheck(nargs, 0, "read");
3679 #ifdef COMMON
3680 push(reader_workspace);
3681 reader_workspace = nil;
3682 #endif
3683 read_failure = NO;
3684 if (!is_stream(stream)) stream = qvalue(terminal_io);
3685 if (!is_stream(stream)) stream = lisp_terminal_io;
3686 curchar = NOT_CHAR;
3687 most_recent_read_point = other_read_action(READ_TELL, stream);
3688 push(stream);
3689 w = read_s(stream);
3690 pop(stream);
3691 if (curchar != NOT_CHAR) other_read_action(curchar, stream);
3692 curchar = cursave;
3693 current_file = stream_type(stream);
3694 #ifdef COMMON
3695 nil = C_nil;
3696 if (exception_pending())
3697 { flip_exception();
3698 pop(reader_workspace);
3699 flip_exception();
3700 return nil;
3701 }
3702 pop(reader_workspace);
3703 #else
3704 errexit();
3705 #endif
3706 if (read_failure) return aerror("read");
3707
3708 return onevalue(w);
3709 }
3710
Lwhere_was_that(Lisp_Object nil,int nargs,...)3711 static Lisp_Object MS_CDECL Lwhere_was_that(Lisp_Object nil, int nargs, ...)
3712 {
3713 Lisp_Object w;
3714 argcheck(nargs, 0, "where-was-that");
3715 #ifdef COMMON
3716 w = list3(current_file, fixnum_of_int(most_recent_read_point),
3717 packname_(CP));
3718 #else
3719 w = list2(current_file, fixnum_of_int(most_recent_read_point));
3720 #endif
3721 errexit();
3722 return onevalue(w);
3723 }
3724
3725 #ifdef COMMON
3726
Lread_1(Lisp_Object nil,Lisp_Object stream)3727 Lisp_Object Lread_1(Lisp_Object nil, Lisp_Object stream)
3728 {
3729 int cursave = curchar;
3730 Lisp_Object w;
3731 Lisp_Object save = Lrds(nil, stream);
3732 errexit();
3733 push2(reader_workspace, save);
3734 reader_workspace = nil;
3735 read_failure = NO;
3736 stream = qvalue(standard_input);
3737 if (!is_stream(stream)) stream = qvalue(terminal_io);
3738 if (!is_stream(stream)) stream = lisp_terminal_io;
3739 curchar = NOT_CHAR;
3740 w = read_s(stream);
3741 if (curchar != NOT_CHAR) other_read_action(curchar, stream);
3742 curchar = cursave;
3743 nil = C_nil;
3744 if (exception_pending())
3745 { flip_exception();
3746 pop2(save, reader_workspace);
3747 Lrds(nil, save);
3748 errexit();
3749 flip_exception();
3750 return nil;
3751 }
3752 pop2(save, reader_workspace);
3753 push(w);
3754 Lrds(nil, save);
3755 pop(w);
3756 errexit();
3757 if (read_failure) return aerror("read");
3758 return onevalue(w);
3759 }
3760
3761 #endif
3762
3763 /*
3764 * compress is not a Common Lisp function, but it is another on those
3765 * things that I want within my implementation for internal purposes as
3766 * well as for real use.
3767 */
3768
char_from_list(Lisp_Object f)3769 int char_from_list(Lisp_Object f)
3770 {
3771 #ifdef COMMON
3772 Lisp_Object nil = C_nil;
3773 #endif
3774 Lisp_Object ch = stream_pushed_char(f);
3775 if (ch == NOT_CHAR)
3776 { if (!consp(stream_read_data(f))) ch = EOF;
3777 else
3778 { if (++kilo >= 1024)
3779 { kilo = 0;
3780 io_now++;
3781 }
3782 ch = qcar(stream_read_data(f));
3783 stream_read_data(f) = qcdr(stream_read_data(f));
3784 }
3785 /*
3786 * here I tend towards generosity - a symbol stands for the first character
3787 * of its name, and character objects and numbers (representing internal
3788 * codes) are also permitted. Incomplete gensyms are OK here - I just
3789 * use the first character of the base of the name.
3790 */
3791 if (is_symbol(ch)) ch = first_char(ch);
3792 else if (is_char(ch)) ch = (char)code_of_char(ch);
3793 else if (is_fixnum(ch)) ch = (char)int_of_fixnum(ch);
3794 else ch = EOF; /* Bad item in the list */
3795 }
3796 else stream_pushed_char(f) = NOT_CHAR;
3797 return ch;
3798 }
3799
char_from_vector(Lisp_Object f)3800 int char_from_vector(Lisp_Object f)
3801 {
3802 #ifdef COMMON
3803 Lisp_Object nil = C_nil;
3804 #endif
3805 Lisp_Object ch = stream_pushed_char(f);
3806 if (ch == NOT_CHAR)
3807 { char *v = (char *)stream_file(f);
3808 if (v == NULL) ch = EOF;
3809 else
3810 { if (++kilo >= 1024)
3811 { kilo = 0;
3812 io_now++;
3813 }
3814 ch = *v++;
3815 if (ch == 0) ch = EOF;
3816 else set_stream_file(f, (FILE *)v);
3817 }
3818 }
3819 else stream_pushed_char(f) = NOT_CHAR;
3820 return ch;
3821 }
3822
read_from_vector(char * v)3823 Lisp_Object read_from_vector(char *v)
3824 {
3825 int savecur = curchar;
3826 Lisp_Object nil = C_nil, r;
3827 stream_read_data(lisp_work_stream) = nil;
3828 set_stream_read_fn(lisp_work_stream, char_from_vector);
3829 set_stream_read_other(lisp_work_stream, read_action_vector);
3830 stream_pushed_char(lisp_work_stream) = NOT_CHAR;
3831 set_stream_file(lisp_work_stream, (FILE *)v);
3832 read_failure = NO;
3833 curchar = NOT_CHAR;
3834 r = read_s(lisp_work_stream);
3835 errexit();
3836 curchar = savecur;
3837 if (read_failure) return aerror("read-from-vector");
3838 return onevalue(r);
3839 }
3840
Lcompress(Lisp_Object env,Lisp_Object stream)3841 Lisp_Object Lcompress(Lisp_Object env, Lisp_Object stream)
3842 {
3843 int savecur = curchar;
3844 Lisp_Object nil = C_nil;
3845 stream_read_data(lisp_work_stream) = stream;
3846 set_stream_read_fn(lisp_work_stream, char_from_list);
3847 set_stream_read_other(lisp_work_stream, read_action_list);
3848 stream_pushed_char(lisp_work_stream) = NOT_CHAR;
3849 read_failure = NO;
3850 curchar = NOT_CHAR;
3851 env = read_s(lisp_work_stream);
3852 errexit();
3853 stream_read_data(lisp_work_stream) = C_nil;
3854 curchar = savecur;
3855 if (read_failure) return aerror("compress");
3856 return onevalue(env);
3857 }
3858
Llist_to_string(Lisp_Object nil,Lisp_Object stream)3859 Lisp_Object Llist_to_string(Lisp_Object nil, Lisp_Object stream)
3860 {
3861 int n = CELL, k;
3862 Lisp_Object str;
3863 char *s;
3864 stream_read_data(lisp_work_stream) = stream;
3865 set_stream_read_fn(lisp_work_stream, char_from_list);
3866 set_stream_read_other(lisp_work_stream, read_action_list);
3867 stream_pushed_char(lisp_work_stream) = NOT_CHAR;
3868 while (consp(stream)) n++, stream = qcdr(stream);
3869 str = getvector(TAG_VECTOR, TYPE_STRING, n);
3870 errexit();
3871 s = (char *)str + CELL - TAG_VECTOR;
3872 for (k=CELL; k<n; k++) *s++ = (char)char_from_list(lisp_work_stream);
3873 for (;(k&7) != 0; k++) *s++ = 0; /* zero-pad final doubleword */
3874 return onevalue(str);
3875 }
3876
Llist_to_symbol(Lisp_Object nil,Lisp_Object stream)3877 Lisp_Object Llist_to_symbol(Lisp_Object nil, Lisp_Object stream)
3878 {
3879 stream = Llist_to_string(nil, stream);
3880 errexit();
3881 #ifdef COMMON
3882 stream = Lintern_2(nil, stream, CP);
3883 errexit();
3884 return onevalue(stream); /* NB intern would have returned 2 values */
3885 #else
3886 return Lintern(nil, stream);
3887 #endif
3888 }
3889
read_eval_print(int noisy)3890 void read_eval_print(int noisy)
3891 {
3892 Lisp_Object nil = C_nil, *save = stack;
3893 #ifndef __cplusplus
3894 #ifdef USE_SIGALTSTACK
3895 sigjmp_buf this_level, *saved_buffer = errorset_buffer;
3896 #else
3897 jmp_buf this_level, *saved_buffer = errorset_buffer;
3898 #endif
3899 #endif
3900 push2(codevec, litvec);
3901 for (;;) /* Loop for each s-expression found */
3902 { Lisp_Object u;
3903 #ifdef COMMON
3904 int32_t nvals, i;
3905 #endif
3906 miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
3907 errorset_msg = NULL;
3908 #ifdef __cplusplus
3909 try
3910 #else
3911 #ifdef USE_SIGALTSTACK
3912 if (!sigsetjmp(this_level, -1))
3913 #else
3914 if (!setjmp(this_level))
3915 #endif
3916 #endif
3917 {
3918 #ifndef __cplusplus
3919 errorset_buffer = &this_level;
3920 #endif
3921 u = Lread(nil, 0);
3922 }
3923 #ifdef __cplusplus
3924 catch (char *)
3925 #else
3926 else
3927 #endif
3928 { nil = u = C_nil;
3929 if (errorset_msg != NULL)
3930 { term_printf("\n%s detected\n", errorset_msg);
3931 errorset_msg = NULL;
3932 }
3933 unwind_stack(save, NO);
3934 stack = save;
3935 #ifndef UNDER_CE
3936 signal(SIGFPE, low_level_signal_handler);
3937 #ifdef USE_SIGALTSTACK
3938 /* SIGSEGV will be handled on the alternative stack */
3939 { struct sigaction sa;
3940 sa.sa_handler = low_level_signal_handler;
3941 sigemptyset(&sa.sa_mask);
3942 sa.sa_flags = SA_ONSTACK | SA_RESETHAND;
3943 if (segvtrap) sigaction(SIGSEGV, &sa, NULL);
3944 }
3945 #else
3946 if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
3947 #endif
3948 #ifdef SIGBUS
3949 if (segvtrap) signal(SIGBUS, low_level_signal_handler);
3950 #endif
3951 #ifdef SIGILL
3952 if (segvtrap) signal(SIGILL, low_level_signal_handler);
3953 #endif
3954 #endif
3955 err_printf("\n... read failed\n");
3956 errors_now++;
3957 if (errors_limit >= 0 && errors_now > errors_limit)
3958 resource_exceeded();
3959 else continue;
3960 }
3961 nil = C_nil;
3962 if (exception_pending())
3963 { flip_exception();
3964 /*
3965 * Maybe (stop) or (preserve) was called from a read-macro? Otherwise
3966 * errors reading are ignored and the system tries to read the next
3967 * expression for evaluation. Note that this behaviour means that
3968 * perhaps unreasonably or unexpectedly, THROW will not be propagated
3969 * back past a read_eval_print loop.
3970 */
3971 if (exit_reason == UNWIND_RESTART ||
3972 exit_reason == UNWIND_RESOURCE)
3973 {
3974 #ifndef __cplusplus
3975 errorset_buffer = saved_buffer;
3976 #endif
3977 pop2(litvec, codevec);
3978 flip_exception();
3979 return;
3980 }
3981 err_printf("\n... read failed\n");
3982 continue;
3983 }
3984 /*
3985 * This will stop at end of file. That could EITHER be a real proper
3986 * end of file, or the user having #\eof in the input file. These are NOT
3987 * equivalent, in that #\eof is read once and then further stuff from the
3988 * stream can be read, while a real EOF (eg typing ^D at the terminal in
3989 * some cases) ends the stream once and for all.
3990 */
3991 if (u == CHAR_EOF)
3992 {
3993 #ifndef __cplusplus
3994 errorset_buffer = saved_buffer;
3995 #endif
3996 pop2(litvec, codevec);
3997 return;
3998 }
3999
4000 if (qvalue(standard_input) == lisp_terminal_io &&
4001 spool_file != NULL) putc('\n', spool_file);
4002
4003 miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
4004 errorset_msg = NULL;
4005 #ifdef __cplusplus
4006 try
4007 #else
4008 #ifdef USE_SIGALTSTACK
4009 if (!sigsetjmp(this_level, -1))
4010 #else
4011 if (!setjmp(this_level))
4012 #endif
4013 #endif
4014 {
4015 u = eval(u, nil);
4016 nil = C_nil;
4017 if (exception_pending())
4018 { flip_exception(); /* safe again! */
4019 if (exit_reason == UNWIND_RESTART ||
4020 exit_reason == UNWIND_RESOURCE)
4021 {
4022 #ifndef __cplusplus
4023 errorset_buffer = saved_buffer;
4024 #endif
4025 pop2(litvec, codevec);
4026 flip_exception();
4027 return;
4028 }
4029 err_printf("\n... continuing after error\n");
4030 if (spool_file != NULL) fflush(spool_file);
4031 continue;
4032 }
4033 if (noisy)
4034 {
4035 #ifndef COMMON
4036 print(u); /* Always exactly one value */
4037 stdout_printf("\n");
4038 nil = C_nil;
4039 if (exception_pending()) flip_exception();
4040 #else
4041 nvals = exit_count;
4042 /*
4043 * These days I have to push mv_2 because print can call find-symbol to
4044 * decide if it needs to display a package qualifier, and in that case
4045 * it alters mv_2 on the way... But at present it should never change
4046 * any higher multiple value. I guess if it were interrupted then a break
4047 * loop (if one existed) could corrupt almost anything, but I will
4048 * ignore that worry.
4049 */
4050 if (nvals > 0)
4051 { push(mv_2);
4052 print(u);
4053 pop(u);
4054 }
4055 nil = C_nil;
4056 if (exception_pending()) flip_exception();
4057 mv_2 = u;
4058 miscflags |= (HEADLINE_FLAG | MESSAGES_FLAG);
4059 for (i=2; i<=nvals; i++)
4060 { print((&mv_2)[i-2]);
4061 nil = C_nil;
4062 if (exception_pending())
4063 { flip_exception();
4064 break;
4065 }
4066 }
4067 stdout_printf("\n");
4068 #endif
4069 }
4070 }
4071 #ifdef __cplusplus
4072 catch (char *)
4073 #else
4074 else
4075 #endif
4076 { if (errorset_msg != NULL)
4077 { term_printf("\n%s detected\n", errorset_msg);
4078 errorset_msg = NULL;
4079 }
4080 unwind_stack(save, NO);
4081 stack = save;
4082 #ifndef UNDER_CE
4083 signal(SIGFPE, low_level_signal_handler);
4084 #ifdef USE_SIGALTSTACK
4085 /* SIGSEGV will be handled on the alternative stack */
4086 { struct sigaction sa;
4087 sa.sa_handler = low_level_signal_handler;
4088 sigemptyset(&sa.sa_mask);
4089 sa.sa_flags = SA_ONSTACK | SA_RESETHAND;
4090 if (segvtrap) sigaction(SIGSEGV, &sa, NULL);
4091 }
4092 #else
4093 if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
4094 #endif
4095 #ifdef SIGBUS
4096 if (segvtrap) signal(SIGBUS, low_level_signal_handler);
4097 #endif
4098 #ifdef SIGILL
4099 if (segvtrap) signal(SIGILL, low_level_signal_handler);
4100 #endif
4101 #endif
4102 err_printf("\n... continuing after error\n");
4103 if (spool_file != NULL) fflush(spool_file);
4104 errors_now++;
4105 if (errors_limit >= 0 && errors_now > errors_limit)
4106 { resource_exceeded();
4107 return;
4108 }
4109 else continue;
4110 }
4111 }
4112 }
4113
4114 /*
4115 * RDF is wanted as it is in Standard Lisp. In Common Lisp the corresponding
4116 * function is LOAD. LOAD takes keyword arguments, which are decoded
4117 * elsewhere, leaving the code here which takes a variable number of
4118 * args, but all with definite simple interpretations.
4119 */
4120
Lrdf4(Lisp_Object nil,Lisp_Object file,Lisp_Object noisyp,Lisp_Object verbosep,Lisp_Object nofilep)4121 Lisp_Object Lrdf4(Lisp_Object nil, Lisp_Object file, Lisp_Object noisyp,
4122 Lisp_Object verbosep, Lisp_Object nofilep)
4123 {
4124 Lisp_Object r = nil;
4125 int noisy = (noisyp != nil),
4126 #ifdef COMMON
4127 nofile = (nofilep != nil),
4128 #endif
4129 verbose = (verbosep != nil);
4130 #ifndef COMMON
4131 CSL_IGNORE(nofilep);
4132 #endif
4133 /*
4134 * (rdf nil)/(load nil) obeys Lisp commands from the current input
4135 */
4136 push3(nil, nil, file);
4137 /*
4138 * I have a somewhat comical chunk of code here. If the file-name passed
4139 * across ends in a suffix that is one of ".o", ".fsl" or ".fasl" then
4140 * instead of reading a textual source file the way one might have
4141 * expected I will subvert things and perform LOAD-MODULE instead.
4142 */
4143 if (file != nil)
4144 { Header h;
4145 char *filestring;
4146 char tail[8];
4147 int32_t i, len;
4148 #ifdef COMMON
4149 if (complex_stringp(file))
4150 { file = simplify_string(file);
4151 errexitn(3);
4152 }
4153 #endif
4154 if (symbolp(file))
4155 { file = get_pname(file);
4156 errexitn(3);
4157 h = vechdr(file);
4158 }
4159 else if (!is_vector(file) ||
4160 type_of_header(h = vechdr(file)) != TYPE_STRING)
4161 return aerror1("load", file);
4162 len = length_of_header(h) - CELL;
4163 filestring = (char *)file + CELL-TAG_VECTOR;
4164 for (i=0; i<6; i++)
4165 { if (len == 0)
4166 { tail[i] = 0;
4167 break;
4168 }
4169 else tail[i] = (char)tolower(filestring[--len]);
4170 }
4171 if (strncmp(tail, "lsf.", 4) == 0 ||
4172 strncmp(tail, "lasf.", 5) == 0 ||
4173 strncmp(tail, "o.", 2) == 0)
4174 { stack[0] = file;
4175 if (verbose)
4176 {
4177 #ifdef COMMON
4178 trace_printf("\n;; Loading module ");
4179 #else
4180 trace_printf("\nReading module ");
4181 #endif
4182 prin_to_trace(file); trace_printf("\n");
4183 }
4184 Lload_module(nil, stack[0]);
4185 errexitn(3);
4186 if (verbose)
4187 {
4188 #ifdef COMMON
4189 trace_printf("\n;; Loaded module ");
4190 #else
4191 trace_printf("\nRead module ");
4192 #endif
4193 prin_to_trace(stack[0]); trace_printf("\n");
4194 }
4195 popv(3);
4196 #ifdef COMMON
4197 return onevalue(lisp_true);
4198 #else
4199 return onevalue(nil);
4200 #endif
4201 }
4202
4203 #ifdef COMMON
4204 stack[-1] = r = Lopen(nil, file, fixnum_of_int(1+(nofile?64:0)));
4205 #else
4206 stack[-1] = r = Lopen(nil, file, fixnum_of_int(1+64));
4207 #endif
4208 errexitn(3);
4209 #ifdef COMMON
4210 /*
4211 * The test here is necessary since in Common Lisp mode an attempt to OPEN a
4212 * file that can not be accessed returns NIL rather than raising an
4213 * exception.
4214 */
4215 if (r == nil)
4216 { pop(file);
4217 popv(2);
4218 if (nofile) return error(1, err_open_failed, file);
4219 else return onevalue(nil);
4220 }
4221 #endif
4222 stack[-2] = r = Lrds(nil, r);
4223 errexitn(3);
4224 if (verbose)
4225 { file = stack[0];
4226 #ifdef COMMON
4227 trace_printf("\n;; Loading "); prin_to_trace(file); trace_printf("\n");
4228 #else
4229 trace_printf("\nReading "); prin_to_trace(file); trace_printf("\n");
4230 #endif
4231 }
4232 errexitn(3);
4233 }
4234 read_eval_print(noisy);
4235 nil = C_nil;
4236 if (exception_pending())
4237 { flip_exception();
4238 if (exit_reason == UNWIND_ERROR ||
4239 exit_reason == UNWIND_RESOURCE)
4240 {
4241 #ifdef COMMON
4242 trace_printf("\n;; Loaded ");
4243 #else
4244 trace_printf("\nFinished reading ");
4245 #endif
4246 prin_to_trace(stack[0]);
4247 trace_printf(" (bad)\n");
4248 }
4249 if (stack[0] != nil)
4250 { Lclose(nil, stack[-1]);
4251 nil = C_nil;
4252 if (exception_pending()) flip_exception();
4253 Lrds(nil, stack[-2]);
4254 errexitn(3);
4255 }
4256 flip_exception();
4257 popv(3);
4258 return nil;
4259 }
4260 if (verbose)
4261 {
4262 #ifdef COMMON
4263 trace_printf("\n;; Loaded ");
4264 #else
4265 trace_printf("\nRead ");
4266 #endif
4267 }
4268 prin_to_trace(stack[0]);
4269 trace_printf("\n");
4270 if (stack[0] != nil)
4271 {
4272 Lclose(nil, stack[-1]);
4273 nil = C_nil;
4274 if (exception_pending()) flip_exception();
4275 Lrds(nil, stack[-2]);
4276 errexitn(3);
4277 }
4278 popv(3);
4279 #ifdef COMMON
4280 return onevalue(lisp_true);
4281 #else
4282 return onevalue(nil);
4283 #endif
4284 }
4285
Lrdf1(Lisp_Object nil,Lisp_Object file)4286 Lisp_Object Lrdf1(Lisp_Object nil, Lisp_Object file)
4287 {
4288 return Lrdf4(nil, file, lisp_true, lisp_true, lisp_true);
4289 }
4290
Lrdf2(Lisp_Object nil,Lisp_Object file,Lisp_Object noisy)4291 Lisp_Object Lrdf2(Lisp_Object nil, Lisp_Object file, Lisp_Object noisy)
4292 {
4293 return Lrdf4(nil, file, noisy, lisp_true, lisp_true);
4294 }
4295
Lrdfn(Lisp_Object nil,int nargs,...)4296 Lisp_Object MS_CDECL Lrdfn(Lisp_Object nil, int nargs, ...)
4297 {
4298 va_list a;
4299 Lisp_Object file, noisy, verbose, nofile = lisp_true;
4300 if (nargs < 3 || nargs > 4) return aerror("load");
4301 va_start(a, nargs);
4302 file = va_arg(a, Lisp_Object);
4303 noisy = va_arg(a, Lisp_Object);
4304 verbose = va_arg(a, Lisp_Object);
4305 if (nargs > 3) nofile = va_arg(a, Lisp_Object);
4306 va_end(a);
4307 return Lrdf4(nil, file, noisy, verbose, nofile);
4308 }
4309
4310 #ifdef COMMON
4311 #define spool_name "dribble"
4312 #else
4313 #define spool_name "spool"
4314 #endif
4315
Lspool(Lisp_Object nil,Lisp_Object file)4316 Lisp_Object Lspool(Lisp_Object nil, Lisp_Object file)
4317 {
4318 char filename[LONGEST_LEGAL_FILENAME];
4319 Header h;
4320 int32_t len;
4321 #ifdef SOCKETS
4322 /*
4323 * Security measure - remote client can not do "spool"
4324 */
4325 if (socket_server != 0) return onevalue(nil);
4326 #endif
4327 if (spool_file != NULL)
4328 {
4329 #ifdef COMMON
4330 fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
4331 #else
4332 fprintf(spool_file, "\n+++ End of transcript +++\n");
4333 #endif
4334 fclose(spool_file);
4335 spool_file = NULL;
4336 }
4337 if (file == nil) return onevalue(lisp_true);
4338 #ifdef COMMON
4339 if (complex_stringp(file))
4340 { file = simplify_string(file);
4341 errexit();
4342 }
4343 #endif
4344 if (symbolp(file))
4345 { file = get_pname(file);
4346 errexit();
4347 h = vechdr(file);
4348 }
4349 if (!is_vector(file) ||
4350 type_of_header(h = vechdr(file)) != TYPE_STRING)
4351 return aerror1(spool_name, file);
4352 len = length_of_header(h) - CELL;
4353 spool_file = open_file(filename,
4354 (char *)file + (CELL-TAG_VECTOR),
4355 (size_t)len, "w", NULL);
4356 if (spool_file != NULL)
4357 { time_t t0 = time(NULL);
4358 strncpy(spool_file_name, filename, 32);
4359 spool_file_name[31] = 0;
4360 #ifdef COMMON
4361 fprintf(spool_file, "Starts dribbling to %s (%.24s)\n",
4362 spool_file_name, ctime(&t0));
4363 #else
4364 fprintf(spool_file, "+++ Transcript to %s started at %.24s +++\n",
4365 spool_file_name, ctime(&t0));
4366 #endif
4367 return onevalue(lisp_true);
4368 }
4369 return onevalue(nil);
4370 }
4371
Lspool0(Lisp_Object nil,int nargs,...)4372 static Lisp_Object MS_CDECL Lspool0(Lisp_Object nil, int nargs, ...)
4373 {
4374 argcheck(nargs, 0, spool_name);
4375 return Lspool(nil, nil);
4376 }
4377
4378 #ifdef COMMON
4379
4380 /* The following two must be powers of 2 */
4381 #define STARTING_SIZE_X 32
4382 #define STARTING_SIZE_I 32
4383
make_package(Lisp_Object name)4384 Lisp_Object make_package(Lisp_Object name)
4385 /*
4386 * ... assuming that there is not already one with this name. Packages
4387 * can grow as extra symbols are inserted into them, so I can reasonably
4388 * start off with a very small package.
4389 */
4390 {
4391 Lisp_Object nil = C_nil;
4392 Lisp_Object p, w;
4393 push(name);
4394 p = getvector_init(sizeof(Package), nil);
4395 pop(name);
4396 errexit();
4397 packhdr_(p) = TYPE_STRUCTURE + (packhdr_(p) & ~header_mask);
4398 packid_(p) = package_symbol;
4399 packname_(p) = name;
4400 push(p);
4401 w = getvector_init(STARTING_SIZE_X+CELL, fixnum_of_int(0));
4402 pop(p);
4403 errexit();
4404 packext_(p) = w;
4405 push(p);
4406 w = getvector_init(STARTING_SIZE_I+CELL, fixnum_of_int(0));
4407 pop(p);
4408 errexit();
4409 packint_(p) = w;
4410 packflags_(p) = fixnum_of_int(++package_bits);
4411 packvext_(p) = fixnum_of_int(1);
4412 packvint_(p) = fixnum_of_int(1);
4413 packnext_(p) = fixnum_of_int(0);
4414 packnint_(p) = fixnum_of_int(0);
4415 push(p);
4416 w = cons(p, all_packages);
4417 pop(p);
4418 errexit();
4419 all_packages = w;
4420 return onevalue(p);
4421 }
4422
want_a_string(Lisp_Object name)4423 static Lisp_Object want_a_string(Lisp_Object name)
4424 {
4425 #ifdef COMMON
4426 Lisp_Object nil = C_nil;
4427 if (complex_stringp(name)) return simplify_string(name);
4428 #else
4429 nil_as_base
4430 #endif
4431 if (symbolp(name)) return get_pname(name);
4432 else if (is_vector(name) &&
4433 type_of_header(vechdr(name)) == TYPE_STRING) return name;
4434 else return aerror1("name or string needed", name);
4435 }
4436
Lfind_package(Lisp_Object nil,Lisp_Object name)4437 static Lisp_Object Lfind_package(Lisp_Object nil, Lisp_Object name)
4438 /*
4439 * This should be given a string as an argument. If it is given a
4440 * symbol it takes its pname as the string to be used. It scans the list
4441 * of all packages and returns the first that it finds where the name
4442 * or a nickname matches the string passed in.
4443 */
4444 {
4445 Lisp_Object w;
4446 Header h;
4447 int32_t len;
4448 CSL_IGNORE(nil);
4449 if (is_vector(name))
4450 { h = vechdr(name);
4451 if (type_of_header(h) == TYPE_STRUCTURE &&
4452 packid_(name) == package_symbol) return onevalue(name);
4453 }
4454 name = want_a_string(name);
4455 errexit();
4456 h = vechdr(name);
4457 len = length_of_header(h) - CELL;
4458 for (w = all_packages; w!=nil; w=qcdr(w))
4459 { Lisp_Object nn, n = packname_(qcar(w));
4460 if (is_vector(n) && vechdr(n) == h &&
4461 memcmp((char *)name + (CELL-TAG_VECTOR),
4462 (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
4463 return onevalue(qcar(w));
4464 for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn))
4465 { n = qcar(nn);
4466 if (!is_vector(n) || vechdr(n) != h) continue;
4467 if (memcmp((char *)name + (CELL-TAG_VECTOR),
4468 (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
4469 return onevalue(qcar(w));
4470 }
4471 }
4472 return onevalue(nil);
4473 }
4474
find_package(char * name,int len)4475 Lisp_Object find_package(char *name, int len)
4476 /*
4477 * This is like Lfind_package but takes a C string as its arg. Note that
4478 * this can not cause garbage collection or return an error, so is safe to
4479 * call from the middle of other things...
4480 */
4481 {
4482 Lisp_Object w, nil = C_nil;
4483 for (w = all_packages; w!=nil; w=qcdr(w))
4484 { Lisp_Object nn, n = packname_(qcar(w));
4485 if (is_vector(n) &&
4486 length_of_header(vechdr(n))==(uint32_t)(len+CELL) &&
4487 memcmp(name, (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
4488 return qcar(w);
4489 for (nn = packnick_(qcar(w)); nn!=nil; nn=qcdr(nn))
4490 { n = qcar(nn);
4491 if (!is_vector(n) ||
4492 length_of_header(vechdr(n)) != (uint32_t)(len+CELL))
4493 continue;
4494 if (memcmp(name,
4495 (char *)n + (CELL-TAG_VECTOR), (size_t)len) == 0)
4496 return qcar(w);
4497 }
4498 }
4499 return nil;
4500 }
4501
Luse_package(Lisp_Object nil,Lisp_Object uses,Lisp_Object pkg)4502 static Lisp_Object Luse_package(Lisp_Object nil, Lisp_Object uses,
4503 Lisp_Object pkg)
4504 {
4505 CSL_IGNORE(nil);
4506 push(uses);
4507 pkg = Lfind_package(nil, pkg);
4508 pop(uses);
4509 errexit();
4510 if (pkg == nil) return onevalue(nil);
4511 if (consp(uses))
4512 { while (consp(uses))
4513 { push2(uses, pkg);
4514 Luse_package(nil, qcar(uses), pkg);
4515 errexitn(2);
4516 pop2(pkg, uses);
4517 uses = qcdr(uses);
4518 }
4519 }
4520 else
4521 { Lisp_Object w, w1;
4522 push(pkg);
4523 uses = Lfind_package(nil, uses);
4524 pop(pkg);
4525 errexit();
4526 if (uses == nil || uses == pkg) return onevalue(nil);
4527 push2(pkg, uses);
4528 /*
4529 * Around here I am supposed to do a large-scale check to ensure that there
4530 * are no unexpected name conflicts between the packages that are being
4531 * worked linked.
4532 */
4533 w = cons(uses, packuses_(pkg));
4534 errexitn(2);
4535 uses = stack[0];
4536 pkg = stack[-1];
4537 push(w);
4538 w1 = cons(pkg, packused_(uses));
4539 errexitn(3);
4540 pop3(w, uses, pkg);
4541 packuses_(pkg) = w;
4542 packused_(uses) = w1;
4543 }
4544 return onevalue(lisp_true);
4545 }
4546
Lmake_package(Lisp_Object nil,int nargs,...)4547 static Lisp_Object MS_CDECL Lmake_package(Lisp_Object nil, int nargs, ...)
4548 {
4549 Lisp_Object name, nicknames = nil, uses = nil, w = nil, k;
4550 CSLbool has_use = NO;
4551 va_list a;
4552 int i;
4553 if (nargs == 0) return aerror("make-package");
4554 /*
4555 * First I scan the arguments - there may be a lot of them - looking for
4556 * any relevant keyword parameters
4557 */
4558 va_start(a, nargs);
4559 push_args(a, nargs);
4560 name = stack[1-nargs];
4561 if ((nargs & 1) == 0)
4562 { popv(1);
4563 nargs--;
4564 }
4565 for (i=1; i<nargs; i+=2)
4566 { pop2(k, w);
4567 if (w == nicknames_symbol) nicknames = k;
4568 else if (w == use_symbol) has_use = YES, uses = k;
4569 }
4570 popv(1);
4571 /*
4572 * I provide a default value for the ":use" argument
4573 */
4574 if (!has_use)
4575 { push2(name, nicknames);
4576 uses = make_string("LISP");
4577 errexitn(2);
4578 uses = ncons(uses);
4579 errexitn(2);
4580 pop2(nicknames, name);
4581 }
4582 push2(uses, nicknames);
4583 /*
4584 * Now I need to ensure that the name I had for the package is
4585 * a string...
4586 */
4587 name = want_a_string(name);
4588 errexitn(2);
4589 push(name);
4590 w = Lfind_package(nil, name);
4591 pop(name);
4592 errexitn(2);
4593 /*
4594 * It is SUPPOSED to be a continuable error if the package already exists.
4595 * For the present I will just display a message and keep going.
4596 */
4597 if (w != nil)
4598 { popv(2);
4599 err_printf("\n+++++ package already exists: ");
4600 prin_to_error(name);
4601 err_printf("\n");
4602 return onevalue(w);
4603 }
4604 /*
4605 * The package does not exist yet - so I will make one...
4606 */
4607 name = make_package(name);
4608 errexitn(2);
4609 /*
4610 * ensure that NICKNAMES is a list of strings...
4611 */
4612 uses = nil;
4613 while (consp(stack[0]))
4614 { w = stack[0];
4615 push(uses);
4616 w = want_a_string(qcar(w));
4617 errexitn(3);
4618 pop(uses);
4619 uses = cons(w, uses);
4620 errexitn(2);
4621 stack[0] = qcdr(stack[0]);
4622 }
4623 nicknames = nil;
4624 while (uses != nil)
4625 { w = uses;
4626 uses = qcdr(w);
4627 qcdr(w) = nicknames;
4628 nicknames = w;
4629 }
4630 popv(1);
4631 packnick_(name) = nicknames;
4632 uses = stack[0];
4633 stack[0] = name;
4634 Luse_package(nil, uses, name);
4635 errexitn(1);
4636 pop(name);
4637 return onevalue(name);
4638 }
4639
Lmake_package_2(Lisp_Object nil,Lisp_Object a,Lisp_Object b)4640 static Lisp_Object Lmake_package_2(Lisp_Object nil, Lisp_Object a, Lisp_Object b)
4641 {
4642 return Lmake_package(nil, 2, a, b);
4643 }
4644
Lmake_package_1(Lisp_Object nil,Lisp_Object a)4645 static Lisp_Object Lmake_package_1(Lisp_Object nil, Lisp_Object a)
4646 {
4647 return Lmake_package(nil, 1, a);
4648 }
4649
Llist_all_packages(Lisp_Object nil,int nargs,...)4650 static Lisp_Object MS_CDECL Llist_all_packages(Lisp_Object nil, int nargs, ...)
4651 {
4652 CSL_IGNORE(nargs);
4653 CSL_IGNORE(nil);
4654 return onevalue(all_packages);
4655 }
4656
4657 #endif
4658
Ltyi(Lisp_Object nil,int nargs,...)4659 Lisp_Object MS_CDECL Ltyi(Lisp_Object nil, int nargs, ...)
4660 {
4661 int ch;
4662 argcheck(nargs, 0, "tyi");
4663 if (curchar == NOT_CHAR)
4664 { Lisp_Object stream = qvalue(standard_input);
4665 if (!is_stream(stream)) stream = qvalue(terminal_io);
4666 if (!is_stream(stream)) stream = lisp_terminal_io;
4667 ch = getc_stream(stream);
4668 errexit();
4669 }
4670 else
4671 { ch = curchar;
4672 curchar = NOT_CHAR;
4673 }
4674 if (ch == EOF || ch == CTRL_D) return onevalue(CHAR_EOF);
4675 #ifdef Kanji
4676 return onevalue(pack_char(0, 0, ch & 0xffff));
4677 #else
4678 return onevalue(pack_char(0, 0, ch & 0xff));
4679 #endif
4680 }
4681
Lreadbyte(Lisp_Object nil,Lisp_Object stream)4682 Lisp_Object Lreadbyte(Lisp_Object nil, Lisp_Object stream)
4683 {
4684 int ch;
4685 Lisp_Object save = qvalue(echo_symbol);
4686 if (!is_stream(stream)) aerror0("readb requires an appropriate stream");
4687 qvalue(echo_symbol) = nil;
4688 ch = getc_stream(stream);
4689 qvalue(echo_symbol) = save;
4690 errexit();
4691 /*
4692 * At one stage this code treated ^D as an end-of file marker - that is
4693 * most nasty for binary files! The code should now be more transparent.
4694 */
4695 if (ch == EOF) return onevalue(CHAR_EOF);
4696 else return fixnum_of_int(ch & 0xff);
4697 }
4698
Lreadch1(Lisp_Object nil,Lisp_Object stream)4699 Lisp_Object Lreadch1(Lisp_Object nil, Lisp_Object stream)
4700 {
4701 Lisp_Object w;
4702 int ch;
4703 if (!is_stream(stream)) stream = qvalue(terminal_io);
4704 if (!is_stream(stream)) stream = lisp_terminal_io;
4705 ch = getc_stream(stream);
4706 errexit();
4707 if (ch == EOF || ch == CTRL_D) w = CHAR_EOF;
4708 else
4709 {
4710 if (qvalue(lower_symbol) != nil) ch = TOlower(ch);
4711 else if (qvalue(raise_symbol) != nil) ch = TOupper(ch);
4712 #ifdef Kanji
4713 if (qvalue(hankaku_symbol) != nil)
4714 is (iszenkaku(curchar)) curchar = tohankaku(curchar);
4715 if (iswchar(ch))
4716 { boffo_char(0) = ch >> 8;
4717 boffo_char(1) = ch;
4718 w = iintern(boffo, 2, lisp_package, 1);
4719 errexit();
4720 }
4721 else
4722 { w = elt(charvec, ch & 0xff);
4723 if (w == nil)
4724 { boffo_char(0) = ch;
4725 /* NB I always want to intern in the LISP package here */
4726 w = iintern(boffo, 1, lisp_package, 0);
4727 errexit();
4728 elt(charvec, ch & 0xff) = w;
4729 }
4730 }
4731 #else
4732 w = elt(charvec, ch & 0xff);
4733 if (w == nil)
4734 { boffo_char(0) = (char)ch;
4735 /* NB I always want to intern in the LISP package here */
4736 w = iintern(boffo, 1, lisp_package, 0);
4737 errexit();
4738 elt(charvec, ch & 0xff) = w;
4739 }
4740 #endif
4741 }
4742 return onevalue(w);
4743 }
4744
Lreadch(Lisp_Object nil,int nargs,...)4745 Lisp_Object MS_CDECL Lreadch(Lisp_Object nil, int nargs, ...)
4746 {
4747 argcheck(nargs, 0, "readch");
4748 return Lreadch1(nil, qvalue(standard_input));
4749 }
4750
Lpeekch2(Lisp_Object nil,Lisp_Object type,Lisp_Object stream)4751 Lisp_Object Lpeekch2(Lisp_Object nil, Lisp_Object type, Lisp_Object stream)
4752 {
4753 Lisp_Object w;
4754 int ch;
4755 if (!is_stream(stream)) stream = qvalue(terminal_io);
4756 if (!is_stream(stream)) stream = lisp_terminal_io;
4757 if (type != nil)
4758 { do
4759 { ch = getc_stream(stream);
4760 errexit();
4761 } while (ISspace(ch));
4762 }
4763 else
4764 { ch = getc_stream(stream);
4765 errexit();
4766 }
4767 other_read_action(ch, stream);
4768 errexit();
4769 if (ch == EOF || ch == CTRL_D) w = CHAR_EOF;
4770 else
4771 { if (qvalue(lower_symbol) != nil) ch = TOlower(ch);
4772 else if (qvalue(raise_symbol) != nil) ch = TOupper(ch);
4773 #ifdef Kanji
4774 if (qvalue(hankaku_symbol) != nil)
4775 is (iszenkaku(curchar)) curchar = tohankaku(curchar);
4776 if (iswchar(curchar))
4777 { boffo_char(0) = curchar >> 8;
4778 boffo_char(1) = curchar;
4779 w = iintern(boffo, 2, lisp_package, 0);
4780 errexit();
4781 }
4782 else
4783 { w = elt(charvec, ch & 0xff);
4784 if (w == nil)
4785 { boffo_char(0) = ch;
4786 /* NB I always want to intern in the LISP package here */
4787 w = iintern(boffo, 1, lisp_package, 0);
4788 errexit();
4789 elt(charvec, ch & 0xff) = w;
4790 }
4791 }
4792 #else
4793 w = elt(charvec, ch & 0xff);
4794 if (w == nil)
4795 { boffo_char(0) = (char)ch;
4796 /* NB I always want to intern in the LISP package here */
4797 w = iintern(boffo, 1, lisp_package, 0);
4798 errexit();
4799 elt(charvec, ch & 0xff) = w;
4800 }
4801 #endif
4802 }
4803 return onevalue(w);
4804 }
4805
Lpeekch1(Lisp_Object nil,Lisp_Object type)4806 Lisp_Object Lpeekch1(Lisp_Object nil, Lisp_Object type)
4807 {
4808 return Lpeekch2(nil, type, qvalue(standard_input));
4809 }
4810
Lpeekch(Lisp_Object nil,int nargs,...)4811 Lisp_Object MS_CDECL Lpeekch(Lisp_Object nil, int nargs, ...)
4812 {
4813 argcheck(nargs, 0, "peekch");
4814 return Lpeekch2(nil, nil, qvalue(standard_input));
4815 }
4816
Lunreadch2(Lisp_Object nil,Lisp_Object a,Lisp_Object stream)4817 Lisp_Object Lunreadch2(Lisp_Object nil, Lisp_Object a, Lisp_Object stream)
4818 {
4819 int ch;
4820 CSL_IGNORE(nil);
4821 if (!is_stream(stream)) stream = qvalue(terminal_io);
4822 if (!is_stream(stream)) stream = lisp_terminal_io;
4823 if (a == CHAR_EOF) ch = EOF;
4824 else
4825 { if (is_symbol(a)) a = pack_char(0, 0, first_char(a));
4826 ch = (char)code_of_char(a);
4827 }
4828 other_read_action(ch, stream);
4829 return onevalue(a);
4830 }
4831
Lunreadch(Lisp_Object nil,Lisp_Object a)4832 Lisp_Object Lunreadch(Lisp_Object nil, Lisp_Object a)
4833 {
4834 return Lunreadch2(nil, a, qvalue(standard_input));
4835 }
4836
Lreadline1(Lisp_Object nil,Lisp_Object stream)4837 Lisp_Object Lreadline1(Lisp_Object nil, Lisp_Object stream)
4838 {
4839 Lisp_Object w;
4840 int ch, n = 0;
4841 char *s;
4842 if (!is_stream(stream)) stream = qvalue(terminal_io);
4843 if (!is_stream(stream)) stream = lisp_terminal_io;
4844 boffop = 0;
4845 while ((ch = getc_stream(stream)) != EOF && ch != '\n')
4846 { errexit();
4847 if (ch != '\r') packbyte(ch);
4848 n++;
4849 }
4850 errexit();
4851 if (ch == EOF && n == 0) w = CHAR_EOF;
4852 else
4853 { w = getvector(TAG_VECTOR, TYPE_STRING, CELL+n);
4854 errexit();
4855 s = (char *)w + CELL - TAG_VECTOR;
4856 memcpy(s, &boffo_char(0), n);
4857 while ((n&7) != 0) s[n++] = 0;
4858 }
4859 #ifdef COMMON
4860 mv_2 = Lispify_predicate(ch == EOF);
4861 #endif
4862 return nvalues(w, 2);
4863 }
4864
Lreadline(Lisp_Object nil,int nargs,...)4865 Lisp_Object MS_CDECL Lreadline(Lisp_Object nil, int nargs, ...)
4866 {
4867 argcheck(nargs, 0, "readline");
4868 return Lreadline1(nil, qvalue(standard_input));
4869 }
4870
4871 setup_type const read_setup[] =
4872 {
4873 {"batchp", wrong_no_na, wrong_no_nb, Lbatchp},
4874 {"rseek", Lrseek, Lrseek_2, wrong_no_1},
4875 #ifdef COMMON
4876 {"rseekend", Lrseekend, too_many_1, wrong_no_1},
4877 #endif
4878 {"rtell", Lrtell_1, wrong_no_nb, Lrtell},
4879 {"gensym1", Lgensym1, too_many_1, wrong_no_1},
4880 {"gensym2", Lgensym2, too_many_1, wrong_no_1},
4881 {"gensymp", Lgensymp, too_many_1, wrong_no_1},
4882 {"reset-gensym", Lreset_gensym, too_many_1, wrong_no_1},
4883 {"getenv", Lgetenv, too_many_1, wrong_no_1},
4884 {"orderp", too_few_2, Lorderp, wrong_no_2},
4885 {"rdf", Lrdf1, Lrdf2, Lrdfn},
4886 {"rds", Lrds, too_many_1, wrong_no_1},
4887 {"peekch", Lpeekch1, Lpeekch2, Lpeekch},
4888 {"readch", Lreadch1, wrong_no_nb, Lreadch},
4889 {"readb", Lreadbyte, too_many_1, wrong_no_1},
4890 {"unreadch", Lunreadch, Lunreadch2, wrong_no_1},
4891 {"readline", Lreadline1, wrong_no_nb, Lreadline},
4892 {"setpchar", Lsetpchar, too_many_1, wrong_no_1},
4893 {"spool", Lspool, too_many_1, Lspool0},
4894 {"system", Lsystem, too_many_1, wrong_no_1},
4895 {"silent-system", Lsilent_system, too_many_1, wrong_no_1},
4896 {"~tyi", wrong_no_na, wrong_no_nb, Ltyi},
4897 {"list-to-string", Llist_to_string, too_many_1, wrong_no_1},
4898 {"list-to-symbol", Llist_to_symbol, too_many_1, wrong_no_1},
4899 {"where-was-that", wrong_no_na, wrong_no_nb, Lwhere_was_that},
4900 #ifdef COMMON
4901 {"compress1", Lcompress, too_many_1, wrong_no_1},
4902 {"dribble", Lspool, too_many_1, Lspool0},
4903 {"read", Lread_1, wrong_no_nb, Lread},
4904 {"intern", Lintern, Lintern_2, wrong_no_1},
4905 {"gensym", Lgensym1, wrong_no_nb, Lgensym},
4906 {"extern", Lextern_1, Lextern, wrong_no_1},
4907 {"import*", Limport_1, Limport, wrong_no_1},
4908 {"find-symbol", Lfind_symbol_1, Lfind_symbol, wrong_no_1},
4909 {"keywordp", Lkeywordp, too_many_1, wrong_no_1},
4910 {"find-package", Lfind_package, too_many_1, wrong_no_1},
4911 {"make-package", Lmake_package_1, Lmake_package_2, Lmake_package},
4912 {"use-package*", too_few_2, Luse_package, wrong_no_2},
4913 {"list-all-packages", wrong_no_na, wrong_no_nb, Llist_all_packages},
4914 {"make-symbol", Lmake_symbol, too_many_1, wrong_no_1},
4915 {"unintern", Lunintern, Lunintern_2, wrong_no_1},
4916 #else
4917 {"compress", Lcompress, too_many_1, wrong_no_1},
4918 {"read", wrong_no_na, wrong_no_nb, Lread},
4919 {"intern", Lintern, too_many_1, wrong_no_1},
4920 {"gensym", Lgensym1, wrong_no_nb, Lgensym},
4921 {"ordp", too_few_2, Lorderp, wrong_no_2},
4922 {"remob", Lunintern, too_many_1, wrong_no_1},
4923 #endif
4924 {NULL, 0, 0, 0}
4925 };
4926
4927 /* end of cslread.c */
4928