1 /* CAMPUS LIsP, Lemon Version */
2 /* Copyright (C) 2000 Hirotsugu Kakugawa (h.kakugawa@computer.org) */
3 /* z88dk variant (SCHEME compatible mode, etc) by Stefano Bodrato */
4 /* This is a free software. See "COPYING" for detail. */
5
6 /* $Id: clisp.c */
7
8 /*
9
10 OPTIONS:
11 --------
12
13 -DFILES For targets with file support, get an optional lisp source file as program parameter
14 and evaluates it before leaving control to the user.
15 A specific LISP command is also available , e.g.: (load 'eliza.l)
16
17 -DSHORT Reduce the 'lisp atom' size to 16 bit to save memory.
18 Be aware that the valid numeric range will be only between -2047 and 2048 !
19 (untested: the structure tags may interfere with values, use it only as a last resort)
20
21 -DSPECLISP Lisp dialect syntax used in "Spec Lisp" by Serious Software ('de' in place of 'defun', etc..)
22
23 -DGRAPHICS Add turtle graphics functions.
24
25 -DMINIMALISTIC Remove many hardcoded functions.
26 'minimalistic.l' includes alternative native Lisp implementations.
27
28 -DNOINIT Remove the stucture initialization, it requires a previous dump of a memory image
29 created by running the full clisp version.
30
31 -DINITONLY Build a limited program intended to initialize the structures in memory and exit.
32
33 -DTINYMEM Shorten the memory structures to a minimal number of objects to save memory
34
35 -DNOTIMER To be used when the target platform misses the clock() function to 'randomize'
36
37 -DZEDIT (ZX81 ONLY), initial LISP code MUST be present @32768, 16K for text available, 48K RAM NEEDED
38 At startup a source file is searched in memory and eventually evaluated before getting to the
39 user prompt.
40
41
42 z88dk build hints:
43 ------------------
44
45 Spectrum
46 zcc +zx -lndos -O3 -create-app -DLARGEMEM=1200 clisp.c
47 zcc +zx -lndos -O3 -create-app -DLARGEMEM=3000 -DGRAPHICS -llib3d -DSHORT -DSPECLISP clisp.c
48
49 zx81 32K exp (don't change LARGEMEM, space allocation is hardcoded), 2 programs needed
50 zcc +zx81 -O3 -create-app -DLARGEMEM=900 -DZX81_32K -DINITONLY clisp.c
51 zcc +zx81 -O3 -create-app -DLARGEMEM=900 -DZX81_32K -DNOINIT clisp.c
52
53 zx81 16K, minimalistic version, graphics support
54 zcc +zx81 -O3 -create-app -DTINYMEM -DSHORT -DMINIMALISTIC -DGRAPHICS -lgfx81 -llib3d clisp.c
55 zx81 48K, minimalistic version, graphics support, initial code must be provided @32768
56 zcc +zx81 -O3 -create-app -DMINIMALISTIC -DGRAPHICS -lgfx81 -llib3d -DZEDIT -DZX81_32K clisp.c
57
58 MicroBee
59 zcc +bee -O3 -create-app -DLARGEMEM=1200 -DGRAPHICS -DNOTIMER -lgfxbee512 -llib3d clisp.c
60
61 Plain CP/M with file support to load programs
62 zcc +cpm -O3 -create-app -DLARGEMEM=2000 -DFILES clisp.c
63
64 For super size optimization, add:
65 --opt-code-size -pragma-define:CRT_INITIALIZE_BSS=0 -custom-copt-rules clisp.opt -DOPTIMIZE
66
67 */
68
69 #define HRGPAGE 42000
70
71 #include <stdio.h>
72 #include <stdlib.h>
73 #include <ctype.h>
74 #include <string.h>
75
76 #ifndef MINIMALISTIC
77 #ifndef NOTIMER
78 #include <time.h>
79 #endif
80 #endif
81
82 #ifdef GRAPHICS
83 #include <graphics.h>
84 #include <lib3d.h>
85 #endif
86
87 #ifdef OPTIMIZE
88 #include <clisp_opt.c>
89 #endif
90
91 #ifdef ZEDIT
92 #define shift 16383
93 #else
94 #define shift 0
95 #endif
96
97 #ifdef ZX81_32K
98 #ifdef ZEDIT
99 #pragma output STACKPTR=65535
100 #else
101 #pragma output STACKPTR=49152
102 #endif
103 unsigned int _sp;
104 #endif
105
106 #ifdef SHORT
107
108 #define D_MASK_DATA 0x0fff
109 #define D_MASK_TAG 0x7000
110 #define D_GC_MARK 0x8000
111 #define D_TAG_BIT_POS 12
112 #define D_INT_SIGN_BIT 0x0800
113
114 /* Data Tags */
115 #define TAG_NIL (0 << D_TAG_BIT_POS)
116 #define TAG_T (1 << D_TAG_BIT_POS)
117 #define TAG_INT (2 << D_TAG_BIT_POS)
118 #define TAG_SYMB (3 << D_TAG_BIT_POS)
119 #define TAG_CONS (4 << D_TAG_BIT_POS)
120 #define TAG_EOF (5 << D_TAG_BIT_POS)
121 #define TAG_UNDEF (6 << D_TAG_BIT_POS)
122
123 #define long int
124
125 #else
126
127 /* Data Representation ('int' must be at least 32 bits) */
128 #define D_MASK_DATA 0x0fffffffUL
129 #define D_MASK_TAG 0x70000000UL
130 #define D_GC_MARK 0x80000000UL
131 #define D_TAG_BIT_POS 28UL
132 #define D_INT_SIGN_BIT 0x08000000UL
133
134 /* Data Tags */
135 #define TAG_NIL (0UL << D_TAG_BIT_POS)
136 #define TAG_T (1UL << D_TAG_BIT_POS)
137 #define TAG_INT (2UL << D_TAG_BIT_POS)
138 #define TAG_SYMB (3UL << D_TAG_BIT_POS)
139 #define TAG_CONS (4UL << D_TAG_BIT_POS)
140 #define TAG_EOF (5UL << D_TAG_BIT_POS)
141 #define TAG_UNDEF (6UL << D_TAG_BIT_POS)
142
143 #endif
144
145 /* Cells */
146 #ifdef TINYMEM
147 #define NCONS 150
148 #else
149 #ifdef LARGEMEM
150 #define NCONS LARGEMEM
151 #else
152 #define NCONS 1024
153 #endif
154 #endif
155 #ifndef ZX81_32K
156 int t_cons_free; /* free list */
157 long t_cons_car[NCONS]; /* "car" part of cell */
158 long t_cons_cdr[NCONS]; /* "cdr" part of cell */
159 #else
160 int t_cons_free @32768+shift;
161 long t_cons_car[] @32780+shift; /* 3600 bytes */
162 long t_cons_cdr[] @36380+shift; /* 3600 bytes */
163 #endif
164
165 /* Symbols */
166 #ifdef TINYMEM
167 #define NSYMBS 63
168 #else
169 #ifdef LARGEMEM
170 #define NSYMBS 180
171 #else
172 #define NSYMBS 170
173 #endif
174 #endif
175
176 #ifndef ZX81_32K
177 int t_symb_free; /* free slot */
178 char *t_symb_pname[NSYMBS]; /* pointer to printable name */
179 /* #define t_symb_val ((long *)0x7e00) */ /*long t_symb_val[NSYMBS];*/ /* symbol value */
180 long t_symb_val[NSYMBS];
181 /*#define t_symb_fval ((long *)0x7efc) */ /*long t_symb_fval[NSYMBS];*/ /* symbol function definition */
182 long t_symb_fval[NSYMBS];
183 int t_symb_ftype[NSYMBS]; /* function type */
184 #else
185 int t_symb_free @32770+shift;
186 char *t_symb_pname[] @39980+shift; /* 360 bytes */
187 long t_symb_val[] @40340+shift; /* 720 bytes */
188 long t_symb_fval[] @41060+shift; /* 720 bytes */
189 int t_symb_ftype[] @41780+shift; /* 360 bytes */
190 #endif
191
192 #ifdef ZEDIT
193 char* text;
194 int c = 0;
195 #endif
196
197 #ifdef FILES
198 FILE *fpin;
199 int c = 0;
200 #endif
201
202 /* Printable name */
203 #ifdef TINYMEM
204 #define PNAME_SIZE 256
205 #else
206 #ifdef LARGEMEM
207 #define PNAME_SIZE LARGEMEM
208 #else
209 #define PNAME_SIZE 512
210 #endif
211 #endif
212
213 #ifndef ZX81_32K
214 int t_pnames_free; /* free pointer */
215 char t_pnames[PNAME_SIZE]; /* names */
216 #else
217 int t_pnames_free @32772+shift;
218 char t_pnames[] @42140+shift; /* 900 bytes */
219 #endif
220
221 /* Stack */
222 /* every stack entry has an extra cost on che real CPU stack
223 the average cost is about 35 bytes (!) the best overflow protection
224 should be to trigger the SP and fire out the error condition when
225 a lower limit has been reached */
226
227 #ifdef TINYMEM
228 #define STACK_SIZE 22
229 #else
230 #ifdef LARGEMEM
231 #define STACK_SIZE LARGEMEM/9
232 #else
233 #define STACK_SIZE 200
234 #endif
235 #endif
236
237 #ifndef ZX81_32K
238 long t_stack[STACK_SIZE]; /* the stack */
239 unsigned int t_stack_ptr; /* stack pointer */
240 #else
241 long t_stack[] @43040+shift; /* up to 100 elements (400 bytes)
242 but only 6112 bytes remaining for both SP and LISP STACK*/
243 unsigned int t_stack_ptr @32774+shift; /* stack pointer */
244 #endif
245
246
247 /* Function types */
248 enum Ftype {
249 FTYPE_UNDEF,
250 FTYPE_SYS,
251 FTYPE_SPECIAL,
252 FTYPE_USER
253 };
254 #define FTYPE(t, nargs) ((t)*1024 + (nargs))
255 #define FTYPE_ANY_ARGS 1023
256 #define FTYPE_GET_TYPE(p) ((p) / 1024)
257 #define FTYPE_GET_NARGS(p) ((p) % 1024)
258
259 /* Keywords */
260 enum keywords {
261 KW_READ, KW_EVAL, KW_GC, KW_CONS, KW_CAR, KW_CDR,
262 KW_QUIT, KW_DEFUN, KW_QUOTE, KW_SETQ, KW_EQ,
263 KW_NULL, KW_CONSP, KW_SYMBP, KW_NUMBERP, KW_PRINC, KW_TERPRI, KW_RPLACA,
264 KW_RPLACD, KW_PROGN, KW_COND, KW_OR, KW_NOT, KW_IF,
265 KW_LIST, KW_ADD, KW_SUB, KW_TIMES, KW_QUOTIENT,
266 KW_GT
267 #ifndef MINIMALISTIC
268 ,KW_LT, KW_AND, KW_DIVIDE, KW_LAMBDA,
269 KW_WHILE, KW_GTE, KW_LTE, KW_COMMENT,
270 KW_ZEROP, KW_ATOM, KW_RAND, KW_REM,
271 KW_INCR, KW_DECR, KW_EQUAL, KW_EQMATH
272 #endif
273 #ifdef GRAPHICS
274 ,KW_CLS, KW_PENU, KW_PEND,
275 KW_LEFT, KW_RIGHT, KW_FWD
276 #endif
277 #ifdef FILES
278 ,KW_LOAD
279 #endif
280 };
281 struct s_keywords {
282 char *key;
283 int ftype;
284 char i;
285 };
286
287 /* Built-in function table */
288 #ifndef NOINIT
289 struct s_keywords funcs[] = {
290 { "read", FTYPE(FTYPE_SYS, 0), KW_READ },
291 { "eval", FTYPE(FTYPE_SYS, 1), KW_EVAL },
292 { "gc", FTYPE(FTYPE_SYS, 0), KW_GC },
293 { "cons", FTYPE(FTYPE_SYS, 2), KW_CONS },
294 { "car", FTYPE(FTYPE_SYS, 1), KW_CAR },
295 { "cdr", FTYPE(FTYPE_SYS, 1), KW_CDR },
296 { "quit", FTYPE(FTYPE_SYS, 0), KW_QUIT },
297 #ifdef SCHEME
298 { "define", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_DEFUN },
299 #else
300 #ifdef SPECLISP
301 { "de", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_DEFUN },
302 #else
303 { "defun", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_DEFUN },
304 #endif
305 #endif
306 { "quote", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_QUOTE },
307 #ifdef SCHEME
308 { "set!", FTYPE(FTYPE_SPECIAL, 2), KW_SETQ },
309 { "eq?", FTYPE(FTYPE_SYS, 2), KW_EQ },
310 { "null?", FTYPE(FTYPE_SYS, 1), KW_NULL },
311 #else
312 { "setq", FTYPE(FTYPE_SPECIAL, 2), KW_SETQ },
313 { "eq", FTYPE(FTYPE_SYS, 2), KW_EQ },
314 { "null", FTYPE(FTYPE_SYS, 1), KW_NULL },
315 #endif
316 #ifdef SCHEME
317 { "pair?", FTYPE(FTYPE_SYS, 1), KW_CONSP },
318 { "symbol?", FTYPE(FTYPE_SYS, 1), KW_SYMBP },
319 { "number?", FTYPE(FTYPE_SYS, 1), KW_NUMBERP },
320 { "display", FTYPE(FTYPE_SYS, 1), KW_PRINC },
321 #else
322 { "consp", FTYPE(FTYPE_SYS, 1), KW_CONSP },
323 { "symbolp", FTYPE(FTYPE_SYS, 1), KW_SYMBP },
324 { "numberp", FTYPE(FTYPE_SYS, 1), KW_NUMBERP },
325 { "princ", FTYPE(FTYPE_SYS, 1), KW_PRINC },
326 #endif
327 { "terpri", FTYPE(FTYPE_SYS, 0), KW_TERPRI },
328 /* Lisp uses functions rplaca and rplacd to alter list structure
329 they change structure the same way as EMACS setcar and setcdr,
330 but the Common Lisp functions return the cons cell while
331 setcar and setcdr return the new car or cdr. */
332 { "rplaca", FTYPE(FTYPE_SYS, 2), KW_RPLACA },
333 { "rplacd", FTYPE(FTYPE_SYS, 2), KW_RPLACD },
334 #ifdef SCHEME
335 { "begin", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_PROGN },
336 #else
337 { "progn", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_PROGN },
338 #endif
339 { "cond", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_COND },
340 { "or", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_OR },
341 { "not", FTYPE(FTYPE_SYS, 1), KW_NOT },
342 { "if", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_IF },
343 { "list", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_LIST },
344 #ifdef SPECLISP
345 { "plus", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_ADD },
346 { "diff", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_SUB },
347 { "times", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_TIMES },
348 { "div", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_QUOTIENT },
349 { "greaterp", FTYPE(FTYPE_SYS, 2), KW_GT },
350 #else
351 { "+", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_ADD },
352 { "-", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_SUB },
353 { "*", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_TIMES },
354 { "/", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_QUOTIENT },
355 { ">", FTYPE(FTYPE_SYS, 2), KW_GT },
356 #endif
357 #ifndef MINIMALISTIC
358 #ifdef SPECLISP
359 { "lessp", FTYPE(FTYPE_SYS, 2), KW_LT },
360 #else
361 { "<", FTYPE(FTYPE_SYS, 2), KW_LT },
362 #endif
363 { "and", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_AND },
364 { "divide", FTYPE(FTYPE_SYS, 2), KW_DIVIDE },
365 { "lambda", FTYPE(FTYPE_SYS, FTYPE_ANY_ARGS), KW_LAMBDA },
366 /* EMACS LISP while syntax */
367 { "while", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_WHILE },
368 { ">=", FTYPE(FTYPE_SYS, 2), KW_GTE },
369 { "<=", FTYPE(FTYPE_SYS, 2), KW_LTE },
370 { "comment", FTYPE(FTYPE_SPECIAL, FTYPE_ANY_ARGS), KW_COMMENT },
371 #ifdef SCHEME
372 { "zero?", FTYPE(FTYPE_SYS, 1), KW_ZEROP },
373 { "atom", FTYPE(FTYPE_SYS, 1), KW_ATOM },
374 #else
375 { "zerop", FTYPE(FTYPE_SYS, 1), KW_ZEROP },
376 { "atom", FTYPE(FTYPE_SYS, 1), KW_ATOM },
377 #endif
378 { "random", FTYPE(FTYPE_SYS, 1), KW_RAND },
379 { "rem", FTYPE(FTYPE_SYS, 2), KW_REM },
380 #ifdef SPECLISP
381 { "add1", FTYPE(FTYPE_SYS, 1), KW_INCR },
382 { "sub1", FTYPE(FTYPE_SYS, 1), KW_DECR },
383 #else
384 { "1+", FTYPE(FTYPE_SYS, 1), KW_INCR },
385 { "1-", FTYPE(FTYPE_SYS, 1), KW_DECR },
386 #endif
387 #ifdef SCHEME
388 { "equal?", FTYPE(FTYPE_SYS, 2), KW_EQUAL },
389 #else
390 { "equal", FTYPE(FTYPE_SYS, 2), KW_EQUAL },
391 #endif
392 { "=", FTYPE(FTYPE_SYS, 2), KW_EQMATH },
393 #endif // (non MINIMALISTIC)
394
395 #ifdef GRAPHICS
396 { "cls", FTYPE(FTYPE_SYS, 0), KW_CLS },
397 { "penu", FTYPE(FTYPE_SYS, 0), KW_PENU },
398 { "pend", FTYPE(FTYPE_SYS, 0), KW_PEND },
399 { "left", FTYPE(FTYPE_SYS, 1), KW_LEFT },
400 { "right", FTYPE(FTYPE_SYS, 1), KW_RIGHT },
401 { "fwd", FTYPE(FTYPE_SYS, 1), KW_FWD },
402 #endif
403
404 #ifdef FILES
405 { "load", FTYPE(FTYPE_SYS, 1), KW_LOAD },
406 #endif
407
408 { NULL, -1, -1 }
409 };
410 #endif
411
412 /* Error messages */
413 char *errmsg_sym_undef = "SYMBOL UNDEFINED: ";
414 char *errmsg_func_undef = "FUNCTION UNDEFINED: ";
415 char *errmsg_ill_nargs = "ILLEGAL NUMBER OF ARGUMENTS: ";
416 char *errmsg_ill_type = "ILLEGAL ARGUMENT TYPE: ";
417 char *errmsg_ill_call = "ILLEGAL FUNCTION CALL: ";
418 char *errmsg_ill_syntax = "ILLEGAL SYNTAX: ";
419 char *errmsg_eof = "END OF FILE";
420 char *errmsg_stack_of = "STACK OVERFLOW";
421 char *errmsg_zero_div = "DIVISION BY ZERO: ";
422 char *errmsg_no_memory = "\nno memory. abort.\n";
423
424 #ifdef Z80
425 #define FASTCALL_MODE __z88dk_fastcall;
426 #else
427 #define FASTCALL_MODE ;
428 #endif
429
430 /* Function types */
431 void init(void);
432 #ifndef INITONLY
433 void toplevel(void);
434 long l_read(void);
435 long l_eval(long s) FASTCALL_MODE
436 long l_print(long s) FASTCALL_MODE
437 char skip_space(void);
438 long int_make_l(long v) FASTCALL_MODE
439 long int_get_c(long s) FASTCALL_MODE
440 long eval_args(long func, long a, long av[2], int n);
441 long special(long f, long a);
442 long fcall(long f, long av[2]); /*, int n*/
443 long apply(long f, long args, int n);
444 char err_msg(char *msg, char f, long s);
445 long l_cons(long car, long cdr);
446 long l_car(long s) FASTCALL_MODE
447 long l_cdr(long s) FASTCALL_MODE
448 int list_len(long s) FASTCALL_MODE
449 void rplacd(long s, long cdr);
450 void gcollect(void);
451 void gc_mark(long s) FASTCALL_MODE
452 char gc_protect(long s) FASTCALL_MODE
453 void gc_unprotect(long s) FASTCALL_MODE
454 #ifdef FILES
455 long l_load(long s) FASTCALL_MODE
456 #endif
457 #endif
458 long symb_make(char *p);
459 void quit(void);
460
D_GET_TAG(long s)461 long D_GET_TAG(long s) FASTCALL_MODE
462 long D_GET_TAG(long s) {
463 return (s & ~(D_GC_MARK | D_MASK_DATA));
464 }
465
D_GET_DATA(long s)466 long D_GET_DATA(long s) FASTCALL_MODE
467 long D_GET_DATA(long s) {
468 return (s & D_MASK_DATA);
469 }
470
471 #ifdef Z80
472
473 #ifdef ZX81_32K
474 char buf[] @43440+shift; /* 43400+(STACK_SIZE*4); */
475 #else
476 char buf[180];
477 #endif
478
479 int cpt;
480 char ug=13;
481
gchar()482 char gchar() {
483
484 #ifdef FILES
485 if (c!=0 && c!=EOF)
486 c=fgetc(fpin);
487 if (c!=0 && c!=EOF)
488 return (c);
489 #endif
490
491 #ifdef ZEDIT
492 if (c!=0 && c!=26)
493 c=text[cpt++];
494 if (c!=0 && c!=26)
495 return (c);
496 #endif
497
498 #ifdef ZX81_32K
499 zx_slow();
500 #endif
501 if (ug==13) {
502 while (!gets(buf)) {};
503 cpt=0;
504 }
505 #ifdef ZX81_32K
506 zx_fast();
507 #endif
508 if ((ug=buf[cpt++]) == 0) ug=13;
509 return (ug);
510
511 }
512
ugchar(char ch)513 void ugchar(char ch) {
514 #ifdef FILES
515 if (c!=0 && c!=EOF)
516 ungetc(ch,fpin);
517 else
518 cpt--;
519 #else
520 cpt--;
521 #endif
522 }
523
524 #else
525
gchar()526 char gchar() {
527
528 #ifdef FILES
529 if (c!=0 && c!=EOF)
530 c=fgetc(fpin);
531 if (c!=0 && c!=EOF)
532 return (c);
533 #endif
534
535 return (fgetc (stdin));
536 }
537
ugchar(char ch)538 void ugchar(char ch) {
539 if (c!=0 && c!=EOF)
540 ungetc(ch,fpin);
541 else
542 ungetc(ch,stdin);
543 }
544
545 #endif
546
547 void
main(int argc,char * argv[])548 main(int argc, char *argv[])
549 {
550 init();
551 #ifdef SCHEME
552 printf("%cCAMPUS LIsP\nLemon version,\nz88dk SCHEME variant\n",12);
553 #else
554 #ifdef SPECLISP
555 printf("%cCAMPUS LIsP\nLemon version,\nz88dk SpecLisp variant\n",12);
556 #else
557 printf("%cCAMPUS LIsP\nLemon version,\nz88dk variant\n",12);
558 #endif
559 #endif
560
561 #if defined(SHORT)||defined(MINIMALISTIC)||defined(TINYMEM)||defined(LARGEMEM)||defined(GRAPHICS)||defined(FILES)
562 printf("Build opt: [ ");
563 #ifdef SHORT
564 printf("SHORT ");
565 #endif
566 #ifdef MINIMALISTIC
567 printf("MINIMALISTIC ");
568 #endif
569 #ifdef TINYMEM
570 printf("TINYMEM ");
571 #endif
572 #ifdef LARGEMEM
573 printf("LARGEMEM ");
574 #endif
575 #ifdef GRAPHICS
576 printf("GRAPHICS ");
577 #endif
578 #ifdef FILES
579 printf("FILES ");
580 #endif
581 printf("]\n");
582 #endif
583
584 #ifdef FILES
585 if (argc == 2) {
586 fpin = fopen(argv[1],"r");
587 if (fpin == NULL)
588 printf ("File open error: %s\n",argv[1]);
589 else
590 c = 1;
591 }
592 #endif
593
594 #ifdef INITONLY
595 printf("\n...memory structures ready.\n");
596 #else
597 toplevel();
598 #endif
599 quit();
600
601 /*return 0;*/
602 }
603
604
605 /* Initialize lisp strage */
606 void
init(void)607 init(void)
608 {
609 int i;
610
611 #ifndef MINIMALISTIC
612 #ifndef NOTIMER
613 /* Randomize */
614 srand((int)time(NULL));
615 #endif
616 #endif
617
618 /* stack */
619 t_stack_ptr = 0;
620
621 #if defined(NOINIT)
622
623 #else
624 /* cells */
625 t_cons_free = 0;
626
627 /* make a free cell list */
628 for (i = 0; i != NCONS-1; i++)
629 t_cons_car[i] = i+1;
630 t_cons_car[NCONS-1] = NCONS-1; /* self-loop (this is very important) */
631
632 /* symbol table */
633 t_symb_free = 0;
634 for (i = 0; i != NSYMBS; i++)
635 t_symb_pname[i] = NULL;
636
637 /* print name (symbol name) */
638 t_pnames_free = 0;
639
640 /* install built-in functions */
641 for (i = 0; funcs[i].key != NULL; i++) {
642 symb_make(funcs[i].key);
643 t_symb_ftype[i] = funcs[i].ftype;
644 #ifndef Z80
645 if (i != funcs[i].i){
646 printf("Function install error: %s\n", funcs[i].key);
647 quit();
648 }
649 #endif
650 }
651
652 #endif
653
654 #ifdef ZEDIT
655 text=(char*)32768;
656 c=1; cpt=0;
657 #endif
658
659 }
660
661
662 #ifndef INITONLY
663 /* Top level */
664 void
toplevel(void)665 toplevel(void)
666 {
667 long s, v;
668
669 for (;;){
670 t_stack_ptr = 0;
671 printf("\n] "); /* prompt */
672 if ((s = l_read()) < 0) /* read */
673 continue;
674 if (s == TAG_EOF) /* end of file */
675 break;
676 if (gc_protect(s) < 0)
677 break;
678 if ((v = l_eval(s)) < 0) /* eval */
679 continue;
680 gc_unprotect(s);
681 printf("\n");
682 (void) l_print(v); /* print */
683 }
684 }
685
686
687 /* Read an S-expression */
688 long
l_read(void)689 l_read(void)
690 {
691 long s, v, t;
692 char token[32];
693 char ch, i;
694
695 /* skip spaces */
696 if ((ch = skip_space()) < 0){ /* eof */
697 return TAG_EOF;
698
699 } else if (ch == ';'){ /* comment */
700 while (( ch != '\n' ) && ( ch != '\r') )
701 ch = gchar();
702 return -1;
703 }
704 #ifdef ZX81
705 else if (ch == '\"'){ /* quote macro */
706 #else
707 else if (ch == '\''){ /* quote macro */
708 #endif
709 if ((t = l_read()) < 0)
710 return -1;
711 if (t == TAG_EOF)
712 return err_msg(errmsg_eof, 0, 0);
713 t = l_cons(t, TAG_NIL);
714 s = l_cons((TAG_SYMB|KW_QUOTE), t);
715
716 } else if (ch != '('){ /* t, nil, symbol, or integer */
717 token[0] = ch;
718 for (i = 1; ; i++){
719 ch = gchar();
720 if (isspace(ch) || iscntrl(ch) || (ch < 0)
721 || (ch == ';') || (ch == '(') || (ch == ')')){
722 ugchar(ch);
723 token[i] = '\0';
724
725 /* Changed to permint the definition of "1+" and "1-" */
726 if ((isdigit((char)token[0]) && (token[1] != '+') && (token[1] != '-'))
727 /* if (isdigit((char)token[0]) */
728 || ((token[0] == '-') && isdigit((char)token[1]))
729 || ((token[0] == '+') && isdigit((char)token[1]))){ /* integer */
730 #ifdef SHORT
731 s = int_make_l(atoi(token));
732 #else
733 s = int_make_l(atol(token));
734 #endif
735 #ifdef SCHEME
736 } else if (strcmp(token, "#f") == 0){ /* nil */
737 s = TAG_NIL;
738 } else if (strcmp(token, "#t") == 0){ /* t */
739 s = TAG_T;
740 #else
741 } else if (strcmp(token, "nil") == 0){ /* nil */
742 s = TAG_NIL;
743 } else if (strcmp(token, "t") == 0){ /* t */
744 s = TAG_T;
745 #endif
746 } else { /* symbol */
747 s = TAG_SYMB | symb_make(token);
748 }
749 break;
750 }
751 token[i] = ch;
752 }
753
754 } else /* ch == '(' */ { /* list */
755 if ((ch = skip_space()) < 0){
756 return err_msg(errmsg_eof, 0, 0);
757 } else if (ch == ')'){
758 s = TAG_NIL; /* "()" = nil */
759 } else {
760 ugchar(ch);
761 if ((t = l_read()) < 0)
762 return err_msg(errmsg_eof, 0, 0);
763 if (t == TAG_EOF)
764 return -1;
765 if ((s = v = l_cons(t, TAG_NIL)) < 0)
766 return -1;
767 if (gc_protect(s) < 0)
768 return -1;
769 for (;;){
770 if ((ch = skip_space()) < 0) /* look ahead next char */
771 return err_msg(errmsg_eof, 0, 0);
772 if (ch == ')')
773 break;
774 ugchar(ch);
775 if ((t = l_read()) < 0)
776 return -1;
777 if (t == TAG_EOF)
778 return err_msg(errmsg_eof, 0, 0);
779 if ((t = l_cons(t, TAG_NIL)) < 0)
780 return -1;
781 rplacd(v, t);
782 v = l_cdr(v);
783 }
784 gc_unprotect(s);
785 }
786 }
787
788 return s;
789 }
790
791 char
792 skip_space(void)
793 {
794 char ch;
795
796 for (;;){
797 if ((ch = gchar()) < 0)
798 return -1; /* end-of-file */
799 if (!isspace(ch) && !iscntrl(ch))
800 break;
801 }
802 return ch;
803 }
804
805
806 #ifndef MINIMALISTIC
807 long
808 l_equal(long s1, long s2)
809 {
810 int d1 = s1 & D_MASK_DATA;
811 int d2 = s2 & D_MASK_DATA;
812
813 if (D_GET_TAG(s1) != D_GET_TAG(s2))
814 return TAG_NIL;
815
816 if (D_GET_TAG(s1) == TAG_CONS)
817 if (l_equal(l_car(s1), l_car(s1)) == TAG_NIL)
818 return TAG_NIL;
819 else
820 return l_equal(l_car(s2), l_car(s2));
821
822 return (s1 == s2) ? TAG_T : TAG_NIL;
823 }
824 #endif
825
826
827 /* Print an S-expression */
828 long
829 l_print(long s)
830 {
831 long v, t;
832 int i;
833
834 switch(D_GET_TAG(s)){
835
836 #ifdef SCHEME
837 case TAG_NIL:
838 printf("#f");
839 break;
840
841 case TAG_T:
842 printf("#t");
843 break;
844 #else
845 case TAG_NIL:
846 printf("nil");
847 break;
848
849 case TAG_T:
850 printf("t");
851 break;
852 #endif
853 case TAG_INT:
854 v = int_get_c(s);
855 #ifdef SHORT
856 printf("%d", v);
857 #else
858 printf("%ld", v);
859 #endif
860 break;
861
862 case TAG_SYMB:
863 i = s & D_MASK_DATA;
864 printf("%s", t_symb_pname[i]);
865 break;
866
867 case TAG_EOF:
868 printf("<eof>");
869 break;
870
871 case TAG_UNDEF: /* for debugging */
872 printf("<undefined>");
873 break;
874
875 case TAG_CONS:
876 printf("(");
877 t = s;
878 l_print(l_car(t));
879 while (D_GET_TAG(l_cdr(t)) == TAG_CONS) {
880 printf(" ");
881 t = l_cdr(t);
882 l_print(l_car(t));
883 }
884 if (D_GET_TAG(l_cdr(t)) != TAG_NIL){
885 printf(" . ");
886 l_print(l_cdr(t));
887 }
888 printf(")");
889 break;
890 }
891 return TAG_T;
892 }
893
894
895 /* Evaluate an S-expression */
896 long
897 l_eval(long s)
898 {
899 long v, f, a, av[2];
900 int n;
901
902 switch(D_GET_TAG(s)){
903
904 case TAG_NIL: /* self-evaluating objects */
905 case TAG_T:
906 case TAG_INT:
907 v = s;
908 break;
909
910 case TAG_SYMB: /* symbol ... refer to the symbol table */
911 if ((v = t_symb_val[D_GET_DATA(s)]) == TAG_UNDEF)
912 return err_msg(errmsg_sym_undef, 1, s);
913 break;
914
915 case TAG_CONS: /* cons ... function call */
916 f = l_car(s); /* function name or lambda exp */
917 a = l_cdr(s); /* actual argument list */
918 #ifndef MINIMALISTIC
919 if ((D_GET_TAG(f) == TAG_CONS) && (D_GET_TAG(l_car(f)) == TAG_SYMB)
920 && ((D_GET_DATA(l_car(f)) == KW_LAMBDA))){ /* lambda exp */
921 if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
922 return -1;
923 v = apply(l_cdr(f), av[0], list_len(l_car(l_cdr(f))));
924 } else
925 #endif
926 if (D_GET_TAG(f) == TAG_SYMB){
927 n = FTYPE_GET_NARGS(t_symb_ftype[D_GET_DATA(f)]);
928 switch (FTYPE_GET_TYPE(t_symb_ftype[D_GET_DATA(f)])){
929 case FTYPE_UNDEF:
930 return err_msg(errmsg_func_undef, 1, f);
931 case FTYPE_SPECIAL:
932 v = special(f, a);
933 break;
934 case FTYPE_SYS:
935 if (eval_args(f, a, av, n) < 0)
936 return -1;
937 v = fcall(f, av/*, n*/);
938 break;
939 case FTYPE_USER:
940 if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
941 return -1;
942 v = apply(f, av[0], n);
943 }
944 } else {
945 return err_msg(errmsg_ill_call, 1, s);
946 }
947 break;
948 }
949 return v;
950 }
951
952
953 /* Execute special form (defun, setq. etc... arguments are not evaluated) */
954 long
955 special(long f, long a)
956 {
957 long t, v, u;
958 int l, i;
959
960 switch (D_GET_DATA(f)){
961
962 case KW_DEFUN:
963 if (list_len(a) < 2)
964 return err_msg(errmsg_ill_syntax, 1, f);
965 #ifdef SCHEME
966 /* (define (func var1 varn) (func content)) */
967 v = l_car(a); /* function name */
968 v = l_car(v); /* list of function name, arg and function body */
969 if (D_GET_TAG(v) != TAG_SYMB)
970 return err_msg(errmsg_ill_syntax, 1, f);
971 t = l_cdr(v); /* list of function args */
972 l = list_len(t); /* #args */
973 a = l_cons( v, l_cons( l_cdr(l_car(a)) , l_cdr(a)));
974 #endif
975 /* (defun func (var1 varn) (func content)) */
976 v = l_car(a); /* function name */
977 if (D_GET_TAG(v) != TAG_SYMB)
978 return err_msg(errmsg_ill_syntax, 1, f);
979 t = l_cdr(a); /* list of function arg and function body */
980 l = list_len(l_car(t)); /* #args */
981
982 i = D_GET_DATA(v);
983 t_symb_fval[i] = t;
984 t_symb_ftype[i] = FTYPE(FTYPE_USER, l);
985 break;
986
987 case KW_SETQ:
988 t = l_car(a); /* symbol name */
989 if (D_GET_TAG(t) != TAG_SYMB)
990 return err_msg(errmsg_ill_type, 1, f);
991 if ((v = l_eval(l_car(l_cdr(a)))) < 0) /* value */
992 return -1;
993 t_symb_val[D_GET_DATA(t)] = v;
994 break;
995
996 case KW_QUOTE:
997 v = l_car(a);
998 break;
999
1000 case KW_PROGN:
1001 for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1002 if ((v = l_eval(l_car(t))) < 0)
1003 return -1;
1004 }
1005 break;
1006 #ifndef MINIMALISTIC
1007 case KW_WHILE:
1008 if (D_GET_TAG(a) != TAG_CONS)
1009 return err_msg(errmsg_ill_syntax, 1, f);
1010 if ((v = l_eval(l_car(a))) < 0)
1011 return -1;
1012 while (D_GET_TAG(v) != TAG_NIL) {
1013 for (t = l_cdr(a); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1014 if ((v = l_eval(l_car(t))) < 0)
1015 return -1;
1016 }
1017 v = l_eval(l_car(a));
1018 }
1019 break;
1020 #endif
1021
1022 #ifndef MINIMALISTIC
1023 case KW_AND:
1024 for (v = TAG_T, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1025 if ((v = l_eval(l_car(t))) < 0)
1026 return -1;
1027 if (D_GET_TAG(t) == TAG_NIL)
1028 break;
1029 }
1030 break;
1031 #endif
1032
1033 case KW_OR:
1034 for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1035 if ((v = l_eval(l_car(t))) < 0)
1036 return -1;
1037 if (D_GET_TAG(v) != TAG_NIL)
1038 break;
1039 }
1040 break;
1041
1042 case KW_COND:
1043 if (D_GET_TAG(a) != TAG_CONS)
1044 return err_msg(errmsg_ill_syntax, 1, f);
1045 v = TAG_NIL;
1046 for (t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1047 u = l_car(t);
1048 if (D_GET_TAG(u) != TAG_CONS)
1049 return err_msg(errmsg_ill_syntax, 1, f);
1050 if ((v = l_eval(l_car(u))) < 0)
1051 return -1;
1052 if (D_GET_TAG(v) != TAG_NIL){
1053 for (u = l_cdr(u); D_GET_TAG(u) == TAG_CONS; u = l_cdr(u)){
1054 if ((v = l_eval(l_car(u))) < 0)
1055 return -1;
1056 }
1057 break;
1058 }
1059 }
1060 break;
1061
1062 #ifndef MINIMALISTIC
1063 case KW_COMMENT:
1064 v = TAG_T;
1065 break;
1066 #endif
1067
1068 case KW_IF:
1069 if (D_GET_TAG(a) != TAG_CONS)
1070 return err_msg(errmsg_ill_syntax, 1, f);
1071 l = list_len(a);
1072 if ((l == 2) || (l == 3)){
1073 if ((v = l_eval(l_car(a))) < 0)
1074 return -1;
1075 if (D_GET_TAG(v) != TAG_NIL)
1076 return l_eval(l_car(l_cdr(a)));
1077 return (l == 2) ? TAG_NIL : l_eval(l_car(l_cdr(l_cdr(a))));
1078 } else {
1079 return err_msg(errmsg_ill_syntax, 1, f);
1080 }
1081 break;
1082 }
1083 return v;
1084 }
1085
1086
1087 /* Evaluate arguments */
1088 long
1089 eval_args(long func, long arg, long av[2], int n)
1090 {
1091 long x, y;
1092
1093 if ((n != FTYPE_ANY_ARGS) && (n != list_len(arg)))
1094 return err_msg(errmsg_ill_nargs, 1, func);
1095
1096 switch (n){
1097
1098 case 0:
1099 av[0] = TAG_NIL;
1100 break;
1101
1102 case 1:
1103 if ((av[0] = l_eval(l_car(arg))) < 0)
1104 return -1;
1105 break;
1106
1107 case 2:
1108 if ((av[0] = l_eval(l_car(arg))) < 0)
1109 return -1;
1110 if (gc_protect(av[0]) < 0)
1111 return -1;
1112 if ((av[1] = l_eval(l_car(l_cdr(arg)))) < 0)
1113 return -1;
1114 gc_unprotect(av[0]);
1115 break;
1116
1117 case FTYPE_ANY_ARGS: /* return evaluated arguments as a list */
1118 if (D_GET_TAG(arg) != TAG_CONS){
1119 av[0] = TAG_NIL;
1120 } else {
1121 if ((x = l_eval(l_car(arg))) < 0)
1122 return -1;
1123 if ((av[0] = y = l_cons(x, TAG_NIL)) < 0)
1124 return -1;
1125 if (gc_protect(av[0]) < 0)
1126 return -1;
1127 for (arg = l_cdr(arg); D_GET_TAG(arg) == TAG_CONS; arg = l_cdr(arg)){
1128 if ((x = l_eval(l_car(arg))) < 0)
1129 return -1;
1130 rplacd(y, l_cons(x, TAG_NIL));
1131 y = l_cdr(y);
1132 }
1133 gc_unprotect(av[0]);
1134 }
1135 }
1136 return av[0];
1137 }
1138
1139
1140 /* Call a built-in function */
1141 long
1142 fcall(long f, long av[2]) /*, int n*/
1143 {
1144 long v, t;
1145 long r, d;
1146
1147 switch (D_GET_DATA(f)){
1148 case KW_RPLACA:
1149 case KW_RPLACD:
1150 case KW_CAR:
1151 case KW_CDR:
1152 if (D_GET_TAG(av[0]) != TAG_CONS)
1153 return err_msg(errmsg_ill_type, 1, f);
1154 break;
1155
1156 case KW_GT:
1157 #ifndef MINIMALISTIC
1158 case KW_LT:
1159 case KW_GTE:
1160 case KW_LTE:
1161 case KW_REM:
1162 #endif
1163 if ((D_GET_TAG(av[0]) != TAG_INT) || (D_GET_TAG(av[1]) != TAG_INT))
1164 return err_msg(errmsg_ill_type, 1, f);
1165 break;
1166 #ifndef MINIMALISTIC
1167 case KW_ZEROP:
1168 case KW_RAND:
1169 case KW_INCR:
1170 case KW_DECR:
1171 if (D_GET_TAG(av[0]) != TAG_INT)
1172 return err_msg(errmsg_ill_type, 1, f);
1173 break;
1174 #endif
1175 }
1176
1177 switch (D_GET_DATA(f)){
1178
1179 #ifndef MINIMALISTIC
1180 case KW_LAMBDA:
1181 return err_msg(errmsg_ill_call, 1, f);
1182 break;
1183 #endif
1184
1185 case KW_QUIT:
1186 quit();
1187 break;
1188
1189 case KW_EQ:
1190 #ifndef MINIMALISTIC
1191 case KW_EQMATH:
1192 #endif
1193 v = (av[0] == av[1]) ? TAG_T : TAG_NIL;
1194 break;
1195
1196 #ifndef MINIMALISTIC
1197 case KW_EQUAL:
1198 return l_equal(av[0], av[1]);
1199 #endif
1200
1201 case KW_CONS:
1202 v = l_cons(av[0], av[1]);
1203 break;
1204
1205 case KW_RPLACA:
1206 v = t_cons_car[D_GET_DATA(av[0])] = av[1];
1207 break;
1208
1209 case KW_RPLACD:
1210 v = t_cons_cdr[D_GET_DATA(av[0])] = av[1];
1211 break;
1212
1213 case KW_CAR:
1214 v = l_car(av[0]);
1215 break;
1216
1217 case KW_CDR:
1218 v = l_cdr(av[0]);
1219 break;
1220
1221 case KW_NULL:
1222 v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
1223 break;
1224
1225 case KW_CONSP:
1226 return (D_GET_TAG(av[0]) == TAG_CONS) ? TAG_T : TAG_NIL;
1227
1228 case KW_SYMBP:
1229 return (D_GET_TAG(av[0]) == TAG_SYMB) ? TAG_T : TAG_NIL;
1230
1231 case KW_NUMBERP:
1232 v = (D_GET_TAG(av[0]) == TAG_INT) ? TAG_T : TAG_NIL;
1233 break;
1234
1235 case KW_LIST:
1236 v = av[0];
1237 break;
1238
1239 case KW_NOT:
1240 v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
1241 break;
1242
1243 case KW_READ:
1244 v = l_read();
1245 break;
1246
1247 case KW_EVAL:
1248 v = l_eval(av[0]);
1249 break;
1250
1251 case KW_PRINC:
1252 v = l_print(av[0]);
1253 break;
1254
1255 case KW_TERPRI:
1256 printf("\n");
1257 v = TAG_NIL;
1258 break;
1259
1260 case KW_GC:
1261 gcollect();
1262 v = TAG_T;
1263 break;
1264
1265 case KW_ADD:
1266 for (r = 0, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1267 if (D_GET_TAG(l_car(t)) != TAG_INT)
1268 return err_msg(errmsg_ill_type, 1, f);
1269 r = r + int_get_c(l_car(t));
1270 }
1271 v = int_make_l(r);
1272 break;
1273
1274 case KW_TIMES:
1275 for (r = 1, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1276 if (D_GET_TAG(l_car(t)) != TAG_INT)
1277 return err_msg(errmsg_ill_type, 1, f);
1278 r = r * int_get_c(l_car(t));
1279 }
1280 v = int_make_l(r);
1281 break;
1282
1283 case KW_SUB:
1284 if (D_GET_TAG(av[0]) == TAG_NIL){
1285 r = 0;
1286 } else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
1287 return err_msg(errmsg_ill_type, 1, f);
1288 } else if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
1289 r = 0 - int_get_c(l_car(av[0]));
1290 } else {
1291 r = int_get_c(l_car(av[0]));
1292 for (t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1293 if (D_GET_TAG(l_car(t)) != TAG_INT)
1294 return err_msg(errmsg_ill_type, 1, f);
1295 r = r - int_get_c(l_car(t));
1296 }
1297 }
1298 v = int_make_l(r);
1299 break;
1300
1301 case KW_QUOTIENT:
1302 if (D_GET_TAG(av[0]) == TAG_NIL){
1303 r = 1;
1304 } else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
1305 return err_msg(errmsg_ill_type, 1, f);
1306 } else if ((d = int_get_c(l_car(av[0]))) == 0){
1307 return err_msg(errmsg_zero_div, 1, f);
1308 } if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
1309 r = 1 / d;
1310 } else {
1311 for (r = d, t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
1312 if (D_GET_TAG(l_car(t)) != TAG_INT)
1313 return err_msg(errmsg_ill_type, 1, f);
1314 if ((d = int_get_c(l_car(t))) == 0)
1315 return err_msg(errmsg_zero_div, 1, f);
1316 r = r / d;
1317 }
1318 }
1319 v = int_make_l(r);
1320 break;
1321
1322 case KW_GT:
1323 v = (int_get_c(av[0]) > int_get_c(av[1])) ? TAG_T : TAG_NIL;
1324 break;
1325
1326
1327 #ifndef MINIMALISTIC
1328
1329 case KW_DIVIDE:
1330 r = int_get_c(av[0]);
1331 if ((d = int_get_c(av[1])) == 0)
1332 return err_msg(errmsg_zero_div, 1, f);
1333 v = l_cons(int_make_l(r / d), int_make_l(r % d));
1334 break;
1335
1336 case KW_LT:
1337 v = (int_get_c(av[0]) < int_get_c(av[1])) ? TAG_T : TAG_NIL;
1338 break;
1339
1340 case KW_ATOM:
1341 v = (D_GET_TAG(av[0]) != TAG_CONS) ? TAG_T : TAG_NIL;
1342 break;
1343
1344 case KW_GTE:
1345 v = (int_get_c(av[0]) >= int_get_c(av[1])) ? TAG_T : TAG_NIL;
1346 break;
1347
1348 case KW_LTE:
1349 v = (int_get_c(av[0]) <= int_get_c(av[1])) ? TAG_T : TAG_NIL;
1350 break;
1351
1352 case KW_ZEROP:
1353 v = (int_get_c(av[0]) == 0) ? TAG_T : TAG_NIL;
1354 break;
1355
1356 case KW_RAND:
1357 v = int_make_l(rand() % int_get_c(av[0]));
1358 break;
1359
1360 case KW_INCR:
1361 v = int_make_l(int_get_c(av[0])+1);
1362 break;
1363
1364 case KW_DECR:
1365 v = int_make_l(int_get_c(av[0])-1);
1366 break;
1367
1368 case KW_REM:
1369 r = int_get_c(av[0]);
1370 if ((d = int_get_c(av[1])) == 0)
1371 return err_msg(errmsg_zero_div, 1, f);
1372 v = int_make_l(r % d);
1373 break;
1374
1375 #endif
1376
1377 #ifdef GRAPHICS
1378 case KW_CLS:
1379 plot(0,getmaxy());
1380 printf("\014");
1381 clg();
1382 pen_up();
1383 set_direction (T_NORTH);
1384 break;
1385 case KW_PENU:
1386 pen_up();
1387 break;
1388 case KW_PEND:
1389 pen_down();
1390 break;
1391 case KW_RIGHT:
1392 turn_right((int)int_get_c(av[0]));
1393 break;
1394 case KW_LEFT:
1395 turn_left((int)int_get_c(av[0]));
1396 break;
1397 case KW_FWD:
1398 fwd((int)int_get_c(av[0]));
1399 break;
1400 #endif
1401
1402 #ifdef FILES
1403 case KW_LOAD:
1404 v = l_load(av[0]);
1405 break;
1406 #endif
1407
1408 }
1409
1410 return v;
1411 }
1412
1413
1414 /* Function application (user defined function) */
1415 long
1416 apply(long func, long aparams, int n)
1417 {
1418 long fdef, fbody, f, sym, a, v;
1419 int i;
1420
1421 #ifdef ZX81_32K
1422 /*
1423 ..almost useless, let's save space
1424 #asm
1425 ld hl,0
1426 add hl,sp
1427 ld (__sp),hl
1428 #endasm
1429 if (200 + &t_stack[t_stack_ptr]>=_sp)
1430 return err_msg(errmsg_stack_of, 0, 0);
1431 */
1432 #else
1433 if (t_stack_ptr + n > STACK_SIZE) /* stack overflow */
1434 return err_msg(errmsg_stack_of, 0, 0);
1435 #endif
1436
1437 if (D_GET_TAG(func) == TAG_SYMB){ /* function symbol */
1438 fdef = t_symb_fval[D_GET_DATA(func)];
1439 } else if (D_GET_TAG(func) == TAG_CONS){ /* lambda exp */
1440 fdef = func;
1441 }
1442
1443 /* bind */
1444 f = l_car(fdef); /* formal parameters */
1445 a = aparams; /* actual parameters */
1446 t_stack_ptr = t_stack_ptr + n;
1447 for (i = 0; i < n; i++, f = l_cdr(f), a = l_cdr(a)){
1448 sym = l_car(f);
1449 /* push old symbol values onto stack */
1450 t_stack[t_stack_ptr - i - 1] = t_symb_val[D_GET_DATA(sym)];
1451 /* bind argument value to symbol */
1452 t_symb_val[D_GET_DATA(sym)] = l_car(a);
1453 }
1454
1455 if (gc_protect(aparams) < 0)
1456 return -1;
1457
1458 /* evaluate function body */
1459 fbody = l_cdr(fdef); /* function body */
1460 for (v = TAG_NIL; D_GET_TAG(fbody) == TAG_CONS; fbody = l_cdr(fbody)){
1461 if ((v = l_eval(l_car(fbody))) < 0)
1462 break; /* error ... never return immediately - need unbinding. */
1463 }
1464
1465 /* pop gc_protected objects, including 'gc_unprotect(aparams)'. */
1466 while ((t_stack[t_stack_ptr-1] & D_GC_MARK) != 0)
1467 --t_stack_ptr;
1468
1469 /* unbind: restore old variable values from stack */
1470 for (i = 0, f = l_car(fdef); i < n; i++, f = l_cdr(f)){
1471 sym = l_car(f);
1472 t_symb_val[D_GET_DATA(sym)] = t_stack[t_stack_ptr - i - 1];
1473 }
1474 t_stack_ptr = t_stack_ptr - n;
1475
1476 return v;
1477 }
1478
1479
1480 /* Print an error message */
1481 char
1482 err_msg(char *msg, char f, long s)
1483 {
1484 printf("\nERROR. \n%s", msg);
1485 if (f != 0)
1486 l_print(s);
1487 printf("\n");
1488 return -1;
1489 }
1490
1491 /* Length of a list */
1492 int
1493 list_len(long s)
1494 {
1495 int i;
1496
1497 for (i = 0; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s))
1498 i++;
1499 return i;
1500 }
1501
1502 /* "Replace cdr" operation ... rewite cdr part of a cons cell */
1503 void
1504 rplacd(long s, long cdr)
1505 {
1506 t_cons_cdr[D_GET_DATA(s)] = cdr;
1507 }
1508
1509
1510 /* "Cons" operation */
1511 long
1512 l_cons(long car, long cdr)
1513 {
1514 int s;
1515
1516 if (t_cons_free < 0){ /* no cons cells */
1517 if (gc_protect(car) < 0)
1518 return -1;
1519 if (gc_protect(cdr) < 0)
1520 return -1;
1521 gcollect(); /* invoke garbage collector */
1522 gc_unprotect(cdr);
1523 gc_unprotect(car);
1524 }
1525
1526 /* get a free cons cell from a free list */
1527 s = t_cons_free;
1528 if (t_cons_car[t_cons_free] != t_cons_free)
1529 t_cons_free = t_cons_car[t_cons_free]; /* next free cell */
1530 else
1531 t_cons_free = -1; /* self-loop: end of free list */
1532
1533 /* constract a new cell */
1534 t_cons_car[s] = car;
1535 t_cons_cdr[s] = cdr;
1536
1537 return (TAG_CONS | s);
1538 }
1539
1540 /* "Car" operation */
1541 long
1542 l_car(long s)
1543 {
1544 return t_cons_car[D_GET_DATA(s)];
1545 }
1546
1547 /* "Cdr" operation */
1548 long
1549 l_cdr(long s)
1550 {
1551 return t_cons_cdr[D_GET_DATA(s)];
1552 }
1553
1554
1555 /* Garbage collector */
1556 void
1557 gcollect(void)
1558 {
1559 int i, n, p;
1560
1561 /* mark */
1562 for (i = 0; i < t_symb_free; i++)
1563 gc_mark(t_symb_val[i]);
1564 for (i = 0; i < t_symb_free; i++)
1565 gc_mark(t_symb_fval[i]);
1566 for (i = 0; i < t_stack_ptr; i++)
1567 gc_mark(t_stack[i]);
1568
1569 /* sweep */
1570 p=0;
1571 t_cons_free = -1;
1572 for (i = 0, n = 0; i != NCONS; i++){
1573 if ((t_cons_car[i] & D_GC_MARK) == 0){ /* collect */
1574 n++;
1575 if (t_cons_free == -1){
1576 t_cons_free = i;
1577 } else {
1578 t_cons_car[p] = i;
1579 }
1580 t_cons_car[i] = i;
1581 p = i;
1582 }
1583 t_cons_car[i] &= ~D_GC_MARK; /* clear mark */
1584 }
1585
1586 if (n == 0){ /* no more cells... */
1587 printf(errmsg_no_memory);
1588 quit();
1589 }
1590 }
1591
1592 /* mark recursively */
1593 void
1594 gc_mark(long s)
1595 {
1596 for ( ; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s)){
1597 if ((t_cons_car[D_GET_DATA(s)] & D_GC_MARK) != 0) /* visited before */
1598 return;
1599 t_cons_car[D_GET_DATA(s)] |= D_GC_MARK; /* mark */
1600 gc_mark(l_car(s)); /* visit car part */
1601 }
1602 }
1603
1604 /* protect/unprotect temporary objects from garbage collector */
1605 char
1606 gc_protect(long s)
1607 {
1608 #ifdef ZX81_32K
1609 #asm
1610 ld hl,0
1611 add hl,sp
1612 ld (__sp),hl
1613 #endasm
1614 if (200 + &t_stack[t_stack_ptr]>=_sp) /* stack overflow */
1615 return err_msg(errmsg_stack_of, 0, 0);
1616 if (D_GET_TAG(s) == TAG_CONS){ /* save only cons cells */
1617 t_stack[t_stack_ptr++] = (D_GC_MARK | s);
1618 #else
1619 if (D_GET_TAG(s) == TAG_CONS){ /* save only cons cells */
1620 if (t_stack_ptr >= STACK_SIZE) /* stack overflow */
1621 return err_msg(errmsg_stack_of, 0, 0);
1622 t_stack[t_stack_ptr++] = (D_GC_MARK | s);
1623 #endif
1624 }
1625 return 0;
1626 }
1627
1628 void
1629 gc_unprotect(long s)
1630 {
1631 if (D_GET_TAG(s) == TAG_CONS)
1632 --t_stack_ptr;
1633 }
1634
1635
1636 /* Make a Lisp integer from a C integer */
1637 long
1638 int_make_l(long v)
1639 {
1640 return (TAG_INT | ((unsigned long)v & D_MASK_DATA));
1641 }
1642
1643 /* Make a C integer from a Lisp integer */
1644 long
1645 int_get_c(long s)
1646 {
1647 if (((unsigned long)s & D_INT_SIGN_BIT) == 0)
1648 return ((unsigned long)s & D_MASK_DATA);
1649 return (long) ((unsigned long)s | ~D_MASK_DATA);
1650 }
1651
1652 #endif //INITONLY
1653
1654 /* Make a new symbol */
1655 long
1656 symb_make(char *p)
1657 {
1658 int i, s;
1659
1660 for (i = 0; i != NSYMBS-1; i++){
1661 if ((t_symb_pname[i] != NULL) && (strcmp(p, t_symb_pname[i]) == 0))
1662 return i;
1663 }
1664
1665 s = t_symb_free;
1666 t_symb_free++;
1667 if (t_symb_free == NSYMBS){
1668 printf(errmsg_no_memory);
1669 quit();
1670 }
1671
1672 t_symb_pname[s] = &t_pnames[t_pnames_free];
1673 t_symb_val[s] = TAG_UNDEF; /* undefined value */
1674 t_symb_fval[s] = TAG_UNDEF; /* undefined value */
1675 t_symb_ftype[s] = FTYPE_UNDEF; /* undefined type */
1676
1677 do {
1678 if (t_pnames_free == PNAME_SIZE){
1679 printf(errmsg_no_memory);
1680 quit();
1681 }
1682 t_pnames[t_pnames_free] = tolower(*p); t_pnames_free++; p++;
1683 } while (*p != '\0');
1684 t_pnames[t_pnames_free] = '\0'; t_pnames_free++;
1685
1686 return (TAG_SYMB | s);
1687 }
1688
1689
1690
1691 /* Load a LISP source file */
1692
1693 #ifdef FILES
1694 long
1695 l_load(long s)
1696 {
1697 if (D_GET_TAG(s)!=TAG_SYMB)
1698 return err_msg(errmsg_ill_type, 1, s);
1699
1700 if ((fpin = fopen(t_symb_pname[s & D_MASK_DATA],"r"))==NULL)
1701 return TAG_NIL;
1702
1703 c = 1;
1704 return TAG_T;
1705 }
1706 #endif
1707
1708
1709 /* Quit micro lisp */
1710 void
1711 quit(void)
1712 {
1713 printf("\nBYE\n");
1714 exit(0);
1715 }
1716
1717 /* END */
1718