1 // Visible Lisp A C Norman, August 2012
2 //
3 // This is a small Lisp system. It is especially
4 // intended for use of the Raspberry Pi board, but should build
5 // on almost any computer with a modern C compiler.
6
7 // This code may be used subject to the BSD licence included in the file
8 // "bsd.txt" that should accompany it.
9
10 #ifdef __GNUC__
11 #define INLINE inline
12 #define USE_INLINE
13 #else // __GNUC__
14 #define INLINE
15 #endif // __GNUC__
16
17 //#ifndef DEBUG
18 //#define NDEBUG 1
19 //#endif // DEBUG
20
21 #include <stdio.h>
22 #include <string.h>
23 #include <stdlib.h>
24 #include <ctype.h>
25 #include <time.h>
26 #include <errno.h>
27 #include <math.h>
28 #include <stdint.h>
29 #include <inttypes.h>
30 #include <stdarg.h>
31 #include <assert.h>
32
33 #ifndef NO_ZLIB
34 #include <zlib.h>
35 #else
36
37 typedef FILE *gzFile;
38
gzopen(const char * name,const char * mode)39 static gzFile gzopen(const char *name, const char *mode)
40 { return fopen(name, mode);
41 }
42
gzclose(gzFile f)43 static gzclose(gzFile f)
44 { fclose(f);
45 }
46
gzread(gzFile f,void * b,size_t n)47 static size_t gzread(gzFile f, void *b, size_t n)
48 { return fread(b, 1, n, f);
49 }
50
gzwrite(gzFile f,void * b,size_t n)51 static void gzwrite(gzFile f, void *b, size_t n)
52 { fwrite(b, 1, n, f);
53 }
54 #endif
55
56 char promptstring[1000] = "> ";
57
58 #ifndef NO_LIBEDIT
59 #include <histedit.h>
60
61 static EditLine *elx_e;
62 static History *elx_h;
63 static HistEvent elx_v;
64
prompt(EditLine * e)65 const char *prompt(EditLine *e)
66 { return promptstring;
67 }
68
69 const char *elx_line = NULL;
70 int elx_count = 0;
71 #endif
72
73 #ifdef WIN32
74 #define popen _popen
75 #endif
76
77 // A Lisp item is represented as an integer and the low 3 bits
78 // contain tag information that specify how the rest will be used.
79
80 typedef intptr_t LispObject;
81
82 #define TAGBITS 0x7
83
84 #define tagCONS 0 // Traditional Lisp "cons" item.
85 #define tagSYMBOL 1 // a symbol.
86 #define tagFIXNUM 2 // An immediate integer value (29 or 61 bits).
87 #define tagFLOAT 3 // A double-precision number.
88 #define tagATOM 4 // Something else that will have a header word.
89 #define tagFORWARD 5 // Used during garbage collection.
90 #define tagHDR 6 // the header word at the start of an atom .
91 #define tagSPARE 7 // not used!
92
93 // Note that in the above I could have used tagATOM to include the case
94 // of symbols (aka identifiers) but as an optimisation I choose to make that
95 // a special case. I still have one spare code (tagSPARE) that could be
96 // used to extend the system.
97
98 // Now I provide macros that test the tag bits. These are all rather obvious!
99
100 #define isCONS(x) (((x) & TAGBITS) == tagCONS)
101 #define isSYMBOL(x) (((x) & TAGBITS) == tagSYMBOL)
102 #define isFIXNUM(x) (((x) & TAGBITS) == tagFIXNUM)
103 #define isFLOAT(x) (((x) & TAGBITS) == tagFLOAT)
104 #define isATOM(x) (((x) & TAGBITS) == tagATOM)
105 #define isFORWARD(x) (((x) & TAGBITS) == tagFORWARD)
106 #define isHDR(x) (((x) & TAGBITS) == tagHDR)
107
108 // In memory CONS cells and FLOATS exist as just 2-word items with
109 // all their bits in use. All other sorts of data have a header word
110 // at their start.
111 // This contains extra information about the exact form of data present.
112
113 #define TYPEBITS 0x78
114
115 #define typeSYM 0x00
116 #define typeGENSYM 0x08
117 #define typeSTRING 0x10
118 #define typeVEC 0x18
119 #define typeBIGNUM 0x20
120 // 0x28
121 #define typeEQHASH 0x30
122 #define typeEQHASHX 0x38
123 #define typeEQUALHASH 0x40
124 #define typeEQUALHASHX 0x48
125 // Codes 0x28, 0x50, 0x58, 0x60, 0x68, 0x70 and 0x78 spare!
126
127 #define veclength(h) (((uintptr_t)(h)) >> 7)
128 #define packlength(n) (((LispObject)(n)) << 7)
129
130 #ifdef USE_INLINE
heapaddr(LispObject x)131 static INLINE LispObject *heapaddr(LispObject x)
132 {
133 return (LispObject *)x;
134 }
135
136 #else // USE_INLINE
137 #define heapaddr(x) ((LispObject *)(x))
138
139 #endif // USE_INLINE
140 // General indirection
141
142 #define qind(x) (*((LispObject *)(x)))
143
144 // Accessor macros the extract fields from LispObjects ...
145
146 #define qcar(x) ((heapaddr(x))[0])
147 #define qcdr(x) ((heapaddr(x))[1])
148
149 // For all other types I must remove the tagging information before I
150 // can use the item as a pointer.
151
152 // An especially important case is that of Symbols. These are the fields that
153 // they provide.
154
155 typedef LispObject SpecialForm(LispObject lits, LispObject a1);
156 typedef LispObject LispFn(LispObject lits, int nargs, ...);
157
158 #define qflags(x) ((heapaddr((x)-tagSYMBOL))[0])
159 #define qvalue(x) ((heapaddr((x)-tagSYMBOL))[1])
160 #define qplist(x) ((heapaddr((x)-tagSYMBOL))[2])
161 #define qpname(x) ((heapaddr((x)-tagSYMBOL))[3])
162 #define qlits(x) ((heapaddr((x)-tagSYMBOL))[4])
163 #define qdefn(x) (((void **) (heapaddr((x)-tagSYMBOL)))[5])
164 #define SYMSIZE 6
165
166 // Bits within the flags field of a symbol. Uses explained later on.
167
168 #define flagTRACED 0x080
169 #define flagSPECFORM 0x100
170 #define flagMACRO 0x200
171 #define flagGLOBAL 0x400
172 #define flagFLUID 0x800
173 // There are LOTS more bits available for flags etc here if needbe!
174
175 // Other atoms have a header that gives info about them. Well as a special
176 // case I will allow that something tagged with tagATOM but with zero as
177 // its address is a special marker value...
178
179 #define NULLATOM (tagATOM + 0)
180 #define qheader(x) ((heapaddr((x)-tagATOM))[0])
181
182 // Fixnums and Floating point numbers are rather easy!
183
184 #define qfixnum(x) ((x) >> 3)
185 #define packfixnum(n) ((((LispObject)(n)) << 3) + tagFIXNUM)
186
187 #define MIN_FIXNUM qfixnum(INTPTR_MIN)
188 #define MAX_FIXNUM qfixnum(INTPTR_MAX)
189
190 #define qfloat(x) (((double *)((x)-tagFLOAT))[0])
191
192 #define isBIGNUM(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeBIGNUM))
193 #define qint64(x) (*(int64_t *)((x) - tagATOM + 8))
194
195 #define isSTRING(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeSTRING))
196 #define qstring(x) ((char *)((x) - tagATOM + sizeof(LispObject)))
197
198 #define isVEC(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeVEC))
199 #define isEQHASH(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQHASH))
200 #define isEQHASHX(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQHASHX))
201 #define isEQUALHASH(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQUALHASH))
202 #define isEQUALHASHX(x) (isATOM(x) && ((qheader(x) & TYPEBITS) == typeEQUALHASHX))
203
204 // The Lisp heap will have fixed size. Here I make it 256 Mbytes on a
205 // 32-bit machine and 612M on a 64-bit one.
206
207 #ifndef MEM
208 #define MEM (256*(sizeof(void *)/4))
209 #endif // MEM
210
211 #define BITMAPSIZE ((uintptr_t)MEM*1024*(1024/128))
212 #define HEAPSIZE (BITMAPSIZE*128)
213 #define STACKSIZE (128*1024*sizeof(LispObject))
214
215 LispObject stackbase, *sp, stacktop;
216 // I should probably arrange to check for stack overflow here.
217 #define push(x) { *sp++ = (x); }
218 #define TOS (sp[-1])
219 #define pop(x) { (x) = *--sp; }
220 #define push2(x, y) { push(x); push(y); }
221 #define pop2(y, x) { pop(y); pop(x); }
222 #define push3(x, y, z) { push(x); push(y); push(z); }
223 #define pop3(z, y, x) { pop(z); pop(y); pop(x); }
224
225 // This sets the size of the hash table used to store all the symbols
226 // that Lisp knows about. I note that if I built a serious application
227 // such as the Reduce algebra system (reduce-algebra.sourceforge.net) I would
228 // end up with around 7000 symbols in a basic installation! So the size
229 // table I use here intended to give decent performance out to that scale.
230 // This is (of course) utterly over the top for the purpose of toy and
231 // demonstration applications! I make the table size a prime in the hope that
232 // that will help keep hashed distribution even across it.
233
234 #define OBHASH_SIZE 1009
235
236 // Some Lisp values that I will use frequently...
237
238 #define nil bases[0]
239 #define undefined bases[1]
240 #define lisptrue bases[2]
241 #define lispsystem bases[3]
242 #define echo bases[4]
243 #define lambda bases[5]
244 #define function bases[6]
245 #define quote bases[7]
246 #define backquote bases[8]
247 #define comma bases[9]
248 #define comma_at bases[10]
249 #define comma_dot bases[11]
250 #define eofsym bases[12]
251 #define cursym bases[13]
252 #define work1 bases[14]
253 #define work2 bases[15]
254 #define restartfn bases[16]
255 #define expr bases[17]
256 #define subr bases[18]
257 #define fexpr bases[19]
258 #define fsubr bases[20]
259 #define macro bases[21]
260 #define input bases[22]
261 #define output bases[23]
262 #define pipe bases[24]
263 #define raise bases[25]
264 #define lower bases[26]
265 #define dfprint bases[27]
266 #define bignum bases[28]
267 #define charvalue bases[29]
268 #define toploopeval bases[30]
269 #define loseflag bases[31]
270 #define condsymbol bases[32]
271 #define prognsymbol bases[33]
272 #define gosymbol bases[34]
273 #define returnsymbol bases[35]
274 #ifdef PSL
275 #define dummyvar bases[36]
276 #endif
277 #define BASES_SIZE 37
278
279 LispObject bases[BASES_SIZE];
280 LispObject obhash[OBHASH_SIZE];
281
282 // ... and non-LispObject values that need to be saved as part of a
283 // heap image.
284
285 #define headerword nonbases[0]
286 #define heap1base nonbases[1]
287 #define heap1top nonbases[2]
288 #define fringe1 nonbases[3]
289 #define saveinterp nonbases[4]
290 #define saveinterpspec nonbases[5]
291 #define fpfringe1 nonbases[6]
292 #define NONBASES_SIZE 7
293
294 LispObject nonbases[NONBASES_SIZE];
295
my_exit(int n)296 void my_exit(int n)
297 {
298 printf("\n+++++ Exit called %d\n", n);
299 fflush(stdout);
300 fflush(stderr);
301 abort();
302 }
303
304 LispObject heap2base, heap2top, fringe2, fpfringe2, bitmap;
305
306 // Here there are some memory blocks allocated, each with their
307 // halfbitmapsize field filled in. Fill in the rest of the entries
308 // in them.
309
310 #define ALIGN8(a) (((a) + 7) & ~(LispObject)7)
311
allocateheap(void * pool)312 void allocateheap(void *pool)
313 {
314 heap1base = (LispObject)pool;
315 heap1base = ALIGN8(heap1base); // ensure alignment
316 heap1top = heap2base = heap1base + (HEAPSIZE/2);
317 heap2top = heap2base + (HEAPSIZE/2);
318 stackbase = heap2top;
319 stacktop = stackbase + STACKSIZE;
320 bitmap = stacktop;
321 sp = (LispObject *)stackbase;
322 fringe1 = heap1base;
323 fringe2 = heap2base;
324 fpfringe1 = heap1top;
325 fpfringe2 = heap2top;
326 }
327
328 // Now I have enough to let me define various allocation functions.
329
330 extern void reclaim();
331 extern LispObject error1(const char *s, LispObject a);
332 extern LispObject error2(const char *s, LispObject a, LispObject b);
333
cons(LispObject a,LispObject b)334 static INLINE LispObject cons(LispObject a, LispObject b)
335 {
336 if (fringe1 + 2*sizeof(LispObject) >= fpfringe1)
337 { push2(a, b);
338 reclaim();
339 pop2(b, a);
340 }
341 qcar(fringe1) = a;
342 qcdr(fringe1) = b;
343 a = fringe1;
344 fringe1 += 2*sizeof(LispObject);
345 return a;
346 }
347
list2star(LispObject a,LispObject b,LispObject c)348 static INLINE LispObject list2star(LispObject a, LispObject b, LispObject c)
349 { // (cons a (cons b c))
350 if (fringe1 + 4*sizeof(LispObject) >= fpfringe1)
351 { push3(a, b, c);
352 reclaim();
353 pop3(c, b, a);
354 }
355 qcar(fringe1) = a;
356 qcdr(fringe1) = fringe1 + 2*sizeof(LispObject);
357 a = fringe1;
358 fringe1 += 2*sizeof(LispObject);
359 qcar(fringe1) = b;
360 qcdr(fringe1) = c;
361 fringe1 += 2*sizeof(LispObject);
362 return a;
363 }
364
acons(LispObject a,LispObject b,LispObject c)365 static INLINE LispObject acons(LispObject a, LispObject b, LispObject c)
366 { // (cons (cons a b) c)
367 if (fringe1 + 4*sizeof(LispObject) >= fpfringe1)
368 { push3(a, b, c);
369 reclaim();
370 pop3(c, b, a);
371 }
372 qcar(fringe1) = fringe1 + 2*sizeof(LispObject);
373 qcdr(fringe1) = c;
374 c = fringe1;
375 fringe1 += 2*sizeof(LispObject);
376 qcar(fringe1) = a;
377 qcdr(fringe1) = b;
378 fringe1 += 2*sizeof(LispObject);
379 return c;
380 }
381
boxfloat(double a)382 static INLINE LispObject boxfloat(double a)
383 { LispObject r;
384 if (fringe1 +sizeof(double) >= fpfringe1) reclaim();
385 fpfringe1 -= sizeof(double);
386 r = fpfringe1 + tagFLOAT;
387 qfloat(r) = a;
388 return r;
389 }
390
391 // The code here does not fill in ANY of the fields within the symbol. That
392 // needs to be done promptly.
393
allocatesymbol()394 LispObject allocatesymbol()
395 { LispObject r;
396 if (fringe1 + 4*sizeof(LispObject) >= fpfringe1) reclaim();
397 r = fringe1 + tagSYMBOL;
398 qflags(r) = tagHDR + typeSYM;
399 fringe1 += 6*sizeof(LispObject);
400 return r;
401 }
402
403 // This one allocates an atom that is n bytes long (plus its header
404 // word) and again does not fill in ANY of the fields.
405
allocateatom(int n)406 static INLINE LispObject allocateatom(int n)
407 { LispObject r;
408 // The actual amount of space allocated must include a word for the
409 // header and must then be rounded up to be a multiple of 8.
410 int nn = ALIGN8(sizeof(LispObject) + n);
411 if (fringe1 + nn >= fpfringe1) reclaim();
412 r = fringe1 + tagATOM;
413 // I mark the new vector as being a string so that it is GC safe
414 qheader(r) = tagHDR + typeSTRING + packlength(n);
415 fringe1 += nn;
416 return r;
417 }
418
makestring(const char * s,int len)419 static INLINE LispObject makestring(const char *s, int len)
420 {
421 LispObject r = allocateatom(len);
422 // qheader(r) = tagHDR + typeSTRING + packlength(len); // already done!
423 memcpy(qstring(r), s, len);
424 return r;
425 }
426
427 #define elt(v, n) \
428 (((LispObject *)((v)-tagATOM+sizeof(LispObject)))[n])
429
makevector(int maxindex)430 static INLINE LispObject makevector(int maxindex)
431 { int i, len = (maxindex+1)*sizeof(LispObject);
432 LispObject r = allocateatom(len);
433 qheader(r) = tagHDR + typeVEC + packlength(len);
434 for (i=0; i<=maxindex; i++) elt(r, i) = nil;
435 return r;
436 }
437
boxint64(int64_t a)438 static INLINE LispObject boxint64(int64_t a)
439 {
440 LispObject r = allocateatom(8);
441 qheader(r) = tagHDR + typeBIGNUM + packlength(8);
442 qint64(r) = a;
443 return r;
444 }
445
446 // I will try to have a general macro that will help me with bringing
447 // everything to consistent numeric types - ie I can start off with a
448 // mix of fixnums, bignums and floats. The strategy here is that if either
449 // args is a float then the other is forced to that, and then for all sorts
450 // of pure integer work everything will be done as int64_t
451
452 #define NUMOP(name, a, b) \
453 if (isFLOAT(a)) \
454 { if (isFLOAT(b)) return FF(qfloat(a), qfloat(b)); \
455 else if (isFIXNUM(b)) return FF(qfloat(a), (double)qfixnum(b)); \
456 else if (isBIGNUM(b)) return FF(qfloat(a), (double)qint64(b)); \
457 else return error1("Bad argument for " name, b); \
458 } \
459 else if (isBIGNUM(a)) \
460 { if (isFLOAT(b)) return FF((double)qint64(a), qfloat(b)); \
461 else if (isFIXNUM(b)) return BB(qint64(a), (int64_t)qfixnum(b)); \
462 else if (isBIGNUM(b)) return BB(qint64(a), qint64(b)); \
463 else return error1("Bad argument for " name, b); \
464 } \
465 else if (isFIXNUM(a)) \
466 { if (isFLOAT(b)) return FF((double)qfixnum(a), qfloat(b)); \
467 else if (isFIXNUM(b)) return BB((int64_t)qfixnum(a), \
468 (int64_t)qfixnum(b)); \
469 else if (isBIGNUM(b)) return BB((int64_t)qfixnum(a), qint64(b)); \
470 else return error1("Bad argument for " name, b); \
471 } \
472 else return error1("Bad argument for " name, a)
473
474 #define UNARYOP(name, a) \
475 if (isFIXNUM(a)) return BB((int64_t)qfixnum(a)); \
476 else if (isFLOAT(a)) return FF(qfloat(a)); \
477 else if (isBIGNUM(a)) return BB(qint64(a)); \
478 else return error1("Bad argument for " name, a)
479
480 // Similar, but only supporting integer (not floating point) values
481
482 #define INTOP(name, a, b) \
483 if (isBIGNUM(a)) \
484 { if (isFIXNUM(b)) return BB(qint64(a), (int64_t)qfixnum(b)); \
485 else if (isBIGNUM(b)) return BB(qint64(a), qint64(b)); \
486 else return error1("Bad argument for " name, b); \
487 } \
488 else if (isFIXNUM(a)) \
489 { if (isFIXNUM(b)) return BB((int64_t)qfixnum(a), \
490 (int64_t)qfixnum(b)); \
491 else if (isBIGNUM(b)) return BB((int64_t)qfixnum(a), qint64(b)); \
492 else return error1("Bad argument for " name, b); \
493 } \
494 else return error1("Bad argument for " name, a)
495
496 #define UNARYINTOP(name, a) \
497 if (isFIXNUM(a)) return BB((int64_t)qfixnum(a)); \
498 else if (isBIGNUM(a)) return BB(qint64(a)); \
499 else return error1("Bad argument for " name, a)
500
501 // This takes an arbitrary 64-bit integer and returns either a fixnum
502 // or a bignum as necessary.
503
makeinteger(int64_t a)504 LispObject makeinteger(int64_t a)
505 { if (a >= MIN_FIXNUM && a <= MAX_FIXNUM) return packfixnum(a);
506 else return boxint64(a);
507 }
508
509 #undef FF
510 #undef BB
511 #define FF(a) boxfloat(-(a))
512 #define BB(a) makeinteger(-(a))
513
Nminus(LispObject a)514 LispObject Nminus(LispObject a)
515 { UNARYOP("minus", a);
516 }
517
518 #undef FF
519 #undef BB
520 #define FF(a, b) boxfloat((a) + (b))
521 #define BB(a, b) makeinteger((a) + (b))
522
Nplus2(LispObject a,LispObject b)523 LispObject Nplus2(LispObject a, LispObject b)
524 { NUMOP("plus", a, b);
525 }
526
527 #undef FF
528 #undef BB
529 #define FF(a, b) boxfloat((a) * (b))
530 #define BB(a, b) makeinteger((a) * (b))
531
Ntimes2(LispObject a,LispObject b)532 LispObject Ntimes2(LispObject a, LispObject b)
533 { NUMOP("times", a, b);
534 }
535
536 #undef BB
537 #define BB(a, b) makeinteger((a) & (b))
538
Nlogand2(LispObject a,LispObject b)539 LispObject Nlogand2(LispObject a, LispObject b)
540 { INTOP("logand", a, b);
541 }
542
543 #undef BB
544 #define BB(a, b) makeinteger((a) | (b))
545
Nlogor2(LispObject a,LispObject b)546 LispObject Nlogor2(LispObject a, LispObject b)
547 { INTOP("logor", a, b);
548 }
549
550 #undef BB
551 #define BB(a, b) makeinteger((a) ^ (b))
552
Nlogxor2(LispObject a,LispObject b)553 LispObject Nlogxor2(LispObject a, LispObject b)
554 { INTOP("logxor", a, b);
555 }
556
557 #undef FF
558 #undef BB
559
560 #define BOFFO_SIZE 4096
561 char boffo[BOFFO_SIZE+4];
562 int boffop;
563
564 #define swap(a,b) w = (a); (a) = (b); (b) = w;
565
566 static INLINE LispObject copy(LispObject x);
567
568 int gccount = 1;
569
570 #define allocate_memory(n) malloc(n)
571
disaster(int line)572 void disaster(int line)
573 { printf("\nInternal inconsistency detected on line %d\n", line);
574 printf("Unable to continue. Apologies.\n");
575 abort();
576 }
577
reclaim()578 void reclaim()
579 {
580 // The strategy here is due to C J Cheyney ("A Nonrecursive List Compacting
581 // Algorithm". Communications of the ACM 13 (11): 677-678, 1970).
582 LispObject *s, w;
583 printf("+++ GC number %d", gccount++);
584 // I need to clear the part of the bitmap that could be relevant for floating
585 // point values.
586 int o = (fpfringe1 - heap1base)/(8*8);
587 while (o < BITMAPSIZE) ((unsigned char *)bitmap)[o++] = 0;
588 // Process everything that is on the stack.
589 for (s=(LispObject *)stackbase; s<sp; s++) *s = copy(*s);
590 // I should also copy any other list base values here.
591 for (o=0; o<BASES_SIZE; o++) bases[o] = copy(bases[o]);
592 for (o=0; o<OBHASH_SIZE; o++)
593 obhash[o] = copy(obhash[o]);
594 // Now perform the second part of Cheyney's algorithm, scanning the
595 // data that has been put in the new heap.
596 s = (LispObject *)heap2base;
597 while ((LispObject)s != fringe2)
598 { LispObject h = *s;
599 if (!isHDR(h)) // The item to be processed is a simple cons cell
600 { *s++ = copy(h);
601 *s = copy(*s);
602 s++;
603 }
604 else // The item is one that uses a header
605 switch (h & TYPEBITS)
606 { case typeSYM:
607 case typeGENSYM:
608 w = ((LispObject)s) + tagSYMBOL;
609 // qflags(w) does not need adjusting
610 qvalue(w) = copy(qvalue(w));
611 qplist(w) = copy(qplist(w));
612 qpname(w) = copy(qpname(w));
613 // qdefn(w) does not need adjusting
614 qlits(w) = copy(qlits(w));
615 s += 6;
616 continue;
617 case typeSTRING:
618 case typeBIGNUM:
619 // These only contain binary information, so none of their content needs
620 // any more processing.
621 w = (sizeof(LispObject) + veclength(h) + 7) & ~7;
622 s += w/sizeof(LispObject);
623 continue;
624 case typeVEC:
625 case typeEQHASH:
626 case typeEQHASHX:
627 case typeEQUALHASH:
628 case typeEQUALHASHX:
629 // These are to be processed the same way. They contain a bunch of
630 // reference items.
631 s++; // Past the header
632 w = veclength(h);
633 while (w > 0)
634 { *s = copy(*s);
635 s++;
636 w -= sizeof(LispObject);
637 }
638 w = (LispObject)s;
639 w = (w + 7) & ~7;
640 s = (LispObject *)w;
641 continue;
642 default:
643 // all the "spare" codes!
644 disaster(__LINE__);
645 }
646 }
647 // Finally flip the two heaps ready for next time.
648 swap(heap1base, heap2base);
649 swap(heap1top, heap2top);
650 fringe1 = fringe2;
651 fpfringe1 = fpfringe2;
652 fringe2 = heap2base;
653 fpfringe2 = heap2top;
654 printf(" - collection complete (%" PRIu64 " Kbytes free)\n",
655 ((uint64_t)(fpfringe1-fringe1))/1024);
656 if (fpfringe1 - fringe1 < 1000*sizeof(LispObject))
657 { printf("\nRun out of memory.\n");
658 exit(1);
659 }
660 fflush(stdout);
661 }
662
copy(LispObject x)663 LispObject copy(LispObject x)
664 { LispObject h;
665 int o, b;
666 switch (x & TAGBITS)
667 { case tagCONS:
668 if (x == 0) disaster(__LINE__);
669 h = *((LispObject *)x);
670 if (isFORWARD(h)) return (h - tagFORWARD);
671 qcar(fringe2) = h;
672 qcdr(fringe2) = qcdr(x);
673 h = fringe2;
674 qcar(x) = tagFORWARD + h;
675 fringe2 += 2*sizeof(LispObject);
676 return h;
677 case tagSYMBOL:
678 h = *((LispObject *)(x - tagSYMBOL));
679 if (isFORWARD(h)) return (h - tagFORWARD + tagSYMBOL);
680 if (!isHDR(h)) disaster(__LINE__);
681 h = fringe2 + tagSYMBOL;
682 qflags(h) = qflags(x);
683 qvalue(h) = qvalue(x);
684 qplist(h) = qplist(x);
685 qpname(h) = qpname(x);
686 qdefn(h) = qdefn(x);
687 qlits(h) = qlits(x);
688 fringe2 += 6*sizeof(LispObject);
689 qflags(x) = h - tagSYMBOL + tagFORWARD;
690 return h;
691 case tagATOM:
692 if (x == NULLATOM) return x; // special case!
693 h = qheader(x);
694 if (isFORWARD(h)) return (h - tagFORWARD + tagATOM);
695 if (!isHDR(h)) disaster(__LINE__);
696 switch (h & TYPEBITS)
697 { case typeEQHASH:
698 case typeEQUALHASH:
699 // When a hash table is copied its header is changes to EQHASHX, which
700 // indicates that it will need rehashing before further use.
701 qheader(x) ^= (typeEQHASH ^ typeEQHASHX);
702 case typeEQHASHX:
703 case typeEQUALHASHX:
704 case typeSTRING:
705 case typeVEC:
706 case typeBIGNUM:
707 o = (int)veclength(h); // number of bytes excluding the header
708 *((LispObject *)fringe2) = h; // copy header word across
709 h = fringe2 + tagATOM;
710 *((LispObject *)(x - tagATOM)) = fringe2 + tagFORWARD;
711 fringe2 += sizeof(LispObject);
712 x = x - tagATOM + sizeof(LispObject);
713 while (o > 0)
714 { *((LispObject *)fringe2) = *((LispObject *)x);
715 fringe2 += sizeof(LispObject);
716 x += sizeof(LispObject);
717 o -= sizeof(LispObject);
718 }
719 fringe2 = (fringe2 + 7) & ~7;
720 return h;
721 default:
722 //case typeSYM: case typeGENSYM:
723 // also the spare codes!
724 disaster(__LINE__);
725 }
726 case tagFLOAT:
727 // every float is 8 bytes wide, regardless of what sort of machine I am on.
728 h = (x - tagFLOAT - heap1base)/8;
729 o = h/8;
730 b = 1 << (h%8);
731 // now o is an offset and b a bit in the bitmap.
732 if ((((unsigned char *)bitmap)[o] & b) != 0) // marked already.
733 return *((LispObject *)(x-tagFLOAT));
734 else
735 { ((unsigned char *)bitmap)[o] |= b; // mark it now.
736 fpfringe2 -= sizeof(double);
737 h = fpfringe2 + tagFLOAT;
738 qfloat(h) = qfloat(x); // copy the float.
739 *((LispObject *)(x-tagFLOAT)) = h; // write in forwarding address.
740 return h;
741 }
742 case tagFIXNUM:
743 return x;
744 default:
745 //case tagFORWARD:
746 //case tagHDR:
747 disaster(__LINE__);
748 return 0; // avoid GCC moans.
749 }
750 }
751
752 #define printPLAIN 1
753 #define printESCAPES 2
754 #define printHEX 4
755
756 // I suspect that linelength and linepos need to be maintained
757 // independently for each output stream. At present that is not
758 // done.
759 int linelength = 80, linepos = 0, printflags = printESCAPES;
760
761 #define MAX_LISPFILES 30
762 #ifdef DEBUG
763 FILE *lispfiles[MAX_LISPFILES], *logfile = NULL;
764 #else // DEBUG
765 FILE *lispfiles[MAX_LISPFILES];
766 #endif // DEBUG
767 int curchars[MAX_LISPFILES+1];
768 int symtypes[MAX_LISPFILES+1];
769 #define curchar curchars[lispin+1]
770 #define symtype symtypes[lispin+1]
771 int32_t file_direction = 0, interactive = 0;
772 int lispin = 0, lispout = 1;
773
774 extern LispObject lookup(const char *s, int n, int flags);
775
wrch(int c)776 void wrch(int c)
777 {
778 if (lispout == -1)
779 { char w[4];
780 // This bit is for the benefit of explode and explodec.
781 LispObject r;
782 w[0] = c; w[1] = 0;
783 r = lookup(w, 1, 1);
784 work1 = cons(r, work1);
785 }
786 else if (lispout == -2) boffo[boffop++] = c;
787 else
788 { putc(c, lispfiles[lispout]);
789 #ifdef DEBUG
790 if (logfile != NULL)
791 { putc(c, logfile);
792 if (c == '\n')
793 { fprintf(logfile, "%d]", lispout);
794 }
795 }
796 #endif // DEBUG
797 if (c == '\n')
798 { linepos = 0;
799 fflush(lispfiles[lispout]);
800 }
801 else linepos++;
802 }
803 }
804
my_getc(FILE * f)805 int my_getc(FILE *f)
806 {
807 #ifdef NO_LIBEDIT
808 // This can help while running under a debugger!
809 return getc(f);
810 #else
811 if (f != stdin) return getc(f);
812 if (elx_count == 0)
813 { elx_line = el_gets(elx_e, &elx_count);
814 if (elx_count <= 0) return EOF;
815 if (elx_count > 1 || (elx_line[0] != '\n' && elx_line[0] != '\r'))
816 history(elx_h, &elx_v, H_ENTER, elx_line);
817 }
818 elx_count--;
819 return *elx_line++;
820 #endif
821 }
822
rdch()823 int rdch()
824 { LispObject w;
825 if (lispin == -1)
826 { if (!isCONS(work1)) return EOF;
827 w = qcar(work1);
828 work1 = qcdr(work1);
829 if (isSYMBOL(w)) w = qpname(w);
830 if (!isSTRING(w)) return EOF;
831 return *qstring(w);
832 }
833 else
834 { int c = my_getc(lispfiles[lispin]);
835 #ifdef DEBUG
836 if (c != EOF /*&& qvalue(echo) != nil*/) wrch(c);
837 #else // DEBUG
838 if (c != EOF && qvalue(echo) != nil) wrch(c);
839 #endif // DEBUG
840 return c;
841 }
842 }
843
844 int gensymcounter = 1;
845
checkspace(int n)846 void checkspace(int n)
847 { if (linepos + n >= linelength && lispout != -1) wrch('\n');
848 }
849
850 char printbuffer[32];
851
852 extern LispObject call1(const char *name, LispObject a1);
853 extern LispObject call2(const char *name, LispObject a1, LispObject a2);
854
internalprint(LispObject x)855 void internalprint(LispObject x)
856 { int sep = '(', i, esc, len;
857 char *s;
858 LispObject pn;
859 i = 0;
860 int some = 0;
861 switch (x & TAGBITS)
862 { case tagCONS:
863 if (x == 0) // can only occur in case of bugs here.
864 { wrch('#');
865 return;
866 }
867 while (isCONS(x))
868 { i = printflags;
869 if (qcar(x) == bignum &&
870 (pn = call1("~big2str", qcdr(x))) != NULLATOM &&
871 pn != nil)
872 { printflags = printPLAIN;
873 internalprint(pn);
874 printflags = i;
875 if (some == 0) return;
876 else break;
877 }
878 printflags = i;
879 checkspace(1);
880 if (linepos != 0 || sep != ' ' || lispout < 0) wrch(sep);
881 sep = ' ';
882 push(x);
883 internalprint(qcar(x));
884 pop(x);
885 some = 1;
886 x = qcdr(x);
887 }
888 if (x != nil)
889 { checkspace(3);
890 wrch(' '); wrch('.'); wrch(' ');
891 internalprint(x);
892 }
893 checkspace(1);
894 wrch(')');
895 return;
896 case tagSYMBOL:
897 pn = qpname(x);
898 if (pn == nil)
899 { int len = sprintf(printbuffer, "g%.3d", gensymcounter++);
900 push(x);
901 pn = makestring(printbuffer, len);
902 pop(x);
903 qpname(x) = pn;
904 }
905 len = veclength(qheader(pn));
906 s = qstring(pn);
907 if ((printflags & printESCAPES) == 0)
908 { int i;
909 checkspace(len);
910 for (i=0; i<len; i++) wrch(s[i]);
911 }
912 else if (len != 0)
913 { esc = 0;
914 if (!islower((int)s[0])) esc++;
915 for (i=1; i<len; i++)
916 { if (!islower((int)s[i]) &&
917 !isdigit((int)s[i]) &&
918 s[i]!='_') esc++;
919 }
920 checkspace(len + esc);
921 if (!islower((int)s[0])) wrch('!');
922 wrch(s[0]);
923 for (i=1; i<len; i++)
924 { if (!islower((int)s[i]) &&
925 !isdigit((int)s[i]) &&
926 s[i]!='_')
927 wrch('!');
928 wrch(s[i]);
929 }
930 }
931 return;
932 case tagATOM:
933 if (x == NULLATOM)
934 { checkspace(5);
935 wrch('#'); wrch('n'); wrch('u'); wrch('l'); wrch('l');
936 return;
937 }
938 else switch (qheader(x) & TYPEBITS)
939 { case typeSTRING:
940 len = veclength(qheader(x));
941 push(x);
942 #define RAWSTRING qstring(TOS)
943 if ((printflags & printESCAPES) == 0)
944 { int i;
945 checkspace(len);
946 for (i=0; i<len; i++) wrch(RAWSTRING[i]);
947 }
948 else
949 { esc = 2;
950 for (i=0; i<len; i++)
951 if (RAWSTRING[i] == '"') esc++;
952 checkspace(len+esc);
953 wrch('"');
954 for (i=0; i<len; i++)
955 { if (RAWSTRING[i] == '"') wrch('"');
956 wrch(RAWSTRING[i]);
957 }
958 wrch('"');
959 }
960 pop(x);
961 #undef RAWSTRING
962 return;
963 case typeBIGNUM:
964 sprintf(printbuffer, "%" PRId64, qint64(x));
965 checkspace(len = strlen(printbuffer));
966 for (i=0; i<len; i++) wrch(printbuffer[i]);
967 return;
968 case typeVEC:
969 i++;
970 case typeEQUALHASH:
971 i++;
972 case typeEQUALHASHX:
973 i++;
974 case typeEQHASH:
975 i++;
976 case typeEQHASHX:
977 switch (i)
978 {
979 // EQ hash table #h
980 // EQUALhash table #H
981 // ditto but in need of rehashing #g or 'G
982 case 0:
983 wrch('#'); wrch('g');
984 break;
985 case 1:
986 wrch('#'); wrch('h');
987 break;
988 case 2:
989 wrch('#'); wrch('G');
990 break;
991 case 3:
992 wrch('#'); wrch('H');
993 break;
994 case 4:
995 break;
996 }
997 sep = '[';
998 push(x);
999 for (i=0; i<veclength(qheader(TOS))/sizeof(LispObject); i++)
1000 { checkspace(1);
1001 wrch(sep);
1002 sep = ' ';
1003 internalprint(elt(TOS, i));
1004 }
1005 pop(x);
1006 checkspace(1);
1007 wrch(']');
1008 return;
1009 default:
1010 //case typeSYM:
1011 // also the spare codes!
1012 assert(0);
1013 }
1014 case tagFLOAT:
1015 { double d = *((double *)(x - tagFLOAT));
1016 if (isnan(d)) strcpy(printbuffer, "NaN");
1017 else if (isfinite(d)) sprintf(printbuffer, "%.14g", d);
1018 else strcpy(printbuffer, "inf");
1019 }
1020 s = printbuffer;
1021 // The C printing of floating point values is not to my taste, so I (slightly)
1022 // asjust the output here...
1023 if (*s == '+' || *s == '-') s++;
1024 while (isdigit((int)*s)) s++;
1025 if (*s == 0 || *s == 'e') // No decimal point present!
1026 { len = strlen(s);
1027 while (len >= 0) // Move existing text up 2 places
1028 { s[len+2] = s[len];
1029 len--;
1030 }
1031 s[0] = '.'; s[1] = '0'; // insert ".0"
1032 }
1033 checkspace(len = strlen(printbuffer));
1034 for (i=0; i<len; i++) wrch(printbuffer[i]);
1035 return;
1036 case tagFIXNUM:
1037 sprintf(printbuffer, "%" PRId64, (int64_t)qfixnum(x));
1038 checkspace(len = strlen(printbuffer));
1039 for (i=0; i<len; i++) wrch(printbuffer[i]);
1040 return;
1041 default:
1042 //case tagFORWARD:
1043 //case tagHDR:
1044 // sprintf(printbuffer, "??%#" PRIxPTR "??\n", x);
1045 // checkspace(len = strlen(printbuffer));
1046 // for (i=0; i<len; i++) wrch(printbuffer[i]);
1047 assert(0);
1048 }
1049 }
1050
prin(LispObject a)1051 LispObject prin(LispObject a)
1052 { printflags = printESCAPES;
1053 push(a);
1054 internalprint(a);
1055 pop(a);
1056 return a;
1057 }
1058
princ(LispObject a)1059 LispObject princ(LispObject a)
1060 { printflags = printPLAIN;
1061 push(a);
1062 internalprint(a);
1063 pop(a);
1064 return a;
1065 }
1066
prinhex(LispObject a)1067 LispObject prinhex(LispObject a)
1068 { printflags = printESCAPES | printHEX;
1069 push(a);
1070 internalprint(a);
1071 pop(a);
1072 return a;
1073 }
1074
print(LispObject a)1075 LispObject print(LispObject a)
1076 { printflags = printESCAPES;
1077 push(a);
1078 internalprint(a);
1079 pop(a);
1080 wrch('\n');
1081 return a;
1082 }
1083
errprint(LispObject a)1084 void errprint(LispObject a)
1085 { int saveout = lispout, saveflags = printflags;
1086 lispout = 1; printflags = printESCAPES;
1087 push(a);
1088 internalprint(a);
1089 pop(a);
1090 wrch('\n');
1091 lispout = saveout; printflags = saveflags;
1092 }
1093
errprin(LispObject a)1094 void errprin(LispObject a)
1095 { int saveout = lispout, saveflags = printflags;
1096 lispout = 1; printflags = printESCAPES;
1097 push(a);
1098 internalprint(a);
1099 pop(a);
1100 lispout = saveout; printflags = saveflags;
1101 }
1102
printc(LispObject a)1103 LispObject printc(LispObject a)
1104 { printflags = printPLAIN;
1105 push(a);
1106 internalprint(a);
1107 pop(a);
1108 wrch('\n');
1109 return a;
1110 }
1111
1112
hexval(int n)1113 int hexval(int n)
1114 { if (isdigit(n)) return n - '0';
1115 else if ('a' <= n && n <= 'f') return n - 'a' + 10;
1116 else if ('A' <= n && n <= 'F') return n - 'A' + 10;
1117 else return 0;
1118 }
1119
token()1120 LispObject token()
1121 { symtype = 'a'; // Default result is an atom.
1122 while (1)
1123 { while (curchar == ' ' ||
1124 curchar == '\t' ||
1125 curchar == '\n') curchar = rdch(); // Skip whitespace
1126 // Discard comments from "%" to end of line.
1127 if (curchar == '%')
1128 { while (curchar != '\n' &&
1129 curchar != EOF) curchar = rdch();
1130 continue;
1131 }
1132 break;
1133 }
1134 if (curchar == EOF)
1135 { symtype = curchar;
1136 return NULLATOM; // End of file marker.
1137 }
1138 if (curchar == '(' || curchar == '.' ||
1139 curchar == ')' || curchar == '\'' ||
1140 curchar == '`' || curchar == ',')
1141 { symtype = curchar; // Lisp special characters.
1142 curchar = rdch();
1143 if (symtype == ',' && curchar == '@')
1144 { symtype = '@';
1145 curchar = rdch();
1146 }
1147 return NULLATOM;
1148 }
1149 boffop = 0;
1150 if (isalpha(curchar) || curchar == '!') // Start a symbol.
1151 { while (isalpha(curchar) ||
1152 isdigit(curchar) ||
1153 curchar == '_' ||
1154 curchar == '!')
1155 { if (curchar == '!') curchar = rdch();
1156 else if (curchar != EOF && qvalue(lower) != nil) curchar = tolower(curchar);
1157 else if (curchar != EOF && qvalue(raise) != nil) curchar = toupper(curchar);
1158 if (curchar != EOF)
1159 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1160 curchar = rdch();
1161 }
1162 }
1163 boffo[boffop] = 0;
1164 return lookup(boffo, boffop, 1);
1165 }
1166 if (curchar == '"') // Start a string
1167 { curchar = rdch();
1168 while (1)
1169 { while (curchar != '"' && curchar != EOF)
1170 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1171 curchar = rdch();
1172 }
1173 // Note that a double-quote can be repeated within a string to denote
1174 // a string with that character within it. As in
1175 // "abc""def" is a string with contents abc"def.
1176 if (curchar != EOF) curchar = rdch();
1177 if (curchar != '"') break;
1178 if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1179 curchar = rdch();
1180 }
1181 return makestring(boffo, boffop);
1182 }
1183 if (curchar == '+' || curchar == '-')
1184 { boffo[boffop++] = curchar;
1185 curchar = rdch();
1186 // + and - are treated specially, since if followed by a digit they
1187 // introduce a (signed) number, but otherwise they are treated as punctuation.
1188 if (!isdigit(curchar))
1189 { boffo[boffop] = 0;
1190 return lookup(boffo, boffop, 1);
1191 }
1192 }
1193 // Note that in some cases after a + or - I drop through to here.
1194 if (curchar == '0' && boffop == 0) // "0" without a sign in front
1195 { boffo[boffop++] = curchar;
1196 curchar = rdch();
1197 if (curchar == 'x' || curchar == 'X') // Ahah - hexadecimal input
1198 { LispObject r;
1199 boffop = 0;
1200 curchar = rdch();
1201 while (isxdigit(curchar))
1202 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1203 curchar = rdch();
1204 }
1205 r = packfixnum(0);
1206 boffop = 0;
1207 while (boffo[boffop] != 0)
1208 { r = call2("plus2", call2("times2", packfixnum(16), r),
1209 packfixnum(hexval(boffo[boffop++])));
1210 }
1211 return r;
1212 }
1213 }
1214 if (isdigit(curchar) || (boffop == 1 && boffo[0] == '0'))
1215 { while (isdigit(curchar))
1216 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1217 curchar = rdch();
1218 }
1219 // At this point I have a (possibly signed) integer. If it is immediately
1220 // followed by a "." then a floating point value is indicated.
1221 if (curchar == '.')
1222 { symtype = 'f';
1223 if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1224 curchar = rdch();
1225 while (isdigit(curchar))
1226 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1227 curchar = rdch();
1228 }
1229 // To make things tidy If I have a "." not followed by any digits I will
1230 // insert a "0".
1231 if (!isdigit((int)boffo[boffop-1])) boffo[boffop++] = '0';
1232 }
1233 // Whether or not there was a ".", an "e" or "E" introduces an exponent and
1234 // hence indicates a floating point value.
1235 if (curchar == 'e' || curchar == 'E')
1236 { symtype = 'f';
1237 if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1238 curchar = rdch();
1239 if (curchar == '+' || curchar == '-')
1240 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1241 curchar = rdch();
1242 }
1243 while (isdigit(curchar))
1244 { if (boffop < BOFFO_SIZE) boffo[boffop++] = curchar;
1245 curchar = rdch();
1246 }
1247 // If there had been an "e" I force at least one digit in following it.
1248 if (!isdigit((int)boffo[boffop-1])) boffo[boffop++] = '0';
1249 }
1250 boffo[boffop] = 0;
1251 if (symtype == 'a')
1252 { int neg = 0;
1253 LispObject r = packfixnum(0);
1254 boffop = 0;
1255 if (boffo[boffop] == '+') boffop++;
1256 else if (boffo[boffop] == '-') neg=1, boffop++;
1257 while (boffo[boffop] != 0)
1258 { r = call2("plus2", call2("times2", packfixnum(10), r),
1259 packfixnum(boffo[boffop++] - '0'));
1260 }
1261 if (neg) r = call1("minus", r);
1262 return r;
1263 }
1264 else
1265 { double d;
1266 sscanf(boffo, "%lg", &d);
1267 return boxfloat(d);
1268 }
1269 }
1270 boffo[boffop++] = curchar;
1271 curchar = rdch();
1272 boffo[boffop] = 0;
1273 symtype = 'a';
1274 return lookup(boffo, boffop, 1);
1275 }
1276
1277 extern LispObject Lget(LispObject lits, int nargs, ...);
1278
char_function(LispObject a)1279 LispObject char_function(LispObject a)
1280 { if (!isSYMBOL(a)) return nil;
1281 LispObject pn = qpname(a);
1282 char *s = qstring(pn);
1283 if (strlen(s) == 1) return packfixnum(s[0]);
1284 return Lget(nil, 2, a, charvalue);
1285 }
1286
1287 // S ::= name
1288 // | integer
1289 // | radix#based-integer
1290 // | float
1291 // | string
1292 // | ' S | ` S | , S | ,@ S | ,. S
1293 // | #/ char integer code for char
1294 // | #\ char integer code is char is single character,
1295 // otherwise NULL, BELL, BACKSPACE, TAB, LF, EOL,
1296 // FF, CR, EOF, ESC, ESCAPE, SPACE, RUBOUT, RUB,
1297 // DELETE, DEL, (lower x), (control x), (ctrl x),
1298 // (meta x). *raise can case-fold x unless ! is used.
1299 // | #' S
1300 // | #. S
1301 // | #+ S S
1302 // | #- S S
1303 // | ( T
1304 // | [ V
1305 // ;
1306 //
1307 // T ::= )
1308 // | . S )
1309 // | S T
1310 // ;
1311 //
1312 // V ::= ]
1313 // | S V
1314 // ;
1315
1316 extern LispObject readS();
1317 extern LispObject readT();
1318 extern LispObject readV();
1319 extern LispObject eval(LispObject x);
1320
read_hash_macro()1321 LispObject read_hash_macro()
1322 { LispObject w;
1323 int c = curchar;
1324 curchar = rdch();
1325 switch (c)
1326 { case '\'': // #'X => (function X)
1327 cursym = token();
1328 w = readS();
1329 return list2star(function, w, nil);
1330 case '.':
1331 cursym = token();
1332 w = readS();
1333 return eval(w);
1334 case '+':
1335 cursym = token();
1336 w = readS();
1337 // For now I will suppose that the machine in use is NEVER one of the
1338 // ones tested fpr. The consequence is that "#+ machine S" always gets
1339 // ignored.
1340 (void)readS();
1341 return readS();
1342 case '-':
1343 cursym = token();
1344 w = readS();
1345 // To match the behaviour of #+ I just make "#- machine" get ignored so that
1346 // the S-expression beyond that is the one that is read.
1347 return readS();
1348 case '/':
1349 c = curchar;
1350 curchar = rdch();
1351 cursym = token();
1352 return packfixnum(c & 0xff);
1353 case '\\':
1354 cursym = token();
1355 w = readS();
1356 return char_function(w);
1357 default:
1358 return nil;
1359 }
1360 }
1361
list_to_vector(LispObject a)1362 LispObject list_to_vector(LispObject a)
1363 { int n = 0;
1364 for (LispObject p=a; p!=nil; p=qcdr(p)) n++;
1365 LispObject r = makevector(n-1);
1366 n = 0;
1367 for (LispObject p=a; p!=nil; p=qcdr(p)) elt(r, n++) = qcar(p);
1368 return r;
1369 }
1370
readS()1371 LispObject readS()
1372 { LispObject q, w;
1373 while (1)
1374 { switch (symtype)
1375 { case '?':
1376 cursym = token();
1377 continue;
1378 case '(':
1379 cursym = token();
1380 return readT();
1381 case '[':
1382 cursym = token();
1383 return list_to_vector(readV());
1384 case '#':
1385 return read_hash_macro();
1386 case '.':
1387 case ')': // Ignore spurious ")" input
1388 cursym = token();
1389 continue;
1390 case '\'':
1391 w = quote;
1392 break;
1393 case '`':
1394 w = backquote;
1395 break;
1396 case ',':
1397 w = comma;
1398 break;
1399 case '@':
1400 w = comma_at;
1401 break;
1402 case '.'+0x100:
1403 w = comma_dot;
1404 break;
1405 case EOF:
1406 return eofsym;
1407 default:
1408 symtype = '?';
1409 return cursym;
1410 }
1411 push(w);
1412 cursym = token();
1413 q = readS();
1414 pop(w);
1415 return list2star(w, q, nil);
1416 }
1417 }
1418
readT()1419 LispObject readT()
1420 { LispObject q, r;
1421 if (symtype == '?') cursym = token();
1422 switch (symtype)
1423 { case EOF:
1424 return eofsym;
1425 case '.':
1426 cursym = token();
1427 q = readS();
1428 if (symtype == '?') cursym = token();
1429 if (symtype == ')') symtype = '?'; // Ignore if not ")".
1430 return q;
1431 case ')':
1432 symtype = '?';
1433 return nil;
1434 // case '(': case '\'':
1435 // case '`': case ',':
1436 // case '@':
1437 default:
1438 q = readS();
1439 push(q);
1440 r = readT();
1441 pop(q);
1442 return cons(q, r);
1443 }
1444 }
1445
readV()1446 LispObject readV()
1447 { LispObject q, r;
1448 if (symtype == '?') cursym = token();
1449 switch (symtype)
1450 { case EOF:
1451 return eofsym;
1452 case ']':
1453 symtype = '?';
1454 return nil;
1455 default:
1456 q = readS();
1457 push(q);
1458 r = readV();
1459 pop(q);
1460 return cons(q, r);
1461 }
1462 }
1463
1464 // createp = -1 for remob
1465 // = 0 for lookup if exists, but do not create
1466 // = 1 for create symbol if necessary.
1467
lookup(const char * s,int len,int createp)1468 LispObject lookup(const char *s, int len, int createp)
1469 { LispObject w, pn;
1470 int i, hash = 1;
1471 for (i=0; i<len; i++) hash = 13*hash + s[i];
1472 hash = (hash & 0x7fffffff) % OBHASH_SIZE;
1473 LispObject *prev = &obhash[hash];
1474 w = *prev;
1475 while (w != tagFIXNUM)
1476 { LispObject a = qcar(w); // Will be a symbol.
1477 LispObject n = qpname(a); // Will be a string.
1478 int l = veclength(qheader(n)); // Length of the name.
1479 if (l == len &&
1480 strncmp(s, qstring(n), len) == 0)
1481 { if (createp == -1) *prev = qcdr(w);
1482 return a; // Existing symbol found.
1483 }
1484 prev = &qcdr(w);
1485 w = *prev;
1486 }
1487 // here the symbol as required was not already present.
1488 if (createp <= 0) return undefined;
1489 pn = makestring(s, len);
1490 push(pn);
1491 w = allocatesymbol();
1492 pop(pn);
1493 qflags(w) = tagHDR + typeSYM;
1494 qvalue(w) = undefined;
1495 qplist(w) = nil;
1496 qpname(w) = pn;
1497 qdefn(w) = NULL;
1498 qlits(w) = nil;
1499 push(w);
1500 obhash[hash] = cons(w, obhash[hash]);
1501 pop(w);
1502 return w;
1503 }
1504
1505 #define unwindNONE 0
1506 #define unwindERROR 1
1507 #define unwindBACKTRACE 2
1508 #define unwindGO 4
1509 #define unwindRETURN 8
1510 #define unwindPRESERVE 16
1511 #define unwindRESTART 32
1512
1513 int unwindflag = unwindNONE;
1514
1515 int backtraceflag = -1;
1516 #define backtraceHEADER 1
1517 #define backtraceTRACE 2
1518 int forcedMIN=0, forcedMAX=3;
1519
error1(const char * msg,LispObject data)1520 LispObject error1(const char *msg, LispObject data)
1521 { if ((backtraceflag & backtraceHEADER) != 0 || forcedMIN > 0)
1522 { linepos = printf("\n+++ Error: %s: ", msg);
1523 #ifdef DEBUG
1524 if (logfile != NULL) fprintf(logfile, "\n+++ Error: %s: ", msg);
1525 #endif // DEBUG
1526 errprint(data);
1527 }
1528 unwindflag = (backtraceflag & backtraceTRACE) != 0 ||
1529 forcedMIN > 1 ? unwindBACKTRACE :
1530 unwindERROR;
1531 return nil;
1532 }
1533
error2(const char * msg,LispObject data1,LispObject data2)1534 LispObject error2(const char *msg, LispObject data1, LispObject data2)
1535 { if ((backtraceflag & backtraceHEADER) != 0 || forcedMIN > 0)
1536 { linepos = printf("\n+++ Error: %s: ", msg);
1537 #ifdef DEBUG
1538 if (logfile != NULL) fprintf(logfile, "\n+++ Error: %s: ", msg);
1539 #endif // DEBUG
1540 errprint(data1);
1541 linepos += printf(" ");
1542 errprint(data2);
1543 }
1544 unwindflag = (backtraceflag & backtraceTRACE) != 0 ||
1545 forcedMIN > 1 ? unwindBACKTRACE : unwindERROR;
1546 return nil;
1547 }
1548
error1s(const char * msg,const char * data)1549 LispObject error1s(const char *msg, const char *data)
1550 { if ((backtraceflag & backtraceHEADER) != 0 || forcedMIN > 0)
1551 #ifdef DEBUG
1552 { printf("\n+++ Error: %s %s\n", msg, data);
1553 if (logfile != NULL) fprintf(logfile, "\n+++ Error: %s %s\n", msg, data);
1554 }
1555 #else // DEBUG
1556 printf("\n+++ Error: %s %s\n", msg, data);
1557 #endif // DEBUG
1558 unwindflag = (backtraceflag & backtraceTRACE) != 0 ||
1559 forcedMIN > 1 ? unwindBACKTRACE : unwindERROR;
1560 return nil;
1561 }
1562
applytostack(int n)1563 LispObject applytostack(int n)
1564 {
1565 // Apply a function to n arguments.
1566 // Here the stack has first the function, and then n arguments. The code is
1567 // grim and basically repetitive, and to avoid it being even worse I will
1568 // expect that almost all Lisp functions have at most 4 arguments, so
1569 // if there are more than that I will pass the fifth and beyond all in a list.
1570 LispObject f, w;
1571 int traced = (qflags(sp[-n-1]) & flagTRACED) != 0;
1572 if (traced)
1573 { int i;
1574 linepos = printf("Calling: ");
1575 #ifdef DEBUG
1576 if (logfile != NULL) fprintf(logfile, "Calling: ");
1577 #endif // DEBUG
1578 errprint(sp[-n-1]);
1579 for (i=1; i<=n; i++)
1580 { linepos = printf("Arg%d: ", i);
1581 #ifdef DEBUG
1582 if (logfile != NULL) fprintf(logfile, "Arg%d: ", i);
1583 #endif // DEBUG
1584 errprint(sp[i-n-1]);
1585 }
1586 }
1587 if (n >= 5)
1588 { push(nil);
1589 n++;
1590 while (n > 5)
1591 { pop(w);
1592 TOS = cons(TOS, w);
1593 n--;
1594 }
1595 }
1596 switch (n)
1597 { case 0:
1598 f = TOS;
1599 w = (*(LispFn *)qdefn(f))(qlits(f), 0);
1600 break;
1601 case 1:
1602 { LispObject a1;
1603 pop(a1);
1604 f = TOS;
1605 w = (*(LispFn *)qdefn(f))(qlits(f), 1, a1);
1606 break;
1607 }
1608 case 2:
1609 { LispObject a1, a2;
1610 pop(a2)
1611 pop(a1);
1612 f = TOS;
1613 w = (*(LispFn *)qdefn(f))(qlits(f), 2, a1, a2);
1614 break;
1615 }
1616 case 3:
1617 { LispObject a1, a2, a3;
1618 pop(a3);
1619 pop(a2)
1620 pop(a1);
1621 f = TOS;
1622 w = (*(LispFn *)qdefn(f))(qlits(f), 3, a1, a2, a3);
1623 break;
1624 }
1625 case 4:
1626 { LispObject a1, a2, a3, a4;
1627 pop(a4);
1628 pop(a3);
1629 pop(a2)
1630 pop(a1);
1631 f = TOS;
1632 w = (*(LispFn *)qdefn(f))(qlits(f), 4,
1633 a1, a2, a3, a4);
1634 break;
1635 }
1636 case 5:
1637 { LispObject a1, a2, a3, a4, a5andup;
1638 pop(a5andup);
1639 pop(a4);
1640 pop(a3);
1641 pop(a2)
1642 pop(a1);
1643 f = TOS;
1644 w = (*(LispFn *)qdefn(f))(qlits(f), 5,
1645 a1, a2, a3, a4, a5andup);
1646 break;
1647 }
1648 default:
1649 assert(0);
1650 return nil;
1651 }
1652 pop(f);
1653 if (unwindflag == unwindBACKTRACE)
1654 { linepos = printf("Calling: ");
1655 #ifdef DEBUG
1656 if (logfile != NULL) fprintf(logfile, "Calling: ");
1657 #endif // DEBUG
1658 errprint(f);
1659 }
1660 else if (traced)
1661 { push(w);
1662 prin(f);
1663 linepos += printf(" = ");
1664 #ifdef DEBUG
1665 if (logfile != NULL) fprintf(logfile, " = ");
1666 #endif // DEBUG
1667 errprint(w);
1668 pop(w);
1669 }
1670 return w;
1671 }
1672
call1(const char * name,LispObject a1)1673 LispObject call1(const char *name, LispObject a1)
1674 {
1675 LispObject fn = lookup(name, strlen(name), 0);
1676 if (fn == undefined || qdefn(fn) == NULL) return NULLATOM;
1677 push2(fn, a1);
1678 return applytostack(1);
1679 }
1680
call2(const char * name,LispObject a1,LispObject a2)1681 LispObject call2(const char *name, LispObject a1, LispObject a2)
1682 {
1683 LispObject fn = lookup(name, strlen(name), 0);
1684 if (fn == undefined || qdefn(fn) == NULL) return NULLATOM;
1685 push3(fn, a1, a2);
1686 return applytostack(2);
1687 }
1688
1689 LispObject interpret(LispObject def, int nargs, ...);
1690 LispObject Lgensym(LispObject lits, int nargs, ...);
1691
eval(LispObject x)1692 LispObject eval(LispObject x)
1693 { while (isCONS(x) && isSYMBOL(qcar(x)) && (qflags(qcar(x)) & flagMACRO))
1694 { push2(qcar(x), x);
1695 x = applytostack(1); // Macroexpand before anything else.
1696 if (unwindflag != unwindNONE) return nil;
1697 }
1698 if (isSYMBOL(x))
1699 { LispObject v = qvalue(x);
1700 if (v == undefined) return error1("undefined variable", x);
1701 else return v;
1702 }
1703 else if (!isCONS(x)) return x;
1704 // Now I have something of the form
1705 // (f arg1 ... argn)
1706 // to process.
1707 { LispObject f = qcar(x);
1708 if (isSYMBOL(f))
1709 { LispObject flags = qflags(f), aa, av;
1710 int i, n = 0;
1711 if (flags & flagSPECFORM)
1712 { SpecialForm *fn = (SpecialForm *)qdefn(f);
1713 return (*fn)(qlits(f), qcdr(x));
1714 }
1715 // ... else not a special form...
1716 if (qdefn(f) == NULL) return error1("undefined function", f);
1717 aa = qcdr(x);
1718 while (isCONS(aa))
1719 { n++; // Count number of args supplied.
1720 aa = qcdr(aa);
1721 }
1722 aa = qcdr(x);
1723 push(f);
1724 // Here I will evaluate all the arguments for the function, leaving the
1725 // evaluated results on the stack.
1726 for (i=0; i<n; i++)
1727 { push(aa);
1728 av = eval(qcar(aa));
1729 if (unwindflag != unwindNONE)
1730 { while (i != 0) // Restore the stack if unwinding.
1731 { pop(aa);
1732 i--;
1733 }
1734 pop2(aa, aa);
1735 return nil;
1736 }
1737 aa = qcdr(TOS);
1738 TOS = av;
1739 }
1740 return applytostack(n);
1741 }
1742 else if (isCONS(f) && qcar(f) == lambda)
1743 { LispObject w;
1744 push(x);
1745 w = Lgensym(nil, 0);
1746 pop(x);
1747 qdefn(w) = (void *)interpret;
1748 qlits(w) = qcdr(qcar(x));
1749 return eval(cons(w, qcdr(x)));
1750 }
1751 else return error1("invalid function", f);
1752 }
1753 }
1754
1755 LispObject Lprogn(LispObject lits, LispObject x);
1756
1757 // The next array is used to help with error recovery, and it does
1758 // not need to be protected by the garbage collector.
1759 #define MAX_ARGS 50
1760 LispObject pushedvars[MAX_ARGS];
1761
nreverse(LispObject a)1762 LispObject nreverse(LispObject a)
1763 { LispObject b = nil, w;
1764 while (isCONS(a))
1765 { w = qcdr(a);
1766 qcdr(a) = b;
1767 b = a;
1768 a = w;
1769 }
1770 return b;
1771 }
1772
interpret(LispObject def,int nargs,...)1773 LispObject interpret(LispObject def, int nargs, ...)
1774 {
1775 // def should be ((a1 a2 ...) e1 e2 ...)
1776 // where the number of args a1 ... should the same as nargs. Use
1777 // "shallow binding" to cope with the need for a1 ... to have some
1778 // sort of local scope.
1779 va_list aa;
1780 int i, npushed;
1781 LispObject arglist, body, w, r = nil;
1782 if (!isCONS(def)) return error1("bad definition", def);
1783 va_start(aa, nargs);
1784 w = arglist = qcar(def);
1785 body = qcdr(def);
1786 npushed = 0;
1787 for (i=0; i<nargs && i<4; i++)
1788 { LispObject var;
1789 if (!isCONS(w) || !isSYMBOL(var = qcar(w)))
1790 { while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
1791 va_end(aa);
1792 return error1("excess arguments or invalid variable-name", w);
1793 }
1794 push(qvalue(var));
1795 pushedvars[npushed++] = var;
1796 qvalue(var) = va_arg(aa, LispObject);
1797 w = qcdr(w);
1798 }
1799 // To make life easier in "eval" where I call functions I will pass up to
1800 // 4 arguments "naturally", but any beyond that will all be collected as
1801 // a list. So if nargs==5 then arg5 actually represents a list of the form
1802 // (arg5 arg6 ...).
1803 if (nargs == 5)
1804 { r = va_arg(aa, LispObject);
1805 while (isCONS(w) && isCONS(r))
1806 { LispObject var = qcar(w);
1807 if (!isSYMBOL(var))
1808 { while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
1809 va_end(aa);
1810 return error1("invalid variable-name", var);
1811 }
1812 push(qvalue(var));
1813 pushedvars[npushed++] = var;
1814 qvalue(var) = qcar(r);
1815 w = qcdr(w);
1816 r = qcdr(r);
1817 }
1818 }
1819 va_end(aa);
1820 if (isCONS(w) || isCONS(r))
1821 { while (npushed != 0) pop(qvalue(pushedvars[--npushed]));
1822 return error2("wrong number of args", r, w);
1823 }
1824 push(arglist);
1825 r = Lprogn(nil, body);
1826 pop(arglist);
1827 // Now I must restore the bound variables (regardless of whether there
1828 // has been an error).
1829 w = nreverse(arglist);
1830 arglist = nil;
1831 while (isCONS(w))
1832 { LispObject x = w;
1833 w = qcdr(w);
1834 qcdr(x) = arglist;
1835 arglist = x;
1836 pop(qvalue(qcar(arglist)));
1837 }
1838 return r;
1839 }
1840
interpretspecform(LispObject lits,LispObject x)1841 LispObject interpretspecform(LispObject lits, LispObject x)
1842 { // lits should be ((var) body...)
1843 LispObject v, v_value;
1844 if (!isCONS(lits)) return nil;
1845 v = qcar(lits);
1846 lits = qcdr(lits);
1847 if (!isCONS(v) || !isSYMBOL(v = qcar(v))) return nil;
1848 v_value = qvalue(v);
1849 qvalue(v) = x;
1850 push2(v, v_value);
1851 lits = Lprogn(nil, lits);
1852 pop2(v_value, v);
1853 qvalue(v) = v_value;
1854 return lits;
1855 }
1856
1857 // Special forms are things that do not have their arguments pre-evaluated.
1858
Lquote(LispObject lits,LispObject x)1859 LispObject Lquote(LispObject lits, LispObject x)
1860 { if (isCONS(x)) return qcar(x);
1861 else return nil;
1862 }
1863
Lcond(LispObject lits,LispObject x)1864 LispObject Lcond(LispObject lits, LispObject x)
1865 {
1866 // Arg is in form
1867 // ((predicate1 val1a val1b ...)
1868 // (predicate2 val2a val2b ...)
1869 // ...)
1870 while (isCONS(x))
1871 { push(x);
1872 x = qcar(x);
1873 if (isCONS(x))
1874 { LispObject p = eval(qcar(x));
1875 if (unwindflag != unwindNONE)
1876 { pop(x);
1877 return nil;
1878 }
1879 else if (p != nil)
1880 { pop(x);
1881 return Lprogn(nil, qcdr(qcar(x)));
1882 }
1883 }
1884 pop(x);
1885 x = qcdr(x);
1886 }
1887 return nil;
1888 }
1889
Land(LispObject lits,LispObject x)1890 LispObject Land(LispObject lits, LispObject x)
1891 { LispObject r = lisptrue;
1892 while (isCONS(x))
1893 { push(x);
1894 r = eval(qcar(x));
1895 pop(x);
1896 if (r == nil || unwindflag != unwindNONE) return nil;
1897 x = qcdr(x);
1898 }
1899 return r;
1900 }
1901
Lor(LispObject lits,LispObject x)1902 LispObject Lor(LispObject lits, LispObject x)
1903 { while (isCONS(x))
1904 { LispObject r;
1905 push(x);
1906 r = eval(qcar(x));
1907 pop(x);
1908 if (r != nil || unwindflag != unwindNONE) return r;
1909 x = qcdr(x);
1910 }
1911 return nil;
1912 }
1913
1914 // A list of lambda-variables should be a properly nil-terminated list
1915 // of symbols, not including keywords or anyting declared global.
1916
allsymbols(LispObject bvl)1917 int allsymbols(LispObject bvl)
1918 {
1919 while (isCONS(bvl))
1920 { if (!isSYMBOL(qcar(bvl)) ||
1921 (qflags(qcar(bvl)) & flagGLOBAL) != 0) return 0;
1922 bvl = qcdr(bvl);
1923 }
1924 return (bvl == nil);
1925 }
1926
definer(LispObject x,int flags,void * fn)1927 LispObject definer(LispObject x, int flags, void *fn)
1928 {
1929 // x should be of the form
1930 // (name (arg list ...) body)
1931 //
1932 // I check for a LOSE flag to give me a way of
1933 // ignoring definitions that I do not like.
1934 LispObject name, def;
1935 if (!isCONS(x) ||
1936 !isSYMBOL(name = qcar(x)) ||
1937 !isCONS(def = qcdr(x)))
1938 return error1("malformed use of de, df or dm", x);
1939 // For the moment I prohibit redefinition of special forms...
1940 if ((qflags(name) & flagSPECFORM) != 0)
1941 return error1("attempt to redefine special form", name);
1942 if (Lget(nil, 2, name, loseflag) != nil)
1943 { printf("\n+++ LOSE flag on function, so definition ignored: ");
1944 errprint(name);
1945 return name;
1946 }
1947 // Now I will <1>try to call macroexpand_list to expand all macros.
1948 x = lookup("macroexpand_list", 16, 0);
1949 if (x != undefined && qdefn(x) != NULL)
1950 { push2(name, def);
1951 push2(x, qcdr(def));
1952 x = applytostack(1);
1953 pop2(def, name);
1954 if (unwindflag != unwindNONE) return name;
1955 qlits(name) = cons(qcar(def), x);
1956 }
1957 else qlits(name) = def;
1958 qflags(name) = (qflags(name) & ~(flagSPECFORM|flagMACRO)) | flags;
1959 qdefn(name) = fn;
1960 return name;
1961 }
1962
Lde(LispObject lits,LispObject x)1963 LispObject Lde(LispObject lits, LispObject x)
1964 { return definer(x, 0, (void *)interpret);
1965 }
1966
Ldf(LispObject lits,LispObject x)1967 LispObject Ldf(LispObject lits, LispObject x)
1968 { return definer(x, flagSPECFORM, (void *)interpretspecform);
1969 }
1970
Ldm(LispObject lits,LispObject x)1971 LispObject Ldm(LispObject lits, LispObject x)
1972 { return definer(x, flagMACRO, (void *)interpret);
1973 }
1974
Lsetq(LispObject lits,LispObject x)1975 LispObject Lsetq(LispObject lits, LispObject x)
1976 { // (setq var1 val1 var2 val2 ...)
1977 LispObject w = nil;
1978 while (isCONS(x) && isCONS(qcdr(x)))
1979 { if (!isSYMBOL(w=qcar(x)) ||
1980 w == nil || w == lisptrue)
1981 return error1("bad variable in setq", x);
1982 push(x);
1983 w = eval(qcar(qcdr(x)));
1984 pop(x);
1985 if (unwindflag != unwindNONE) return nil;
1986 qvalue(qcar(x)) = w;
1987 x = qcdr(qcdr(x));
1988 }
1989 return w;
1990 }
1991
Lprogn(LispObject lits,LispObject x)1992 LispObject Lprogn(LispObject lits, LispObject x)
1993 { LispObject r = nil;
1994 while (isCONS(x))
1995 { push(x);
1996 r = eval(qcar(x));
1997 pop(x);
1998 x = qcdr(x);
1999 if (unwindflag != unwindNONE) return nil;
2000 }
2001 return r;
2002 }
2003
2004 // I want to police a constraint that GO and RETURN are only used in
2005 // "prog context". The following limited number of forms are relevant to
2006 // this:
2007 // COND
2008 // PROGN
2009 // GO
2010 // RETURN
2011 // and (at least for now) I am not going to allow other conditionals, macros
2012 // or anything else to be transparent to it.
2013
2014 static LispObject eval_prog_context(LispObject x);
2015
progprogn(LispObject x)2016 LispObject progprogn(LispObject x)
2017 { LispObject r = nil;
2018 while (isCONS(x))
2019 { push(x);
2020 r = eval_prog_context(qcar(x));
2021 pop(x);
2022 x = qcdr(x);
2023 if (unwindflag != unwindNONE) return nil;
2024 }
2025 return r;
2026 }
2027
progcond(LispObject x)2028 LispObject progcond(LispObject x)
2029 {
2030 while (isCONS(x))
2031 { push(x);
2032 x = qcar(x);
2033 if (isCONS(x))
2034 { LispObject p = eval(qcar(x));
2035 if (unwindflag != unwindNONE)
2036 { pop(x);
2037 return nil;
2038 }
2039 else if (p != nil)
2040 { pop(x);
2041 return progprogn(qcdr(qcar(x)));
2042 }
2043 }
2044 pop(x);
2045 x = qcdr(x);
2046 }
2047 return nil;
2048 }
2049
proggo(LispObject x)2050 LispObject proggo(LispObject x)
2051 { if (!isCONS(x) || !isSYMBOL(work1 = qcar(x)))
2052 return error1("bad go", x);
2053 work1 = qcar(x);
2054 unwindflag = unwindGO;
2055 return nil;
2056 }
2057
progreturn(LispObject args)2058 LispObject progreturn(LispObject args)
2059 { if (!isCONS(args) || isCONS(qcdr(args)))
2060 return error1("RETURN need just 1 argument", args);
2061 args = eval(qcar(args));
2062 if (unwindflag != unwindNONE) return nil;
2063 work1 = args;
2064 unwindflag = unwindRETURN;
2065 return nil;
2066 }
2067
eval_prog_context(LispObject x)2068 static LispObject eval_prog_context(LispObject x)
2069 { if (!isCONS(x)) return eval(x);
2070 else if (qcar(x) == condsymbol) return progcond(qcdr(x));
2071 else if (qcar(x) == prognsymbol) return progprogn(qcdr(x));
2072 else if (qcar(x) == gosymbol) return proggo(qcdr(x));
2073 else if (qcar(x) == returnsymbol) return progreturn(qcdr(x));
2074 else return eval(x);
2075 }
2076
Lprog(LispObject lits,LispObject x)2077 LispObject Lprog(LispObject lits, LispObject x)
2078 {
2079 LispObject w, vars;
2080 if (!isCONS(x)) return nil;
2081 vars = qcar(x);
2082 x = qcdr(x);
2083 w = vars;
2084 // Now bind all the local variables, giving them the value nil.
2085 while (isCONS(w))
2086 { LispObject v = qcar(w);
2087 w = qcdr(w);
2088 if (isSYMBOL(v))
2089 { push(qvalue(v));
2090 qvalue(v) = nil;
2091 }
2092 }
2093 push(vars); // So that I know what to unbind at the end.
2094 push(x); // So that "go" can scan the whole block to find a label.
2095 work1 = nil;
2096 while (isCONS(x))
2097 { push(x);
2098 if (isCONS(qcar(x))) eval_prog_context(qcar(x));
2099 pop(x);
2100 x = qcdr(x);
2101 if (unwindflag == unwindRETURN)
2102 { unwindflag = unwindNONE;
2103 break;
2104 }
2105 else if (unwindflag == unwindGO)
2106 { unwindflag = unwindNONE;
2107 x = TOS;
2108 while (isCONS(x) && qcar(x) != work1) x = qcdr(x);
2109 continue;
2110 }
2111 if (unwindflag != unwindNONE) break;
2112 work1 = nil;
2113 }
2114 // Now I must unbind all the variables.
2115 pop(x);
2116 pop(vars);
2117 w = nreverse(vars);
2118 vars = nil;
2119 while (isCONS(w))
2120 { LispObject x = w;
2121 w = qcdr(w);
2122 qcdr(x) = vars;
2123 vars = x;
2124 x = qcar(vars);
2125 if (isSYMBOL(x)) pop(qvalue(x));
2126 }
2127 return work1;
2128 }
2129
Lgo(LispObject lits,LispObject x)2130 LispObject Lgo(LispObject lits, LispObject x)
2131 { return error1("GO not in PROG context", x);
2132 // if (!isCONS(x) || !isSYMBOL(work1 = qcar(x)))
2133 // return error1("bad go", x);
2134 // work1 = qcar(x);
2135 // unwindflag = unwindGO;
2136 // return nil;
2137 }
2138
2139 #define NARY(x, base, combinefn) \
2140 LispObject r; \
2141 if (!isCONS(x)) return base; \
2142 push(x); \
2143 r = eval(qcar(x)); \
2144 pop(x); \
2145 if (unwindflag != unwindNONE) \
2146 return nil; \
2147 x = qcdr(x); \
2148 while (isCONS(x)) \
2149 { LispObject a; \
2150 push2(x, r); \
2151 a = eval(qcar(x)); \
2152 pop(r); \
2153 if (unwindflag != unwindNONE) \
2154 { pop(x); \
2155 return nil; \
2156 } \
2157 r = combinefn(r, a); \
2158 pop(x); \
2159 x = qcdr(x); \
2160 } \
2161 return r
2162
Lplus(LispObject lits,LispObject x)2163 LispObject Lplus(LispObject lits, LispObject x)
2164 { NARY(x, packfixnum(0), Nplus2);
2165 }
2166
Ltimes(LispObject lits,LispObject x)2167 LispObject Ltimes(LispObject lits, LispObject x)
2168 { NARY(x, packfixnum(1), Ntimes2);
2169 }
2170
Llogand(LispObject lits,LispObject x)2171 LispObject Llogand(LispObject lits, LispObject x)
2172 { NARY(x, packfixnum(-1), Nlogand2);
2173 }
2174
Llogor(LispObject lits,LispObject x)2175 LispObject Llogor(LispObject lits, LispObject x)
2176 { NARY(x, packfixnum(0), Nlogor2);
2177 }
2178
Llogxor(LispObject lits,LispObject x)2179 LispObject Llogxor(LispObject lits, LispObject x)
2180 { NARY(x, packfixnum(0), Nlogxor2);
2181 }
2182
Llist(LispObject lits,LispObject x)2183 LispObject Llist(LispObject lits, LispObject x)
2184 { int n = 0;
2185 LispObject r;
2186 while (isCONS(x))
2187 { push(x);
2188 r = eval(qcar(x));
2189 if (unwindflag != unwindNONE)
2190 { while (n != 0)
2191 { pop(x);
2192 n--;
2193 }
2194 pop(x);
2195 return nil;
2196 }
2197 x = qcdr(TOS);
2198 TOS = r;
2199 n++;
2200 }
2201 r = nil;
2202 while (n > 0)
2203 { pop(x);
2204 r = cons(x, r);
2205 n--;
2206 }
2207 return r;
2208 }
2209
Lliststar(LispObject lits,LispObject x)2210 LispObject Lliststar(LispObject lits, LispObject x)
2211 { int n = 0;
2212 LispObject r;
2213 while (isCONS(x))
2214 { push(x);
2215 r = eval(qcar(x));
2216 if (unwindflag != unwindNONE)
2217 { while (n != 0)
2218 { pop(x);
2219 n--;
2220 }
2221 pop(x);
2222 return nil;
2223 }
2224 x = qcdr(TOS);
2225 TOS = r;
2226 n++;
2227 }
2228 if (n == 0) return nil;
2229 pop(r);
2230 n--;
2231 while (n > 0)
2232 { pop(x);
2233 r = cons(x, r);
2234 n--;
2235 }
2236 return r;
2237 }
2238
2239 // The way that arguments are passed to functions is a little
2240 // ugly, and uses the C facility for calling functions with variable
2241 // numbers of arguments. To shorten the code I put much of the mess into
2242 // macros
2243
2244 #define ARG0(name) \
2245 if (nargs != 0) return error1s("wrong number of arguments for", name)
2246
2247 #define ARG1(name, x) \
2248 va_list a; \
2249 LispObject x; \
2250 if (nargs != 1) return error1s("wrong number of arguments for", name); \
2251 va_start(a, nargs); \
2252 x = va_arg(a, LispObject); \
2253 va_end(a)
2254
2255 #define ARG2(name, x, y) \
2256 va_list a; \
2257 LispObject x, y; \
2258 if (nargs != 2) return error1s("wrong number of arguments for", name); \
2259 va_start(a, nargs); \
2260 x = va_arg(a, LispObject); \
2261 y = va_arg(a, LispObject); \
2262 va_end(a)
2263
2264 #define ARG3(name, x, y, z) \
2265 va_list a; \
2266 LispObject x, y, z; \
2267 if (nargs != 3) return error1s("wrong number of arguments for", name); \
2268 va_start(a, nargs); \
2269 x = va_arg(a, LispObject); \
2270 y = va_arg(a, LispObject); \
2271 z = va_arg(a, LispObject); \
2272 va_end(a)
2273
2274 #define ARG0123(name, x, y, z) \
2275 va_list a; \
2276 LispObject x=NULLATOM, y=NULLATOM, z=NULLATOM; \
2277 if (nargs > 3) return error1s("wrong number of arguments for", name); \
2278 va_start(a, nargs); \
2279 if (nargs > 0) x = va_arg(a, LispObject); \
2280 if (nargs > 1) y = va_arg(a, LispObject); \
2281 if (nargs > 2) z = va_arg(a, LispObject); \
2282 va_end(a)
2283
Lcar(LispObject lits,int nargs,...)2284 LispObject Lcar(LispObject lits, int nargs, ...)
2285 { ARG1("car", x); // Note that this WILL take car of a bignum!
2286 if (isCONS(x)) return qcar(x);
2287 else return error1("car of an atom", x);
2288 }
2289
Lcdr(LispObject lits,int nargs,...)2290 LispObject Lcdr(LispObject lits, int nargs, ...)
2291 { ARG1("cdr", x);
2292 if (isCONS(x)) return qcdr(x);
2293 else return error1("cdr of an atom", x);
2294 }
2295
Lrplaca(LispObject lits,int nargs,...)2296 LispObject Lrplaca(LispObject lits, int nargs, ...)
2297 { ARG2("rplaca", x, y);
2298 if (isCONS(x))
2299 { qcar(x) = y;
2300 return x;
2301 }
2302 else return error1("rplaca on an atom", x);
2303 }
2304
Lrplacd(LispObject lits,int nargs,...)2305 LispObject Lrplacd(LispObject lits, int nargs, ...)
2306 { ARG2("rplacd", x, y);
2307 if (isCONS(x))
2308 { qcdr(x) = y;
2309 return x;
2310 }
2311 else return error1("rplaca on an atom", x);
2312 }
2313
Lreclaim(LispObject lits,int nargs,...)2314 LispObject Lreclaim(LispObject lits, int nargs, ...)
2315 { ARG0("reclaim");
2316 reclaim();
2317 return nil;
2318 }
2319
Lcons(LispObject lits,int nargs,...)2320 LispObject Lcons(LispObject lits, int nargs, ...)
2321 { ARG2("cons", x, y);
2322 return cons(x, y);
2323 }
2324
Latom(LispObject lits,int nargs,...)2325 LispObject Latom(LispObject lits, int nargs, ...)
2326 { ARG1("atom", x); // Observe treatment of bignums!
2327 return (isCONS(x) && qcar(x) != bignum ? nil : lisptrue);
2328 }
2329
Lbignump(LispObject lits,int nargs,...)2330 LispObject Lbignump(LispObject lits, int nargs, ...)
2331 { ARG1("bignump", x);
2332 return (isCONS(x) && qcar(x) == bignum ? lisptrue : nil);
2333 }
2334
Lsymbolp(LispObject lits,int nargs,...)2335 LispObject Lsymbolp(LispObject lits, int nargs, ...)
2336 { ARG1("symbolp", x);
2337 return (isSYMBOL(x) ? lisptrue : nil);
2338 }
2339
Lstringp(LispObject lits,int nargs,...)2340 LispObject Lstringp(LispObject lits, int nargs, ...)
2341 { ARG1("stringp", x);
2342 return (isSTRING(x) ? lisptrue : nil);
2343 }
2344
Lvectorp(LispObject lits,int nargs,...)2345 LispObject Lvectorp(LispObject lits, int nargs, ...)
2346 { ARG1("vectorp", x);
2347 return (isVEC(x) ? lisptrue : nil);
2348 }
2349
Lprog1(LispObject lits,int nargs,...)2350 LispObject Lprog1(LispObject lits, int nargs, ...)
2351 { ARG2("prog1", x, y);
2352 y = y;
2353 return x;
2354 }
2355
Lprog2(LispObject lits,int nargs,...)2356 LispObject Lprog2(LispObject lits, int nargs, ...)
2357 { ARG2("prog2", x, y);
2358 x = x;
2359 return y;
2360 }
2361
Lnumberp(LispObject lits,int nargs,...)2362 LispObject Lnumberp(LispObject lits, int nargs, ...)
2363 { ARG1("numberp", x);
2364 return (isFIXNUM(x) || isBIGNUM(x) || isFLOAT(x) ? lisptrue : nil);
2365 }
2366
Lfixp(LispObject lits,int nargs,...)2367 LispObject Lfixp(LispObject lits, int nargs, ...)
2368 { ARG1("fixp", x);
2369 return (isFIXNUM(x) || isBIGNUM(x) ? lisptrue : nil);
2370 }
2371
Lfloatp(LispObject lits,int nargs,...)2372 LispObject Lfloatp(LispObject lits, int nargs, ...)
2373 { ARG1("floatp", x);
2374 return (isFLOAT(x) ? lisptrue : nil);
2375 }
2376
Lfix(LispObject lits,int nargs,...)2377 LispObject Lfix(LispObject lits, int nargs, ...)
2378 { ARG1("fix", x);
2379 return (isFIXNUM(x) || isBIGNUM(x) ? x :
2380 isFLOAT(x) ? boxint64((int64_t)qfloat(x)) :
2381 error1("arg for fix", x));
2382 }
2383
Lfloor(LispObject lits,int nargs,...)2384 LispObject Lfloor(LispObject lits, int nargs, ...)
2385 { ARG1("floor", x);
2386 return (isFIXNUM(x) || isBIGNUM(x) ? x :
2387 isFLOAT(x) ? boxint64((int64_t)floor(qfloat(x))) :
2388 error1("arg for floor", x));
2389 }
2390
Lceiling(LispObject lits,int nargs,...)2391 LispObject Lceiling(LispObject lits, int nargs, ...)
2392 { ARG1("ceiling", x);
2393 return (isFIXNUM(x) || isBIGNUM(x) ? x :
2394 isFLOAT(x) ? boxint64((int64_t)ceil(qfloat(x))) :
2395 error1("arg for ceiling", x));
2396 }
2397
Lfloat(LispObject lits,int nargs,...)2398 LispObject Lfloat(LispObject lits, int nargs, ...)
2399 { ARG1("float", x);
2400 return (isFLOAT(x) ? x :
2401 isFIXNUM(x) ? boxfloat((double)qfixnum(x)) :
2402 isBIGNUM(x) ? boxfloat((double)qint64(x)) :
2403 error1("arg for float", x));
2404 }
2405
2406 #define floatval(x) \
2407 isFLOAT(x) ? qfloat(x) : \
2408 isFIXNUM(x) ? (double)qfixnum(x) : \
2409 isBIGNUM(x) ? (double)qint64(x) : \
2410 0.0
2411
Lcos(LispObject lits,int nargs,...)2412 LispObject Lcos(LispObject lits, int nargs, ...)
2413 { ARG1("cos", x);
2414 return boxfloat(cos(floatval(x)));
2415 }
2416
Lsin(LispObject lits,int nargs,...)2417 LispObject Lsin(LispObject lits, int nargs, ...)
2418 { ARG1("sin", x);
2419 return boxfloat(sin(floatval(x)));
2420 }
2421
Lsqrt(LispObject lits,int nargs,...)2422 LispObject Lsqrt(LispObject lits, int nargs, ...)
2423 { ARG1("sqrt", x);
2424 return boxfloat(sqrt(floatval(x)));
2425 }
2426
Llog(LispObject lits,int nargs,...)2427 LispObject Llog(LispObject lits, int nargs, ...)
2428 { ARG1("log", x);
2429 return boxfloat(log(floatval(x)));
2430 }
2431
Lexp(LispObject lits,int nargs,...)2432 LispObject Lexp(LispObject lits, int nargs, ...)
2433 { ARG1("exp", x);
2434 return boxfloat(exp(floatval(x)));
2435 }
2436
Latan(LispObject lits,int nargs,...)2437 LispObject Latan(LispObject lits, int nargs, ...)
2438 { ARG1("atan", x);
2439 return boxfloat(atan(floatval(x)));
2440 }
2441
Lnull(LispObject lits,int nargs,...)2442 LispObject Lnull(LispObject lits, int nargs, ...)
2443 { ARG1("null", x);
2444 return (x == nil ? lisptrue : nil);
2445 }
2446
Leq(LispObject lits,int nargs,...)2447 LispObject Leq(LispObject lits, int nargs, ...)
2448 { ARG2("eq", x, y);
2449 return (x == y ? lisptrue : nil);
2450 }
2451
Lequal(LispObject lits,int nargs,...)2452 LispObject Lequal(LispObject lits, int nargs, ...)
2453 { ARG2("equal", x, y);
2454 while (x != y && isCONS(x) && isCONS(y))
2455 { if (Lequal(lits, 2, qcar(x), qcar(y)) == nil) return nil;
2456 x = qcdr(x); y = qcdr(y);
2457 }
2458 if (x == y) return lisptrue;
2459 if ((x & TAGBITS) != (y & TAGBITS)) return nil;
2460 if (isSYMBOL(x) || isFIXNUM(x)) return nil;
2461 if (isFLOAT(x)) return (qfloat(x) == qfloat(y) ? lisptrue : nil);
2462 if (qheader(x) != qheader(y)) return nil;
2463 switch (qheader(x) & TYPEBITS)
2464 { case typeVEC: case typeEQHASH: case typeEQHASHX:
2465 case typeEQUALHASH: case typeEQUALHASHX:
2466 { int i;
2467 for (i=0; i<veclength(qheader(x))/sizeof(LispObject); i++)
2468 if (Lequal(lits, 2, elt(x, i), elt(y, i)) == nil) return nil;
2469 return lisptrue;
2470 }
2471 default: // Treat all other cases as containing binary information.
2472 { int i;
2473 const char *xx = qstring(x), *yy = qstring(y);
2474 for (i=0; i<veclength(qheader(x)); i++)
2475 if (xx[i] != yy[i]) return nil;
2476 return lisptrue;
2477 }
2478 }
2479 }
2480
Lset(LispObject lits,int nargs,...)2481 LispObject Lset(LispObject lits, int nargs, ...)
2482 { ARG2("set", x, y);
2483 if (!isSYMBOL(x)) return error1("bad arg for set", x);
2484 return (qvalue(x) = y);
2485 }
2486
Lboundp(LispObject lits,int nargs,...)2487 LispObject Lboundp(LispObject lits, int nargs, ...)
2488 { ARG1("boundp", x);
2489 return (isSYMBOL(x) && qvalue(x)!=undefined) ? lisptrue : nil;
2490 }
2491
Lmakeunbound(LispObject lits,int nargs,...)2492 LispObject Lmakeunbound(LispObject lits, int nargs, ...)
2493 { ARG1("makeunbound", x);
2494 if (isSYMBOL(x)) qvalue(x) = undefined;
2495 return nil;
2496 }
2497
Lgensym(LispObject lits,int nargs,...)2498 LispObject Lgensym(LispObject lits, int nargs, ...)
2499 { LispObject r;
2500 ARG0("gensym");
2501 r = allocatesymbol();
2502 qflags(r) = tagHDR + typeGENSYM;
2503 qvalue(r) = undefined;
2504 qplist(r) = nil;
2505 qpname(r) = nil; // A nil pname marks this as a not-yet-printed gensym.
2506 qdefn(r) = NULL;
2507 qlits(r) = nil;
2508 return r;
2509 }
2510
Lgensymp(LispObject lits,int nargs,...)2511 LispObject Lgensymp(LispObject lits, int nargs, ...)
2512 { ARG1("gensymp", x);
2513 if (!isSYMBOL(x)) return nil;
2514 return (qflags(x) & TYPEBITS) == typeGENSYM ? lisptrue : nil;
2515 }
2516
Lchar(LispObject lits,int nargs,...)2517 LispObject Lchar(LispObject lits, int nargs, ...)
2518 { ARG1("char", x);
2519 return char_function(x);
2520 }
2521
2522
2523
Lcharcode(LispObject lits,int nargs,...)2524 LispObject Lcharcode(LispObject lits, int nargs, ...)
2525 { ARG1("char-code", x);
2526 if (isFIXNUM(x)) return x;
2527 if (isSYMBOL(x)) x = qpname(x);
2528 if (!isSTRING(x)) return error1("bad arg for char-code", x);
2529 return packfixnum(*qstring(x));
2530 }
2531
Lcodechar(LispObject lits,int nargs,...)2532 LispObject Lcodechar(LispObject lits, int nargs, ...)
2533 { char ch[4];
2534 ARG1("code-char", x);
2535 if (!isFIXNUM(x)) return error1("bad arg for code-char", x);
2536 ch[0] = (char)qfixnum(x); ch[1] = 0;
2537 return lookup(ch, 1, 1);
2538 }
2539
Ltime(LispObject lits,int nargs,...)2540 LispObject Ltime(LispObject lits, int nargs, ...)
2541 { clock_t c = clock();
2542 ARG0("time"); // I will convert the time to be in milliseconds
2543 return packfixnum((intptr_t)((1000*(int64_t )c)/CLOCKS_PER_SEC));
2544 }
2545
2546 // (date) "14-May-2013"
2547 // (date!-and!-time) "Tue May 14 09:52:45 2013"
2548 //
2549
Ldate(LispObject lits,int nargs,...)2550 LispObject Ldate(LispObject lits, int nargs, ...)
2551 { time_t t = time(NULL);
2552 char today[32];
2553 char today1[32];
2554 strcpy(today, ctime(&t));
2555 // e.g. "Sun Sep 16 01:03:52 1973\n"
2556 // 012345678901234567890123
2557 today[24] = 0; // loses final '\n'
2558 today1[0] = today[8]==' ' ? '0' : today[8];
2559 today1[1] = today[9];
2560 today1[2] = '-';
2561 today1[3] = today[4];
2562 today1[4] = today[5];
2563 today1[5] = today[6];
2564 today1[6] = '-';
2565 today1[7] = today[20];
2566 today1[8] = today[21];
2567 today1[9] = today[22];
2568 today1[10] = today[23];
2569 today1[11] = 0; // Now as in 03-Apr-2009
2570 return makestring(today1, 11);
2571 }
2572
Ldate_and_time(LispObject lits,int nargs,...)2573 LispObject Ldate_and_time(LispObject lits, int nargs, ...)
2574 { time_t t = time(NULL);
2575 char today[32];
2576 strcpy(today, ctime(&t));
2577 // e.g. "Sun Sep 16 01:03:52 1973\n"
2578 today[24] = 0; // loses final '\n'
2579 return makestring(today, 24);
2580 }
2581
Loblist(LispObject lits,int nargs,...)2582 LispObject Loblist(LispObject lits, int nargs, ...)
2583 {
2584 int i;
2585 ARG0("oblist");
2586 work1 = nil;
2587 for (i=0; i<OBHASH_SIZE; i++)
2588 for (work2=obhash[i]; isCONS(work2); work2 = qcdr(work2))
2589 { if (qcar(work2) != undefined)
2590 work1 = cons(qcar(work2), work1);
2591 }
2592 return work1;
2593 }
2594
Leval(LispObject lits,int nargs,...)2595 LispObject Leval(LispObject lits, int nargs, ...)
2596 { ARG1("eval", x);
2597 return eval(x);
2598 }
2599
Lapply(LispObject lits,int nargs,...)2600 LispObject Lapply(LispObject lits, int nargs, ...)
2601 { int n = 0;
2602 ARG2("apply", x, y);
2603 if (isCONS(x) && qcar(x) == lambda)
2604 { LispObject g;
2605 push2(x, y);
2606 g = Lgensym(nil, 0);
2607 pop2(y, x);
2608 if (unwindflag != unwindNONE) return nil;
2609 qdefn(g) = (void *)interpret;
2610 qlits(g) = qcdr(x);
2611 x = g;
2612 }
2613 else if (!isSYMBOL(x)) return error1("bad arg to apply", x);
2614 push(x);
2615 while (isCONS(y))
2616 { push(qcar(y));
2617 y = qcdr(y);
2618 n++;
2619 }
2620 return applytostack(n);
2621 }
2622
Lplist(LispObject lits,int nargs,...)2623 LispObject Lplist(LispObject lits, int nargs, ...)
2624 { ARG1("plist", x);
2625 if (!isSYMBOL(x)) return nil;
2626 else return qplist(x);
2627 }
2628
Lpname(LispObject lits,int nargs,...)2629 LispObject Lpname(LispObject lits, int nargs, ...)
2630 { ARG1("pname", x);
2631 if (!isSYMBOL(x)) return nil;
2632 else return qpname(x);
2633 }
2634
Lput(LispObject lits,int nargs,...)2635 LispObject Lput(LispObject lits, int nargs, ...)
2636 { LispObject w;
2637 ARG3("put", x, y, z);
2638 if (!isSYMBOL(x)) return error1("bad arg put", x);
2639 w = qplist(x);
2640 while (isCONS(w))
2641 { LispObject a = qcar(w);
2642 w = qcdr(w);
2643 if (isCONS(a) && qcar(a) == y)
2644 { qcdr(a) = z;
2645 return z;
2646 }
2647 }
2648 push2(x, z);
2649 w = acons(y, z, qplist(x));
2650 pop2(z, x);
2651 qplist(x) = w;
2652 return z;
2653 }
2654
Lget(LispObject lits,int nargs,...)2655 LispObject Lget(LispObject lits, int nargs, ...)
2656 { ARG2("get", x, y);
2657 if (!isSYMBOL(x)) return nil;
2658 x = qplist(x);
2659 while (isCONS(x))
2660 { LispObject a = qcar(x);
2661 x = qcdr(x);
2662 if (isCONS(a) && qcar(a) == y) return qcdr(a);
2663 }
2664 return nil;
2665 }
2666
Lremprop(LispObject lits,int nargs,...)2667 LispObject Lremprop(LispObject lits, int nargs, ...)
2668 { LispObject p, r, *prev;
2669 ARG2("remprop", x, y);
2670 if (!isSYMBOL(x)) return nil;
2671 p = *(prev = &qplist(x));
2672 while (p != nil)
2673 { if (isCONS(r = qcar(p)) && qcar(qcar(p)) == y)
2674 { *prev = qcdr(p);
2675 return r;
2676 }
2677 p = *(prev = &qcdr(p));
2678 }
2679 return nil;
2680 }
2681
Lmkvect(LispObject lits,int nargs,...)2682 LispObject Lmkvect(LispObject lits, int nargs, ...)
2683 { int n;
2684 ARG1("mkvect", x);
2685 if (!isFIXNUM(x)) return error1("bad size in mkvect", x);
2686 n = (int)qfixnum(x);
2687 // I put an (arbitrary) limit on the size of the largest vector.
2688 if (n < 0 || n > 100000) return error1("bad size in mkvect", x);
2689 return makevector(n);
2690 }
2691
Lupbv(LispObject lits,int nargs,...)2692 LispObject Lupbv(LispObject lits, int nargs, ...)
2693 { ARG1("upbv", x);
2694 if (!isVEC(x)) return error1("bad arg to upbv", x);
2695 return makeinteger(veclength(qheader(x))/sizeof(LispObject)-1);
2696 }
2697
Lputv(LispObject lits,int nargs,...)2698 LispObject Lputv(LispObject lits, int nargs, ...)
2699 { int n;
2700 ARG3("putv", x, y, z);
2701 if (!isVEC(x) || !isFIXNUM(y))
2702 return error2("bad arg to putv", x, y);
2703 n = (int)qfixnum(y);
2704 if (n < 0 || n >= veclength(qheader(x))/sizeof(LispObject))
2705 return error1("subscript out of range in putv", y);
2706 elt(x, n) = z;
2707 return z;
2708 }
2709
Lgetv(LispObject lits,int nargs,...)2710 LispObject Lgetv(LispObject lits, int nargs, ...)
2711 { int n;
2712 ARG2("getv", x, y);
2713 // As a matter of convenience and generosity I will allow "getv" to
2714 // access items from hash tables as well as ordinary vectors.
2715 if ((!isVEC(x) && !isEQHASH(x) && !isEQHASHX(x) &&
2716 !isEQUALHASH(x) && !isEQUALHASHX(x)) || !isFIXNUM(y))
2717 return error2("bad arg to getv", x, y);
2718 n = (int)qfixnum(y);
2719 if (n < 0 || n >= veclength(qheader(x))/sizeof(LispObject))
2720 return error1("subscript out of range in getv", y);
2721 return elt(x, n);
2722 }
2723
Lmkhash(LispObject lits,int nargs,...)2724 LispObject Lmkhash(LispObject lits, int nargs, ...)
2725 { LispObject size = packfixnum(10), r, flavour = packfixnum(0);
2726 va_list a; // I am going to permit mkhash to have extra arguments.
2727 va_start(a, nargs); // This is for easier compatibility with Reduce.
2728 if (nargs >= 1) size = va_arg(a, LispObject);
2729 if (nargs >= 2) flavour = va_arg(a, LispObject);
2730 va_end(a);
2731 if (!isFIXNUM(size)) return error1("bad size in mkhash", size);
2732 if (!isFIXNUM(flavour)) return error1("bad flavour in mkhash", flavour);
2733 int n = (int)qfixnum(size);
2734 int f = (int)qfixnum(flavour);
2735 // I force hash tables to be of limited size.
2736 if (n <= 10) n = 11;
2737 else if (n > 1000) n = 997;
2738 n |= 1; // Force table-size to be an odd number
2739 r = makevector(n-1);
2740 f = (f == 0 ? typeEQHASH : typeEQUALHASH);
2741 qheader(r) ^= (typeVEC ^ f);
2742 return r;
2743 }
2744
Lclrhash(LispObject lits,int nargs,...)2745 LispObject Lclrhash(LispObject lits, int nargs, ...)
2746 { ARG1("clrhash", x);
2747 if (isEQHASHX(x)) qheader(x) ^= (typeEQHASH ^ typeEQHASHX);
2748 if (isEQUALHASHX(x)) qheader(x) ^= (typeEQUALHASH ^ typeEQUALHASHX);
2749 if (!isEQHASH(x) && !isEQUALHASH(x))
2750 return error1("not a hash table in clrhash", x);
2751 size_t n = veclength(qheader(x))/sizeof(LispObject);
2752 for (size_t i=0; i<n; i++) elt(x, i) = nil;
2753 return x;
2754 }
2755
hashup(LispObject a,int isEQUAL)2756 uintptr_t hashup(LispObject a, int isEQUAL)
2757 { if (!isEQUAL) return (uintptr_t)a;
2758 switch (a & TAGBITS)
2759 { case tagCONS: // Traditional Lisp "cons" item.
2760 return 19937*hashup(qcar(a), 1) + hashup(qcdr(a), 1);
2761 case tagFLOAT: // A double-precision number.
2762 { union { double d; uintptr_t i;} dd;
2763 dd.d = qfloat(a);
2764 return dd.i;
2765 }
2766 case tagATOM: // Something else that will have a header word.
2767 if (isSTRING(a))
2768 { int len = veclength(qheader(a));
2769 char *s = qstring(a);
2770 uintptr_t h = 0;
2771 for (int i=0; i<len; i++) h = 11213*h + s[i];
2772 return h;
2773 }
2774 return 1; // give up for other atoms!
2775 default:
2776 case tagSYMBOL: // a symbol.
2777 case tagFIXNUM: // An immediate integer value (29 or 61 bits).
2778 return (uintptr_t)a;
2779 }
2780 }
2781
rehash(LispObject x)2782 void rehash(LispObject x)
2783 { int isEQUAL = isEQUALHASHX(x);
2784 int n = veclength(qheader(x));
2785 int i;
2786 // At the moment that this is invoked it is at least certain that
2787 // garbage collection is not in progress. Hence the second half-space
2788 // is all memory available for use! So on a temporary basis I will put
2789 // a copy of the hash table there.
2790 LispObject x1 = heap2base + tagATOM;
2791 memcpy((void *)(x1 - tagATOM), (void *)(x - tagATOM),
2792 n + sizeof(LispObject));
2793 n = n/sizeof(LispObject); // Now a count of slots in the table.
2794 // I will now re-hash from the copy that I made back into the hash table, but
2795 // now using the new hash values that reflect and changes that have
2796 // arisen.
2797 for (i=0; i<n; i++) elt(x, i) = nil;
2798 for (i=0; i<n; i++)
2799 { LispObject b = elt(x1, i);
2800 while (b != nil)
2801 { LispObject ca = qcar(b), cd = qcdr(b);
2802 int h = (int)(hashup(qcar(ca), isEQUAL)%((uintptr_t)n)); // New bucket.
2803 qcdr(b) = elt(x, h);
2804 elt(x, h) = b; // Re-inserted in table.
2805 b = cd;
2806 }
2807 }
2808 qheader(x) ^= (typeEQHASH ^ typeEQHASHX);
2809 }
2810
hashsame(LispObject x,LispObject y,int isEQUAL)2811 int hashsame(LispObject x, LispObject y, int isEQUAL)
2812 {
2813 if (isEQUAL) return Lequal(nil, 2, x, y) != nil;
2814 else return x == y;
2815 }
2816
Lputhash(LispObject lits,int nargs,...)2817 LispObject Lputhash(LispObject lits, int nargs, ...)
2818 { int n, h;
2819 LispObject c;
2820 ARG3("puthash", x, y, z);
2821 if (isEQHASHX(y) || isEQUALHASHX(y)) rehash(y);
2822 if (!isEQHASH(y) && !isEQUALHASH(y))
2823 return error2("not a hash table in puthash", x, y);
2824 n = veclength(qheader(y))/sizeof(LispObject);
2825 // I use unsigned types so I get a positive remainder.
2826 h = (int)(hashup(x, isEQUALHASH(y)) % ((uintptr_t)n));
2827 c = elt(y, h);
2828 while (isCONS(c))
2829 { if (hashsame(qcar(qcar(c)), x, isEQUALHASH(y)))
2830 { qcdr(qcar(c)) = z;
2831 return z;
2832 }
2833 c = qcdr(c);
2834 }
2835 push2(y, z);
2836 c = acons(x, z, elt(y, h));
2837 pop2(z, y);
2838 elt(y, h) = c;
2839 return z;
2840 }
2841
Lremhash(LispObject lits,int nargs,...)2842 LispObject Lremhash(LispObject lits, int nargs, ...)
2843 { int n, h;
2844 LispObject c, *cp;
2845 ARG2("remhash", x, y);
2846 if (isEQHASHX(y) || isEQUALHASHX(y)) rehash(y);
2847 if (!isEQHASH(y) && !isEQUALHASH(y))
2848 return error2("not a hash table in remhash", x, y);
2849 n = veclength(qheader(y))/sizeof(LispObject);
2850 h = (int)(hashup(x, isEQUALHASH(y)) % ((uintptr_t)n));
2851 c = *(cp = &elt(y, h));
2852 while (isCONS(c))
2853 { if (hashsame(qcar(qcar(c)), x, isEQUALHASH(y)))
2854 { *cp = qcdr(c);
2855 return qcdr(qcar(c));
2856 }
2857 c = *(cp = &qcdr(c));
2858 }
2859 return nil;
2860 }
2861
Lgethash(LispObject lits,int nargs,...)2862 LispObject Lgethash(LispObject lits, int nargs, ...)
2863 { int n, h;
2864 LispObject c;
2865 ARG2("gethash", x, y);
2866 if (isEQHASHX(y) || isEQUALHASHX(y)) rehash(y);
2867 if (!isEQHASH(y) && !isEQUALHASH(y))
2868 return error2("not a hash table in gethash", x, y);
2869 n = veclength(qheader(y))/sizeof(LispObject);
2870 h = (int)(hashup(x, isEQUALHASH(y)) % ((uintptr_t)n));
2871 c = elt(y, h);
2872 while (isCONS(c))
2873 { if (hashsame(qcar(qcar(c)), x, isEQUALHASH(y))) return qcdr(qcar(c));
2874 c = qcdr(c);
2875 }
2876 return nil;
2877 }
2878
Lgetd(LispObject lits,int nargs,...)2879 LispObject Lgetd(LispObject lits, int nargs, ...)
2880 { ARG1("getd", x);
2881 if (!isSYMBOL(x)) return nil;
2882 if ((qflags(x) & flagSPECFORM) != 0)
2883 { if (qdefn(x) == (void *)interpretspecform)
2884 return list2star(fexpr, lambda, qlits(x));
2885 else return cons(fsubr, x);
2886 }
2887 else if (qdefn(x) == NULL) return nil;
2888 else if (qdefn(x) == (void *)interpret)
2889 return list2star((qflags(x) & flagMACRO) ? macro : expr,
2890 lambda, qlits(x));
2891 else return cons(subr, x);
2892 }
2893
Lreturn(LispObject lits,int nargs,...)2894 LispObject Lreturn(LispObject lits, int nargs, ...)
2895 { ARG1("return", x);
2896 return error1("RETURN not in PROG context", x);
2897 }
2898
2899 // Now some numeric functions
2900
2901 #undef FF
2902 #undef BB
2903 #define FF(a, b) ((a) > (b) ? lisptrue : nil)
2904 #define BB(a, b) ((a) > (b) ? lisptrue : nil)
2905
Lgreaterp(LispObject lits,int nargs,...)2906 LispObject Lgreaterp(LispObject lits, int nargs, ...)
2907 { ARG2("greaterp", x, y);
2908 NUMOP("greaterp", x, y);
2909 }
2910
2911 #undef FF
2912 #undef BB
2913 #define FF(a, b) ((a) >= (b) ? lisptrue : nil)
2914 #define BB(a, b) ((a) >= (b) ? lisptrue : nil)
2915
Lgeq(LispObject lits,int nargs,...)2916 LispObject Lgeq(LispObject lits, int nargs, ...)
2917 { ARG2("geq", x, y);
2918 NUMOP("geq", x, y);
2919 }
2920
2921 #undef FF
2922 #undef BB
2923 #define FF(a, b) ((a) < (b) ? lisptrue : nil)
2924 #define BB(a, b) ((a) < (b) ? lisptrue : nil)
2925
Llessp(LispObject lits,int nargs,...)2926 LispObject Llessp(LispObject lits, int nargs, ...)
2927 { ARG2("lessp", x, y);
2928 NUMOP("lessp", x, y);
2929 }
2930
2931 #undef FF
2932 #undef BB
2933 #define FF(a, b) ((a) <= (b) ? lisptrue : nil)
2934 #define BB(a, b) ((a) <= (b) ? lisptrue : nil)
2935
Lleq(LispObject lits,int nargs,...)2936 LispObject Lleq(LispObject lits, int nargs, ...)
2937 { ARG2("leq", x, y);
2938 NUMOP("leq", x, y);
2939 }
2940
Lminus(LispObject lits,int nargs,...)2941 LispObject Lminus(LispObject lits, int nargs, ...)
2942 { ARG1("minus", x);
2943 return Nminus(x);
2944 }
2945
Lminusp(LispObject lits,int nargs,...)2946 LispObject Lminusp(LispObject lits, int nargs, ...)
2947 { ARG1("minusp", x);
2948 // Anything non-numeric will not be negative!
2949 if ((isFIXNUM(x) && x < 0) ||
2950 (isFLOAT(x) && qfloat(x) < 0.0) ||
2951 (isATOM(x) &&
2952 (qheader(x) & TYPEBITS) == typeBIGNUM &&
2953 qint64(x) < 0)) return lisptrue;
2954 else return nil;
2955 }
2956
2957 #undef BB
2958 #define BB(a) makeinteger(~(a))
2959
Llognot(LispObject lits,int nargs,...)2960 LispObject Llognot(LispObject lits, int nargs, ...)
2961 { ARG1("lognot", x);
2962 UNARYINTOP("lognot", x);
2963 }
2964
Lzerop(LispObject lits,int nargs,...)2965 LispObject Lzerop(LispObject lits, int nargs, ...)
2966 { ARG1("zerop", x);
2967 // Note that a bignum can never be zero! Because that is not "big".
2968 // This code is generous and anything non-numeric is not zero.
2969 if (x == packfixnum(0) ||
2970 (isFLOAT(x) && qfloat(x) == 0.0)) return lisptrue;
2971 else return nil;
2972 }
2973
Lonep(LispObject lits,int nargs,...)2974 LispObject Lonep(LispObject lits, int nargs, ...)
2975 { ARG1("onep", x);
2976 if (x == packfixnum(1) ||
2977 (isFLOAT(x) && qfloat(x) == 1.0)) return lisptrue;
2978 else return nil;
2979 }
2980
2981 #undef FF
2982 #undef BB
2983 #define FF(a) boxfloat((a) + 1.0)
2984 #define BB(a) makeinteger((a) + 1)
2985
Ladd1(LispObject lits,int nargs,...)2986 LispObject Ladd1(LispObject lits, int nargs, ...)
2987 { ARG1("add1", x);
2988 UNARYOP("add1", x);
2989 }
2990
2991 #undef FF
2992 #undef BB
2993 #define FF(a) boxfloat((a) - 1.0)
2994 #define BB(a) makeinteger((a) - 1)
2995
Lsub1(LispObject lits,int nargs,...)2996 LispObject Lsub1(LispObject lits, int nargs, ...)
2997 { ARG1("sub1", x);
2998 UNARYOP("sub1", x);
2999 }
3000
3001 #undef FF
3002 #undef BB
3003 #define FF(a, b) boxfloat((a) - (b))
3004 #define BB(a, b) makeinteger((a) - (b))
3005
Ldifference(LispObject lits,int nargs,...)3006 LispObject Ldifference(LispObject lits, int nargs, ...)
3007 { ARG2("difference", x, y);
3008 NUMOP("difference", x, y);
3009 }
3010
3011 #undef FF
3012 #undef BB
3013 #define FF(a, b) ((b) == 0.0 ? error1("division by 0.0", nil) : \
3014 boxfloat((a) / (b)))
3015 #define BB(a, b) ((b) == 0 ? error1("division by 0", nil) : \
3016 makeinteger((a) / (b)))
3017
Lquotient(LispObject lits,int nargs,...)3018 LispObject Lquotient(LispObject lits, int nargs, ...)
3019 { ARG2("quotient", x, y);
3020 NUMOP("quotient", x, y);
3021 }
3022
3023 #undef BB
3024 #define BB(a, b) ((b) == 0 ? error1("remainder by 0", nil) : \
3025 makeinteger((a) % (b)))
3026
Lremainder(LispObject lits,int nargs,...)3027 LispObject Lremainder(LispObject lits, int nargs, ...)
3028 { ARG2("remainder", x, y);
3029 INTOP("remainder", x, y);
3030 }
3031
3032 #undef BB
3033 #define BB(a, b) ((b) == 0 ? error1("division by 0", nil) : \
3034 cons(makeinteger((a) / (b)), makeinteger((a) % (b))))
3035
Ldivide(LispObject lits,int nargs,...)3036 LispObject Ldivide(LispObject lits, int nargs, ...)
3037 { ARG2("divide", x, y);
3038 INTOP("divide", x, y);
3039 }
3040
3041 #undef BB
3042 #define BB(a) makeinteger((a) << sh)
3043
Lleftshift(LispObject lits,int nargs,...)3044 LispObject Lleftshift(LispObject lits, int nargs, ...)
3045 { int sh;
3046 ARG2("leftshift", x, y);
3047 if (!isFIXNUM(y)) return error1("Bad argument for leftshift", y);
3048 sh = (int)qfixnum(y);
3049 UNARYINTOP("leftshift", x);
3050 }
3051
3052 #undef BB
3053 #define BB(a) makeinteger((a) >> sh)
3054
Lrightshift(LispObject lits,int nargs,...)3055 LispObject Lrightshift(LispObject lits, int nargs, ...)
3056 { int sh;
3057 ARG2("rightshift", x, y);
3058 if (!isFIXNUM(y)) return error1("Bad argument for rightshift", y);
3059 sh = (int)qfixnum(y);
3060 UNARYINTOP("rightshift", x);
3061 }
3062
Lstop(LispObject lits,int nargs,...)3063 LispObject Lstop(LispObject lits, int nargs, ...)
3064 { LispObject x = packfixnum(0);
3065 if (nargs != 0)
3066 { ARG1("stop", x1);
3067 x = x1;
3068 }
3069 exit(isFIXNUM(x) ? (int)qfixnum(x) : EXIT_SUCCESS);
3070 return nil;
3071 }
3072
Lposn(LispObject lits,int nargs,...)3073 LispObject Lposn(LispObject lits, int nargs, ...)
3074 { ARG0("posn");
3075 return packfixnum(linepos);
3076 }
3077
Llinelength(LispObject lits,int nargs,...)3078 LispObject Llinelength(LispObject lits, int nargs, ...)
3079 { ARG1("linelength", n);
3080 LispObject prev = packfixnum(linelength);
3081 if (isFIXNUM(n)) linelength = qfixnum(n);
3082 return prev;
3083 }
3084
Lprinbyte(LispObject lits,int nargs,...)3085 LispObject Lprinbyte(LispObject lits, int nargs, ...)
3086 { ARG1("prinbyte", x); // Arg is an integer, send it to output
3087 // with no messing around.
3088 putc(qfixnum(x), lispfiles[lispout]);
3089 return x;
3090 }
3091
3092 int coldstart = 0;
3093
Lrestart_csl(LispObject lits,int nargs,...)3094 LispObject Lrestart_csl(LispObject lits, int nargs, ...)
3095 // (restart!-lisp) Cold restart (as for command-line "-z" option)...
3096 // OR (restart!-lisp nil)Runs standard Read-Eval-Print loop.
3097 // (restart!-lisp t) Reload current heap image then uses its restart fn.
3098 // (restart!-lisp f) Reload heap image then invoke (f). (f!=nil, f!=t)
3099 // (restart!-lisp (m f)) Reload heap, load module m, then call f.
3100 // (restart!-lisp f a) Reload heap, call (f a). a=nil is NOT special, so
3101 // this case depends on the number of args passed rather
3102 // than just using default values.
3103 // (restart!-list (m f) a) Reload heap, load module m, call (f a).
3104 { ARG0123("restart-csl", x, y, z);
3105 if (z != NULLATOM)
3106 return error1s("wrong number of arguments for", "restart-lisp");
3107 if (x == NULLATOM) x = nil;
3108 if (y == NULLATOM) work1 = cons(x, nil);
3109 else work1 = list2star(x, y, nil);
3110 if (unwindflag == unwindNONE) unwindflag = unwindRESTART;
3111 return nil;
3112 }
3113
Lpreserve(LispObject lits,int nargs,...)3114 LispObject Lpreserve(LispObject lits, int nargs, ...)
3115 // (preserve) Dump image, leave restart fn unchanged, exit.
3116 // (preserve f) Dump image with new restart fn if f!=nil, exit.
3117 // (preserve f b) As above, but also change banner to b if b!=nil.
3118 // (preserve f b nil) As above.
3119 // (preserve f b t) Dump image as before, then do restart that loads
3120 // the newly created image and uses its restart fn.
3121 // (preserve f b g) Dump image, readload it but override restart fn
3122 // to be g just this time.
3123 // (preserve f b (m g)) Dump image, reload, load-module m, call function g.
3124 // (preserve f b g a) Reserved to pass a as argument to the restart function.
3125 // not implemeted yet.
3126 { ARG0123("preserve", x,y,z);
3127 if (x == NULLATOM) x = nil;
3128 if (y == NULLATOM) y = nil; // Ignored for now!
3129 if (z == NULLATOM) z = nil;
3130 restartfn = x;
3131 work1 = cons(z, nil);
3132 if (unwindflag == unwindNONE)
3133 { unwindflag = unwindPRESERVE;
3134 if (z != nil) unwindflag |= unwindRESTART;
3135 }
3136 return nil;
3137 }
3138
Lprin(LispObject lits,int nargs,...)3139 LispObject Lprin(LispObject lits, int nargs, ...)
3140 { ARG1("prin", x);
3141 return prin(x);
3142 }
3143
Lprint(LispObject lits,int nargs,...)3144 LispObject Lprint(LispObject lits, int nargs, ...)
3145 { ARG1("print", x);
3146 return print(x);
3147 }
3148
Lprinc(LispObject lits,int nargs,...)3149 LispObject Lprinc(LispObject lits, int nargs, ...)
3150 { ARG1("princ", x);
3151 return princ(x);
3152 }
3153
Lprinhex(LispObject lits,int nargs,...)3154 LispObject Lprinhex(LispObject lits, int nargs, ...)
3155 { ARG1("princ", x);
3156 return prinhex(x);
3157 }
3158
Lprintc(LispObject lits,int nargs,...)3159 LispObject Lprintc(LispObject lits, int nargs, ...)
3160 { ARG1("printc", x);
3161 return printc(x);
3162 }
3163
Lterpri(LispObject lits,int nargs,...)3164 LispObject Lterpri(LispObject lits, int nargs, ...)
3165 { ARG0("terpri");
3166 wrch('\n');
3167 return nil;
3168 }
3169
Lnreverse(LispObject lits,int nargs,...)3170 LispObject Lnreverse(LispObject lits, int nargs, ...)
3171 { ARG1("nreverse", x);
3172 return nreverse(x);
3173 }
3174
Lexplode(LispObject lits,int nargs,...)3175 LispObject Lexplode(LispObject lits, int nargs, ...)
3176 { int f = lispout;
3177 ARG1("explode", x);
3178 lispout = -1;
3179 work1 = nil;
3180 prin(x);
3181 lispout = f;
3182 return nreverse(work1);
3183 }
3184
Lexplodec(LispObject lits,int nargs,...)3185 LispObject Lexplodec(LispObject lits, int nargs, ...)
3186 { int f = lispout;
3187 ARG1("explodec", x);
3188 lispout = -1;
3189 work1 = nil;
3190 princ(x);
3191 lispout = f;
3192 return nreverse(work1);
3193 }
3194
Lreadbyte(LispObject lits,int nargs,...)3195 LispObject Lreadbyte(LispObject lits, int nargs, ...)
3196 { int ch;
3197 ARG0("readbyte"); // Read byte and return integer.
3198 ch = curchar;
3199 curchar = rdch();
3200 return packfixnum(ch & 0xff);
3201 }
3202
Lreadch(LispObject lits,int nargs,...)3203 LispObject Lreadch(LispObject lits, int nargs, ...)
3204 { char ch[4];
3205 ARG0("readch");
3206 if (curchar == EOF) return eofsym;
3207 ch[0] = qvalue(lower) != nil ? tolower(curchar) :
3208 qvalue(raise) != nil ? toupper(curchar) : curchar;
3209 ch[1] = 0;
3210 curchar = rdch();
3211 return lookup(ch, 1, 1);
3212 }
3213
Lreadline(LispObject lits,int nargs,...)3214 LispObject Lreadline(LispObject lits, int nargs, ...)
3215 { char ch[200];
3216 int n = 0;
3217 ARG0("readline");
3218 if (curchar == '\n') curchar = rdch();
3219 while (curchar != '\n' && curchar != EOF)
3220 { if (n < sizeof(ch)-1) ch[n++] = curchar;
3221 curchar = rdch();
3222 }
3223 if (n == 0 && curchar == EOF) return eofsym;
3224 ch[n] = 0;
3225 return lookup(ch, n, 1);
3226 }
3227
Lremob(LispObject lits,int nargs,...)3228 LispObject Lremob(LispObject lits, int nargs, ...)
3229 { ARG1("remob", x);
3230 if (!isSYMBOL(x)) return x;
3231 LispObject pn = qpname(x);
3232 int len = veclength(qheader(pn));
3233 const char *s = qstring(pn);
3234 return lookup(s, len, -1);
3235 }
3236
Lread(LispObject lits,int nargs,...)3237 LispObject Lread(LispObject lits, int nargs, ...)
3238 { ARG0("read");
3239 return readS();
3240 }
3241
Lcompress(LispObject lits,int nargs,...)3242 LispObject Lcompress(LispObject lits, int nargs, ...)
3243 { int f = lispin;
3244 LispObject r;
3245 ARG1("compress", x);
3246 lispin = -1;
3247 symtype = '?';
3248 curchar = '\n';
3249 push(cursym);
3250 work1 = x;
3251 r = readS();
3252 lispin = f;
3253 pop(cursym);
3254 return r;
3255 }
3256
Lrds(LispObject lits,int nargs,...)3257 LispObject Lrds(LispObject lits, int nargs, ...)
3258 { int old = lispin;
3259 ARG1("rds", x);
3260 if (x == nil) x = packfixnum(3);
3261 if (isFIXNUM(x))
3262 { int n = (int)qfixnum(x);
3263 if (0 <= n && n < MAX_LISPFILES && lispfiles[n] != NULL &&
3264 (file_direction & (1<<n)) == 0)
3265 { lispin = n;
3266 symtype = '?';
3267 // If you RDS between two files then curchar (for each) must not be
3268 // disturbed, but this hack makes EOF get re-checked for...
3269 if (curchar == EOF) curchar = '\n';
3270 return packfixnum(old);
3271 }
3272 }
3273 return error1("rds failed", x);
3274 }
3275
Lwrs(LispObject lits,int nargs,...)3276 LispObject Lwrs(LispObject lits, int nargs, ...)
3277 { int old = lispout;
3278 ARG1("wrs", x);
3279 if (x == nil) x = packfixnum(1);
3280 if (isFIXNUM(x))
3281 { int n = (int)qfixnum(x);
3282 if (0 <= n && n < MAX_LISPFILES && lispfiles[n] != NULL &&
3283 (file_direction & (1<<n)) != 0)
3284 { lispout = n;
3285 return packfixnum(old);
3286 }
3287 }
3288 return error1("wrs failed", x);
3289 }
3290
3291 #define LONGEST_FILENAME 1000
3292 char filename[2*LONGEST_FILENAME+50];
3293 static char imagename[LONGEST_FILENAME];
3294 static char lispdirectory[LONGEST_FILENAME];
3295
Lget_lisp_directory(LispObject lits,int nargs,...)3296 LispObject Lget_lisp_directory(LispObject lits, int nargs, ...)
3297 {
3298 return makestring(lispdirectory, strlen(lispdirectory));
3299 }
3300
Lsystem(LispObject lits,int nargs,...)3301 LispObject Lsystem(LispObject lits, int nargs, ...)
3302 { ARG1("system", x);
3303 if (isSYMBOL(x)) x = qpname(x);
3304 if (!isSTRING(x))
3305 return error1("bad arg for system", x);
3306 sprintf(filename, "%.*s", (int)veclength(qheader(x)), qstring(x));
3307 system(filename);
3308 return nil;
3309 }
3310
Lsetpchar(LispObject lits,int nargs,...)3311 LispObject Lsetpchar(LispObject lits, int nargs, ...)
3312 { ARG1("setpchar", x);
3313 if (isSYMBOL(x)) x = qpname(x);
3314 if (!isSTRING(x))
3315 return error1("bad arg for setpchar", x);
3316 LispObject r = makestring(promptstring, strlen(promptstring));
3317 sprintf(promptstring, "%.*s", (int)veclength(qheader(x)), qstring(x));
3318 return r;
3319 }
3320
Lopen(LispObject lits,int nargs,...)3321 LispObject Lopen(LispObject lits, int nargs, ...)
3322 { FILE *f;
3323 int n, how = 0;
3324 char *p;
3325 ARG2("open", x, y);
3326 if (isSYMBOL(x)) x = qpname(x);
3327 if (!isSTRING(x) ||
3328 !((y == input && (how=1)!=0) ||
3329 (y == output && (how=2)!=0) ||
3330 (y == pipe && (how=3)!=0)))
3331 return error2("bad arg for open", x, y);
3332 if (*qstring(x)=='$' && (p=strchr(qstring(x), '/'))!=NULL)
3333 { sprintf(filename, "@%.*s", (int)(p-qstring(x))-1, 1+qstring(x));
3334 lits = qvalue(lookup(filename, strlen(filename), 0));
3335 if (isSTRING(lits)) sprintf(filename, "%.*s%.*s",
3336 (int)veclength(qheader(lits)), qstring(lits),
3337 (int)(veclength(qheader(x)) - (p-qstring(x))), p);
3338 else sprintf(filename, "%.*s", (int)veclength(qheader(x)), qstring(x));
3339 }
3340 else sprintf(filename, "%.*s", (int)veclength(qheader(x)), qstring(x));
3341 #ifdef __WIN32__
3342 // while (strchr(filename, '/') != NULL) *strchr(filename, '/') = '\\';
3343 #endif // __WIN32__
3344 if (how == 3) f = popen(filename, "w");
3345 else f = fopen(filename, (how == 1 ? "r" : "w"));
3346 if (f == NULL) return error1("[open] file could not be opened", x);
3347 for (n=4; n<MAX_LISPFILES && lispfiles[n]!=NULL; n++);
3348 if (n<MAX_LISPFILES)
3349 { lispfiles[n] = f;
3350 if (y != input) file_direction |= (1 << n);
3351 return packfixnum(n);
3352 }
3353 return error1("too many open files", x);
3354 }
3355
Lopen_module(LispObject lits,int nargs,...)3356 LispObject Lopen_module(LispObject lits, int nargs, ...)
3357 { FILE *f;
3358 int n, how = 0;
3359 ARG2("open-module", x, y);
3360 if (isSYMBOL(x)) x = qpname(x);
3361 if (!isSTRING(x) ||
3362 !((y == input && (how=1)!=0) ||
3363 (y == output && (how=2)!=0)))
3364 return error2("bad arg for open-module", x, y);
3365 sprintf(filename, "%s.modules/%.*s.fasl", imagename,
3366 (int)veclength(qheader(x)), qstring(x));
3367 f = fopen(filename, (how == 1 ? "r" : "w"));
3368 if (f == NULL)
3369 { if (how == 2)
3370 {
3371 // The function mkdir() is declared in sys/stat.h and may not be
3372 // available on all platforms? If I fail to open xxx.img.modules/yyy.fasl
3373 // I will try makeing certain that the directory exists...
3374 sprintf(filename, "mkdir %s.modules", imagename);
3375 system(filename);
3376 sprintf(filename, "%s.modules/%.*s.fasl", imagename,
3377 (int)veclength(qheader(x)), qstring(x));
3378 f = fopen(filename, "w");
3379 if (f == NULL)
3380 { printf("+++ module file-name: %s mode=%d\n", filename, how);
3381 return error1("module could not be opened", x);
3382 }
3383 }
3384 else
3385 { printf("+++ module file-name: %s mode=%d\n", filename, how);
3386 return error1("module could not be opened", x);
3387 }
3388 }
3389 for (n=4; n<MAX_LISPFILES && lispfiles[n]!=NULL; n++);
3390 if (n<MAX_LISPFILES)
3391 { lispfiles[n] = f;
3392 if (y != input) file_direction |= (1 << n);
3393 return packfixnum(n);
3394 }
3395 return error1("too many open files", x);
3396 }
3397
Lmodulep(LispObject lits,int nargs,...)3398 LispObject Lmodulep(LispObject lits, int nargs, ...)
3399 { FILE *f;
3400 ARG1("modulep", x);
3401 if (isSYMBOL(x)) x = qpname(x);
3402 if (!isSTRING(x))
3403 return error1("bad arg for modulep", x);
3404 sprintf(filename, "%s.modules/%.*s.fasl", imagename,
3405 (int)veclength(qheader(x)), qstring(x));
3406 f = fopen(filename, "r");
3407 if (f == NULL) return nil;
3408 fclose(f);
3409 return lisptrue;
3410 }
3411
Lclose(LispObject lits,int nargs,...)3412 LispObject Lclose(LispObject lits, int nargs, ...)
3413 { ARG1("close", x);
3414 if (isFIXNUM(x))
3415 { int n = (int)qfixnum(x);
3416 if (n > 3 && n < MAX_LISPFILES)
3417 { if (lispin == n) lispin = 3;
3418 if (lispout == n) lispout = 1;
3419 if (lispfiles[n] != NULL) fclose(lispfiles[n]);
3420 lispfiles[n] = NULL;
3421 file_direction &= ~(1<<n);
3422 }
3423 }
3424 return nil;
3425 }
3426
readevalprint(int loadp)3427 void readevalprint(int loadp)
3428 { while (symtype != EOF)
3429 { LispObject r;
3430 push(qvalue(echo));
3431 unwindflag = unwindNONE;
3432 if (loadp) qvalue(echo) = nil;
3433 backtraceflag = backtraceHEADER | backtraceTRACE;
3434 r = readS();
3435 pop(qvalue(echo));
3436 fflush(stdout);
3437 if (unwindflag != unwindNONE) /* Do nothing */ ;
3438 else if (loadp || qvalue(dfprint) == nil ||
3439 (isCONS(r) && (qcar(r) == lookup("rdf", 3, 0) ||
3440 qcar(r) == lookup("faslend", 7, 0))))
3441 { r = eval(r);
3442 if (unwindflag == unwindNONE && !loadp)
3443 { linepos += printf("Value: ");
3444 #ifdef DEBUG
3445 if (logfile != NULL) fprintf(logfile, "Value: ");
3446 #endif // DEBUG
3447 print(r);
3448 fflush(stdout);
3449 }
3450 }
3451 else
3452 { r = cons(r, nil);
3453 if (unwindflag == unwindNONE) Lapply(nil, 2, qvalue(dfprint), r);
3454 }
3455 if ((unwindflag & (unwindPRESERVE | unwindRESTART)) != 0) return;
3456 }
3457 }
3458
Lrdf(LispObject lits,int nargs,...)3459 LispObject Lrdf(LispObject lits, int nargs, ...)
3460 { int f, f1;
3461 ARG1("rdf", x);
3462 f1 = Lopen(nil, 2, x, input);
3463 if (unwindflag != unwindNONE) return nil;
3464 f = Lrds(nil, 1, f1);
3465 readevalprint(0);
3466 Lrds(nil, 1, f);
3467 Lclose(nil, 1, f1);
3468 printf("+++ End of rdf\n");
3469 return nil;
3470 }
3471
Lload_module(LispObject lits,int nargs,...)3472 LispObject Lload_module(LispObject lits, int nargs, ...)
3473 { int f, f1;
3474 ARG1("load-module", x);
3475 f1 = Lopen_module(nil, 2, x, input);
3476 if (unwindflag != unwindNONE) return nil;
3477 // I want to save the current input status
3478 f = Lrds(nil, 1, f1);
3479 readevalprint(1);
3480 Lrds(nil, 1, f);
3481 Lclose(nil, 1, f1);
3482 return nil;
3483 }
3484
Ltrace(LispObject lits,int nargs,...)3485 LispObject Ltrace(LispObject lits, int nargs, ...)
3486 { ARG1("trace", x);
3487 while (isCONS(x))
3488 { if (isSYMBOL(qcar(x))) qflags(qcar(x)) |= flagTRACED;
3489 x = qcdr(x);
3490 }
3491 return nil;
3492 }
3493
Luntrace(LispObject lits,int nargs,...)3494 LispObject Luntrace(LispObject lits, int nargs, ...)
3495 { ARG1("untrace", x);
3496 while (isCONS(x))
3497 { if (isSYMBOL(qcar(x))) qflags(qcar(x)) &= ~flagTRACED;
3498 x = qcdr(x);
3499 }
3500 return nil;
3501 }
3502
Lerror(LispObject lits,int nargs,...)3503 LispObject Lerror(LispObject lits, int nargs, ...)
3504 { ARG2("error", x, y);
3505 return error2("error function called", x, y);
3506 }
3507
Lenable_errorset(LispObject lits,int nargs,...)3508 LispObject Lenable_errorset(LispObject lits, int nargs, ...)
3509 { ARG2("enable-errorset", x, y);
3510 if (isFIXNUM(x))
3511 { forcedMIN = qfixnum(x);
3512 if (forcedMIN < 0) forcedMIN = 0;
3513 else if (forcedMIN > 3) forcedMIN = 3;
3514 }
3515 else if (x == nil) forcedMIN = 0;
3516 else forcedMIN = 3;
3517 if (isFIXNUM(y))
3518 { forcedMAX = qfixnum(x);
3519 if (forcedMAX < 0) forcedMAX = 0;
3520 else if (forcedMAX > 3) forcedMAX = 3;
3521 }
3522 else if (y == nil) forcedMAX = 0;
3523 else forcedMAX = 3;
3524 if (forcedMIN > forcedMAX) forcedMAX = forcedMIN;
3525 if (forcedMIN > 0) backtraceflag |= backtraceHEADER;
3526 if (forcedMIN > 1) backtraceflag |= backtraceHEADER;
3527 if (forcedMAX < 1) backtraceflag &= ~backtraceHEADER;
3528 if (forcedMAX < 2) backtraceflag &= ~backtraceHEADER;
3529 return nil;
3530 }
3531
Lerrorset(LispObject lits,int nargs,...)3532 LispObject Lerrorset(LispObject lits, int nargs, ...)
3533 { int save = backtraceflag;
3534 ARG3("errorset", x, y, z);
3535 backtraceflag = 0;
3536 if (y != nil) backtraceflag |= backtraceHEADER;
3537 if (z != nil) backtraceflag |= backtraceTRACE;
3538 if (forcedMAX < 1) backtraceflag &= ~backtraceHEADER;
3539 if (forcedMAX < 2) backtraceflag &= ~backtraceHEADER;
3540 if (forcedMIN > 0) backtraceflag |= backtraceHEADER;
3541 if (forcedMIN > 1) backtraceflag |= backtraceHEADER;
3542 x = eval(x);
3543 if (unwindflag == unwindERROR ||
3544 unwindflag == unwindBACKTRACE)
3545 { unwindflag = unwindNONE;
3546 x = nil;
3547 }
3548 else x = cons(x, nil);
3549 backtraceflag = save;
3550 return x;
3551 }
3552
3553 struct defined_functions
3554 { const char *name;
3555 int flags;
3556 void *entrypoint;
3557 };
3558
3559 struct defined_functions fnsetup[] =
3560 {
3561 // First the special forms
3562 {"quote", flagSPECFORM, (void *)Lquote},
3563 {"cond", flagSPECFORM, (void *)Lcond},
3564 {"and", flagSPECFORM, (void *)Land},
3565 {"or", flagSPECFORM, (void *)Lor},
3566 {"de", flagSPECFORM, (void *)Lde},
3567 {"df", flagSPECFORM, (void *)Ldf},
3568 {"dm", flagSPECFORM, (void *)Ldm},
3569 {"setq", flagSPECFORM, (void *)Lsetq},
3570 {"progn", flagSPECFORM, (void *)Lprogn},
3571 {"prog", flagSPECFORM, (void *)Lprog},
3572 {"go", flagSPECFORM, (void *)Lgo},
3573 // The following are implemented as special forms here because they
3574 // take variable or arbitrary numbers of arguments - however they all
3575 // evaluate all their arguments in a rather simple way, so they
3576 // could be treated a sorts of "ordinary" function.
3577 {"list", flagSPECFORM, (void *)Llist},
3578 {"list*", flagSPECFORM, (void *)Lliststar},
3579 {"iplus", flagSPECFORM, (void *)Lplus},
3580 {"itimes", flagSPECFORM, (void *)Ltimes},
3581 {"ilogand", flagSPECFORM, (void *)Llogand},
3582 {"ilogor", flagSPECFORM, (void *)Llogor},
3583 {"ilogxor", flagSPECFORM, (void *)Llogxor},
3584 // Now ordinary functions.
3585 {"apply", 0, (void *)Lapply},
3586 {"atan", 0, (void *)Latan},
3587 {"atom", 0, (void *)Latom},
3588 {"bignump", 0, (void *)Lbignump},
3589 {"boundp", 0, (void *)Lboundp},
3590 {"car", 0, (void *)Lcar},
3591 {"cdr", 0, (void *)Lcdr},
3592 {"char", 0, (void *)Lchar},
3593 {"char-code", 0, (void *)Lcharcode},
3594 {"checkpoint", 0, (void *)Lpreserve},
3595 {"close", 0, (void *)Lclose},
3596 {"clrhash", 0, (void *)Lclrhash},
3597 {"code-char", 0, (void *)Lcodechar},
3598 {"compress", 0, (void *)Lcompress},
3599 {"cons", 0, (void *)Lcons},
3600 {"cos", 0, (void *)Lcos},
3601 {"date", 0, (void *)Ldate},
3602 {"date-and-time",0, (void *)Ldate_and_time},
3603 {"eq", 0, (void *)Leq},
3604 {"equal", 0, (void *)Lequal},
3605 {"error", 0, (void *)Lerror},
3606 {"errorset", 0, (void *)Lerrorset},
3607 {"eval", 0, (void *)Leval},
3608 {"exp", 0, (void *)Lexp},
3609 {"explode", 0, (void *)Lexplode},
3610 {"explodec", 0, (void *)Lexplodec},
3611 {"floatp", 0, (void *)Lfloatp},
3612 {"gensym", 0, (void *)Lgensym},
3613 {"gensymp", 0, (void *)Lgensymp},
3614 {"get", 0, (void *)Lget},
3615 {"get-lisp-directory",0, (void *)Lget_lisp_directory},
3616 {"getd", 0, (void *)Lgetd},
3617 {"gethash", 0, (void *)Lgethash},
3618 {"getv", 0, (void *)Lgetv},
3619 {"iadd1", 0, (void *)Ladd1},
3620 {"iceiling", 0, (void *)Lceiling},
3621 {"idifference",0, (void *)Ldifference},
3622 {"idivide", 0, (void *)Ldivide},
3623 {"iequal", 0, (void *)Lequal},
3624 {"ifix", 0, (void *)Lfix},
3625 {"ifixp", 0, (void *)Lfixp},
3626 {"ifloat", 0, (void *)Lfloat},
3627 {"ifloor", 0, (void *)Lfloor},
3628 {"igeq", 0, (void *)Lgeq},
3629 {"igreaterp", 0, (void *)Lgreaterp},
3630 {"ileftshift", 0, (void *)Lleftshift},
3631 {"ileq", 0, (void *)Lleq},
3632 {"ilessp", 0, (void *)Llessp},
3633 {"ilognot", 0, (void *)Llognot},
3634 {"iminus", 0, (void *)Lminus},
3635 {"iminusp", 0, (void *)Lminusp},
3636 {"inumberp", 0, (void *)Lnumberp},
3637 {"iquotient", 0, (void *)Lquotient},
3638 {"iremainder", 0, (void *)Lremainder},
3639 {"irightshift",0, (void *)Lrightshift},
3640 {"isub1", 0, (void *)Lsub1},
3641 {"linelength*",0, (void *)Llinelength},
3642 {"load-module",0, (void *)Lload_module},
3643 {"log", 0, (void *)Llog},
3644 {"lposn", 0, (void *)Lposn},
3645 {"makeunbound",0, (void *)Lmakeunbound},
3646 {"mkhash", 0, (void *)Lmkhash},
3647 {"mkvect", 0, (void *)Lmkvect},
3648 {"modulep", 0, (void *)Lmodulep},
3649 {"null", 0, (void *)Lnull},
3650 {"oblist", 0, (void *)Loblist},
3651 {"onep", 0, (void *)Lonep},
3652 {"open", 0, (void *)Lopen},
3653 {"open-module",0, (void *)Lopen_module},
3654 {"plist", 0, (void *)Lplist},
3655 {"pname", 0, (void *)Lpname},
3656 {"posn", 0, (void *)Lposn},
3657 {"preserve", 0, (void *)Lpreserve},
3658 {"prin", 0, (void *)Lprin},
3659 {"prin1", 0, (void *)Lprin},
3660 {"prin2", 0, (void *)Lprinc},
3661 {"prinbyte", 0, (void *)Lprinbyte},
3662 {"princ", 0, (void *)Lprinc},
3663 {"prinhex", 0, (void *)Lprinhex},
3664 {"print", 0, (void *)Lprint},
3665 {"printc", 0, (void *)Lprintc},
3666 {"prog1", 0, (void *)Lprog1},
3667 {"prog2", 0, (void *)Lprog2},
3668 {"put", 0, (void *)Lput},
3669 {"puthash", 0, (void *)Lputhash},
3670 {"putv", 0, (void *)Lputv},
3671 {"rdf", 0, (void *)Lrdf},
3672 {"rds", 0, (void *)Lrds},
3673 {"read", 0, (void *)Lread},
3674 {"readbyte", 0, (void *)Lreadbyte},
3675 {"readch", 0, (void *)Lreadch},
3676 {"readline", 0, (void *)Lreadline},
3677 {"reclaim", 0, (void *)Lreclaim},
3678 {"remhash", 0, (void *)Lremhash},
3679 {"remob", 0, (void *)Lremob},
3680 {"remprop", 0, (void *)Lremprop},
3681 {"restart-lisp",0, (void *)Lrestart_csl},
3682 {"restart-csl",0, (void *)Lrestart_csl},
3683 {"return", 0, (void *)Lreturn},
3684 {"rplaca", 0, (void *)Lrplaca},
3685 {"rplacd", 0, (void *)Lrplacd},
3686 {"set", 0, (void *)Lset},
3687 {"setpchar*", 0, (void *)Lsetpchar},
3688 {"sin", 0, (void *)Lsin},
3689 {"sqrt", 0, (void *)Lsqrt},
3690 {"stop", 0, (void *)Lstop},
3691 {"stringp", 0, (void *)Lstringp},
3692 {"symbol-name",0, (void *)Lpname},
3693 {"symbolp", 0, (void *)Lsymbolp},
3694 {"system", 0, (void *)Lsystem},
3695 {"terpri", 0, (void *)Lterpri},
3696 {"time", 0, (void *)Ltime},
3697 {"trace", 0, (void *)Ltrace},
3698 {"untrace", 0, (void *)Luntrace},
3699 {"upbv", 0, (void *)Lupbv},
3700 {"vectorp", 0, (void *)Lvectorp},
3701 {"wrs", 0, (void *)Lwrs},
3702 {"zerop", 0, (void *)Lzerop},
3703 {NULL, 0, NULL}
3704 };
3705
setup()3706 void setup()
3707 {
3708 // Ensure that initial symbols and functions are in place. Parts of this
3709 // code are rather rambling and repetitive but this is at least a simple
3710 // way to do things. I am going to assume that nothing can fail within this
3711 // setup code, so I can omit all checks for error conditions.
3712 struct defined_functions *p;
3713 undefined = lookup("~indefinite-value~", 18, 1);
3714 qflags(undefined) |= flagGLOBAL;
3715 qvalue(undefined) = undefined;
3716 nil = lookup("nil", 3, 1);
3717 qflags(nil) |= flagGLOBAL;
3718 qvalue(nil) = nil;
3719 lisptrue = lookup("t", 1, 1);
3720 qflags(lisptrue) |= flagGLOBAL;
3721 qvalue(lisptrue) = lisptrue;
3722 qvalue(echo = lookup("*echo", 5, 1)) = interactive ? nil : lisptrue;
3723 qflags(echo) |= flagFLUID;
3724 qvalue(lispsystem = lookup("lispsystem*", 11, 1)) =
3725 list2star(lookup("vsl", 3, 1), lookup("csl", 3, 1),
3726 list2star(lookup("embedded", 8, 1),
3727 cons(lookup("image", 5, 3),
3728 makestring(imagename, strlen(imagename))), nil));
3729 qflags(lispsystem) |= flagGLOBAL;
3730 quote = lookup("quote", 5, 1);
3731 function = lookup("function", 8, 1);
3732 backquote = lookup("`", 1, 1);
3733 comma = lookup(",", 1, 1);
3734 comma_at = lookup(",@", 2, 1);
3735 comma_dot = lookup(",.", 2, 1);
3736 eofsym = lookup("$eof$", 5, 1);
3737 qflags(eofsym) |= flagGLOBAL;
3738 qvalue(eofsym) = eofsym;
3739 lambda = lookup("lambda", 6, 1);
3740 expr = lookup("expr", 4, 1);
3741 subr = lookup("subr", 4, 1);
3742 fexpr = lookup("fexpr", 5, 1);
3743 fsubr = lookup("fsubr", 5, 1);
3744 macro = lookup("macro", 5, 1);
3745 input = lookup("input", 5, 1);
3746 output = lookup("output", 6, 1);
3747 pipe = lookup("pipe", 4, 1);
3748 qvalue(dfprint = lookup("dfprint*", 6, 1)) = nil;
3749 qflags(dfprint) |= flagFLUID;
3750 bignum = lookup("~bignum", 7, 1);
3751 qvalue(raise = lookup("*raise", 6, 1)) = nil;
3752 qvalue(lower = lookup("*lower", 6, 1)) = lisptrue;
3753 qflags(raise) |= flagFLUID;
3754 qflags(lower) |= flagFLUID;
3755 toploopeval = lookup("toploopeval*", 12, 1);
3756 loseflag = lookup("lose", 4, 1);
3757 bignum = lookup("~bignum", 7, 1);
3758 condsymbol = lookup("cond", 4, 1);
3759 prognsymbol = lookup("progn", 5, 1);
3760 gosymbol = lookup("go", 2, 1);
3761 returnsymbol = lookup("return", 6, 1);
3762 #ifdef PSL
3763 dummyvar = lookup("~dummyvar", 9, 1);
3764 #endif
3765 cursym = nil;
3766 work1 = work2 = nil;
3767 p = fnsetup;
3768 while (p->name != NULL)
3769 { LispObject w = lookup(p->name, strlen(p->name), 1);
3770 qflags(w) |= p->flags;
3771 qdefn(w) = p->entrypoint;
3772 p++;
3773 }
3774 }
3775
cold_start()3776 void cold_start()
3777 {
3778 // version of setup to call when there is no initial heap image at all.
3779 int i;
3780 // I make the object-hash-table lists end in a fixnum rather than nil
3781 // because I want to create the hash table before even the symbol nil
3782 // exists.
3783 for (i=0; i<OBHASH_SIZE; i++) obhash[i] = tagFIXNUM;
3784 for (i=0; i<BASES_SIZE; i++) bases[i] = NULLATOM;
3785 setup();
3786 // The following fields could not be set up quite early enough in the
3787 // cold start case, so I repair them now.
3788 restartfn = qplist(undefined) = qlits(undefined) =
3789 qplist(nil) = qlits(nil) = nil;
3790 }
3791
relocate(LispObject a,LispObject change)3792 LispObject relocate(LispObject a, LispObject change)
3793 {
3794 // Used to update a LispObject when reloaded from a saved heap image.
3795 switch (a & TAGBITS)
3796 { case tagATOM:
3797 if (a == NULLATOM) return a;
3798 case tagCONS:
3799 case tagSYMBOL:
3800 case tagFLOAT:
3801 return a + change;
3802 default:
3803 //case tagFIXNUM:
3804 //case tagFORWARD:
3805 //case tagHDR:
3806 return a;
3807 }
3808 }
3809
3810 // A saved image will start with a word that contains the following 32-bit
3811 // code. This identifies the word-width of the system involved.
3812
3813 #define FILEID (('v' << 0) | ('s' << 8) | ('l' << 16) | \
3814 (('0' + sizeof(LispObject)) << 24))
3815
warm_start()3816 void warm_start()
3817 {
3818 // The idea here is that a file that will already have been
3819 // created by a previous use of Lisp, and it should be re-loaded.
3820 gzFile f = gzopen(imagename, "rb");
3821 int i;
3822 LispObject currentbase = heap1base, change, s;
3823 if (f == NULL)
3824 { printf("Error: unable to open image for reading\n");
3825 my_exit(EXIT_FAILURE);
3826 }
3827 if (gzread(f, nonbases, (unsigned int)sizeof(nonbases)) != sizeof(nonbases) ||
3828 headerword != FILEID ||
3829 gzread(f, bases, (unsigned int)sizeof(bases)) != sizeof(bases) ||
3830 gzread(f, obhash, (unsigned int)sizeof(obhash)) != sizeof(obhash))
3831 { printf("Error: Image file corrupted or incompatible\n");
3832 my_exit(EXIT_FAILURE);
3833 }
3834 change = currentbase - heap1base;
3835 // Now I relocate the key addresses to refer to the CURRENT rather than
3836 // the saved address map.
3837 heap1base += change;
3838 heap1top += change;
3839 fringe1 += change;
3840 fpfringe1 += change;
3841 if (gzread(f, (void *)heap1base, (unsigned int)(fringe1-heap1base)) !=
3842 (int)(fringe1-heap1base) ||
3843 gzread(f, (void *)fpfringe1, (unsigned int)(heap1top-fpfringe1)) !=
3844 (int)(heap1top-fpfringe1))
3845 { printf("Error: Unable to read image file\n");
3846 my_exit(EXIT_FAILURE);
3847 }
3848 gzclose(f);
3849 if (change != 0)
3850 { for (i=0; i<BASES_SIZE; i++)
3851 bases[i] = relocate(bases[i], change);
3852 for (i=0; i<OBHASH_SIZE; i++)
3853 obhash[i] = relocate(obhash[i], change);
3854 // The main heap now needs to be scanned and addresses in it corrected.
3855 s = heap1base;
3856 while (s != fringe1)
3857 { LispObject h, w;
3858 if (!isHDR(h = qcar(s))) // A simple cons cell
3859 { qcar(s) = relocate(h, change);
3860 qcdr(s) = relocate(qcdr(s), change);
3861 s += 2*sizeof(LispObject);
3862 }
3863 else // The item is one that uses a header
3864 switch (h & TYPEBITS)
3865 { case typeSYM:
3866 case typeGENSYM:
3867 w = s + tagSYMBOL;
3868 // qflags(w) does not need adjusting
3869 qvalue(w) = relocate(qvalue(w), change);
3870 qplist(w) = relocate(qplist(w), change);
3871 qpname(w) = relocate(qpname(w), change);
3872 if (qdefn(w) == (void *)saveinterp)
3873 qdefn(w) = (void *)interpret;
3874 else if (qdefn(w) == (void *)saveinterpspec)
3875 qdefn(w) = (void *)interpretspecform;
3876 qlits(w) = relocate(qlits(w), change);
3877 s += SYMSIZE*sizeof(LispObject);
3878 continue;
3879 case typeSTRING: case typeBIGNUM:
3880 // These sorts of atom just contain binary data so do not need adjusting,
3881 // but I have to allow for the length code being in bytes etc.
3882 s += ALIGN8(sizeof(LispObject) + veclength(h));
3883 continue;
3884 case typeEQHASH: case typeEQUALHASH:
3885 qcar(s) ^= (typeEQHASH ^ typeEQHASHX);
3886 case typeVEC: case typeEQHASHX: case typeEQUALHASHX:
3887 s += sizeof(LispObject);
3888 w = veclength(h);
3889 while (w > 0)
3890 { qcar(s) = relocate(qcar(s), change);
3891 s += sizeof(LispObject);
3892 w -= sizeof(LispObject);
3893 }
3894 s = ALIGN8(s);
3895 continue;
3896 default:
3897 // The spare codes!
3898 printf("Failure with h = %x\n", (int)h & TYPEBITS);
3899 assert(0);
3900 }
3901 }
3902 }
3903 setup(); // resets all built-in functions properly.
3904 }
3905
3906 #define VERSION 1002
3907
main(int argc,char * argv[])3908 int main(int argc, char *argv[])
3909 {
3910 for (int i=0; i<MAX_LISPFILES+1; i++)
3911 { curchars[i] = '\n';
3912 symtypes[i] = 0;
3913 }
3914 #ifndef NO_LIBEDIT
3915 elx_e = el_init(argv[0], stdin, stdout, stderr);
3916 el_set(elx_e, EL_PROMPT, prompt);
3917 el_set(elx_e, EL_EDITOR, "emacs");
3918 if ((elx_h = history_init()) == 0)
3919 { fprintf(stderr, "Unable to initialize history\n");
3920 exit(1);
3921 }
3922 history(elx_h, &elx_v, H_SETSIZE, 400);
3923 el_set(elx_e, EL_HIST, history, elx_h);
3924 #endif
3925 int i;
3926 const char *inputfilename = NULL;
3927 void *pool;
3928 pool = (void *)malloc(HEAPSIZE + BITMAPSIZE + STACKSIZE + 16);
3929 if (pool == NULL)
3930 { printf("Not enough memory available: Unable to proceed\n");
3931 my_exit(EXIT_FAILURE);
3932 }
3933 memset(pool, 0, HEAPSIZE + BITMAPSIZE + STACKSIZE + 16);
3934 coldstart = 0;
3935 interactive = 1;
3936 #ifdef DEBUG
3937 logfile = fopen("vsl.log", "w");
3938 #endif // DEBUG
3939 #ifdef __WIN32__
3940 i = strlen(argv[0]);
3941 if (strcmp(argv[0]+i-4, ".exe") == 0) i -= 4;
3942 sprintf(imagename, "%.*s.img", i, argv[0]);
3943 #else // __WIN32__
3944 sprintf(imagename, "%s.img", argv[0]);
3945 #endif // __WIN32__
3946 strcpy(lispdirectory, imagename);
3947 { char *p = lispdirectory+strlen(lispdirectory)-5;
3948 while (isalnum((int)*p) && p != &lispdirectory[0]) p--;
3949 if (*p != '/' && *p != '\\') p++;
3950 *p = 0;
3951 }
3952 for (i=1; i<argc; i++)
3953 {
3954 // I have some VERY simple command-line options here.
3955 // -z do a "cold start".
3956 // -ifilename use that as image file
3957 // -i filename ditto
3958 // filename read from that file rather than from the standard input.
3959 // -g force all diagnostics
3960 if (strcmp(argv[i], "-z") == 0) coldstart = 1;
3961 else if (strcmp(argv[i], "-g") == 0)
3962 Lenable_errorset(nil, 2, lisptrue, lisptrue);
3963 else if (strcmp(argv[i], "-i") == 0 && i<argc-1)
3964 { strcpy(imagename, argv[i+1]);
3965 i++;
3966 }
3967 else if (strncmp(argv[i], "-i", 2) == 0) strcpy(imagename, argv[i]+2);
3968 else if (argv[i][0] != '-') inputfilename = argv[i], interactive = 0;
3969 }
3970 printf("VSL version %d.%.3d\n", VERSION/1000, VERSION%1000); fflush(stdout);
3971 linepos = 0;
3972 for (i=0; i<MAX_LISPFILES; i++) lispfiles[i] = 0;
3973 lispfiles[0] = stdin; lispfiles[1] = stdout;
3974 lispfiles[2] = stderr; lispfiles[3] = stdin;
3975 file_direction = (1<<1) | (1<<2); // 1 bits for writable files.
3976 lispin = 3; lispout = 1;
3977 if (inputfilename != NULL)
3978 { FILE *in = fopen(inputfilename, "r");
3979 if (in == NULL)
3980 printf("Unable to read from %s, so using standard input\n",
3981 inputfilename);
3982 else lispfiles[3] = in;
3983 }
3984 boffop = 0;
3985 for (;;) // This loop is for restart-lisp and preserve.
3986 { allocateheap(pool);
3987 // A warm start will read an image file which it expects to have been
3988 // made by a previous use of vsl.
3989 if (coldstart) cold_start();
3990 else warm_start();
3991 // Any predefined specified on the command-line using -Dxx=yy are
3992 // instated or re-instated here so they apply even after restart!-lisp.
3993 for (i=1; i<argc; i++)
3994 { if (argv[i][0] == '-' && argv[i][1] == 'D')
3995 { const char *d1 = strchr(argv[i], '=');
3996 if (d1 == NULL) continue;
3997 // In general through setup (and I count this as still being setup)
3998 // I will code on the basis that there will not be any garbage collection
3999 // so I do not need to think about the effects of data movement during GC.
4000 qvalue(lookup(argv[i]+2, (d1-argv[i])-2, 1)) =
4001 makestring(d1+1, strlen(d1+1));
4002 }
4003 }
4004 fflush(stdout);
4005 curchar = '\n'; symtype = '?'; cursym = nil;
4006 if (boffop == 0) // Use standard restart function from image.
4007 { if (restartfn == nil) readevalprint(0);
4008 else Lapply(nil, 2, restartfn, nil);
4009 }
4010 else
4011 { LispObject x, data = makestring(boffo, boffop);
4012 data = Lcompress(nil, 1, Lexplodec(nil, 1, data));
4013 x = qcar(data); // 'fn or '(module fn)
4014 if (x != nil)
4015 { if (x == lisptrue) x = restartfn;
4016 else if (isCONS(x) && isCONS(qcdr(x)))
4017 { push2(data, qcar(qcdr(x)));
4018 Lload_module(nil, 1, qcar(x));
4019 pop2(x, data);
4020 }
4021 Lapply(nil, 2, x, qcdr(data));
4022 }
4023 }
4024 if ((unwindflag & unwindPRESERVE) != 0)
4025 { gzFile f = gzopen(imagename, "wbT");
4026 if (f == NULL)
4027 printf("\n+++ Unable to open %s for writing\n", imagename);
4028 else
4029 { reclaim(); // To compact memory.
4030 headerword = FILEID;
4031 saveinterp = (LispObject)(void *)interpret;
4032 saveinterpspec = (LispObject)(void *)interpretspecform;
4033 gzwrite(f, nonbases, (unsigned int)sizeof(nonbases));
4034 gzwrite(f, bases, (unsigned int)sizeof(bases));
4035 gzwrite(f, obhash, (unsigned int)sizeof(obhash));
4036 gzwrite(f, (void *)heap1base, (unsigned int)(fringe1-heap1base));
4037 gzwrite(f, (void *)fpfringe1, (unsigned int)(heap1top-fpfringe1));
4038 }
4039 gzclose(f);
4040 // A cautious person would have checked for error codes returned by the
4041 // above calls to write and close. I omit that here to be concise.
4042 }
4043 if ((unwindflag & unwindRESTART) == 0) break;
4044 unwindflag = unwindNONE;
4045 boffop = 0;
4046 if (qcar(work1) == nil) coldstart = 1;
4047 else if (qcar(work1) == lisptrue) coldstart = 0;
4048 else
4049 { int save = lispout;
4050 lispout = -2;
4051 internalprint(work1);
4052 wrch(0);
4053 lispout = save;
4054 coldstart = 0;
4055 }
4056 }
4057 return 0;
4058 }
4059
4060 // end of main source file.
4061