ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
Revision: 1.18
Committed: Thu Nov 26 21:32:16 2015 UTC (8 years, 6 months ago) by root
Content type: text/plain
Branch: MAIN
Changes since 1.17: +81 -88 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 /*
2 * µscheme
3 *
4 * Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
5 * do as you want with this, attribution appreciated.
6 *
7 * Based opn tinyscheme-1.41 (original credits follow)
8 * Dimitrios Souflis (dsouflis@acm.org)
9 * Based on MiniScheme (original credits follow)
10 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
11 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
12 * (MINISCM) This version has been modified by R.C. Secrist.
13 * (MINISCM)
14 * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
15 * (MINISCM)
16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 *
19 */
20
21 #define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22 #include "malloc.c"
23
24 #define SCHEME_SOURCE
25 #include "scheme-private.h"
26 #ifndef WIN32
27 # include <unistd.h>
28 #endif
29 #if USE_MATH
30 # include <math.h>
31 #endif
32
33 #include <sys/types.h>
34 #include <sys/stat.h>
35 #include <fcntl.h>
36
37 #include <string.h>
38 #include <stdlib.h>
39
40 #include <limits.h>
41 #include <inttypes.h>
42 #include <float.h>
43 //#include <ctype.h>
44
45 enum {
46 TOK_EOF,
47 TOK_LPAREN,
48 TOK_RPAREN,
49 TOK_DOT,
50 TOK_ATOM,
51 TOK_QUOTE,
52 TOK_DQUOTE,
53 TOK_BQUOTE,
54 TOK_COMMA,
55 TOK_ATMARK,
56 TOK_SHARP,
57 TOK_SHARP_CONST,
58 TOK_VEC
59 };
60
61 #define BACKQUOTE '`'
62 #define DELIMITERS "()\";\f\t\v\n\r "
63
64 #define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
65 #define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66 #define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67 #define S_SINK (&SCHEME_V->xsink)
68 #define S_EOF (&SCHEME_V->xEOF_OBJ)
69
70 /* should use libecb */
71 #if __GNUC__ >= 4
72 # define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73 # define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74 # define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
75 #else
76 # define ecb_expect_false(expr) !!(expr)
77 # define ecb_expect_true(expr) !!(expr)
78 #endif
79
80 #if !USE_MULTIPLICITY
81 static scheme sc;
82 #endif
83
84 static void
85 xbase (char *s, long n, int base)
86 {
87 if (n < 0)
88 {
89 *s++ = '-';
90 n = -n;
91 }
92
93 char *p = s;
94
95 do {
96 *p++ = '0' + n % base;
97 n /= base;
98 } while (n);
99
100 *p-- = 0;
101
102 while (p > s)
103 {
104 char x = *s; *s = *p; *p = x;
105 --p; ++s;
106 }
107 }
108
109 static void
110 xnum (char *s, long n)
111 {
112 xbase (s, n, 10);
113 }
114
115 static void
116 xwrstr (const char *s)
117 {
118 write (1, s, strlen (s));
119 }
120
121 static void
122 xwrnum (long n)
123 {
124 char buf[64];
125
126 xnum (buf, n);
127 xwrstr (buf);
128 }
129
130 static char
131 xtoupper (char c)
132 {
133 if (c >= 'a' && c <= 'z')
134 c -= 'a' - 'A';
135
136 return c;
137 }
138
139 static char
140 xtolower (char c)
141 {
142 if (c >= 'A' && c <= 'Z')
143 c += 'a' - 'A';
144
145 return c;
146 }
147
148 static int
149 xisdigit (char c)
150 {
151 return c >= '0' && c <= '9';
152 }
153
154 #define toupper(c) xtoupper (c)
155 #define tolower(c) xtolower (c)
156 #define isdigit(c) xisdigit (c)
157
158 #if USE_STRLWR
159 static const char *
160 strlwr (char *s)
161 {
162 const char *p = s;
163
164 while (*s)
165 {
166 *s = tolower (*s);
167 s++;
168 }
169
170 return p;
171 }
172 #endif
173
174 #define stricmp(a,b) strcmp (a, b)
175 #define strlwr(s) (s)
176
177 #ifndef prompt
178 # define prompt "ts> "
179 #endif
180
181 #ifndef InitFile
182 # define InitFile "init.scm"
183 #endif
184
185 #ifndef FIRST_CELLSEGS
186 # define FIRST_CELLSEGS 3
187 #endif
188
189 enum scheme_types
190 {
191 T_FREE,
192 T_STRING,
193 T_NUMBER,
194 T_SYMBOL,
195 T_PROC,
196 T_PAIR,
197 T_CLOSURE,
198 T_CONTINUATION,
199 T_FOREIGN,
200 T_CHARACTER,
201 T_PORT,
202 T_VECTOR,
203 T_MACRO,
204 T_PROMISE,
205 T_ENVIRONMENT,
206 /* one more... */
207 T_NUM_SYSTEM_TYPES
208 };
209
210 #define T_MASKTYPE 0x000f
211 #define T_SYNTAX 0x0010
212 #define T_IMMUTABLE 0x0020
213 #define T_ATOM 0x0040 /* only for gc */
214 #define T_MARK 0x0080 /* only for gc */
215
216 enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
217
218 static num num_op (enum num_op op, num a, num b);
219 static num num_intdiv (num a, num b);
220 static num num_rem (num a, num b);
221 static num num_mod (num a, num b);
222
223 #if USE_MATH
224 static double round_per_R5RS (double x);
225 #endif
226 static int is_zero_rvalue (RVALUE x);
227
228 static INLINE int
229 num_is_integer (pointer p)
230 {
231 return num_is_fixnum (p->object.number);
232 }
233
234 static num num_zero;
235 static num num_one;
236
237 /* macros for cell operations */
238 #define typeflag(p) ((p)->flag + 0)
239 #define set_typeflag(p,v) ((p)->flag = (v))
240 #define type(p) (typeflag (p) & T_MASKTYPE)
241
242 INTERFACE INLINE int
243 is_string (pointer p)
244 {
245 return type (p) == T_STRING;
246 }
247
248 #define strvalue(p) ((p)->object.string.svalue)
249 #define strlength(p) ((p)->object.string.length)
250
251 INTERFACE int is_list (SCHEME_P_ pointer p);
252 INTERFACE INLINE int
253 is_vector (pointer p)
254 {
255 return type (p) == T_VECTOR;
256 }
257
258 #define vecvalue(p) ((p)->object.vector.vvalue)
259 #define veclength(p) ((p)->object.vector.length)
260 INTERFACE void fill_vector (pointer vec, pointer obj);
261 INTERFACE uint32_t vector_length (pointer vec);
262 INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
263 INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
264
265 INTERFACE uint32_t
266 vector_length (pointer vec)
267 {
268 return vec->object.vector.length;
269 }
270
271 INTERFACE INLINE int
272 is_number (pointer p)
273 {
274 return type (p) == T_NUMBER;
275 }
276
277 INTERFACE INLINE int
278 is_integer (pointer p)
279 {
280 if (!is_number (p))
281 return 0;
282
283 if (num_is_integer (p) || ivalue (p) == rvalue (p))
284 return 1;
285
286 return 0;
287 }
288
289 INTERFACE INLINE int
290 is_real (pointer p)
291 {
292 return is_number (p) && !num_is_fixnum (p->object.number);
293 }
294
295 INTERFACE INLINE int
296 is_character (pointer p)
297 {
298 return type (p) == T_CHARACTER;
299 }
300
301 INTERFACE INLINE char *
302 string_value (pointer p)
303 {
304 return strvalue (p);
305 }
306
307 INLINE num
308 nvalue (pointer p)
309 {
310 return (p)->object.number;
311 }
312
313 static IVALUE
314 num_get_ivalue (const num n)
315 {
316 return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
317 }
318
319 static RVALUE
320 num_get_rvalue (const num n)
321 {
322 return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
323 }
324
325 INTERFACE IVALUE
326 ivalue (pointer p)
327 {
328 return num_get_ivalue (p->object.number);
329 }
330
331 INTERFACE RVALUE
332 rvalue (pointer p)
333 {
334 return num_get_rvalue (p->object.number);
335 }
336
337 #define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
338 #if USE_REAL
339 # define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
340 # define set_num_integer(p) (p)->object.number.is_fixnum=1;
341 # define set_num_real(p) (p)->object.number.is_fixnum=0;
342 #else
343 # define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
344 # define set_num_integer(p) 0
345 # define set_num_real(p) 0
346 #endif
347 INTERFACE long
348 charvalue (pointer p)
349 {
350 return ivalue_unchecked (p);
351 }
352
353 INTERFACE INLINE int
354 is_port (pointer p)
355 {
356 return type (p) == T_PORT;
357 }
358
359 INTERFACE INLINE int
360 is_inport (pointer p)
361 {
362 return is_port (p) && p->object.port->kind & port_input;
363 }
364
365 INTERFACE INLINE int
366 is_outport (pointer p)
367 {
368 return is_port (p) && p->object.port->kind & port_output;
369 }
370
371 INTERFACE INLINE int
372 is_pair (pointer p)
373 {
374 return type (p) == T_PAIR;
375 }
376
377 #define car(p) ((p)->object.cons.car + 0)
378 #define cdr(p) ((p)->object.cons.cdr + 0)
379
380 static pointer caar (pointer p) { return car (car (p)); }
381 static pointer cadr (pointer p) { return car (cdr (p)); }
382 static pointer cdar (pointer p) { return cdr (car (p)); }
383 static pointer cddr (pointer p) { return cdr (cdr (p)); }
384
385 static pointer cadar (pointer p) { return car (cdr (car (p))); }
386 static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
387 static pointer cdaar (pointer p) { return cdr (car (car (p))); }
388
389 INTERFACE void
390 set_car (pointer p, pointer q)
391 {
392 p->object.cons.car = q;
393 }
394
395 INTERFACE void
396 set_cdr (pointer p, pointer q)
397 {
398 p->object.cons.cdr = q;
399 }
400
401 INTERFACE pointer
402 pair_car (pointer p)
403 {
404 return car (p);
405 }
406
407 INTERFACE pointer
408 pair_cdr (pointer p)
409 {
410 return cdr (p);
411 }
412
413 INTERFACE INLINE int
414 is_symbol (pointer p)
415 {
416 return type (p) == T_SYMBOL;
417 }
418
419 INTERFACE INLINE char *
420 symname (pointer p)
421 {
422 return strvalue (car (p));
423 }
424
425 #if USE_PLIST
426 SCHEME_EXPORT INLINE int
427 hasprop (pointer p)
428 {
429 return typeflag (p) & T_SYMBOL;
430 }
431
432 # define symprop(p) cdr(p)
433 #endif
434
435 INTERFACE INLINE int
436 is_syntax (pointer p)
437 {
438 return typeflag (p) & T_SYNTAX;
439 }
440
441 INTERFACE INLINE int
442 is_proc (pointer p)
443 {
444 return type (p) == T_PROC;
445 }
446
447 INTERFACE INLINE int
448 is_foreign (pointer p)
449 {
450 return type (p) == T_FOREIGN;
451 }
452
453 INTERFACE INLINE char *
454 syntaxname (pointer p)
455 {
456 return strvalue (car (p));
457 }
458
459 #define procnum(p) ivalue (p)
460 static const char *procname (pointer x);
461
462 INTERFACE INLINE int
463 is_closure (pointer p)
464 {
465 return type (p) == T_CLOSURE;
466 }
467
468 INTERFACE INLINE int
469 is_macro (pointer p)
470 {
471 return type (p) == T_MACRO;
472 }
473
474 INTERFACE INLINE pointer
475 closure_code (pointer p)
476 {
477 return car (p);
478 }
479
480 INTERFACE INLINE pointer
481 closure_env (pointer p)
482 {
483 return cdr (p);
484 }
485
486 INTERFACE INLINE int
487 is_continuation (pointer p)
488 {
489 return type (p) == T_CONTINUATION;
490 }
491
492 #define cont_dump(p) cdr (p)
493 #define set_cont_dump(p,v) set_cdr ((p), (v))
494
495 /* To do: promise should be forced ONCE only */
496 INTERFACE INLINE int
497 is_promise (pointer p)
498 {
499 return type (p) == T_PROMISE;
500 }
501
502 INTERFACE INLINE int
503 is_environment (pointer p)
504 {
505 return type (p) == T_ENVIRONMENT;
506 }
507
508 #define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
509
510 #define is_atom(p) (typeflag (p) & T_ATOM)
511 #define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
512 #define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
513
514 #define is_mark(p) (typeflag (p) & T_MARK)
515 #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
516 #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
517
518 INTERFACE INLINE int
519 is_immutable (pointer p)
520 {
521 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
522 }
523
524 INTERFACE INLINE void
525 setimmutable (pointer p)
526 {
527 #if USE_ERROR_CHECKING
528 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
529 #endif
530 }
531
532 #if USE_CHAR_CLASSIFIERS
533 static INLINE int
534 Cisalpha (int c)
535 {
536 return isascii (c) && isalpha (c);
537 }
538
539 static INLINE int
540 Cisdigit (int c)
541 {
542 return isascii (c) && isdigit (c);
543 }
544
545 static INLINE int
546 Cisspace (int c)
547 {
548 return isascii (c) && isspace (c);
549 }
550
551 static INLINE int
552 Cisupper (int c)
553 {
554 return isascii (c) && isupper (c);
555 }
556
557 static INLINE int
558 Cislower (int c)
559 {
560 return isascii (c) && islower (c);
561 }
562 #endif
563
564 #if USE_ASCII_NAMES
565 static const char *charnames[32] = {
566 "nul",
567 "soh",
568 "stx",
569 "etx",
570 "eot",
571 "enq",
572 "ack",
573 "bel",
574 "bs",
575 "ht",
576 "lf",
577 "vt",
578 "ff",
579 "cr",
580 "so",
581 "si",
582 "dle",
583 "dc1",
584 "dc2",
585 "dc3",
586 "dc4",
587 "nak",
588 "syn",
589 "etb",
590 "can",
591 "em",
592 "sub",
593 "esc",
594 "fs",
595 "gs",
596 "rs",
597 "us"
598 };
599
600 static int
601 is_ascii_name (const char *name, int *pc)
602 {
603 int i;
604
605 for (i = 0; i < 32; i++)
606 {
607 if (stricmp (name, charnames[i]) == 0)
608 {
609 *pc = i;
610 return 1;
611 }
612 }
613
614 if (stricmp (name, "del") == 0)
615 {
616 *pc = 127;
617 return 1;
618 }
619
620 return 0;
621 }
622
623 #endif
624
625 static int file_push (SCHEME_P_ const char *fname);
626 static void file_pop (SCHEME_P);
627 static int file_interactive (SCHEME_P);
628 static INLINE int is_one_of (char *s, int c);
629 static int alloc_cellseg (SCHEME_P_ int n);
630 static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
631 static void finalize_cell (SCHEME_P_ pointer a);
632 static int count_consecutive_cells (pointer x, int needed);
633 static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
634 static pointer mk_number (SCHEME_P_ const num n);
635 static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
636 static pointer mk_vector (SCHEME_P_ uint32_t len);
637 static pointer mk_atom (SCHEME_P_ char *q);
638 static pointer mk_sharp_const (SCHEME_P_ char *name);
639
640 #if USE_PORTS
641 static pointer mk_port (SCHEME_P_ port *p);
642 static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
643 static pointer port_from_file (SCHEME_P_ int, int prop);
644 static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
645 static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
646 static port *port_rep_from_file (SCHEME_P_ int, int prop);
647 static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
648 static void port_close (SCHEME_P_ pointer p, int flag);
649 #endif
650 static void mark (pointer a);
651 static void gc (SCHEME_P_ pointer a, pointer b);
652 static int basic_inchar (port *pt);
653 static int inchar (SCHEME_P);
654 static void backchar (SCHEME_P_ int c);
655 static char *readstr_upto (SCHEME_P_ char *delim);
656 static pointer readstrexp (SCHEME_P);
657 static INLINE int skipspace (SCHEME_P);
658 static int token (SCHEME_P);
659 static void printslashstring (SCHEME_P_ char *s, int len);
660 static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
661 static void printatom (SCHEME_P_ pointer l, int f);
662 static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
663 static pointer mk_closure (SCHEME_P_ pointer c, pointer e);
664 static pointer mk_continuation (SCHEME_P_ pointer d);
665 static pointer reverse (SCHEME_P_ pointer a);
666 static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
667 static pointer revappend (SCHEME_P_ pointer a, pointer b);
668 static pointer ss_get_cont (SCHEME_P);
669 static void ss_set_cont (SCHEME_P_ pointer cont);
670 static void dump_stack_mark (SCHEME_P);
671 static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
672 static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);
673 static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
674 static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
675 static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
676 static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
677 static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
678 static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
679 static void assign_syntax (SCHEME_P_ const char *name);
680 static int syntaxnum (pointer p);
681 static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
682
683 static num
684 num_op (enum num_op op, num a, num b)
685 {
686 num ret;
687
688 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
689
690 if (num_is_fixnum (ret))
691 {
692 IVALUE av = num_get_ivalue (a);
693 IVALUE bv = num_get_ivalue (b);
694
695 switch (op)
696 {
697 case NUM_ADD: av += bv; break;
698 case NUM_SUB: av -= bv; break;
699 case NUM_MUL: av *= bv; break;
700 case NUM_INTDIV: av /= bv; break;
701 }
702
703 num_set_ivalue (ret, av);
704 }
705 else
706 {
707 RVALUE av = num_get_rvalue (a);
708 RVALUE bv = num_get_rvalue (b);
709
710 switch (op)
711 {
712 case NUM_ADD: av += bv; break;
713 case NUM_SUB: av -= bv; break;
714 case NUM_MUL: av *= bv; break;
715 case NUM_INTDIV: av /= bv; break;
716 }
717
718 num_set_rvalue (ret, av);
719 }
720
721 return ret;
722 }
723
724 static num
725 num_div (num a, num b)
726 {
727 num ret;
728
729 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0);
730
731 if (num_is_fixnum (ret))
732 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
733 else
734 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
735
736 return ret;
737 }
738
739 static num
740 num_rem (num a, num b)
741 {
742 num ret;
743 long e1, e2, res;
744
745 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
746 e1 = num_get_ivalue (a);
747 e2 = num_get_ivalue (b);
748 res = e1 % e2;
749
750 /* remainder should have same sign as second operand */
751 if (res > 0)
752 {
753 if (e1 < 0)
754 res -= labs (e2);
755 }
756 else if (res < 0)
757 {
758 if (e1 > 0)
759 res += labs (e2);
760 }
761
762 num_set_ivalue (ret, res);
763 return ret;
764 }
765
766 static num
767 num_mod (num a, num b)
768 {
769 num ret;
770 long e1, e2, res;
771
772 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
773 e1 = num_get_ivalue (a);
774 e2 = num_get_ivalue (b);
775 res = e1 % e2;
776
777 /* modulo should have same sign as second operand */
778 if (res * e2 < 0)
779 res += e2;
780
781 num_set_ivalue (ret, res);
782 return ret;
783 }
784
785 /* this completely disrespects NaNs */
786 static int
787 num_cmp (num a, num b)
788 {
789 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
790 int ret;
791
792 if (is_fixnum)
793 {
794 IVALUE av = num_get_ivalue (a);
795 IVALUE bv = num_get_ivalue (b);
796
797 ret = av == bv ? 0 : av < bv ? -1 : +1;
798 }
799 else
800 {
801 RVALUE av = num_get_rvalue (a);
802 RVALUE bv = num_get_rvalue (b);
803
804 ret = av == bv ? 0 : av < bv ? -1 : +1;
805 }
806
807 return ret;
808 }
809
810 #if USE_MATH
811
812 /* Round to nearest. Round to even if midway */
813 static double
814 round_per_R5RS (double x)
815 {
816 double fl = floor (x);
817 double ce = ceil (x);
818 double dfl = x - fl;
819 double dce = ce - x;
820
821 if (dfl > dce)
822 return ce;
823 else if (dfl < dce)
824 return fl;
825 else
826 {
827 if (fmod (fl, 2) == 0) /* I imagine this holds */
828 return fl;
829 else
830 return ce;
831 }
832 }
833 #endif
834
835 static int
836 is_zero_rvalue (RVALUE x)
837 {
838 #if USE_REAL
839 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
840 #else
841 return x == 0;
842 #endif
843 }
844
845 /* allocate new cell segment */
846 static int
847 alloc_cellseg (SCHEME_P_ int n)
848 {
849 pointer newp;
850 pointer last;
851 pointer p;
852 char *cp;
853 long i;
854 int k;
855
856 static int segsize = CELL_SEGSIZE >> 1;
857 segsize <<= 1;
858
859 for (k = 0; k < n; k++)
860 {
861 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
862 return k;
863
864 cp = malloc (segsize * sizeof (struct cell));
865
866 if (!cp && USE_ERROR_CHECKING)
867 return k;
868
869 i = ++SCHEME_V->last_cell_seg;
870 SCHEME_V->alloc_seg[i] = cp;
871
872 /* insert new segment in address order */
873 newp = (pointer)cp;
874 SCHEME_V->cell_seg[i] = newp;
875 SCHEME_V->cell_segsize[i] = segsize;
876
877 //TODO: insert, not swap
878 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
879 {
880 p = SCHEME_V->cell_seg[i];
881 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
882 SCHEME_V->cell_seg[i - 1] = p;
883
884 k = SCHEME_V->cell_segsize[i];
885 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
886 SCHEME_V->cell_segsize[i - 1] = k;
887
888 --i;
889 }
890
891 SCHEME_V->fcells += segsize;
892 last = newp + segsize - 1;
893
894 for (p = newp; p <= last; p++)
895 {
896 set_typeflag (p, T_FREE);
897 set_car (p, NIL);
898 set_cdr (p, p + 1);
899 }
900
901 /* insert new cells in address order on free list */
902 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
903 {
904 set_cdr (last, SCHEME_V->free_cell);
905 SCHEME_V->free_cell = newp;
906 }
907 else
908 {
909 p = SCHEME_V->free_cell;
910
911 while (cdr (p) != NIL && newp > cdr (p))
912 p = cdr (p);
913
914 set_cdr (last, cdr (p));
915 set_cdr (p, newp);
916 }
917 }
918
919 return n;
920 }
921
922 /* get new cell. parameter a, b is marked by gc. */
923 static INLINE pointer
924 get_cell_x (SCHEME_P_ pointer a, pointer b)
925 {
926 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
927 {
928 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
929 return S_SINK;
930
931 if (SCHEME_V->free_cell == NIL)
932 {
933 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8;
934
935 gc (SCHEME_A_ a, b);
936
937 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
938 {
939 /* if only a few recovered, get more to avoid fruitless gc's */
940 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL)
941 {
942 #if USE_ERROR_CHECKING
943 SCHEME_V->no_memory = 1;
944 return S_SINK;
945 #endif
946 }
947 }
948 }
949 }
950
951 {
952 pointer x = SCHEME_V->free_cell;
953
954 SCHEME_V->free_cell = cdr (x);
955 --SCHEME_V->fcells;
956 return x;
957 }
958 }
959
960 /* To retain recent allocs before interpreter knows about them -
961 Tehom */
962
963 static void
964 push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
965 {
966 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
967
968 set_typeflag (holder, T_PAIR);
969 setimmutable (holder);
970 set_car (holder, recent);
971 set_cdr (holder, car (S_SINK));
972 set_car (S_SINK, holder);
973 }
974
975 static pointer
976 get_cell (SCHEME_P_ pointer a, pointer b)
977 {
978 pointer cell = get_cell_x (SCHEME_A_ a, b);
979
980 /* For right now, include "a" and "b" in "cell" so that gc doesn't
981 think they are garbage. */
982 /* Tentatively record it as a pair so gc understands it. */
983 set_typeflag (cell, T_PAIR);
984 set_car (cell, a);
985 set_cdr (cell, b);
986 push_recent_alloc (SCHEME_A_ cell, NIL);
987
988 return cell;
989 }
990
991 static pointer
992 get_vector_object (SCHEME_P_ uint32_t len, pointer init)
993 {
994 pointer v = get_cell_x (SCHEME_A_ 0, 0);
995 pointer *e = malloc (len * sizeof (pointer));
996
997 if (!e && USE_ERROR_CHECKING)
998 return S_SINK;
999
1000 /* Record it as a vector so that gc understands it. */
1001 set_typeflag (v, T_VECTOR | T_ATOM);
1002
1003 v->object.vector.vvalue = e;
1004 v->object.vector.length = len;
1005 fill_vector (v, init);
1006 push_recent_alloc (SCHEME_A_ v, NIL);
1007
1008 return v;
1009 }
1010
1011 static INLINE void
1012 ok_to_freely_gc (SCHEME_P)
1013 {
1014 set_car (S_SINK, NIL);
1015 }
1016
1017 #if defined TSGRIND
1018 static void
1019 check_cell_alloced (pointer p, int expect_alloced)
1020 {
1021 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1022 if (typeflag (p) & !expect_alloced)
1023 xwrstr ("Cell is already allocated!\n");
1024
1025 if (!(typeflag (p)) & expect_alloced)
1026 xwrstr ("Cell is not allocated!\n");
1027 }
1028
1029 static void
1030 check_range_alloced (pointer p, int n, int expect_alloced)
1031 {
1032 int i;
1033
1034 for (i = 0; i < n; i++)
1035 check_cell_alloced (p + i, expect_alloced);
1036 }
1037 #endif
1038
1039 /* Medium level cell allocation */
1040
1041 /* get new cons cell */
1042 pointer
1043 xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1044 {
1045 pointer x = get_cell (SCHEME_A_ a, b);
1046
1047 set_typeflag (x, T_PAIR);
1048
1049 if (immutable)
1050 setimmutable (x);
1051
1052 set_car (x, a);
1053 set_cdr (x, b);
1054
1055 return x;
1056 }
1057
1058 /* ========== oblist implementation ========== */
1059
1060 #ifndef USE_OBJECT_LIST
1061
1062 static int hash_fn (const char *key, int table_size);
1063
1064 static pointer
1065 oblist_initial_value (SCHEME_P)
1066 {
1067 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1068 }
1069
1070 /* returns the new symbol */
1071 static pointer
1072 oblist_add_by_name (SCHEME_P_ const char *name)
1073 {
1074 int location;
1075
1076 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1077 set_typeflag (x, T_SYMBOL);
1078 setimmutable (car (x));
1079
1080 location = hash_fn (name, veclength (SCHEME_V->oblist));
1081 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1082 return x;
1083 }
1084
1085 static INLINE pointer
1086 oblist_find_by_name (SCHEME_P_ const char *name)
1087 {
1088 int location;
1089 pointer x;
1090 char *s;
1091
1092 location = hash_fn (name, veclength (SCHEME_V->oblist));
1093
1094 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1095 {
1096 s = symname (car (x));
1097
1098 /* case-insensitive, per R5RS section 2 */
1099 if (stricmp (name, s) == 0)
1100 return car (x);
1101 }
1102
1103 return NIL;
1104 }
1105
1106 static pointer
1107 oblist_all_symbols (SCHEME_P)
1108 {
1109 int i;
1110 pointer x;
1111 pointer ob_list = NIL;
1112
1113 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1114 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1115 ob_list = cons (x, ob_list);
1116
1117 return ob_list;
1118 }
1119
1120 #else
1121
1122 static pointer
1123 oblist_initial_value (SCHEME_P)
1124 {
1125 return NIL;
1126 }
1127
1128 static INLINE pointer
1129 oblist_find_by_name (SCHEME_P_ const char *name)
1130 {
1131 pointer x;
1132 char *s;
1133
1134 for (x = SCHEME_V->oblist; x != NIL; x = cdr (x))
1135 {
1136 s = symname (car (x));
1137
1138 /* case-insensitive, per R5RS section 2 */
1139 if (stricmp (name, s) == 0)
1140 return car (x);
1141 }
1142
1143 return NIL;
1144 }
1145
1146 /* returns the new symbol */
1147 static pointer
1148 oblist_add_by_name (SCHEME_P_ const char *name)
1149 {
1150 pointer x;
1151
1152 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1153 set_typeflag (x, T_SYMBOL);
1154 setimmutable (car (x));
1155 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1156 return x;
1157 }
1158
1159 static pointer
1160 oblist_all_symbols (SCHEME_P)
1161 {
1162 return SCHEME_V->oblist;
1163 }
1164
1165 #endif
1166
1167 #if USE_PORTS
1168 static pointer
1169 mk_port (SCHEME_P_ port *p)
1170 {
1171 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1172
1173 set_typeflag (x, T_PORT | T_ATOM);
1174 x->object.port = p;
1175
1176 return x;
1177 }
1178 #endif
1179
1180 pointer
1181 mk_foreign_func (SCHEME_P_ foreign_func f)
1182 {
1183 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1184
1185 set_typeflag (x, (T_FOREIGN | T_ATOM));
1186 x->object.ff = f;
1187
1188 return x;
1189 }
1190
1191 INTERFACE pointer
1192 mk_character (SCHEME_P_ int c)
1193 {
1194 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1195
1196 set_typeflag (x, (T_CHARACTER | T_ATOM));
1197 ivalue_unchecked (x) = c & 0xff;
1198 set_num_integer (x);
1199 return x;
1200 }
1201
1202 /* get number atom (integer) */
1203 INTERFACE pointer
1204 mk_integer (SCHEME_P_ long num)
1205 {
1206 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1207
1208 set_typeflag (x, (T_NUMBER | T_ATOM));
1209 ivalue_unchecked (x) = num;
1210 set_num_integer (x);
1211 return x;
1212 }
1213
1214 INTERFACE pointer
1215 mk_real (SCHEME_P_ RVALUE n)
1216 {
1217 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1218
1219 set_typeflag (x, (T_NUMBER | T_ATOM));
1220 rvalue_unchecked (x) = n;
1221 set_num_real (x);
1222 return x;
1223 }
1224
1225 static pointer
1226 mk_number (SCHEME_P_ const num n)
1227 {
1228 if (num_is_fixnum (n))
1229 return mk_integer (SCHEME_A_ num_get_ivalue (n));
1230 else
1231 return mk_real (SCHEME_A_ num_get_rvalue (n));
1232 }
1233
1234 /* allocate name to string area */
1235 static char *
1236 store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
1237 {
1238 char *q = malloc (len_str + 1);
1239
1240 if (q == 0 && USE_ERROR_CHECKING)
1241 {
1242 SCHEME_V->no_memory = 1;
1243 return SCHEME_V->strbuff;
1244 }
1245
1246 if (str)
1247 {
1248 int l = strlen (str);
1249
1250 if (l > len_str)
1251 l = len_str;
1252
1253 memcpy (q, str, l);
1254 q[l] = 0;
1255 }
1256 else
1257 {
1258 memset (q, fill, len_str);
1259 q[len_str] = 0;
1260 }
1261
1262 return q;
1263 }
1264
1265 INTERFACE pointer
1266 mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1267 {
1268 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1269
1270 set_typeflag (x, T_STRING | T_ATOM);
1271 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1272 strlength (x) = len;
1273 return x;
1274 }
1275
1276 INTERFACE pointer
1277 mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1278 {
1279 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1280
1281 set_typeflag (x, T_STRING | T_ATOM);
1282 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1283 strlength (x) = len;
1284 return x;
1285 }
1286
1287 INTERFACE pointer
1288 mk_string (SCHEME_P_ const char *str)
1289 {
1290 return mk_counted_string (SCHEME_A_ str, strlen (str));
1291 }
1292
1293 INTERFACE pointer
1294 mk_vector (SCHEME_P_ uint32_t len)
1295 {
1296 return get_vector_object (SCHEME_A_ len, NIL);
1297 }
1298
1299 INTERFACE void
1300 fill_vector (pointer vec, pointer obj)
1301 {
1302 int i;
1303
1304 for (i = 0; i < vec->object.vector.length; i++)
1305 vecvalue (vec)[i] = obj;
1306 }
1307
1308 INTERFACE pointer
1309 vector_elem (pointer vec, uint32_t ielem)
1310 {
1311 return vecvalue(vec)[ielem];
1312 }
1313
1314 INTERFACE void
1315 set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1316 {
1317 vecvalue(vec)[ielem] = a;
1318 }
1319
1320 /* get new symbol */
1321 INTERFACE pointer
1322 mk_symbol (SCHEME_P_ const char *name)
1323 {
1324 /* first check oblist */
1325 pointer x = oblist_find_by_name (SCHEME_A_ name);
1326
1327 if (x == NIL)
1328 x = oblist_add_by_name (SCHEME_A_ name);
1329
1330 return x;
1331 }
1332
1333 INTERFACE pointer
1334 gensym (SCHEME_P)
1335 {
1336 pointer x;
1337
1338 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1339 {
1340 char name[40] = "gensym-";
1341 xnum (name + 7, SCHEME_V->gensym_cnt);
1342
1343 /* first check oblist */
1344 x = oblist_find_by_name (SCHEME_A_ name);
1345
1346 if (x == NIL)
1347 {
1348 x = oblist_add_by_name (SCHEME_A_ name);
1349 return x;
1350 }
1351 }
1352
1353 return NIL;
1354 }
1355
1356 /* make symbol or number atom from string */
1357 static pointer
1358 mk_atom (SCHEME_P_ char *q)
1359 {
1360 char c, *p;
1361 int has_dec_point = 0;
1362 int has_fp_exp = 0;
1363
1364 #if USE_COLON_HOOK
1365 if ((p = strstr (q, "::")) != 0)
1366 {
1367 *p = 0;
1368 return cons (SCHEME_V->COLON_HOOK,
1369 cons (cons (SCHEME_V->QUOTE,
1370 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1371 }
1372 #endif
1373
1374 p = q;
1375 c = *p++;
1376
1377 if ((c == '+') || (c == '-'))
1378 {
1379 c = *p++;
1380
1381 if (c == '.')
1382 {
1383 has_dec_point = 1;
1384 c = *p++;
1385 }
1386
1387 if (!isdigit (c))
1388 return mk_symbol (SCHEME_A_ strlwr (q));
1389 }
1390 else if (c == '.')
1391 {
1392 has_dec_point = 1;
1393 c = *p++;
1394
1395 if (!isdigit (c))
1396 return mk_symbol (SCHEME_A_ strlwr (q));
1397 }
1398 else if (!isdigit (c))
1399 return mk_symbol (SCHEME_A_ strlwr (q));
1400
1401 for (; (c = *p) != 0; ++p)
1402 {
1403 if (!isdigit (c))
1404 {
1405 if (c == '.')
1406 {
1407 if (!has_dec_point)
1408 {
1409 has_dec_point = 1;
1410 continue;
1411 }
1412 }
1413 else if ((c == 'e') || (c == 'E'))
1414 {
1415 if (!has_fp_exp)
1416 {
1417 has_dec_point = 1; /* decimal point illegal
1418 from now on */
1419 p++;
1420
1421 if ((*p == '-') || (*p == '+') || isdigit (*p))
1422 continue;
1423 }
1424 }
1425
1426 return mk_symbol (SCHEME_A_ strlwr (q));
1427 }
1428 }
1429
1430 #if USE_REAL
1431 if (has_dec_point)
1432 return mk_real (SCHEME_A_ atof (q));
1433 #endif
1434
1435 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1436 }
1437
1438 /* make constant */
1439 static pointer
1440 mk_sharp_const (SCHEME_P_ char *name)
1441 {
1442 if (!strcmp (name, "t"))
1443 return S_T;
1444 else if (!strcmp (name, "f"))
1445 return S_F;
1446 else if (*name == '\\') /* #\w (character) */
1447 {
1448 int c;
1449
1450 if (stricmp (name + 1, "space") == 0)
1451 c = ' ';
1452 else if (stricmp (name + 1, "newline") == 0)
1453 c = '\n';
1454 else if (stricmp (name + 1, "return") == 0)
1455 c = '\r';
1456 else if (stricmp (name + 1, "tab") == 0)
1457 c = '\t';
1458 else if (name[1] == 'x' && name[2] != 0)
1459 {
1460 long c1 = strtol (name + 2, 0, 16);
1461
1462 if (0 <= c1 && c1 <= UCHAR_MAX)
1463 c = c1;
1464 else
1465 return NIL;
1466 }
1467 #if USE_ASCII_NAMES
1468 else if (is_ascii_name (name + 1, &c))
1469 /* nothing */;
1470 #endif
1471 else if (name[2] == 0)
1472 c = name[1];
1473 else
1474 return NIL;
1475
1476 return mk_character (SCHEME_A_ c);
1477 }
1478 else
1479 {
1480 /* identify base by string index */
1481 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1482 char *base = strchr (baseidx, *name);
1483
1484 if (base)
1485 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1486
1487 return NIL;
1488 }
1489 }
1490
1491 /* ========== garbage collector ========== */
1492
1493 /*--
1494 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1495 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1496 * for marking.
1497 *
1498 * The exception is vectors - vectors are currently marked recursively,
1499 * which is inherited form tinyscheme and could be fixed by having another
1500 * word of context in the vector
1501 */
1502 static void
1503 mark (pointer a)
1504 {
1505 pointer t, q, p;
1506
1507 t = 0;
1508 p = a;
1509 E2:
1510 setmark (p);
1511
1512 if (ecb_expect_false (is_vector (p)))
1513 {
1514 int i;
1515
1516 for (i = 0; i < p->object.vector.length; i++)
1517 mark (vecvalue (p)[i]);
1518 }
1519
1520 if (is_atom (p))
1521 goto E6;
1522
1523 /* E4: down car */
1524 q = car (p);
1525
1526 if (q && !is_mark (q))
1527 {
1528 setatom (p); /* a note that we have moved car */
1529 set_car (p, t);
1530 t = p;
1531 p = q;
1532 goto E2;
1533 }
1534
1535 E5:
1536 q = cdr (p); /* down cdr */
1537
1538 if (q && !is_mark (q))
1539 {
1540 set_cdr (p, t);
1541 t = p;
1542 p = q;
1543 goto E2;
1544 }
1545
1546 E6: /* up. Undo the link switching from steps E4 and E5. */
1547 if (!t)
1548 return;
1549
1550 q = t;
1551
1552 if (is_atom (q))
1553 {
1554 clratom (q);
1555 t = car (q);
1556 set_car (q, p);
1557 p = q;
1558 goto E5;
1559 }
1560 else
1561 {
1562 t = cdr (q);
1563 set_cdr (q, p);
1564 p = q;
1565 goto E6;
1566 }
1567 }
1568
1569 /* garbage collection. parameter a, b is marked. */
1570 static void
1571 gc (SCHEME_P_ pointer a, pointer b)
1572 {
1573 pointer p;
1574 int i;
1575
1576 if (SCHEME_V->gc_verbose)
1577 putstr (SCHEME_A_ "gc...");
1578
1579 /* mark system globals */
1580 mark (SCHEME_V->oblist);
1581 mark (SCHEME_V->global_env);
1582
1583 /* mark current registers */
1584 mark (SCHEME_V->args);
1585 mark (SCHEME_V->envir);
1586 mark (SCHEME_V->code);
1587 dump_stack_mark (SCHEME_A);
1588 mark (SCHEME_V->value);
1589 mark (SCHEME_V->inport);
1590 mark (SCHEME_V->save_inport);
1591 mark (SCHEME_V->outport);
1592 mark (SCHEME_V->loadport);
1593
1594 /* Mark recent objects the interpreter doesn't know about yet. */
1595 mark (car (S_SINK));
1596 /* Mark any older stuff above nested C calls */
1597 mark (SCHEME_V->c_nest);
1598
1599 /* mark variables a, b */
1600 mark (a);
1601 mark (b);
1602
1603 /* garbage collect */
1604 clrmark (NIL);
1605 SCHEME_V->fcells = 0;
1606 SCHEME_V->free_cell = NIL;
1607
1608 /* free-list is kept sorted by address so as to maintain consecutive
1609 ranges, if possible, for use with vectors. Here we scan the cells
1610 (which are also kept sorted by address) downwards to build the
1611 free-list in sorted order.
1612 */
1613 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1614 {
1615 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1616
1617 while (--p >= SCHEME_V->cell_seg[i])
1618 {
1619 if (is_mark (p))
1620 clrmark (p);
1621 else
1622 {
1623 /* reclaim cell */
1624 if (typeflag (p) != T_FREE)
1625 {
1626 finalize_cell (SCHEME_A_ p);
1627 set_typeflag (p, T_FREE);
1628 set_car (p, NIL);
1629 }
1630
1631 ++SCHEME_V->fcells;
1632 set_cdr (p, SCHEME_V->free_cell);
1633 SCHEME_V->free_cell = p;
1634 }
1635 }
1636 }
1637
1638 if (SCHEME_V->gc_verbose)
1639 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
1640 }
1641
1642 static void
1643 finalize_cell (SCHEME_P_ pointer a)
1644 {
1645 /* TODO, fast bitmap check? */
1646 if (is_string (a))
1647 free (strvalue (a));
1648 else if (is_vector (a))
1649 free (vecvalue (a));
1650 #if USE_PORTS
1651 else if (is_port (a))
1652 {
1653 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1654 port_close (SCHEME_A_ a, port_input | port_output);
1655
1656 free (a->object.port);
1657 }
1658 #endif
1659 }
1660
1661 /* ========== Routines for Reading ========== */
1662
1663 static int
1664 file_push (SCHEME_P_ const char *fname)
1665 {
1666 #if USE_PORTS
1667 int fin;
1668
1669 if (SCHEME_V->file_i == MAXFIL - 1)
1670 return 0;
1671
1672 fin = open (fname, O_RDONLY);
1673
1674 if (fin >= 0)
1675 {
1676 SCHEME_V->file_i++;
1677 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1678 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1679 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1680 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1681 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1682 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;
1683
1684 #if SHOW_ERROR_LINE
1685 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1686
1687 if (fname)
1688 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1689 #endif
1690 }
1691
1692 return fin >= 0;
1693
1694 #else
1695 return 1;
1696 #endif
1697 }
1698
1699 static void
1700 file_pop (SCHEME_P)
1701 {
1702 if (SCHEME_V->file_i != 0)
1703 {
1704 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1705 #if USE_PORTS
1706 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1707 #endif
1708 SCHEME_V->file_i--;
1709 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;
1710 }
1711 }
1712
1713 static int
1714 file_interactive (SCHEME_P)
1715 {
1716 #if USE_PORTS
1717 return SCHEME_V->file_i == 0
1718 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1719 && (SCHEME_V->inport->object.port->kind & port_file);
1720 #else
1721 return 0;
1722 #endif
1723 }
1724
1725 #if USE_PORTS
1726 static port *
1727 port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1728 {
1729 int fd;
1730 int flags;
1731 char *rw;
1732 port *pt;
1733
1734 if (prop == (port_input | port_output))
1735 flags = O_RDWR | O_APPEND | O_CREAT;
1736 else if (prop == port_output)
1737 flags = O_WRONLY | O_TRUNC | O_CREAT;
1738 else
1739 flags = O_RDONLY;
1740
1741 fd = open (fn, flags, 0666);
1742
1743 if (fd < 0)
1744 return 0;
1745
1746 pt = port_rep_from_file (SCHEME_A_ fd, prop);
1747 pt->rep.stdio.closeit = 1;
1748
1749 # if SHOW_ERROR_LINE
1750 if (fn)
1751 pt->rep.stdio.filename = store_string (SCHEME_A_ strlen (fn), fn, 0);
1752
1753 pt->rep.stdio.curr_line = 0;
1754 # endif
1755
1756 return pt;
1757 }
1758
1759 static pointer
1760 port_from_filename (SCHEME_P_ const char *fn, int prop)
1761 {
1762 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1763
1764 if (!pt && USE_ERROR_CHECKING)
1765 return NIL;
1766
1767 return mk_port (SCHEME_A_ pt);
1768 }
1769
1770 static port *
1771 port_rep_from_file (SCHEME_P_ int f, int prop)
1772 {
1773 port *pt = malloc (sizeof *pt);
1774
1775 if (!pt && USE_ERROR_CHECKING)
1776 return NULL;
1777
1778 pt->unget = -1;
1779 pt->kind = port_file | prop;
1780 pt->rep.stdio.file = f;
1781 pt->rep.stdio.closeit = 0;
1782 return pt;
1783 }
1784
1785 static pointer
1786 port_from_file (SCHEME_P_ int f, int prop)
1787 {
1788 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1789
1790 if (!pt && USE_ERROR_CHECKING)
1791 return NIL;
1792
1793 return mk_port (SCHEME_A_ pt);
1794 }
1795
1796 static port *
1797 port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1798 {
1799 port *pt = malloc (sizeof (port));
1800
1801 if (!pt && USE_ERROR_CHECKING)
1802 return 0;
1803
1804 pt->unget = -1;
1805 pt->kind = port_string | prop;
1806 pt->rep.string.start = start;
1807 pt->rep.string.curr = start;
1808 pt->rep.string.past_the_end = past_the_end;
1809 return pt;
1810 }
1811
1812 static pointer
1813 port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1814 {
1815 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1816
1817 if (!pt && USE_ERROR_CHECKING)
1818 return NIL;
1819
1820 return mk_port (SCHEME_A_ pt);
1821 }
1822
1823 # define BLOCK_SIZE 256
1824
1825 static port *
1826 port_rep_from_scratch (SCHEME_P)
1827 {
1828 char *start;
1829 port *pt = malloc (sizeof (port));
1830
1831 if (!pt && USE_ERROR_CHECKING)
1832 return 0;
1833
1834 start = malloc (BLOCK_SIZE);
1835
1836 if (start == 0)
1837 return 0;
1838
1839 memset (start, ' ', BLOCK_SIZE - 1);
1840 start[BLOCK_SIZE - 1] = '\0';
1841 pt->unget = -1;
1842 pt->kind = port_string | port_output | port_srfi6;
1843 pt->rep.string.start = start;
1844 pt->rep.string.curr = start;
1845 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1846 return pt;
1847 }
1848
1849 static pointer
1850 port_from_scratch (SCHEME_P)
1851 {
1852 port *pt = port_rep_from_scratch (SCHEME_A);
1853
1854 if (!pt && USE_ERROR_CHECKING)
1855 return NIL;
1856
1857 return mk_port (SCHEME_A_ pt);
1858 }
1859
1860 static void
1861 port_close (SCHEME_P_ pointer p, int flag)
1862 {
1863 port *pt = p->object.port;
1864
1865 pt->kind &= ~flag;
1866
1867 if ((pt->kind & (port_input | port_output)) == 0)
1868 {
1869 if (pt->kind & port_file)
1870 {
1871
1872 # if SHOW_ERROR_LINE
1873 /* Cleanup is here so (close-*-port) functions could work too */
1874 pt->rep.stdio.curr_line = 0;
1875
1876 if (pt->rep.stdio.filename)
1877 free (pt->rep.stdio.filename);
1878
1879 # endif
1880
1881 close (pt->rep.stdio.file);
1882 }
1883
1884 pt->kind = port_free;
1885 }
1886 }
1887 #endif
1888
1889 /* get new character from input file */
1890 static int
1891 inchar (SCHEME_P)
1892 {
1893 int c;
1894 port *pt;
1895
1896 pt = SCHEME_V->inport->object.port;
1897
1898 if (pt->kind & port_saw_EOF)
1899 return EOF;
1900
1901 c = basic_inchar (pt);
1902
1903 if (c == EOF && SCHEME_V->inport == SCHEME_V->loadport)
1904 {
1905 /* Instead, set port_saw_EOF */
1906 pt->kind |= port_saw_EOF;
1907
1908 /* file_pop(SCHEME_A); */
1909 return EOF;
1910 /* NOTREACHED */
1911 }
1912
1913 return c;
1914 }
1915
1916 static int ungot = -1;
1917
1918 static int
1919 basic_inchar (port *pt)
1920 {
1921 #if USE_PORTS
1922 if (pt->unget != -1)
1923 {
1924 int r = pt->unget;
1925 pt->unget = -1;
1926 return r;
1927 }
1928
1929 if (pt->kind & port_file)
1930 {
1931 char c;
1932
1933 if (!read (pt->rep.stdio.file, &c, 1))
1934 return EOF;
1935
1936 return c;
1937 }
1938 else
1939 {
1940 if (*pt->rep.string.curr == 0 || pt->rep.string.curr == pt->rep.string.past_the_end)
1941 return EOF;
1942 else
1943 return *pt->rep.string.curr++;
1944 }
1945 #else
1946 if (ungot == -1)
1947 {
1948 char c;
1949 if (!read (0, &c, 1))
1950 return EOF;
1951
1952 ungot = c;
1953 }
1954
1955 {
1956 int r = ungot;
1957 ungot = -1;
1958 return r;
1959 }
1960 #endif
1961 }
1962
1963 /* back character to input buffer */
1964 static void
1965 backchar (SCHEME_P_ int c)
1966 {
1967 #if USE_PORTS
1968 port *pt;
1969
1970 if (c == EOF)
1971 return;
1972
1973 pt = SCHEME_V->inport->object.port;
1974 pt->unget = c;
1975 #else
1976 if (c == EOF)
1977 return;
1978
1979 ungot = c;
1980 #endif
1981 }
1982
1983 #if USE_PORTS
1984 static int
1985 realloc_port_string (SCHEME_P_ port *p)
1986 {
1987 char *start = p->rep.string.start;
1988 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
1989 char *str = malloc (new_size);
1990
1991 if (str)
1992 {
1993 memset (str, ' ', new_size - 1);
1994 str[new_size - 1] = '\0';
1995 strcpy (str, start);
1996 p->rep.string.start = str;
1997 p->rep.string.past_the_end = str + new_size - 1;
1998 p->rep.string.curr -= start - str;
1999 free (start);
2000 return 1;
2001 }
2002 else
2003 return 0;
2004 }
2005 #endif
2006
2007 INTERFACE void
2008 putstr (SCHEME_P_ const char *s)
2009 {
2010 #if USE_PORTS
2011 port *pt = SCHEME_V->outport->object.port;
2012
2013 if (pt->kind & port_file)
2014 write (pt->rep.stdio.file, s, strlen (s));
2015 else
2016 for (; *s; s++)
2017 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2018 *pt->rep.string.curr++ = *s;
2019 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2020 *pt->rep.string.curr++ = *s;
2021
2022 #else
2023 xwrstr (s);
2024 #endif
2025 }
2026
2027 static void
2028 putchars (SCHEME_P_ const char *s, int len)
2029 {
2030 #if USE_PORTS
2031 port *pt = SCHEME_V->outport->object.port;
2032
2033 if (pt->kind & port_file)
2034 write (pt->rep.stdio.file, s, len);
2035 else
2036 {
2037 for (; len; len--)
2038 {
2039 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2040 *pt->rep.string.curr++ = *s++;
2041 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2042 *pt->rep.string.curr++ = *s++;
2043 }
2044 }
2045
2046 #else
2047 write (1, s, len);
2048 #endif
2049 }
2050
2051 INTERFACE void
2052 putcharacter (SCHEME_P_ int c)
2053 {
2054 #if USE_PORTS
2055 port *pt = SCHEME_V->outport->object.port;
2056
2057 if (pt->kind & port_file)
2058 {
2059 char cc = c;
2060 write (pt->rep.stdio.file, &cc, 1);
2061 }
2062 else
2063 {
2064 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2065 *pt->rep.string.curr++ = c;
2066 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2067 *pt->rep.string.curr++ = c;
2068 }
2069
2070 #else
2071 char cc = c;
2072 write (1, &c, 1);
2073 #endif
2074 }
2075
2076 /* read characters up to delimiter, but cater to character constants */
2077 static char *
2078 readstr_upto (SCHEME_P_ char *delim)
2079 {
2080 char *p = SCHEME_V->strbuff;
2081
2082 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2083
2084 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2085 *p = 0;
2086 else
2087 {
2088 backchar (SCHEME_A_ p[-1]);
2089 *--p = '\0';
2090 }
2091
2092 return SCHEME_V->strbuff;
2093 }
2094
2095 /* read string expression "xxx...xxx" */
2096 static pointer
2097 readstrexp (SCHEME_P)
2098 {
2099 char *p = SCHEME_V->strbuff;
2100 int c;
2101 int c1 = 0;
2102 enum
2103 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2104
2105 for (;;)
2106 {
2107 c = inchar (SCHEME_A);
2108
2109 if (c == EOF || p - SCHEME_V->strbuff > sizeof (SCHEME_V->strbuff) - 1)
2110 return S_F;
2111
2112 switch (state)
2113 {
2114 case st_ok:
2115 switch (c)
2116 {
2117 case '\\':
2118 state = st_bsl;
2119 break;
2120
2121 case '"':
2122 *p = 0;
2123 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2124
2125 default:
2126 *p++ = c;
2127 break;
2128 }
2129
2130 break;
2131
2132 case st_bsl:
2133 switch (c)
2134 {
2135 case '0':
2136 case '1':
2137 case '2':
2138 case '3':
2139 case '4':
2140 case '5':
2141 case '6':
2142 case '7':
2143 state = st_oct1;
2144 c1 = c - '0';
2145 break;
2146
2147 case 'x':
2148 case 'X':
2149 state = st_x1;
2150 c1 = 0;
2151 break;
2152
2153 case 'n':
2154 *p++ = '\n';
2155 state = st_ok;
2156 break;
2157
2158 case 't':
2159 *p++ = '\t';
2160 state = st_ok;
2161 break;
2162
2163 case 'r':
2164 *p++ = '\r';
2165 state = st_ok;
2166 break;
2167
2168 case '"':
2169 *p++ = '"';
2170 state = st_ok;
2171 break;
2172
2173 default:
2174 *p++ = c;
2175 state = st_ok;
2176 break;
2177 }
2178
2179 break;
2180
2181 case st_x1:
2182 case st_x2:
2183 c = toupper (c);
2184
2185 if (c >= '0' && c <= 'F')
2186 {
2187 if (c <= '9')
2188 c1 = (c1 << 4) + c - '0';
2189 else
2190 c1 = (c1 << 4) + c - 'A' + 10;
2191
2192 if (state == st_x1)
2193 state = st_x2;
2194 else
2195 {
2196 *p++ = c1;
2197 state = st_ok;
2198 }
2199 }
2200 else
2201 return S_F;
2202
2203 break;
2204
2205 case st_oct1:
2206 case st_oct2:
2207 if (c < '0' || c > '7')
2208 {
2209 *p++ = c1;
2210 backchar (SCHEME_A_ c);
2211 state = st_ok;
2212 }
2213 else
2214 {
2215 if (state == st_oct2 && c1 >= 32)
2216 return S_F;
2217
2218 c1 = (c1 << 3) + (c - '0');
2219
2220 if (state == st_oct1)
2221 state = st_oct2;
2222 else
2223 {
2224 *p++ = c1;
2225 state = st_ok;
2226 }
2227 }
2228
2229 break;
2230
2231 }
2232 }
2233 }
2234
2235 /* check c is in chars */
2236 static INLINE int
2237 is_one_of (char *s, int c)
2238 {
2239 if (c == EOF)
2240 return 1;
2241
2242 return !!strchr (s, c);
2243 }
2244
2245 /* skip white characters */
2246 static INLINE int
2247 skipspace (SCHEME_P)
2248 {
2249 int c, curr_line = 0;
2250
2251 do
2252 {
2253 c = inchar (SCHEME_A);
2254 #if SHOW_ERROR_LINE
2255 if (c == '\n')
2256 curr_line++;
2257 #endif
2258 }
2259 while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
2260
2261 /* record it */
2262 #if SHOW_ERROR_LINE
2263 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2264 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2265 #endif
2266
2267 if (c != EOF)
2268 {
2269 backchar (SCHEME_A_ c);
2270 return 1;
2271 }
2272 else
2273 return EOF;
2274 }
2275
2276 /* get token */
2277 static int
2278 token (SCHEME_P)
2279 {
2280 int c = skipspace (SCHEME_A);
2281
2282 if (c == EOF)
2283 return TOK_EOF;
2284
2285 switch ((c = inchar (SCHEME_A)))
2286 {
2287 case EOF:
2288 return TOK_EOF;
2289
2290 case '(':
2291 return TOK_LPAREN;
2292
2293 case ')':
2294 return TOK_RPAREN;
2295
2296 case '.':
2297 c = inchar (SCHEME_A);
2298
2299 if (is_one_of (" \n\t", c))
2300 return TOK_DOT;
2301 else
2302 {
2303 //TODO: ungetc twice in a row is not supported in C
2304 backchar (SCHEME_A_ c);
2305 backchar (SCHEME_A_ '.');
2306 return TOK_ATOM;
2307 }
2308
2309 case '\'':
2310 return TOK_QUOTE;
2311
2312 case ';':
2313 while ((c = inchar (SCHEME_A)) != '\n' && c != EOF)
2314 ;
2315
2316 #if SHOW_ERROR_LINE
2317
2318 if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2319 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;
2320
2321 #endif
2322
2323 if (c == EOF)
2324 return TOK_EOF;
2325 else
2326 return token (SCHEME_A);
2327
2328 case '"':
2329 return TOK_DQUOTE;
2330
2331 case BACKQUOTE:
2332 return TOK_BQUOTE;
2333
2334 case ',':
2335 if ((c = inchar (SCHEME_A)) == '@')
2336 return TOK_ATMARK;
2337 else
2338 {
2339 backchar (SCHEME_A_ c);
2340 return TOK_COMMA;
2341 }
2342
2343 case '#':
2344 c = inchar (SCHEME_A);
2345
2346 if (c == '(')
2347 return TOK_VEC;
2348 else if (c == '!')
2349 {
2350 while ((c = inchar (SCHEME_A)) != '\n' && c != EOF)
2351 ;
2352
2353 #if SHOW_ERROR_LINE
2354
2355 if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2356 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;
2357
2358 #endif
2359
2360 if (c == EOF)
2361 return TOK_EOF;
2362 else
2363 return token (SCHEME_A);
2364 }
2365 else
2366 {
2367 backchar (SCHEME_A_ c);
2368
2369 if (is_one_of (" tfodxb\\", c))
2370 return TOK_SHARP_CONST;
2371 else
2372 return TOK_SHARP;
2373 }
2374
2375 default:
2376 backchar (SCHEME_A_ c);
2377 return TOK_ATOM;
2378 }
2379 }
2380
2381 /* ========== Routines for Printing ========== */
2382 #define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2383
2384 static void
2385 printslashstring (SCHEME_P_ char *p, int len)
2386 {
2387 int i;
2388 unsigned char *s = (unsigned char *) p;
2389
2390 putcharacter (SCHEME_A_ '"');
2391
2392 for (i = 0; i < len; i++)
2393 {
2394 if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
2395 {
2396 putcharacter (SCHEME_A_ '\\');
2397
2398 switch (*s)
2399 {
2400 case '"':
2401 putcharacter (SCHEME_A_ '"');
2402 break;
2403
2404 case '\n':
2405 putcharacter (SCHEME_A_ 'n');
2406 break;
2407
2408 case '\t':
2409 putcharacter (SCHEME_A_ 't');
2410 break;
2411
2412 case '\r':
2413 putcharacter (SCHEME_A_ 'r');
2414 break;
2415
2416 case '\\':
2417 putcharacter (SCHEME_A_ '\\');
2418 break;
2419
2420 default:
2421 {
2422 int d = *s / 16;
2423
2424 putcharacter (SCHEME_A_ 'x');
2425
2426 if (d < 10)
2427 putcharacter (SCHEME_A_ d + '0');
2428 else
2429 putcharacter (SCHEME_A_ d - 10 + 'A');
2430
2431 d = *s % 16;
2432
2433 if (d < 10)
2434 putcharacter (SCHEME_A_ d + '0');
2435 else
2436 putcharacter (SCHEME_A_ d - 10 + 'A');
2437 }
2438 }
2439 }
2440 else
2441 putcharacter (SCHEME_A_ * s);
2442
2443 s++;
2444 }
2445
2446 putcharacter (SCHEME_A_ '"');
2447 }
2448
2449
2450 /* print atoms */
2451 static void
2452 printatom (SCHEME_P_ pointer l, int f)
2453 {
2454 char *p;
2455 int len;
2456
2457 atom2str (SCHEME_A_ l, f, &p, &len);
2458 putchars (SCHEME_A_ p, len);
2459 }
2460
2461
2462 /* Uses internal buffer unless string pointer is already available */
2463 static void
2464 atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2465 {
2466 char *p;
2467
2468 if (l == NIL)
2469 p = "()";
2470 else if (l == S_T)
2471 p = "#t";
2472 else if (l == S_F)
2473 p = "#f";
2474 else if (l == S_EOF)
2475 p = "#<EOF>";
2476 else if (is_port (l))
2477 p = "#<PORT>";
2478 else if (is_number (l))
2479 {
2480 p = SCHEME_V->strbuff;
2481
2482 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2483 {
2484 if (num_is_integer (l))
2485 xnum (p, ivalue_unchecked (l));
2486 #if USE_REAL
2487 else
2488 {
2489 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2490 /* r5rs says there must be a '.' (unless 'e'?) */
2491 f = strcspn (p, ".e");
2492
2493 if (p[f] == 0)
2494 {
2495 p[f] = '.'; /* not found, so add '.0' at the end */
2496 p[f + 1] = '0';
2497 p[f + 2] = 0;
2498 }
2499 }
2500 #endif
2501 }
2502 else
2503 {
2504 long v = ivalue (l);
2505
2506 if (f == 16)
2507 xbase (p, v, 16);
2508 else if (f == 8)
2509 xbase (p, v, 8);
2510 else if (f == 2)
2511 {
2512 unsigned long b = (v < 0) ? -v : v;
2513
2514 p = &p[STRBUFFSIZE - 1];
2515 *p = 0;
2516
2517 do
2518 {
2519 *--p = (b & 1) ? '1' : '0';
2520 b >>= 1;
2521 }
2522 while (b != 0);
2523
2524 if (v < 0)
2525 *--p = '-';
2526 }
2527 }
2528 }
2529 else if (is_string (l))
2530 {
2531 if (!f)
2532 p = strvalue (l);
2533 else /* Hack, uses the fact that printing is needed */
2534 {
2535 *pp = SCHEME_V->strbuff;
2536 *plen = 0;
2537 printslashstring (SCHEME_A_ strvalue (l), strlength (l));
2538 return;
2539 }
2540 }
2541 else if (is_character (l))
2542 {
2543 int c = charvalue (l);
2544
2545 p = SCHEME_V->strbuff;
2546
2547 if (!f)
2548 {
2549 p[0] = c;
2550 p[1] = 0;
2551 }
2552 else
2553 {
2554 switch (c)
2555 {
2556 case ' ':
2557 p ="#\\space";
2558 break;
2559
2560 case '\n':
2561 p ="#\\newline";
2562 break;
2563
2564 case '\r':
2565 p ="#\\return";
2566 break;
2567
2568 case '\t':
2569 p ="#\\tab";
2570 break;
2571
2572 default:
2573 #if USE_ASCII_NAMES
2574 if (c == 127)
2575 {
2576 strcpy (p, "#\\del");
2577 break;
2578 }
2579 else if (c < 32)
2580 {
2581 strcpy (p, "#\\");
2582 strcpy (p + 2, charnames[c]);
2583 break;
2584 }
2585
2586 #else
2587
2588 if (c < 32)
2589 {
2590 strcpy (p, "#\\x");
2591 xbase (p + 3, c, 16);
2592 break;
2593 }
2594
2595 #endif
2596 strcpy (p, "#\\%");
2597 p[2] = c;
2598 break;
2599 }
2600 }
2601 }
2602 else if (is_symbol (l))
2603 p = symname (l);
2604 else if (is_proc (l))
2605 {
2606 #if USE_PRINTF
2607 p = SCHEME_V->strbuff;
2608 snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l));
2609 #else
2610 p = "#<PROCEDURE>";
2611 #endif
2612 }
2613 else if (is_macro (l))
2614 p = "#<MACRO>";
2615 else if (is_closure (l))
2616 p = "#<CLOSURE>";
2617 else if (is_promise (l))
2618 p = "#<PROMISE>";
2619 else if (is_foreign (l))
2620 {
2621 #if USE_PRINTF
2622 p = SCHEME_V->strbuff;
2623 snprintf (p, STRBUFFSIZE, "#<FOREIGN PROCEDURE %ld>", procnum (l));
2624 #else
2625 p = "#<FOREIGN PROCEDURE>";
2626 #endif
2627 }
2628 else if (is_continuation (l))
2629 p = "#<CONTINUATION>";
2630 else
2631 p = "#<ERROR>";
2632
2633 *pp = p;
2634 *plen = strlen (p);
2635 }
2636
2637 /* ========== Routines for Evaluation Cycle ========== */
2638
2639 /* make closure. c is code. e is environment */
2640 static pointer
2641 mk_closure (SCHEME_P_ pointer c, pointer e)
2642 {
2643 pointer x = get_cell (SCHEME_A_ c, e);
2644
2645 set_typeflag (x, T_CLOSURE);
2646 set_car (x, c);
2647 set_cdr (x, e);
2648 return x;
2649 }
2650
2651 /* make continuation. */
2652 static pointer
2653 mk_continuation (SCHEME_P_ pointer d)
2654 {
2655 pointer x = get_cell (SCHEME_A_ NIL, d);
2656
2657 set_typeflag (x, T_CONTINUATION);
2658 set_cont_dump (x, d);
2659 return x;
2660 }
2661
2662 static pointer
2663 list_star (SCHEME_P_ pointer d)
2664 {
2665 pointer p, q;
2666
2667 if (cdr (d) == NIL)
2668 return car (d);
2669
2670 p = cons (car (d), cdr (d));
2671 q = p;
2672
2673 while (cdr (cdr (p)) != NIL)
2674 {
2675 d = cons (car (p), cdr (p));
2676
2677 if (cdr (cdr (p)) != NIL)
2678 p = cdr (d);
2679 }
2680
2681 set_cdr (p, car (cdr (p)));
2682 return q;
2683 }
2684
2685 /* reverse list -- produce new list */
2686 static pointer
2687 reverse (SCHEME_P_ pointer a)
2688 {
2689 /* a must be checked by gc */
2690 pointer p = NIL;
2691
2692 for (; is_pair (a); a = cdr (a))
2693 p = cons (car (a), p);
2694
2695 return p;
2696 }
2697
2698 /* reverse list --- in-place */
2699 static pointer
2700 reverse_in_place (SCHEME_P_ pointer term, pointer list)
2701 {
2702 pointer result = term;
2703 pointer p = list;
2704
2705 while (p != NIL)
2706 {
2707 pointer q = cdr (p);
2708 set_cdr (p, result);
2709 result = p;
2710 p = q;
2711 }
2712
2713 return result;
2714 }
2715
2716 /* append list -- produce new list (in reverse order) */
2717 static pointer
2718 revappend (SCHEME_P_ pointer a, pointer b)
2719 {
2720 pointer result = a;
2721 pointer p = b;
2722
2723 while (is_pair (p))
2724 {
2725 result = cons (car (p), result);
2726 p = cdr (p);
2727 }
2728
2729 if (p == NIL)
2730 return result;
2731
2732 return S_F; /* signal an error */
2733 }
2734
2735 /* equivalence of atoms */
2736 int
2737 eqv (pointer a, pointer b)
2738 {
2739 if (is_string (a))
2740 {
2741 if (is_string (b))
2742 return strvalue (a) == strvalue (b);
2743 else
2744 return 0;
2745 }
2746 else if (is_number (a))
2747 {
2748 if (is_number (b))
2749 if (num_is_integer (a) == num_is_integer (b))
2750 return num_cmp (nvalue (a), nvalue (b)) == 0;
2751
2752 return 0;
2753 }
2754 else if (is_character (a))
2755 {
2756 if (is_character (b))
2757 return charvalue (a) == charvalue (b);
2758 else
2759 return 0;
2760 }
2761 else if (is_port (a))
2762 {
2763 if (is_port (b))
2764 return a == b;
2765 else
2766 return 0;
2767 }
2768 else if (is_proc (a))
2769 {
2770 if (is_proc (b))
2771 return procnum (a) == procnum (b);
2772 else
2773 return 0;
2774 }
2775 else
2776 return a == b;
2777 }
2778
2779 /* true or false value macro */
2780
2781 /* () is #t in R5RS */
2782 #define is_true(p) ((p) != S_F)
2783 #define is_false(p) ((p) == S_F)
2784
2785 /* ========== Environment implementation ========== */
2786
2787 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2788
2789 static int
2790 hash_fn (const char *key, int table_size)
2791 {
2792 const unsigned char *p = key;
2793 uint32_t hash = 2166136261;
2794
2795 while (*p)
2796 hash = (hash ^ *p++) * 16777619;
2797
2798 return hash % table_size;
2799 }
2800 #endif
2801
2802 #ifndef USE_ALIST_ENV
2803
2804 /*
2805 * In this implementation, each frame of the environment may be
2806 * a hash table: a vector of alists hashed by variable name.
2807 * In practice, we use a vector only for the initial frame;
2808 * subsequent frames are too small and transient for the lookup
2809 * speed to out-weigh the cost of making a new vector.
2810 */
2811
2812 static void
2813 new_frame_in_env (SCHEME_P_ pointer old_env)
2814 {
2815 pointer new_frame;
2816
2817 /* The interaction-environment has about 300 variables in it. */
2818 if (old_env == NIL)
2819 new_frame = mk_vector (SCHEME_A_ 461);
2820 else
2821 new_frame = NIL;
2822
2823 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2824 setenvironment (SCHEME_V->envir);
2825 }
2826
2827 static INLINE void
2828 new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2829 {
2830 pointer slot = immutable_cons (variable, value);
2831
2832 if (is_vector (car (env)))
2833 {
2834 int location = hash_fn (symname (variable), veclength (car (env)));
2835
2836 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2837 }
2838 else
2839 set_car (env, immutable_cons (slot, car (env)));
2840 }
2841
2842 static pointer
2843 find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2844 {
2845 pointer x, y;
2846 int location;
2847
2848 for (x = env; x != NIL; x = cdr (x))
2849 {
2850 if (is_vector (car (x)))
2851 {
2852 location = hash_fn (symname (hdl), veclength (car (x)));
2853 y = vector_elem (car (x), location);
2854 }
2855 else
2856 y = car (x);
2857
2858 for (; y != NIL; y = cdr (y))
2859 if (caar (y) == hdl)
2860 break;
2861
2862 if (y != NIL)
2863 break;
2864
2865 if (!all)
2866 return NIL;
2867 }
2868
2869 if (x != NIL)
2870 return car (y);
2871
2872 return NIL;
2873 }
2874
2875 #else /* USE_ALIST_ENV */
2876
2877 static INLINE void
2878 new_frame_in_env (SCHEME_P_ pointer old_env)
2879 {
2880 SCHEME_V->envir = immutable_cons (NIL, old_env);
2881 setenvironment (SCHEME_V->envir);
2882 }
2883
2884 static INLINE void
2885 new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2886 {
2887 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2888 }
2889
2890 static pointer
2891 find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2892 {
2893 pointer x, y;
2894
2895 for (x = env; x != NIL; x = cdr (x))
2896 {
2897 for (y = car (x); y != NIL; y = cdr (y))
2898 if (caar (y) == hdl)
2899 break;
2900
2901 if (y != NIL)
2902 break;
2903
2904 if (!all)
2905 return NIL;
2906 }
2907
2908 if (x != NIL)
2909 return car (y);
2910
2911 return NIL;
2912 }
2913
2914 #endif /* USE_ALIST_ENV else */
2915
2916 static INLINE void
2917 new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2918 {
2919 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2920 }
2921
2922 static INLINE void
2923 set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2924 {
2925 set_cdr (slot, value);
2926 }
2927
2928 static INLINE pointer
2929 slot_value_in_env (pointer slot)
2930 {
2931 return cdr (slot);
2932 }
2933
2934 /* ========== Evaluation Cycle ========== */
2935
2936 static pointer
2937 xError_1 (SCHEME_P_ const char *s, pointer a)
2938 {
2939 #if USE_ERROR_HOOK
2940 pointer x;
2941 pointer hdl = SCHEME_V->ERROR_HOOK;
2942 #endif
2943
2944 #if USE_PRINTF
2945 #if SHOW_ERROR_LINE
2946 char sbuf[STRBUFFSIZE];
2947
2948 /* make sure error is not in REPL */
2949 if ((SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) && SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file != STDIN_FILENO)
2950 {
2951 int ln = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line;
2952 const char *fname = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename;
2953
2954 /* should never happen */
2955 if (!fname)
2956 fname = "<unknown>";
2957
2958 /* we started from 0 */
2959 ln++;
2960 snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2961
2962 s = sbuf;
2963 }
2964 #endif
2965 #endif
2966
2967 #if USE_ERROR_HOOK
2968 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
2969
2970 if (x != NIL)
2971 {
2972 pointer code = a
2973 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
2974 : NIL;
2975
2976 code = cons (mk_string (SCHEME_A_ s), code);
2977 setimmutable (car (code));
2978 SCHEME_V->code = cons (slot_value_in_env (x), code);
2979 SCHEME_V->op = OP_EVAL;
2980
2981 return S_T;
2982 }
2983 #endif
2984
2985 if (a)
2986 SCHEME_V->args = cons (a, NIL);
2987 else
2988 SCHEME_V->args = NIL;
2989
2990 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2991 setimmutable (car (SCHEME_V->args));
2992 SCHEME_V->op = OP_ERR0;
2993 return S_T;
2994 }
2995
2996 #define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2997 #define Error_0(s) Error_1 (s, 0)
2998
2999 /* Too small to turn into function */
3000 #define BEGIN do {
3001 #define END } while (0)
3002 #define s_goto(a) BEGIN \
3003 SCHEME_V->op = a; \
3004 return S_T; END
3005
3006 #define s_return(a) return xs_return (SCHEME_A_ a)
3007
3008 #ifndef USE_SCHEME_STACK
3009
3010 /* this structure holds all the interpreter's registers */
3011 struct dump_stack_frame
3012 {
3013 enum scheme_opcodes op;
3014 pointer args;
3015 pointer envir;
3016 pointer code;
3017 };
3018
3019 # define STACK_GROWTH 3
3020
3021 static void
3022 s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3023 {
3024 int nframes = (uintptr_t)SCHEME_V->dump;
3025 struct dump_stack_frame *next_frame;
3026
3027 /* enough room for the next frame? */
3028 if (nframes >= SCHEME_V->dump_size)
3029 {
3030 SCHEME_V->dump_size += STACK_GROWTH;
3031 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3032 }
3033
3034 next_frame = SCHEME_V->dump_base + nframes;
3035
3036 next_frame->op = op;
3037 next_frame->args = args;
3038 next_frame->envir = SCHEME_V->envir;
3039 next_frame->code = code;
3040
3041 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3042 }
3043
3044 static pointer
3045 xs_return (SCHEME_P_ pointer a)
3046 {
3047 int nframes = (uintptr_t)SCHEME_V->dump;
3048 struct dump_stack_frame *frame;
3049
3050 SCHEME_V->value = a;
3051
3052 if (nframes <= 0)
3053 return NIL;
3054
3055 frame = &SCHEME_V->dump_base[--nframes];
3056 SCHEME_V->op = frame->op;
3057 SCHEME_V->args = frame->args;
3058 SCHEME_V->envir = frame->envir;
3059 SCHEME_V->code = frame->code;
3060 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3061
3062 return S_T;
3063 }
3064
3065 static INLINE void
3066 dump_stack_reset (SCHEME_P)
3067 {
3068 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3069 SCHEME_V->dump = (pointer)+0;
3070 }
3071
3072 static INLINE void
3073 dump_stack_initialize (SCHEME_P)
3074 {
3075 SCHEME_V->dump_size = 0;
3076 SCHEME_V->dump_base = 0;
3077 dump_stack_reset (SCHEME_A);
3078 }
3079
3080 static void
3081 dump_stack_free (SCHEME_P)
3082 {
3083 free (SCHEME_V->dump_base);
3084 SCHEME_V->dump_base = 0;
3085 SCHEME_V->dump = (pointer)0;
3086 SCHEME_V->dump_size = 0;
3087 }
3088
3089 static void
3090 dump_stack_mark (SCHEME_P)
3091 {
3092 int nframes = (uintptr_t)SCHEME_V->dump;
3093 int i;
3094
3095 for (i = 0; i < nframes; i++)
3096 {
3097 struct dump_stack_frame *frame = SCHEME_V->dump_base + i;
3098
3099 mark (frame->args);
3100 mark (frame->envir);
3101 mark (frame->code);
3102 }
3103 }
3104
3105 static pointer
3106 ss_get_cont (SCHEME_P)
3107 {
3108 int nframes = (uintptr_t)SCHEME_V->dump;
3109 int i;
3110
3111 pointer cont = NIL;
3112
3113 for (i = nframes; i--; )
3114 {
3115 struct dump_stack_frame *frame = SCHEME_V->dump_base + i;
3116
3117 cont = cons (mk_integer (SCHEME_A_ frame->op),
3118 cons (frame->args,
3119 cons (frame->envir,
3120 cons (frame->code,
3121 cont))));
3122 }
3123
3124 return cont;
3125 }
3126
3127 static void
3128 ss_set_cont (SCHEME_P_ pointer cont)
3129 {
3130 int i = 0;
3131 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3132
3133 while (cont != NIL)
3134 {
3135 frame->op = ivalue (car (cont)); cont = cdr (cont);
3136 frame->args = car (cont) ; cont = cdr (cont);
3137 frame->envir = car (cont) ; cont = cdr (cont);
3138 frame->code = car (cont) ; cont = cdr (cont);
3139
3140 ++frame;
3141 ++i;
3142 }
3143
3144 SCHEME_V->dump = (pointer)(uintptr_t)i;
3145 }
3146
3147 #else
3148
3149 static INLINE void
3150 dump_stack_reset (SCHEME_P)
3151 {
3152 SCHEME_V->dump = NIL;
3153 }
3154
3155 static INLINE void
3156 dump_stack_initialize (SCHEME_P)
3157 {
3158 dump_stack_reset (SCHEME_A);
3159 }
3160
3161 static void
3162 dump_stack_free (SCHEME_P)
3163 {
3164 SCHEME_V->dump = NIL;
3165 }
3166
3167 static pointer
3168 xs_return (SCHEME_P_ pointer a)
3169 {
3170 pointer dump = SCHEME_V->dump;
3171
3172 SCHEME_V->value = a;
3173
3174 if (dump == NIL)
3175 return NIL;
3176
3177 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3178 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3179 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3180 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3181
3182 SCHEME_V->dump = dump;
3183
3184 return S_T;
3185 }
3186
3187 static void
3188 s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3189 {
3190 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3191 cons (args,
3192 cons (SCHEME_V->envir,
3193 cons (code,
3194 SCHEME_V->dump))));
3195 }
3196
3197 static void
3198 dump_stack_mark (SCHEME_P)
3199 {
3200 mark (SCHEME_V->dump);
3201 }
3202
3203 static pointer
3204 ss_get_cont (SCHEME_P)
3205 {
3206 return SCHEME_V->dump;
3207 }
3208
3209 static void
3210 ss_set_cont (SCHEME_P_ pointer cont)
3211 {
3212 SCHEME_V->dump = cont;
3213 }
3214
3215 #endif
3216
3217 #define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3218
3219 static pointer
3220 opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3221 {
3222 pointer args = SCHEME_V->args;
3223 pointer x, y;
3224
3225 switch (op)
3226 {
3227 case OP_LOAD: /* load */
3228 if (file_interactive (SCHEME_A))
3229 {
3230 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3231 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3232 }
3233
3234 if (!file_push (SCHEME_A_ strvalue (car (args))))
3235 Error_1 ("unable to open", car (args));
3236 else
3237 {
3238 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3239 s_goto (OP_T0LVL);
3240 }
3241
3242 case OP_T0LVL: /* top level */
3243
3244 /* If we reached the end of file, this loop is done. */
3245 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF)
3246 {
3247 if (SCHEME_V->file_i == 0)
3248 {
3249 SCHEME_V->args = NIL;
3250 s_goto (OP_QUIT);
3251 }
3252 else
3253 {
3254 file_pop (SCHEME_A);
3255 s_return (SCHEME_V->value);
3256 }
3257
3258 /* NOTREACHED */
3259 }
3260
3261 /* If interactive, be nice to user. */
3262 if (file_interactive (SCHEME_A))
3263 {
3264 SCHEME_V->envir = SCHEME_V->global_env;
3265 dump_stack_reset (SCHEME_A);
3266 putstr (SCHEME_A_ "\n");
3267 putstr (SCHEME_A_ prompt);
3268 }
3269
3270 /* Set up another iteration of REPL */
3271 SCHEME_V->nesting = 0;
3272 SCHEME_V->save_inport = SCHEME_V->inport;
3273 SCHEME_V->inport = SCHEME_V->loadport;
3274 s_save (SCHEME_A_ OP_T0LVL, NIL, NIL);
3275 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3276 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3277 s_goto (OP_READ_INTERNAL);
3278
3279 case OP_T1LVL: /* top level */
3280 SCHEME_V->code = SCHEME_V->value;
3281 SCHEME_V->inport = SCHEME_V->save_inport;
3282 s_goto (OP_EVAL);
3283
3284 case OP_READ_INTERNAL: /* internal read */
3285 SCHEME_V->tok = token (SCHEME_A);
3286
3287 if (SCHEME_V->tok == TOK_EOF)
3288 s_return (S_EOF);
3289
3290 s_goto (OP_RDSEXPR);
3291
3292 case OP_GENSYM:
3293 s_return (gensym (SCHEME_A));
3294
3295 case OP_VALUEPRINT: /* print evaluation result */
3296
3297 /* OP_VALUEPRINT is always pushed, because when changing from
3298 non-interactive to interactive mode, it needs to be
3299 already on the stack */
3300 #if USE_TRACING
3301 if (SCHEME_V->tracing)
3302 putstr (SCHEME_A_ "\nGives: ");
3303 #endif
3304
3305 if (file_interactive (SCHEME_A))
3306 {
3307 SCHEME_V->print_flag = 1;
3308 SCHEME_V->args = SCHEME_V->value;
3309 s_goto (OP_P0LIST);
3310 }
3311 else
3312 s_return (SCHEME_V->value);
3313
3314 case OP_EVAL: /* main part of evaluation */
3315 #if USE_TRACING
3316 if (SCHEME_V->tracing)
3317 {
3318 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
3319 s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
3320 SCHEME_V->args = SCHEME_V->code;
3321 putstr (SCHEME_A_ "\nEval: ");
3322 s_goto (OP_P0LIST);
3323 }
3324
3325 /* fall through */
3326
3327 case OP_REAL_EVAL:
3328 #endif
3329 if (is_symbol (SCHEME_V->code)) /* symbol */
3330 {
3331 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3332
3333 if (x != NIL)
3334 s_return (slot_value_in_env (x));
3335 else
3336 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3337 }
3338 else if (is_pair (SCHEME_V->code))
3339 {
3340 x = car (SCHEME_V->code);
3341
3342 if (is_syntax (x)) /* SYNTAX */
3343 {
3344 SCHEME_V->code = cdr (SCHEME_V->code);
3345 s_goto (syntaxnum (x));
3346 }
3347 else /* first, eval top element and eval arguments */
3348 {
3349 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3350 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3351 SCHEME_V->code = x;
3352 s_goto (OP_EVAL);
3353 }
3354 }
3355 else
3356 s_return (SCHEME_V->code);
3357
3358 case OP_E0ARGS: /* eval arguments */
3359 if (is_macro (SCHEME_V->value)) /* macro expansion */
3360 {
3361 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3362 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3363 SCHEME_V->code = SCHEME_V->value;
3364 s_goto (OP_APPLY);
3365 }
3366 else
3367 {
3368 SCHEME_V->code = cdr (SCHEME_V->code);
3369 s_goto (OP_E1ARGS);
3370 }
3371
3372 case OP_E1ARGS: /* eval arguments */
3373 args = cons (SCHEME_V->value, args);
3374
3375 if (is_pair (SCHEME_V->code)) /* continue */
3376 {
3377 s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
3378 SCHEME_V->code = car (SCHEME_V->code);
3379 SCHEME_V->args = NIL;
3380 s_goto (OP_EVAL);
3381 }
3382 else /* end */
3383 {
3384 args = reverse_in_place (SCHEME_A_ NIL, args);
3385 SCHEME_V->code = car (args);
3386 SCHEME_V->args = cdr (args);
3387 s_goto (OP_APPLY);
3388 }
3389
3390 #if USE_TRACING
3391
3392 case OP_TRACING:
3393 {
3394 int tr = SCHEME_V->tracing;
3395
3396 SCHEME_V->tracing = ivalue (car (args));
3397 s_return (mk_integer (SCHEME_A_ tr));
3398 }
3399
3400 #endif
3401
3402 case OP_APPLY: /* apply 'code' to 'args' */
3403 #if USE_TRACING
3404 if (SCHEME_V->tracing)
3405 {
3406 s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
3407 SCHEME_V->print_flag = 1;
3408 /* args=cons(SCHEME_V->code,args); */
3409 putstr (SCHEME_A_ "\nApply to: ");
3410 s_goto (OP_P0LIST);
3411 }
3412
3413 /* fall through */
3414
3415 case OP_REAL_APPLY:
3416 #endif
3417 if (is_proc (SCHEME_V->code))
3418 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3419 else if (is_foreign (SCHEME_V->code))
3420 {
3421 /* Keep nested calls from GC'ing the arglist */
3422 push_recent_alloc (SCHEME_A_ args, NIL);
3423 x = SCHEME_V->code->object.ff (SCHEME_A_ args);
3424
3425 s_return (x);
3426 }
3427 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3428 {
3429 /* Should not accept promise */
3430 /* make environment */
3431 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3432
3433 for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
3434 {
3435 if (y == NIL)
3436 Error_0 ("not enough arguments");
3437 else
3438 new_slot_in_env (SCHEME_A_ car (x), car (y));
3439 }
3440
3441 if (x == NIL)
3442 {
3443 /*--
3444 * if (y != NIL) {
3445 * Error_0("too many arguments");
3446 * }
3447 */
3448 }
3449 else if (is_symbol (x))
3450 new_slot_in_env (SCHEME_A_ x, y);
3451 else
3452 Error_1 ("syntax error in closure: not a symbol:", x);
3453
3454 SCHEME_V->code = cdr (closure_code (SCHEME_V->code));
3455 SCHEME_V->args = NIL;
3456 s_goto (OP_BEGIN);
3457 }
3458 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3459 {
3460 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3461 s_return (args != NIL ? car (args) : NIL);
3462 }
3463 else
3464 Error_0 ("illegal function");
3465
3466 case OP_DOMACRO: /* do macro */
3467 SCHEME_V->code = SCHEME_V->value;
3468 s_goto (OP_EVAL);
3469
3470 #if 1
3471
3472 case OP_LAMBDA: /* lambda */
3473 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3474 set SCHEME_V->value fall thru */
3475 {
3476 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
3477
3478 if (f != NIL)
3479 {
3480 s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
3481 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3482 SCHEME_V->code = slot_value_in_env (f);
3483 s_goto (OP_APPLY);
3484 }
3485
3486 SCHEME_V->value = SCHEME_V->code;
3487 /* Fallthru */
3488 }
3489
3490 case OP_LAMBDA1:
3491 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3492
3493 #else
3494
3495 case OP_LAMBDA: /* lambda */
3496 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3497
3498 #endif
3499
3500 case OP_MKCLOSURE: /* make-closure */
3501 x = car (args);
3502
3503 if (car (x) == SCHEME_V->LAMBDA)
3504 x = cdr (x);
3505
3506 if (cdr (args) == NIL)
3507 y = SCHEME_V->envir;
3508 else
3509 y = cadr (args);
3510
3511 s_return (mk_closure (SCHEME_A_ x, y));
3512
3513 case OP_QUOTE: /* quote */
3514 s_return (car (SCHEME_V->code));
3515
3516 case OP_DEF0: /* define */
3517 if (is_immutable (car (SCHEME_V->code)))
3518 Error_1 ("define: unable to alter immutable", car (SCHEME_V->code));
3519
3520 if (is_pair (car (SCHEME_V->code)))
3521 {
3522 x = caar (SCHEME_V->code);
3523 SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code)));
3524 }
3525 else
3526 {
3527 x = car (SCHEME_V->code);
3528 SCHEME_V->code = cadr (SCHEME_V->code);
3529 }
3530
3531 if (!is_symbol (x))
3532 Error_0 ("variable is not a symbol");
3533
3534 s_save (SCHEME_A_ OP_DEF1, NIL, x);
3535 s_goto (OP_EVAL);
3536
3537 case OP_DEF1: /* define */
3538 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);
3539
3540 if (x != NIL)
3541 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
3542 else
3543 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3544
3545 s_return (SCHEME_V->code);
3546
3547
3548 case OP_DEFP: /* defined? */
3549 x = SCHEME_V->envir;
3550
3551 if (cdr (args) != NIL)
3552 x = cadr (args);
3553
3554 s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);
3555
3556 case OP_SET0: /* set! */
3557 if (is_immutable (car (SCHEME_V->code)))
3558 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));
3559
3560 s_save (SCHEME_A_ OP_SET1, NIL, car (SCHEME_V->code));
3561 SCHEME_V->code = cadr (SCHEME_V->code);
3562 s_goto (OP_EVAL);
3563
3564 case OP_SET1: /* set! */
3565 y = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3566
3567 if (y != NIL)
3568 {
3569 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3570 s_return (SCHEME_V->value);
3571 }
3572 else
3573 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3574
3575
3576 case OP_BEGIN: /* begin */
3577 if (!is_pair (SCHEME_V->code))
3578 s_return (SCHEME_V->code);
3579
3580 if (cdr (SCHEME_V->code) != NIL)
3581 s_save (SCHEME_A_ OP_BEGIN, NIL, cdr (SCHEME_V->code));
3582
3583 SCHEME_V->code = car (SCHEME_V->code);
3584 s_goto (OP_EVAL);
3585
3586 case OP_IF0: /* if */
3587 s_save (SCHEME_A_ OP_IF1, NIL, cdr (SCHEME_V->code));
3588 SCHEME_V->code = car (SCHEME_V->code);
3589 s_goto (OP_EVAL);
3590
3591 case OP_IF1: /* if */
3592 if (is_true (SCHEME_V->value))
3593 SCHEME_V->code = car (SCHEME_V->code);
3594 else
3595 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3596 s_goto (OP_EVAL);
3597
3598 case OP_LET0: /* let */
3599 SCHEME_V->args = NIL;
3600 SCHEME_V->value = SCHEME_V->code;
3601 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3602 s_goto (OP_LET1);
3603
3604 case OP_LET1: /* let (calculate parameters) */
3605 args = cons (SCHEME_V->value, args);
3606
3607 if (is_pair (SCHEME_V->code)) /* continue */
3608 {
3609 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3610 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3611
3612 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
3613 SCHEME_V->code = cadar (SCHEME_V->code);
3614 SCHEME_V->args = NIL;
3615 s_goto (OP_EVAL);
3616 }
3617 else /* end */
3618 {
3619 args = reverse_in_place (SCHEME_A_ NIL, args);
3620 SCHEME_V->code = car (args);
3621 SCHEME_V->args = cdr (args);
3622 s_goto (OP_LET2);
3623 }
3624
3625 case OP_LET2: /* let */
3626 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3627
3628 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3629 y != NIL; x = cdr (x), y = cdr (y))
3630 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3631
3632 if (is_symbol (car (SCHEME_V->code))) /* named let */
3633 {
3634 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3635 {
3636 if (!is_pair (x))
3637 Error_1 ("Bad syntax of binding in let :", x);
3638
3639 if (!is_list (SCHEME_A_ car (x)))
3640 Error_1 ("Bad syntax of binding in let :", car (x));
3641
3642 args = cons (caar (x), args);
3643 }
3644
3645 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
3646 SCHEME_V->envir);
3647 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
3648 SCHEME_V->code = cddr (SCHEME_V->code);
3649 }
3650 else
3651 {
3652 SCHEME_V->code = cdr (SCHEME_V->code);
3653 }
3654
3655 SCHEME_V->args = NIL;
3656 s_goto (OP_BEGIN);
3657
3658 case OP_LET0AST: /* let* */
3659 if (car (SCHEME_V->code) == NIL)
3660 {
3661 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3662 SCHEME_V->code = cdr (SCHEME_V->code);
3663 s_goto (OP_BEGIN);
3664 }
3665
3666 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3667 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code));
3668
3669 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3670 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3671 s_goto (OP_EVAL);
3672
3673 case OP_LET1AST: /* let* (make new frame) */
3674 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3675 s_goto (OP_LET2AST);
3676
3677 case OP_LET2AST: /* let* (calculate parameters) */
3678 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
3679 SCHEME_V->code = cdr (SCHEME_V->code);
3680
3681 if (is_pair (SCHEME_V->code)) /* continue */
3682 {
3683 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3684 SCHEME_V->code = cadar (SCHEME_V->code);
3685 SCHEME_V->args = NIL;
3686 s_goto (OP_EVAL);
3687 }
3688 else /* end */
3689 {
3690 SCHEME_V->code = args;
3691 SCHEME_V->args = NIL;
3692 s_goto (OP_BEGIN);
3693 }
3694
3695 case OP_LET0REC: /* letrec */
3696 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3697 SCHEME_V->args = NIL;
3698 SCHEME_V->value = SCHEME_V->code;
3699 SCHEME_V->code = car (SCHEME_V->code);
3700 s_goto (OP_LET1REC);
3701
3702 case OP_LET1REC: /* letrec (calculate parameters) */
3703 args = cons (SCHEME_V->value, args);
3704
3705 if (is_pair (SCHEME_V->code)) /* continue */
3706 {
3707 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3708 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3709
3710 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3711 SCHEME_V->code = cadar (SCHEME_V->code);
3712 SCHEME_V->args = NIL;
3713 s_goto (OP_EVAL);
3714 }
3715 else /* end */
3716 {
3717 args = reverse_in_place (SCHEME_A_ NIL, args);
3718 SCHEME_V->code = car (args);
3719 SCHEME_V->args = cdr (args);
3720 s_goto (OP_LET2REC);
3721 }
3722
3723 case OP_LET2REC: /* letrec */
3724 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3725 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3726
3727 SCHEME_V->code = cdr (SCHEME_V->code);
3728 SCHEME_V->args = NIL;
3729 s_goto (OP_BEGIN);
3730
3731 case OP_COND0: /* cond */
3732 if (!is_pair (SCHEME_V->code))
3733 Error_0 ("syntax error in cond");
3734
3735 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3736 SCHEME_V->code = caar (SCHEME_V->code);
3737 s_goto (OP_EVAL);
3738
3739 case OP_COND1: /* cond */
3740 if (is_true (SCHEME_V->value))
3741 {
3742 if ((SCHEME_V->code = cdar (SCHEME_V->code)) == NIL)
3743 s_return (SCHEME_V->value);
3744
3745 if (car (SCHEME_V->code) == SCHEME_V->FEED_TO)
3746 {
3747 if (!is_pair (cdr (SCHEME_V->code)))
3748 Error_0 ("syntax error in cond");
3749
3750 x = cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL));
3751 SCHEME_V->code = cons (cadr (SCHEME_V->code), cons (x, NIL));
3752 s_goto (OP_EVAL);
3753 }
3754
3755 s_goto (OP_BEGIN);
3756 }
3757 else
3758 {
3759 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3760 s_return (NIL);
3761 else
3762 {
3763 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3764 SCHEME_V->code = caar (SCHEME_V->code);
3765 s_goto (OP_EVAL);
3766 }
3767 }
3768
3769 case OP_DELAY: /* delay */
3770 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3771 set_typeflag (x, T_PROMISE);
3772 s_return (x);
3773
3774 case OP_AND0: /* and */
3775 if (SCHEME_V->code == NIL)
3776 s_return (S_T);
3777
3778 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3779 SCHEME_V->code = car (SCHEME_V->code);
3780 s_goto (OP_EVAL);
3781
3782 case OP_AND1: /* and */
3783 if (is_false (SCHEME_V->value))
3784 s_return (SCHEME_V->value);
3785 else if (SCHEME_V->code == NIL)
3786 s_return (SCHEME_V->value);
3787 else
3788 {
3789 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3790 SCHEME_V->code = car (SCHEME_V->code);
3791 s_goto (OP_EVAL);
3792 }
3793
3794 case OP_OR0: /* or */
3795 if (SCHEME_V->code == NIL)
3796 s_return (S_F);
3797
3798 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3799 SCHEME_V->code = car (SCHEME_V->code);
3800 s_goto (OP_EVAL);
3801
3802 case OP_OR1: /* or */
3803 if (is_true (SCHEME_V->value))
3804 s_return (SCHEME_V->value);
3805 else if (SCHEME_V->code == NIL)
3806 s_return (SCHEME_V->value);
3807 else
3808 {
3809 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3810 SCHEME_V->code = car (SCHEME_V->code);
3811 s_goto (OP_EVAL);
3812 }
3813
3814 case OP_C0STREAM: /* cons-stream */
3815 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3816 SCHEME_V->code = car (SCHEME_V->code);
3817 s_goto (OP_EVAL);
3818
3819 case OP_C1STREAM: /* cons-stream */
3820 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */
3821 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3822 set_typeflag (x, T_PROMISE);
3823 s_return (cons (args, x));
3824
3825 case OP_MACRO0: /* macro */
3826 if (is_pair (car (SCHEME_V->code)))
3827 {
3828 x = caar (SCHEME_V->code);
3829 SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code)));
3830 }
3831 else
3832 {
3833 x = car (SCHEME_V->code);
3834 SCHEME_V->code = cadr (SCHEME_V->code);
3835 }
3836
3837 if (!is_symbol (x))
3838 Error_0 ("variable is not a symbol");
3839
3840 s_save (SCHEME_A_ OP_MACRO1, NIL, x);
3841 s_goto (OP_EVAL);
3842
3843 case OP_MACRO1: /* macro */
3844 set_typeflag (SCHEME_V->value, T_MACRO);
3845 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);
3846
3847 if (x != NIL)
3848 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
3849 else
3850 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3851
3852 s_return (SCHEME_V->code);
3853
3854 case OP_CASE0: /* case */
3855 s_save (SCHEME_A_ OP_CASE1, NIL, cdr (SCHEME_V->code));
3856 SCHEME_V->code = car (SCHEME_V->code);
3857 s_goto (OP_EVAL);
3858
3859 case OP_CASE1: /* case */
3860 for (x = SCHEME_V->code; x != NIL; x = cdr (x))
3861 {
3862 if (!is_pair (y = caar (x)))
3863 break;
3864
3865 for (; y != NIL; y = cdr (y))
3866 if (eqv (car (y), SCHEME_V->value))
3867 break;
3868
3869 if (y != NIL)
3870 break;
3871 }
3872
3873 if (x != NIL)
3874 {
3875 if (is_pair (caar (x)))
3876 {
3877 SCHEME_V->code = cdar (x);
3878 s_goto (OP_BEGIN);
3879 }
3880 else /* else */
3881 {
3882 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3883 SCHEME_V->code = caar (x);
3884 s_goto (OP_EVAL);
3885 }
3886 }
3887 else
3888 s_return (NIL);
3889
3890 case OP_CASE2: /* case */
3891 if (is_true (SCHEME_V->value))
3892 s_goto (OP_BEGIN);
3893 else
3894 s_return (NIL);
3895
3896 case OP_PAPPLY: /* apply */
3897 SCHEME_V->code = car (args);
3898 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3899 /*SCHEME_V->args = cadr(args); */
3900 s_goto (OP_APPLY);
3901
3902 case OP_PEVAL: /* eval */
3903 if (cdr (args) != NIL)
3904 SCHEME_V->envir = cadr (args);
3905
3906 SCHEME_V->code = car (args);
3907 s_goto (OP_EVAL);
3908
3909 case OP_CONTINUATION: /* call-with-current-continuation */
3910 SCHEME_V->code = car (args);
3911 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3912 s_goto (OP_APPLY);
3913 }
3914
3915 abort ();
3916 }
3917
3918 static pointer
3919 opexe_2 (SCHEME_P_ enum scheme_opcodes op)
3920 {
3921 pointer args = SCHEME_V->args;
3922 pointer x = car (args);
3923 num v;
3924
3925 #if USE_MATH
3926 RVALUE dd;
3927 #endif
3928
3929 switch (op)
3930 {
3931 #if USE_MATH
3932 case OP_INEX2EX: /* inexact->exact */
3933 if (num_is_integer (x))
3934 s_return (x);
3935 else if (modf (rvalue_unchecked (x), &dd) == 0)
3936 s_return (mk_integer (SCHEME_A_ ivalue (x)));
3937 else
3938 Error_1 ("inexact->exact: not integral:", x);
3939
3940 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3941 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));
3942 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3943 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
3944 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
3945 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
3946 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
3947
3948 case OP_ATAN:
3949 if (cdr (args) == NIL)
3950 s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
3951 else
3952 {
3953 pointer y = cadr (args);
3954 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
3955 }
3956
3957 case OP_SQRT:
3958 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3959
3960 case OP_EXPT:
3961 {
3962 RVALUE result;
3963 int real_result = 1;
3964 pointer y = cadr (args);
3965
3966 if (num_is_integer (x) && num_is_integer (y))
3967 real_result = 0;
3968
3969 /* This 'if' is an R5RS compatibility fix. */
3970 /* NOTE: Remove this 'if' fix for R6RS. */
3971 if (rvalue (x) == 0 && rvalue (y) < 0)
3972 result = 0;
3973 else
3974 result = pow (rvalue (x), rvalue (y));
3975
3976 /* Before returning integer result make sure we can. */
3977 /* If the test fails, result is too big for integer. */
3978 if (!real_result)
3979 {
3980 long result_as_long = result;
3981
3982 if (result != (RVALUE) result_as_long)
3983 real_result = 1;
3984 }
3985
3986 if (real_result)
3987 s_return (mk_real (SCHEME_A_ result));
3988 else
3989 s_return (mk_integer (SCHEME_A_ result));
3990 }
3991
3992 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
3993 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3994
3995 case OP_TRUNCATE:
3996 {
3997 RVALUE rvalue_of_x;
3998
3999 rvalue_of_x = rvalue (x);
4000
4001 if (rvalue_of_x > 0)
4002 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4003 else
4004 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4005 }
4006
4007 case OP_ROUND:
4008 if (num_is_integer (x))
4009 s_return (x);
4010
4011 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4012 #endif
4013
4014 case OP_ADD: /* + */
4015 v = num_zero;
4016
4017 for (x = args; x != NIL; x = cdr (x))
4018 v = num_op ('+', v, nvalue (car (x)));
4019
4020 s_return (mk_number (SCHEME_A_ v));
4021
4022 case OP_MUL: /* * */
4023 v = num_one;
4024
4025 for (x = args; x != NIL; x = cdr (x))
4026 v = num_op ('+', v, nvalue (car (x)));
4027
4028 s_return (mk_number (SCHEME_A_ v));
4029
4030 case OP_SUB: /* - */
4031 if (cdr (args) == NIL)
4032 {
4033 x = args;
4034 v = num_zero;
4035 }
4036 else
4037 {
4038 x = cdr (args);
4039 v = nvalue (car (args));
4040 }
4041
4042 for (; x != NIL; x = cdr (x))
4043 v = num_op ('+', v, nvalue (car (x)));
4044
4045 s_return (mk_number (SCHEME_A_ v));
4046
4047 case OP_DIV: /* / */
4048 if (cdr (args) == NIL)
4049 {
4050 x = args;
4051 v = num_one;
4052 }
4053 else
4054 {
4055 x = cdr (args);
4056 v = nvalue (car (args));
4057 }
4058
4059 for (; x != NIL; x = cdr (x))
4060 {
4061 if (!is_zero_rvalue (rvalue (car (x))))
4062 v = num_div (v, nvalue (car (x)));
4063 else
4064 Error_0 ("/: division by zero");
4065 }
4066
4067 s_return (mk_number (SCHEME_A_ v));
4068
4069 case OP_INTDIV: /* quotient */
4070 if (cdr (args) == NIL)
4071 {
4072 x = args;
4073 v = num_one;
4074 }
4075 else
4076 {
4077 x = cdr (args);
4078 v = nvalue (car (args));
4079 }
4080
4081 for (; x != NIL; x = cdr (x))
4082 {
4083 if (ivalue (car (x)) != 0)
4084 v = num_op ('/', v, nvalue (car (x)));
4085 else
4086 Error_0 ("quotient: division by zero");
4087 }
4088
4089 s_return (mk_number (SCHEME_A_ v));
4090
4091 case OP_REM: /* remainder */
4092 v = nvalue (x);
4093
4094 if (ivalue (cadr (args)) != 0)
4095 v = num_rem (v, nvalue (cadr (args)));
4096 else
4097 Error_0 ("remainder: division by zero");
4098
4099 s_return (mk_number (SCHEME_A_ v));
4100
4101 case OP_MOD: /* modulo */
4102 v = nvalue (x);
4103
4104 if (ivalue (cadr (args)) != 0)
4105 v = num_mod (v, nvalue (cadr (args)));
4106 else
4107 Error_0 ("modulo: division by zero");
4108
4109 s_return (mk_number (SCHEME_A_ v));
4110
4111 case OP_CAR: /* car */
4112 s_return (caar (args));
4113
4114 case OP_CDR: /* cdr */
4115 s_return (cdar (args));
4116
4117 case OP_CONS: /* cons */
4118 set_cdr (args, cadr (args));
4119 s_return (args);
4120
4121 case OP_SETCAR: /* set-car! */
4122 if (!is_immutable (x))
4123 {
4124 set_car (x, cadr (args));
4125 s_return (car (args));
4126 }
4127 else
4128 Error_0 ("set-car!: unable to alter immutable pair");
4129
4130 case OP_SETCDR: /* set-cdr! */
4131 if (!is_immutable (x))
4132 {
4133 set_cdr (x, cadr (args));
4134 s_return (car (args));
4135 }
4136 else
4137 Error_0 ("set-cdr!: unable to alter immutable pair");
4138
4139 case OP_CHAR2INT: /* char->integer */
4140 s_return (mk_integer (SCHEME_A_ ivalue (x)));
4141
4142 case OP_INT2CHAR: /* integer->char */
4143 s_return (mk_character (SCHEME_A_ ivalue (x)));
4144
4145 case OP_CHARUPCASE:
4146 {
4147 unsigned char c = ivalue (x);
4148 c = toupper (c);
4149 s_return (mk_character (SCHEME_A_ c));
4150 }
4151
4152 case OP_CHARDNCASE:
4153 {
4154 unsigned char c = ivalue (x);
4155 c = tolower (c);
4156 s_return (mk_character (SCHEME_A_ c));
4157 }
4158
4159 case OP_STR2SYM: /* string->symbol */
4160 s_return (mk_symbol (SCHEME_A_ strvalue (x)));
4161
4162 case OP_STR2ATOM: /* string->atom */
4163 {
4164 char *s = strvalue (x);
4165 long pf = 0;
4166
4167 if (cdr (args) != NIL)
4168 {
4169 /* we know cadr(args) is a natural number */
4170 /* see if it is 2, 8, 10, or 16, or error */
4171 pf = ivalue_unchecked (cadr (args));
4172
4173 if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4174 {
4175 /* base is OK */
4176 }
4177 else
4178 pf = -1;
4179 }
4180
4181 if (pf < 0)
4182 Error_1 ("string->atom: bad base:", cadr (args));
4183 else if (*s == '#') /* no use of base! */
4184 s_return (mk_sharp_const (SCHEME_A_ s + 1));
4185 else
4186 {
4187 if (pf == 0 || pf == 10)
4188 s_return (mk_atom (SCHEME_A_ s));
4189 else
4190 {
4191 char *ep;
4192 long iv = strtol (s, &ep, (int) pf);
4193
4194 if (*ep == 0)
4195 s_return (mk_integer (SCHEME_A_ iv));
4196 else
4197 s_return (S_F);
4198 }
4199 }
4200 }
4201
4202 case OP_SYM2STR: /* symbol->string */
4203 x = mk_string (SCHEME_A_ symname (x));
4204 setimmutable (x);
4205 s_return (x);
4206
4207 case OP_ATOM2STR: /* atom->string */
4208 {
4209 long pf = 0;
4210
4211 if (cdr (args) != NIL)
4212 {
4213 /* we know cadr(args) is a natural number */
4214 /* see if it is 2, 8, 10, or 16, or error */
4215 pf = ivalue_unchecked (cadr (args));
4216
4217 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4218 {
4219 /* base is OK */
4220 }
4221 else
4222 pf = -1;
4223 }
4224
4225 if (pf < 0)
4226 Error_1 ("atom->string: bad base:", cadr (args));
4227 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4228 {
4229 char *p;
4230 int len;
4231
4232 atom2str (SCHEME_A_ x, pf, &p, &len);
4233 s_return (mk_counted_string (SCHEME_A_ p, len));
4234 }
4235 else
4236 Error_1 ("atom->string: not an atom:", x);
4237 }
4238
4239 case OP_MKSTRING: /* make-string */
4240 {
4241 int fill = ' ';
4242 int len;
4243
4244 len = ivalue (x);
4245
4246 if (cdr (args) != NIL)
4247 fill = charvalue (cadr (args));
4248
4249 s_return (mk_empty_string (SCHEME_A_ len, fill));
4250 }
4251
4252 case OP_STRLEN: /* string-length */
4253 s_return (mk_integer (SCHEME_A_ strlength (x)));
4254
4255 case OP_STRREF: /* string-ref */
4256 {
4257 char *str;
4258 int index;
4259
4260 str = strvalue (x);
4261
4262 index = ivalue (cadr (args));
4263
4264 if (index >= strlength (x))
4265 Error_1 ("string-ref: out of bounds:", cadr (args));
4266
4267 s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4268 }
4269
4270 case OP_STRSET: /* string-set! */
4271 {
4272 char *str;
4273 int index;
4274 int c;
4275
4276 if (is_immutable (x))
4277 Error_1 ("string-set!: unable to alter immutable string:", x);
4278
4279 str = strvalue (x);
4280
4281 index = ivalue (cadr (args));
4282
4283 if (index >= strlength (x))
4284 Error_1 ("string-set!: out of bounds:", cadr (args));
4285
4286 c = charvalue (caddr (args));
4287
4288 str[index] = c;
4289 s_return (car (args));
4290 }
4291
4292 case OP_STRAPPEND: /* string-append */
4293 {
4294 /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4295 int len = 0;
4296 pointer newstr;
4297 char *pos;
4298
4299 /* compute needed length for new string */
4300 for (x = args; x != NIL; x = cdr (x))
4301 len += strlength (car (x));
4302
4303 newstr = mk_empty_string (SCHEME_A_ len, ' ');
4304
4305 /* store the contents of the argument strings into the new string */
4306 for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4307 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4308
4309 s_return (newstr);
4310 }
4311
4312 case OP_SUBSTR: /* substring */
4313 {
4314 char *str;
4315 int index0;
4316 int index1;
4317 int len;
4318
4319 str = strvalue (x);
4320
4321 index0 = ivalue (cadr (args));
4322
4323 if (index0 > strlength (x))
4324 Error_1 ("substring: start out of bounds:", cadr (args));
4325
4326 if (cddr (args) != NIL)
4327 {
4328 index1 = ivalue (caddr (args));
4329
4330 if (index1 > strlength (x) || index1 < index0)
4331 Error_1 ("substring: end out of bounds:", caddr (args));
4332 }
4333 else
4334 index1 = strlength (x);
4335
4336 len = index1 - index0;
4337 x = mk_empty_string (SCHEME_A_ len, ' ');
4338 memcpy (strvalue (x), str + index0, len);
4339 strvalue (x)[len] = 0;
4340
4341 s_return (x);
4342 }
4343
4344 case OP_VECTOR: /* vector */
4345 {
4346 int i;
4347 pointer vec;
4348 int len = list_length (SCHEME_A_ args);
4349
4350 if (len < 0)
4351 Error_1 ("vector: not a proper list:", args);
4352
4353 vec = mk_vector (SCHEME_A_ len);
4354
4355 #if USE_ERROR_CHECKING
4356 if (SCHEME_V->no_memory)
4357 s_return (S_SINK);
4358 #endif
4359
4360 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4361 set_vector_elem (vec, i, car (x));
4362
4363 s_return (vec);
4364 }
4365
4366 case OP_MKVECTOR: /* make-vector */
4367 {
4368 pointer fill = NIL;
4369 int len;
4370 pointer vec;
4371
4372 len = ivalue (x);
4373
4374 if (cdr (args) != NIL)
4375 fill = cadr (args);
4376
4377 vec = mk_vector (SCHEME_A_ len);
4378
4379 #if USE_ERROR_CHECKING
4380 if (SCHEME_V->no_memory)
4381 s_return (S_SINK);
4382 #endif
4383
4384 if (fill != NIL)
4385 fill_vector (vec, fill);
4386
4387 s_return (vec);
4388 }
4389
4390 case OP_VECLEN: /* vector-length */
4391 s_return (mk_integer (SCHEME_A_ veclength (x)));
4392
4393 case OP_VECREF: /* vector-ref */
4394 {
4395 int index;
4396
4397 index = ivalue (cadr (args));
4398
4399 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4400 Error_1 ("vector-ref: out of bounds:", cadr (args));
4401
4402 s_return (vector_elem (x, index));
4403 }
4404
4405 case OP_VECSET: /* vector-set! */
4406 {
4407 int index;
4408
4409 if (is_immutable (x))
4410 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4411
4412 index = ivalue (cadr (args));
4413
4414 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4415 Error_1 ("vector-set!: out of bounds:", cadr (args));
4416
4417 set_vector_elem (x, index, caddr (args));
4418 s_return (x);
4419 }
4420 }
4421
4422 return S_T;
4423 }
4424
4425 INTERFACE int
4426 is_list (SCHEME_P_ pointer a)
4427 {
4428 return list_length (SCHEME_A_ a) >= 0;
4429 }
4430
4431 /* Result is:
4432 proper list: length
4433 circular list: -1
4434 not even a pair: -2
4435 dotted list: -2 minus length before dot
4436 */
4437 INTERFACE int
4438 list_length (SCHEME_P_ pointer a)
4439 {
4440 int i = 0;
4441 pointer slow, fast;
4442
4443 slow = fast = a;
4444
4445 while (1)
4446 {
4447 if (fast == NIL)
4448 return i;
4449
4450 if (!is_pair (fast))
4451 return -2 - i;
4452
4453 fast = cdr (fast);
4454 ++i;
4455
4456 if (fast == NIL)
4457 return i;
4458
4459 if (!is_pair (fast))
4460 return -2 - i;
4461
4462 ++i;
4463 fast = cdr (fast);
4464
4465 /* Safe because we would have already returned if `fast'
4466 encountered a non-pair. */
4467 slow = cdr (slow);
4468
4469 if (fast == slow)
4470 {
4471 /* the fast pointer has looped back around and caught up
4472 with the slow pointer, hence the structure is circular,
4473 not of finite length, and therefore not a list */
4474 return -1;
4475 }
4476 }
4477 }
4478
4479 static pointer
4480 opexe_r (SCHEME_P_ enum scheme_opcodes op)
4481 {
4482 pointer x = SCHEME_V->args;
4483
4484 for (;;)
4485 {
4486 num v = nvalue (car (x));
4487 x = cdr (x);
4488
4489 if (x == NIL)
4490 break;
4491
4492 int r = num_cmp (v, nvalue (car (x)));
4493
4494 switch (op)
4495 {
4496 case OP_NUMEQ: r = r == 0; break;
4497 case OP_LESS: r = r < 0; break;
4498 case OP_GRE: r = r > 0; break;
4499 case OP_LEQ: r = r <= 0; break;
4500 case OP_GEQ: r = r >= 0; break;
4501 }
4502
4503 if (!r)
4504 s_return (S_F);
4505 }
4506
4507 s_return (S_T);
4508 }
4509
4510 static pointer
4511 opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4512 {
4513 pointer args = SCHEME_V->args;
4514 pointer a = car (args);
4515 pointer d = cdr (args);
4516 int r;
4517
4518 switch (op)
4519 {
4520 case OP_NOT: /* not */ r = is_false (a) ; break;
4521 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break;
4522 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4523 case OP_NULLP: /* null? */ r = a == NIL ; break;
4524 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4525 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4526 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4527 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4528 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4529 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4530
4531 #if USE_CHAR_CLASSIFIERS
4532 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;
4533 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;
4534 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;
4535 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;
4536 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;
4537 #endif
4538
4539 #if USE_PORTS
4540 case OP_PORTP: /* port? */ r = is_port (a) ; break;
4541 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4542 case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4543 #endif
4544
4545 case OP_PROCP: /* procedure? */
4546
4547 /*--
4548 * continuation should be procedure by the example
4549 * (call-with-current-continuation procedure?) ==> #t
4550 * in R^3 report sec. 6.9
4551 */
4552 r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4553 break;
4554
4555 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4556 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4557 case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4558 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4559 case OP_EQ: /* eq? */ r = a == cadr (args) ; break;
4560 case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break;
4561 }
4562
4563 s_retbool (r);
4564 }
4565
4566 static pointer
4567 opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4568 {
4569 pointer args = SCHEME_V->args;
4570 pointer a = car (args);
4571 pointer x, y;
4572
4573 switch (op)
4574 {
4575 case OP_FORCE: /* force */
4576 SCHEME_V->code = a;
4577
4578 if (is_promise (SCHEME_V->code))
4579 {
4580 /* Should change type to closure here */
4581 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
4582 SCHEME_V->args = NIL;
4583 s_goto (OP_APPLY);
4584 }
4585 else
4586 s_return (SCHEME_V->code);
4587
4588 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4589 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));
4590 s_return (SCHEME_V->value);
4591
4592 #if USE_PORTS
4593
4594 case OP_WRITE: /* write */
4595 case OP_DISPLAY: /* display */
4596 case OP_WRITE_CHAR: /* write-char */
4597 if (is_pair (cdr (SCHEME_V->args)))
4598 {
4599 if (cadr (SCHEME_V->args) != SCHEME_V->outport)
4600 {
4601 x = cons (SCHEME_V->outport, NIL);
4602 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4603 SCHEME_V->outport = cadr (SCHEME_V->args);
4604 }
4605 }
4606
4607 SCHEME_V->args = a;
4608
4609 if (op == OP_WRITE)
4610 SCHEME_V->print_flag = 1;
4611 else
4612 SCHEME_V->print_flag = 0;
4613
4614 s_goto (OP_P0LIST);
4615
4616 case OP_NEWLINE: /* newline */
4617 if (is_pair (args))
4618 {
4619 if (a != SCHEME_V->outport)
4620 {
4621 x = cons (SCHEME_V->outport, NIL);
4622 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4623 SCHEME_V->outport = a;
4624 }
4625 }
4626
4627 putstr (SCHEME_A_ "\n");
4628 s_return (S_T);
4629 #endif
4630
4631 case OP_ERR0: /* error */
4632 SCHEME_V->retcode = -1;
4633
4634 if (!is_string (a))
4635 {
4636 args = cons (mk_string (SCHEME_A_ " -- "), args);
4637 setimmutable (car (args));
4638 }
4639
4640 putstr (SCHEME_A_ "Error: ");
4641 putstr (SCHEME_A_ strvalue (car (args)));
4642 SCHEME_V->args = cdr (args);
4643 s_goto (OP_ERR1);
4644
4645 case OP_ERR1: /* error */
4646 putstr (SCHEME_A_ " ");
4647
4648 if (args != NIL)
4649 {
4650 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4651 SCHEME_V->args = a;
4652 SCHEME_V->print_flag = 1;
4653 s_goto (OP_P0LIST);
4654 }
4655 else
4656 {
4657 putstr (SCHEME_A_ "\n");
4658
4659 if (SCHEME_V->interactive_repl)
4660 s_goto (OP_T0LVL);
4661 else
4662 return NIL;
4663 }
4664
4665 case OP_REVERSE: /* reverse */
4666 s_return (reverse (SCHEME_A_ a));
4667
4668 case OP_LIST_STAR: /* list* */
4669 s_return (list_star (SCHEME_A_ SCHEME_V->args));
4670
4671 case OP_APPEND: /* append */
4672 x = NIL;
4673 y = args;
4674
4675 if (y == x)
4676 s_return (x);
4677
4678 /* cdr() in the while condition is not a typo. If car() */
4679 /* is used (append '() 'a) will return the wrong result. */
4680 while (cdr (y) != NIL)
4681 {
4682 x = revappend (SCHEME_A_ x, car (y));
4683 y = cdr (y);
4684
4685 if (x == S_F)
4686 Error_0 ("non-list argument to append");
4687 }
4688
4689 s_return (reverse_in_place (SCHEME_A_ car (y), x));
4690
4691 #if USE_PLIST
4692
4693 case OP_PUT: /* put */
4694 if (!hasprop (a) || !hasprop (cadr (args)))
4695 Error_0 ("illegal use of put");
4696
4697 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4698 {
4699 if (caar (x) == y)
4700 break;
4701 }
4702
4703 if (x != NIL)
4704 cdar (x) = caddr (args);
4705 else
4706 symprop (a) = cons (cons (y, caddr (args)), symprop (a));
4707
4708 s_return (S_T);
4709
4710 case OP_GET: /* get */
4711 if (!hasprop (a) || !hasprop (cadr (args)))
4712 Error_0 ("illegal use of get");
4713
4714 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4715 if (caar (x) == y)
4716 break;
4717
4718 if (x != NIL)
4719 s_return (cdar (x));
4720 else
4721 s_return (NIL);
4722
4723 #endif /* USE_PLIST */
4724
4725 case OP_QUIT: /* quit */
4726 if (is_pair (args))
4727 SCHEME_V->retcode = ivalue (a);
4728
4729 return NIL;
4730
4731 case OP_GC: /* gc */
4732 gc (SCHEME_A_ NIL, NIL);
4733 s_return (S_T);
4734
4735 case OP_GCVERB: /* gc-verbose */
4736 {
4737 int was = SCHEME_V->gc_verbose;
4738
4739 SCHEME_V->gc_verbose = (a != S_F);
4740 s_retbool (was);
4741 }
4742
4743 case OP_NEWSEGMENT: /* new-segment */
4744 if (!is_pair (args) || !is_number (a))
4745 Error_0 ("new-segment: argument must be a number");
4746
4747 alloc_cellseg (SCHEME_A_ (int)ivalue (a));
4748
4749 s_return (S_T);
4750
4751 case OP_OBLIST: /* oblist */
4752 s_return (oblist_all_symbols (SCHEME_A));
4753
4754 #if USE_PORTS
4755
4756 case OP_CURR_INPORT: /* current-input-port */
4757 s_return (SCHEME_V->inport);
4758
4759 case OP_CURR_OUTPORT: /* current-output-port */
4760 s_return (SCHEME_V->outport);
4761
4762 case OP_OPEN_INFILE: /* open-input-file */
4763 case OP_OPEN_OUTFILE: /* open-output-file */
4764 case OP_OPEN_INOUTFILE: /* open-input-output-file */
4765 {
4766 int prop = 0;
4767 pointer p;
4768
4769 switch (op)
4770 {
4771 case OP_OPEN_INFILE:
4772 prop = port_input;
4773 break;
4774
4775 case OP_OPEN_OUTFILE:
4776 prop = port_output;
4777 break;
4778
4779 case OP_OPEN_INOUTFILE:
4780 prop = port_input | port_output;
4781 break;
4782 }
4783
4784 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4785
4786 if (p == NIL)
4787 s_return (S_F);
4788
4789 s_return (p);
4790 }
4791
4792 # if USE_STRING_PORTS
4793
4794 case OP_OPEN_INSTRING: /* open-input-string */
4795 case OP_OPEN_INOUTSTRING: /* open-input-output-string */
4796 {
4797 int prop = 0;
4798 pointer p;
4799
4800 switch (op)
4801 {
4802 case OP_OPEN_INSTRING:
4803 prop = port_input;
4804 break;
4805
4806 case OP_OPEN_INOUTSTRING:
4807 prop = port_input | port_output;
4808 break;
4809 }
4810
4811 p = port_from_string (SCHEME_A_ strvalue (a),
4812 strvalue (a) + strlength (a), prop);
4813
4814 if (p == NIL)
4815 s_return (S_F);
4816
4817 s_return (p);
4818 }
4819
4820 case OP_OPEN_OUTSTRING: /* open-output-string */
4821 {
4822 pointer p;
4823
4824 if (a == NIL)
4825 {
4826 p = port_from_scratch (SCHEME_A);
4827
4828 if (p == NIL)
4829 s_return (S_F);
4830 }
4831 else
4832 {
4833 p = port_from_string (SCHEME_A_ strvalue (a),
4834 strvalue (a) + strlength (a), port_output);
4835
4836 if (p == NIL)
4837 s_return (S_F);
4838 }
4839
4840 s_return (p);
4841 }
4842
4843 case OP_GET_OUTSTRING: /* get-output-string */
4844 {
4845 port *p;
4846
4847 if ((p = a->object.port)->kind & port_string)
4848 {
4849 off_t size;
4850 char *str;
4851
4852 size = p->rep.string.curr - p->rep.string.start + 1;
4853 str = malloc (size);
4854
4855 if (str != NULL)
4856 {
4857 pointer s;
4858
4859 memcpy (str, p->rep.string.start, size - 1);
4860 str[size - 1] = '\0';
4861 s = mk_string (SCHEME_A_ str);
4862 free (str);
4863 s_return (s);
4864 }
4865 }
4866
4867 s_return (S_F);
4868 }
4869
4870 # endif
4871
4872 case OP_CLOSE_INPORT: /* close-input-port */
4873 port_close (SCHEME_A_ a, port_input);
4874 s_return (S_T);
4875
4876 case OP_CLOSE_OUTPORT: /* close-output-port */
4877 port_close (SCHEME_A_ a, port_output);
4878 s_return (S_T);
4879 #endif
4880
4881 case OP_INT_ENV: /* interaction-environment */
4882 s_return (SCHEME_V->global_env);
4883
4884 case OP_CURR_ENV: /* current-environment */
4885 s_return (SCHEME_V->envir);
4886
4887 }
4888
4889 abort ();
4890 }
4891
4892 static pointer
4893 opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4894 {
4895 pointer args = SCHEME_V->args;
4896 pointer x;
4897
4898 if (SCHEME_V->nesting != 0)
4899 {
4900 int n = SCHEME_V->nesting;
4901
4902 SCHEME_V->nesting = 0;
4903 SCHEME_V->retcode = -1;
4904 Error_1 ("unmatched parentheses:", mk_integer (SCHEME_A_ n));
4905 }
4906
4907 switch (op)
4908 {
4909 /* ========== reading part ========== */
4910 #if USE_PORTS
4911 case OP_READ:
4912 if (!is_pair (args))
4913 s_goto (OP_READ_INTERNAL);
4914
4915 if (!is_inport (car (args)))
4916 Error_1 ("read: not an input port:", car (args));
4917
4918 if (car (args) == SCHEME_V->inport)
4919 s_goto (OP_READ_INTERNAL);
4920
4921 x = SCHEME_V->inport;
4922 SCHEME_V->inport = car (args);
4923 x = cons (x, NIL);
4924 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4925 s_goto (OP_READ_INTERNAL);
4926
4927 case OP_READ_CHAR: /* read-char */
4928 case OP_PEEK_CHAR: /* peek-char */
4929 {
4930 int c;
4931
4932 if (is_pair (args))
4933 {
4934 if (car (args) != SCHEME_V->inport)
4935 {
4936 x = SCHEME_V->inport;
4937 x = cons (x, NIL);
4938 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4939 SCHEME_V->inport = car (args);
4940 }
4941 }
4942
4943 c = inchar (SCHEME_A);
4944
4945 if (c == EOF)
4946 s_return (S_EOF);
4947
4948 if (SCHEME_V->op == OP_PEEK_CHAR)
4949 backchar (SCHEME_A_ c);
4950
4951 s_return (mk_character (SCHEME_A_ c));
4952 }
4953
4954 case OP_CHAR_READY: /* char-ready? */
4955 {
4956 pointer p = SCHEME_V->inport;
4957 int res;
4958
4959 if (is_pair (args))
4960 p = car (args);
4961
4962 res = p->object.port->kind & port_string;
4963
4964 s_retbool (res);
4965 }
4966
4967 case OP_SET_INPORT: /* set-input-port */
4968 SCHEME_V->inport = car (args);
4969 s_return (SCHEME_V->value);
4970
4971 case OP_SET_OUTPORT: /* set-output-port */
4972 SCHEME_V->outport = car (args);
4973 s_return (SCHEME_V->value);
4974 #endif
4975
4976 case OP_RDSEXPR:
4977 switch (SCHEME_V->tok)
4978 {
4979 case TOK_EOF:
4980 s_return (S_EOF);
4981 /* NOTREACHED */
4982
4983 case TOK_VEC:
4984 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4985 /* fall through */
4986
4987 case TOK_LPAREN:
4988 SCHEME_V->tok = token (SCHEME_A);
4989
4990 if (SCHEME_V->tok == TOK_RPAREN)
4991 s_return (NIL);
4992 else if (SCHEME_V->tok == TOK_DOT)
4993 Error_0 ("syntax error: illegal dot expression");
4994 else
4995 {
4996 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
4997 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
4998 s_goto (OP_RDSEXPR);
4999 }
5000
5001 case TOK_QUOTE:
5002 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5003 SCHEME_V->tok = token (SCHEME_A);
5004 s_goto (OP_RDSEXPR);
5005
5006 case TOK_BQUOTE:
5007 SCHEME_V->tok = token (SCHEME_A);
5008
5009 if (SCHEME_V->tok == TOK_VEC)
5010 {
5011 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5012 SCHEME_V->tok = TOK_LPAREN;
5013 s_goto (OP_RDSEXPR);
5014 }
5015 else
5016 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5017
5018 s_goto (OP_RDSEXPR);
5019
5020 case TOK_COMMA:
5021 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5022 SCHEME_V->tok = token (SCHEME_A);
5023 s_goto (OP_RDSEXPR);
5024
5025 case TOK_ATMARK:
5026 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
5027 SCHEME_V->tok = token (SCHEME_A);
5028 s_goto (OP_RDSEXPR);
5029
5030 case TOK_ATOM:
5031 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS)));
5032
5033 case TOK_DQUOTE:
5034 x = readstrexp (SCHEME_A);
5035
5036 if (x == S_F)
5037 Error_0 ("Error reading string");
5038
5039 setimmutable (x);
5040 s_return (x);
5041
5042 case TOK_SHARP:
5043 {
5044 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5045
5046 if (f == NIL)
5047 Error_0 ("undefined sharp expression");
5048 else
5049 {
5050 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5051 s_goto (OP_EVAL);
5052 }
5053 }
5054
5055 case TOK_SHARP_CONST:
5056 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL)
5057 Error_0 ("undefined sharp expression");
5058 else
5059 s_return (x);
5060
5061 default:
5062 Error_0 ("syntax error: illegal token");
5063 }
5064
5065 break;
5066
5067 case OP_RDLIST:
5068 SCHEME_V->args = cons (SCHEME_V->value, args);
5069 SCHEME_V->tok = token (SCHEME_A);
5070
5071 switch (SCHEME_V->tok)
5072 {
5073 case TOK_EOF:
5074 s_return (S_EOF);
5075
5076 case TOK_RPAREN:
5077 {
5078 int c = inchar (SCHEME_A);
5079
5080 if (c != '\n')
5081 backchar (SCHEME_A_ c);
5082 #if SHOW_ERROR_LINE
5083 else if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
5084 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;
5085 #endif
5086
5087 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5088 s_return (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args));
5089 }
5090
5091 case TOK_DOT:
5092 s_save (SCHEME_A_ OP_RDDOT, SCHEME_V->args, NIL);
5093 SCHEME_V->tok = token (SCHEME_A);
5094 s_goto (OP_RDSEXPR);
5095
5096 default:
5097 s_save (SCHEME_A_ OP_RDLIST, SCHEME_V->args, NIL);
5098 s_goto (OP_RDSEXPR);
5099 }
5100
5101 case OP_RDDOT:
5102 if (token (SCHEME_A) != TOK_RPAREN)
5103 Error_0 ("syntax error: illegal dot expression");
5104
5105 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5106 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5107
5108 case OP_RDQUOTE:
5109 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5110
5111 case OP_RDQQUOTE:
5112 s_return (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL)));
5113
5114 case OP_RDQQUOTEVEC:
5115 s_return (cons (mk_symbol (SCHEME_A_ "apply"),
5116 cons (mk_symbol (SCHEME_A_ "vector"),
5117 cons (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL)), NIL))));
5118
5119 case OP_RDUNQUOTE:
5120 s_return (cons (SCHEME_V->UNQUOTE, cons (SCHEME_V->value, NIL)));
5121
5122 case OP_RDUQTSP:
5123 s_return (cons (SCHEME_V->UNQUOTESP, cons (SCHEME_V->value, NIL)));
5124
5125 case OP_RDVEC:
5126 /*SCHEME_V->code=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value);
5127 s_goto(OP_EVAL); Cannot be quoted */
5128 /*x=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value);
5129 s_return(x); Cannot be part of pairs */
5130 /*SCHEME_V->code=mk_proc(SCHEME_A_ OP_VECTOR);
5131 SCHEME_V->args=SCHEME_V->value;
5132 s_goto(OP_APPLY); */
5133 SCHEME_V->args = SCHEME_V->value;
5134 s_goto (OP_VECTOR);
5135
5136 /* ========== printing part ========== */
5137 case OP_P0LIST:
5138 if (is_vector (args))
5139 {
5140 putstr (SCHEME_A_ "#(");
5141 SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5142 s_goto (OP_PVECFROM);
5143 }
5144 else if (is_environment (args))
5145 {
5146 putstr (SCHEME_A_ "#<ENVIRONMENT>");
5147 s_return (S_T);
5148 }
5149 else if (!is_pair (args))
5150 {
5151 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5152 s_return (S_T);
5153 }
5154 else
5155 {
5156 pointer a = car (args);
5157 pointer b = cdr (args);
5158 int ok_abbr = ok_abbrev (b);
5159 SCHEME_V->args = car (b);
5160
5161 if (a == SCHEME_V->QUOTE && ok_abbr)
5162 putstr (SCHEME_A_ "'");
5163 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5164 putstr (SCHEME_A_ "`");
5165 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5166 putstr (SCHEME_A_ ",");
5167 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5168 putstr (SCHEME_A_ ",@");
5169 else
5170 {
5171 putstr (SCHEME_A_ "(");
5172 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5173 SCHEME_V->args = a;
5174 }
5175
5176 s_goto (OP_P0LIST);
5177 }
5178
5179 case OP_P1LIST:
5180 if (is_pair (args))
5181 {
5182 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5183 putstr (SCHEME_A_ " ");
5184 SCHEME_V->args = car (args);
5185 s_goto (OP_P0LIST);
5186 }
5187 else if (is_vector (args))
5188 {
5189 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5190 putstr (SCHEME_A_ " . ");
5191 s_goto (OP_P0LIST);
5192 }
5193 else
5194 {
5195 if (args != NIL)
5196 {
5197 putstr (SCHEME_A_ " . ");
5198 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5199 }
5200
5201 putstr (SCHEME_A_ ")");
5202 s_return (S_T);
5203 }
5204
5205 case OP_PVECFROM:
5206 {
5207 int i = ivalue_unchecked (cdr (args));
5208 pointer vec = car (args);
5209 int len = veclength (vec);
5210
5211 if (i == len)
5212 {
5213 putstr (SCHEME_A_ ")");
5214 s_return (S_T);
5215 }
5216 else
5217 {
5218 pointer elem = vector_elem (vec, i);
5219
5220 ivalue_unchecked (cdr (args)) = i + 1;
5221 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5222 SCHEME_V->args = elem;
5223
5224 if (i > 0)
5225 putstr (SCHEME_A_ " ");
5226
5227 s_goto (OP_P0LIST);
5228 }
5229 }
5230 }
5231
5232 abort ();
5233 }
5234
5235 static pointer
5236 opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5237 {
5238 pointer args = SCHEME_V->args;
5239 pointer a = car (args);
5240 pointer x, y;
5241
5242 switch (op)
5243 {
5244 case OP_LIST_LENGTH: /* length *//* a.k */
5245 {
5246 long v = list_length (SCHEME_A_ a);
5247
5248 if (v < 0)
5249 Error_1 ("length: not a list:", a);
5250
5251 s_return (mk_integer (SCHEME_A_ v));
5252 }
5253
5254 case OP_ASSQ: /* assq *//* a.k */
5255 x = a;
5256
5257 for (y = cadr (args); is_pair (y); y = cdr (y))
5258 {
5259 if (!is_pair (car (y)))
5260 Error_0 ("unable to handle non pair element");
5261
5262 if (x == caar (y))
5263 break;
5264 }
5265
5266 if (is_pair (y))
5267 s_return (car (y));
5268 else
5269 s_return (S_F);
5270
5271
5272 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5273 SCHEME_V->args = a;
5274
5275 if (SCHEME_V->args == NIL)
5276 s_return (S_F);
5277 else if (is_closure (SCHEME_V->args))
5278 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5279 else if (is_macro (SCHEME_V->args))
5280 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5281 else
5282 s_return (S_F);
5283
5284 case OP_CLOSUREP: /* closure? */
5285 /*
5286 * Note, macro object is also a closure.
5287 * Therefore, (closure? <#MACRO>) ==> #t
5288 */
5289 s_retbool (is_closure (a));
5290
5291 case OP_MACROP: /* macro? */
5292 s_retbool (is_macro (a));
5293 }
5294
5295 abort ();
5296 }
5297
5298 typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5299
5300 typedef int (*test_predicate) (pointer);
5301 static int
5302 is_any (pointer p)
5303 {
5304 return 1;
5305 }
5306
5307 static int
5308 is_nonneg (pointer p)
5309 {
5310 return ivalue (p) >= 0 && is_integer (p);
5311 }
5312
5313 /* Correspond carefully with following defines! */
5314 static struct
5315 {
5316 test_predicate fct;
5317 const char *kind;
5318 } tests[] =
5319 {
5320 { 0, 0}, /* unused */
5321 { is_any, 0},
5322 { is_string, "string" },
5323 { is_symbol, "symbol" },
5324 { is_port, "port" },
5325 { is_inport, "input port" },
5326 { is_outport, "output port" },
5327 { is_environment, "environment" },
5328 { is_pair, "pair" },
5329 { 0, "pair or '()" },
5330 { is_character, "character" },
5331 { is_vector, "vector" },
5332 { is_number, "number" },
5333 { is_integer, "integer" },
5334 { is_nonneg, "non-negative integer" }
5335 };
5336
5337 #define TST_NONE 0 /* TST_NONE used for standard procedures, for internal ops, 0 is used */
5338 #define TST_ANY "\001"
5339 #define TST_STRING "\002"
5340 #define TST_SYMBOL "\003"
5341 #define TST_PORT "\004"
5342 #define TST_INPORT "\005"
5343 #define TST_OUTPORT "\006"
5344 #define TST_ENVIRONMENT "\007"
5345 #define TST_PAIR "\010"
5346 #define TST_LIST "\011"
5347 #define TST_CHAR "\012"
5348 #define TST_VECTOR "\013"
5349 #define TST_NUMBER "\014"
5350 #define TST_INTEGER "\015"
5351 #define TST_NATURAL "\016"
5352
5353 typedef struct
5354 {
5355 dispatch_func func;
5356 char *name;
5357 int min_arity;
5358 int max_arity;
5359 char arg_tests_encoding[3];
5360 } op_code_info;
5361
5362 #define INF_ARG 0xffff
5363
5364 static op_code_info dispatch_table[] = {
5365 #define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest },
5366 #include "opdefines.h"
5367 #undef OP_DEF
5368 {0}
5369 };
5370
5371 static const char *
5372 procname (pointer x)
5373 {
5374 int n = procnum (x);
5375 const char *name = dispatch_table[n].name;
5376
5377 if (name == 0)
5378 name = "ILLEGAL!";
5379
5380 return name;
5381 }
5382
5383 /* kernel of this interpreter */
5384 static void
5385 Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5386 {
5387 SCHEME_V->op = op;
5388
5389 for (;;)
5390 {
5391 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5392
5393 #if USE_ERROR_CHECKING
5394 if (pcd->name) /* if built-in function, check arguments */
5395 {
5396 int ok = 1;
5397 char msg[STRBUFFSIZE];
5398 int n = list_length (SCHEME_A_ SCHEME_V->args);
5399
5400 /* Check number of arguments */
5401 if (ecb_expect_false (n < pcd->min_arity))
5402 {
5403 ok = 0;
5404 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5405 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5406 }
5407 else if (ecb_expect_false (n > pcd->max_arity))
5408 {
5409 ok = 0;
5410 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5411 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5412 }
5413
5414 if (ecb_expect_false (ok))
5415 {
5416 if (*pcd->arg_tests_encoding)
5417 {
5418 int i = 0;
5419 int j;
5420 const char *t = pcd->arg_tests_encoding;
5421 pointer arglist = SCHEME_V->args;
5422
5423 do
5424 {
5425 pointer arg = car (arglist);
5426
5427 j = t[0];
5428
5429 if (j == TST_LIST[0])
5430 {
5431 if (arg != NIL && !is_pair (arg))
5432 break;
5433 }
5434 else
5435 {
5436 if (!tests[j].fct (arg))
5437 break;
5438 }
5439
5440 if (t[1]) /* last test is replicated as necessary */
5441 t++;
5442
5443 arglist = cdr (arglist);
5444 i++;
5445 }
5446 while (i < n);
5447
5448 if (i < n)
5449 {
5450 ok = 0;
5451 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);
5452 }
5453 }
5454 }
5455
5456 if (!ok)
5457 {
5458 if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5459 return;
5460
5461 pcd = dispatch_table + SCHEME_V->op;
5462 }
5463 }
5464 #endif
5465
5466 ok_to_freely_gc (SCHEME_A);
5467
5468 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5469 return;
5470
5471 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5472 {
5473 xwrstr ("No memory!\n");
5474 return;
5475 }
5476 }
5477 }
5478
5479 /* ========== Initialization of internal keywords ========== */
5480
5481 static void
5482 assign_syntax (SCHEME_P_ const char *name)
5483 {
5484 pointer x = oblist_add_by_name (SCHEME_A_ name);
5485 set_typeflag (x, typeflag (x) | T_SYNTAX);
5486 }
5487
5488 static void
5489 assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5490 {
5491 pointer x = mk_symbol (SCHEME_A_ name);
5492 pointer y = mk_proc (SCHEME_A_ op);
5493 new_slot_in_env (SCHEME_A_ x, y);
5494 }
5495
5496 static pointer
5497 mk_proc (SCHEME_P_ enum scheme_opcodes op)
5498 {
5499 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5500 set_typeflag (y, (T_PROC | T_ATOM));
5501 ivalue_unchecked (y) = op;
5502 set_num_integer (y);
5503 return y;
5504 }
5505
5506 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5507 static int
5508 syntaxnum (pointer p)
5509 {
5510 const char *s = strvalue (car (p));
5511
5512 switch (strlength (car (p)))
5513 {
5514 case 2:
5515 if (s[0] == 'i')
5516 return OP_IF0; /* if */
5517 else
5518 return OP_OR0; /* or */
5519
5520 case 3:
5521 if (s[0] == 'a')
5522 return OP_AND0; /* and */
5523 else
5524 return OP_LET0; /* let */
5525
5526 case 4:
5527 switch (s[3])
5528 {
5529 case 'e':
5530 return OP_CASE0; /* case */
5531
5532 case 'd':
5533 return OP_COND0; /* cond */
5534
5535 case '*':
5536 return OP_LET0AST;/* let* */
5537
5538 default:
5539 return OP_SET0; /* set! */
5540 }
5541
5542 case 5:
5543 switch (s[2])
5544 {
5545 case 'g':
5546 return OP_BEGIN; /* begin */
5547
5548 case 'l':
5549 return OP_DELAY; /* delay */
5550
5551 case 'c':
5552 return OP_MACRO0; /* macro */
5553
5554 default:
5555 return OP_QUOTE; /* quote */
5556 }
5557
5558 case 6:
5559 switch (s[2])
5560 {
5561 case 'm':
5562 return OP_LAMBDA; /* lambda */
5563
5564 case 'f':
5565 return OP_DEF0; /* define */
5566
5567 default:
5568 return OP_LET0REC;/* letrec */
5569 }
5570
5571 default:
5572 return OP_C0STREAM; /* cons-stream */
5573 }
5574 }
5575
5576 #if USE_MULTIPLICITY
5577 scheme *
5578 scheme_init_new ()
5579 {
5580 scheme *sc = malloc (sizeof (scheme));
5581
5582 if (!scheme_init (SCHEME_A))
5583 {
5584 free (SCHEME_A);
5585 return 0;
5586 }
5587 else
5588 return sc;
5589 }
5590 #endif
5591
5592 int
5593 scheme_init (SCHEME_P)
5594 {
5595 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5596 pointer x;
5597
5598 num_set_fixnum (num_zero, 1);
5599 num_set_ivalue (num_zero, 0);
5600 num_set_fixnum (num_one, 1);
5601 num_set_ivalue (num_one, 1);
5602
5603 #if USE_INTERFACE
5604 SCHEME_V->vptr = &vtbl;
5605 #endif
5606 SCHEME_V->gensym_cnt = 0;
5607 SCHEME_V->last_cell_seg = -1;
5608 SCHEME_V->free_cell = NIL;
5609 SCHEME_V->fcells = 0;
5610 SCHEME_V->no_memory = 0;
5611 SCHEME_V->inport = NIL;
5612 SCHEME_V->outport = NIL;
5613 SCHEME_V->save_inport = NIL;
5614 SCHEME_V->loadport = NIL;
5615 SCHEME_V->nesting = 0;
5616 SCHEME_V->interactive_repl = 0;
5617
5618 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)
5619 {
5620 #if USE_ERROR_CHECKING
5621 SCHEME_V->no_memory = 1;
5622 return 0;
5623 #endif
5624 }
5625
5626 SCHEME_V->gc_verbose = 0;
5627 dump_stack_initialize (SCHEME_A);
5628 SCHEME_V->code = NIL;
5629 SCHEME_V->args = NIL;
5630 SCHEME_V->envir = NIL;
5631 SCHEME_V->tracing = 0;
5632
5633 /* init NIL */
5634 set_typeflag (NIL, T_ATOM | T_MARK);
5635 set_car (NIL, NIL);
5636 set_cdr (NIL, NIL);
5637 /* init T */
5638 set_typeflag (S_T, T_ATOM | T_MARK);
5639 set_car (S_T, S_T);
5640 set_cdr (S_T, S_T);
5641 /* init F */
5642 set_typeflag (S_F, T_ATOM | T_MARK);
5643 set_car (S_F, S_F);
5644 set_cdr (S_F, S_F);
5645 /* init EOF_OBJ */
5646 set_typeflag (S_EOF, T_ATOM | T_MARK);
5647 set_car (S_EOF, S_EOF);
5648 set_cdr (S_EOF, S_EOF);
5649 /* init sink */
5650 set_typeflag (S_SINK, T_PAIR | T_MARK);
5651 set_car (S_SINK, NIL);
5652
5653 /* init c_nest */
5654 SCHEME_V->c_nest = NIL;
5655
5656 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5657 /* init global_env */
5658 new_frame_in_env (SCHEME_A_ NIL);
5659 SCHEME_V->global_env = SCHEME_V->envir;
5660 /* init else */
5661 x = mk_symbol (SCHEME_A_ "else");
5662 new_slot_in_env (SCHEME_A_ x, S_T);
5663
5664 {
5665 static const char *syntax_names[] = {
5666 "lambda", "quote", "define", "if", "begin", "set!",
5667 "let", "let*", "letrec", "cond", "delay", "and",
5668 "or", "cons-stream", "macro", "case"
5669 };
5670
5671 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5672 assign_syntax (SCHEME_A_ syntax_names[i]);
5673 }
5674
5675 for (i = 0; i < n; i++)
5676 if (dispatch_table[i].name != 0)
5677 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5678
5679 /* initialization of global pointers to special symbols */
5680 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5681 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5682 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5683 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5684 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5685 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5686 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5687 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5688 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5689 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5690
5691 return !SCHEME_V->no_memory;
5692 }
5693
5694 #if USE_PORTS
5695 void
5696 scheme_set_input_port_file (SCHEME_P_ int fin)
5697 {
5698 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5699 }
5700
5701 void
5702 scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5703 {
5704 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5705 }
5706
5707 void
5708 scheme_set_output_port_file (SCHEME_P_ int fout)
5709 {
5710 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5711 }
5712
5713 void
5714 scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5715 {
5716 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5717 }
5718 #endif
5719
5720 void
5721 scheme_set_external_data (SCHEME_P_ void *p)
5722 {
5723 SCHEME_V->ext_data = p;
5724 }
5725
5726 void
5727 scheme_deinit (SCHEME_P)
5728 {
5729 int i;
5730
5731 #if SHOW_ERROR_LINE
5732 char *fname;
5733 #endif
5734
5735 SCHEME_V->oblist = NIL;
5736 SCHEME_V->global_env = NIL;
5737 dump_stack_free (SCHEME_A);
5738 SCHEME_V->envir = NIL;
5739 SCHEME_V->code = NIL;
5740 SCHEME_V->args = NIL;
5741 SCHEME_V->value = NIL;
5742
5743 if (is_port (SCHEME_V->inport))
5744 set_typeflag (SCHEME_V->inport, T_ATOM);
5745
5746 SCHEME_V->inport = NIL;
5747 SCHEME_V->outport = NIL;
5748
5749 if (is_port (SCHEME_V->save_inport))
5750 set_typeflag (SCHEME_V->save_inport, T_ATOM);
5751
5752 SCHEME_V->save_inport = NIL;
5753
5754 if (is_port (SCHEME_V->loadport))
5755 set_typeflag (SCHEME_V->loadport, T_ATOM);
5756
5757 SCHEME_V->loadport = NIL;
5758 SCHEME_V->gc_verbose = 0;
5759 gc (SCHEME_A_ NIL, NIL);
5760
5761 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5762 free (SCHEME_V->alloc_seg[i]);
5763
5764 #if SHOW_ERROR_LINE
5765 for (i = 0; i <= SCHEME_V->file_i; i++)
5766 {
5767 if (SCHEME_V->load_stack[i].kind & port_file)
5768 {
5769 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5770
5771 if (fname)
5772 free (fname);
5773 }
5774 }
5775 #endif
5776 }
5777
5778 void
5779 scheme_load_file (SCHEME_P_ int fin)
5780 {
5781 scheme_load_named_file (SCHEME_A_ fin, 0);
5782 }
5783
5784 void
5785 scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5786 {
5787 dump_stack_reset (SCHEME_A);
5788 SCHEME_V->envir = SCHEME_V->global_env;
5789 SCHEME_V->file_i = 0;
5790 SCHEME_V->load_stack[0].unget = -1;
5791 SCHEME_V->load_stack[0].kind = port_input | port_file;
5792 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5793 #if USE_PORTS
5794 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5795 #endif
5796 SCHEME_V->retcode = 0;
5797
5798 #if USE_PORTS
5799 if (fin == STDIN_FILENO)
5800 SCHEME_V->interactive_repl = 1;
5801 #endif
5802
5803 #if USE_PORTS
5804 #if SHOW_ERROR_LINE
5805 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5806
5807 if (fin != STDIN_FILENO && filename)
5808 SCHEME_V->load_stack[0].rep.stdio.filename = store_string (SCHEME_A_ strlen (filename), filename, 0);
5809 #endif
5810 #endif
5811
5812 SCHEME_V->inport = SCHEME_V->loadport;
5813 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5814 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5815 set_typeflag (SCHEME_V->loadport, T_ATOM);
5816
5817 if (SCHEME_V->retcode == 0)
5818 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5819 }
5820
5821 void
5822 scheme_load_string (SCHEME_P_ const char *cmd)
5823 {
5824 dump_stack_reset (SCHEME_A);
5825 SCHEME_V->envir = SCHEME_V->global_env;
5826 SCHEME_V->file_i = 0;
5827 SCHEME_V->load_stack[0].kind = port_input | port_string;
5828 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5829 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5830 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5831 #if USE_PORTS
5832 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5833 #endif
5834 SCHEME_V->retcode = 0;
5835 SCHEME_V->interactive_repl = 0;
5836 SCHEME_V->inport = SCHEME_V->loadport;
5837 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5838 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5839 set_typeflag (SCHEME_V->loadport, T_ATOM);
5840
5841 if (SCHEME_V->retcode == 0)
5842 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5843 }
5844
5845 void
5846 scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5847 {
5848 pointer x;
5849
5850 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
5851
5852 if (x != NIL)
5853 set_slot_in_env (SCHEME_A_ x, value);
5854 else
5855 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5856 }
5857
5858 #if !STANDALONE
5859
5860 void
5861 scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5862 {
5863 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5864 }
5865
5866 void
5867 scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5868 {
5869 int i;
5870
5871 for (i = 0; i < count; i++)
5872 scheme_register_foreign_func (SCHEME_A_ list + i);
5873 }
5874
5875 pointer
5876 scheme_apply0 (SCHEME_P_ const char *procname)
5877 {
5878 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5879 }
5880
5881 void
5882 save_from_C_call (SCHEME_P)
5883 {
5884 pointer saved_data = cons (car (S_SINK),
5885 cons (SCHEME_V->envir,
5886 SCHEME_V->dump));
5887
5888 /* Push */
5889 SCHEME_V->c_nest = cons (saved_data, SCHEME_V->c_nest);
5890 /* Truncate the dump stack so TS will return here when done, not
5891 directly resume pre-C-call operations. */
5892 dump_stack_reset (SCHEME_A);
5893 }
5894
5895 void
5896 restore_from_C_call (SCHEME_P)
5897 {
5898 set_car (S_SINK, caar (SCHEME_V->c_nest));
5899 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5900 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5901 /* Pop */
5902 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5903 }
5904
5905 /* "func" and "args" are assumed to be already eval'ed. */
5906 pointer
5907 scheme_call (SCHEME_P_ pointer func, pointer args)
5908 {
5909 int old_repl = SCHEME_V->interactive_repl;
5910
5911 SCHEME_V->interactive_repl = 0;
5912 save_from_C_call (SCHEME_A);
5913 SCHEME_V->envir = SCHEME_V->global_env;
5914 SCHEME_V->args = args;
5915 SCHEME_V->code = func;
5916 SCHEME_V->retcode = 0;
5917 Eval_Cycle (SCHEME_A_ OP_APPLY);
5918 SCHEME_V->interactive_repl = old_repl;
5919 restore_from_C_call (SCHEME_A);
5920 return SCHEME_V->value;
5921 }
5922
5923 pointer
5924 scheme_eval (SCHEME_P_ pointer obj)
5925 {
5926 int old_repl = SCHEME_V->interactive_repl;
5927
5928 SCHEME_V->interactive_repl = 0;
5929 save_from_C_call (SCHEME_A);
5930 SCHEME_V->args = NIL;
5931 SCHEME_V->code = obj;
5932 SCHEME_V->retcode = 0;
5933 Eval_Cycle (SCHEME_A_ OP_EVAL);
5934 SCHEME_V->interactive_repl = old_repl;
5935 restore_from_C_call (SCHEME_A);
5936 return SCHEME_V->value;
5937 }
5938
5939 #endif
5940
5941 /* ========== Main ========== */
5942
5943 #if STANDALONE
5944
5945 int
5946 main (int argc, char **argv)
5947 {
5948 # if USE_MULTIPLICITY
5949 scheme ssc;
5950 scheme *const SCHEME_V = &ssc;
5951 # else
5952 # endif
5953 int fin;
5954 char *file_name = InitFile;
5955 int retcode;
5956 int isfile = 1;
5957
5958 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5959 {
5960 xwrstr ("Usage: tinyscheme -?\n");
5961 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");
5962 xwrstr ("followed by\n");
5963 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n");
5964 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n");
5965 xwrstr ("assuming that the executable is named tinyscheme.\n");
5966 xwrstr ("Use - as filename for stdin.\n");
5967 return 1;
5968 }
5969
5970 if (!scheme_init (SCHEME_A))
5971 {
5972 xwrstr ("Could not initialize!\n");
5973 return 2;
5974 }
5975
5976 # if USE_PORTS
5977 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
5978 scheme_set_output_port_file (SCHEME_A_ STDOUT_FILENO);
5979 # endif
5980
5981 argv++;
5982
5983 #if 0
5984 if (access (file_name, 0) != 0)
5985 {
5986 char *p = getenv ("TINYSCHEMEINIT");
5987
5988 if (p != 0)
5989 file_name = p;
5990 }
5991 #endif
5992
5993 do
5994 {
5995 #if USE_PORTS
5996 if (strcmp (file_name, "-") == 0)
5997 fin = STDIN_FILENO;
5998 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
5999 {
6000 pointer args = NIL;
6001
6002 isfile = file_name[1] == '1';
6003 file_name = *argv++;
6004
6005 if (strcmp (file_name, "-") == 0)
6006 fin = STDIN_FILENO;
6007 else if (isfile)
6008 fin = open (file_name, O_RDONLY);
6009
6010 for (; *argv; argv++)
6011 {
6012 pointer value = mk_string (SCHEME_A_ * argv);
6013
6014 args = cons (value, args);
6015 }
6016
6017 args = reverse_in_place (SCHEME_A_ NIL, args);
6018 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6019
6020 }
6021 else
6022 fin = open (file_name, O_RDONLY);
6023 #endif
6024
6025 if (isfile && fin < 0)
6026 {
6027 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");
6028 }
6029 else
6030 {
6031 if (isfile)
6032 scheme_load_named_file (SCHEME_A_ fin, file_name);
6033 else
6034 scheme_load_string (SCHEME_A_ file_name);
6035
6036 #if USE_PORTS
6037 if (!isfile || fin != STDIN_FILENO)
6038 {
6039 if (SCHEME_V->retcode != 0)
6040 {
6041 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");
6042 }
6043
6044 if (isfile)
6045 close (fin);
6046 }
6047 #endif
6048 }
6049
6050 file_name = *argv++;
6051 }
6052 while (file_name != 0);
6053
6054 if (argc == 1)
6055 scheme_load_named_file (SCHEME_A_ STDIN_FILENO, 0);
6056
6057 retcode = SCHEME_V->retcode;
6058 scheme_deinit (SCHEME_A);
6059
6060 return retcode;
6061 }
6062
6063 #endif
6064
6065 /*
6066 Local variables:
6067 c-file-style: "k&r"
6068 End:
6069 */