ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.1 by root, Wed Nov 25 05:02:56 2015 UTC vs.
Revision 1.2 by root, Wed Nov 25 10:01:39 2015 UTC

… …
26#endif 26#endif
27 27
28#include <sys/types.h> 28#include <sys/types.h>
29#include <sys/stat.h> 29#include <sys/stat.h>
30#include <fcntl.h> 30#include <fcntl.h>
31
32#include <string.h>
33#include <stdlib.h>
31 34
32#include <limits.h> 35#include <limits.h>
33#include <inttypes.h> 36#include <inttypes.h>
34#include <float.h> 37#include <float.h>
35//#include <ctype.h> 38//#include <ctype.h>
… …
52 55
53#define BACKQUOTE '`' 56#define BACKQUOTE '`'
54#define DELIMITERS "()\";\f\t\v\n\r " 57#define DELIMITERS "()\";\f\t\v\n\r "
55 58
56#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 59#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
57#define S_T (&SCHEME_V->xT) 60#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
58#define S_F (&SCHEME_V->xF) 61#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
59#define S_SINK (&SCHEME_V->xsink) 62#define S_SINK (&SCHEME_V->xsink)
60#define S_EOF (&SCHEME_V->xEOF_OBJ) 63#define S_EOF (&SCHEME_V->xEOF_OBJ)
61
62/*
63 * Basic memory allocation units
64 */
65
66#define banner "TinyScheme 1.41-s"
67
68#include <string.h>
69#include <stdlib.h>
70 64
71#if !USE_MULTIPLICITY 65#if !USE_MULTIPLICITY
72static scheme sc; 66static scheme sc;
73#endif 67#endif
74 68
… …
169# define FIRST_CELLSEGS 3 163# define FIRST_CELLSEGS 3
170#endif 164#endif
171 165
172enum scheme_types 166enum scheme_types
173{ 167{
174 T_NULL, 168 T_FREE,
175 T_STRING, 169 T_STRING,
176 T_NUMBER, 170 T_NUMBER,
177 T_SYMBOL, 171 T_SYMBOL,
178 T_PROC, 172 T_PROC,
179 T_PAIR, 173 T_PAIR,
… …
184 T_PORT, 178 T_PORT,
185 T_VECTOR, 179 T_VECTOR,
186 T_MACRO, 180 T_MACRO,
187 T_PROMISE, 181 T_PROMISE,
188 T_ENVIRONMENT, 182 T_ENVIRONMENT,
183 /* one more... */
189 T_NUM_SYSTEM_TYPES 184 T_NUM_SYSTEM_TYPES
190}; 185};
191 186
192#define T_MASKTYPE 31 /* 0000000000011111 */ 187#define T_MASKTYPE 0x000f
193#define T_SYNTAX 4096 /* 0001000000000000 */ 188#define T_SYNTAX 0x0010
194#define T_IMMUTABLE 8192 /* 0010000000000000 */ 189#define T_IMMUTABLE 0x0020
195#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ 190#define T_ATOM 0x0040 /* only for gc */
196#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ 191#define T_MARK 0x0080 /* only for gc */
197#define MARK 32768 /* 1000000000000000 */
198#define UNMARK 32767 /* 0111111111111111 */
199
200 192
201static num num_add (num a, num b); 193static num num_add (num a, num b);
202static num num_mul (num a, num b); 194static num num_mul (num a, num b);
203static num num_div (num a, num b); 195static num num_div (num a, num b);
204static num num_intdiv (num a, num b); 196static num num_intdiv (num a, num b);
… …
290nvalue (pointer p) 282nvalue (pointer p)
291{ 283{
292 return (p)->object.number; 284 return (p)->object.number;
293} 285}
294 286
295INTERFACE long 287static IVALUE
288num_get_ivalue (const num n)
289{
290 return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
291}
292
293static RVALUE
294num_get_rvalue (const num n)
295{
296 return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
297}
298
299INTERFACE IVALUE
296ivalue (pointer p) 300ivalue (pointer p)
297{ 301{
298 return num_is_integer (p) ? num_ivalue ((p)->object.number) : (long) num_rvalue ((p)->object.number); 302 return num_get_ivalue (p->object.number);
299} 303}
300 304
301INTERFACE RVALUE 305INTERFACE RVALUE
302rvalue (pointer p) 306rvalue (pointer p)
303{ 307{
304 return num_is_integer (p) ? (RVALUE) num_ivalue ((p)->object.number) : num_rvalue ((p)->object.number); 308 return num_get_rvalue (p->object.number);
305} 309}
306 310
307#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 311#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
308#if USE_FLOAT 312#if USE_FLOAT
309# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 313# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
… …
424syntaxname (pointer p) 428syntaxname (pointer p)
425{ 429{
426 return strvalue (car (p)); 430 return strvalue (car (p));
427} 431}
428 432
429#define procnum(p) ivalue(p) 433#define procnum(p) ivalue (p)
430static const char *procname (pointer x); 434static const char *procname (pointer x);
431 435
432INTERFACE INLINE int 436INTERFACE INLINE int
433is_closure (pointer p) 437is_closure (pointer p)
434{ 438{
… …
475 return type (p) == T_ENVIRONMENT; 479 return type (p) == T_ENVIRONMENT;
476} 480}
477 481
478#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 482#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
479 483
484#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
480#define is_atom(p) (typeflag (p) & T_ATOM) 485#define is_atom(p) (typeflag (p) & T_ATOM)
481#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 486#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
482#define clratom(p) set_typeflag ((p), typeflag (p) & CLRATOM) 487#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
483 488
484#define is_mark(p) (typeflag (p) & MARK) 489#define is_mark(p) (typeflag (p) & T_MARK)
485#define setmark(p) set_typeflag ((p), typeflag (p) | MARK) 490#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
486#define clrmark(p) set_typeflag ((p), typeflag (p) & UNMARK) 491#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
492
493#if 0
494static int
495is_atom(pointer p)
496{
497 if (!is_atom1(p) != !is_atom2(p))
498 printf ("atoms disagree %x\n", typeflag(p));
499
500 return is_atom2(p);
501}
502#endif
487 503
488INTERFACE INLINE int 504INTERFACE INLINE int
489is_immutable (pointer p) 505is_immutable (pointer p)
490{ 506{
491 return typeflag (p) & T_IMMUTABLE; 507 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
492} 508}
493 509
494INTERFACE INLINE void 510INTERFACE INLINE void
495setimmutable (pointer p) 511setimmutable (pointer p)
496{ 512{
513#if USE_ERROR_CHECKING
497 set_typeflag (p, T_IMMUTABLE); 514 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
515#endif
498} 516}
499 517
500#if USE_CHAR_CLASSIFIERS 518#if USE_CHAR_CLASSIFIERS
501static INLINE int 519static INLINE int
502Cisalpha (int c) 520Cisalpha (int c)
… …
595static int file_interactive (SCHEME_P); 613static int file_interactive (SCHEME_P);
596static INLINE int is_one_of (char *s, int c); 614static INLINE int is_one_of (char *s, int c);
597static int alloc_cellseg (SCHEME_P_ int n); 615static int alloc_cellseg (SCHEME_P_ int n);
598static long binary_decode (const char *s); 616static long binary_decode (const char *s);
599static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 617static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
600static pointer xget_cell (SCHEME_P_ pointer a, pointer b);
601static pointer reserve_cells (SCHEME_P_ int n); 618static pointer reserve_cells (SCHEME_P_ int n);
602static pointer get_consecutive_cells (SCHEME_P_ int n); 619static pointer get_consecutive_cells (SCHEME_P_ int n);
603static pointer find_consecutive_cells (SCHEME_P_ int n); 620static pointer find_consecutive_cells (SCHEME_P_ int n);
604static void finalize_cell (SCHEME_P_ pointer a); 621static void finalize_cell (SCHEME_P_ pointer a);
605static int count_consecutive_cells (pointer x, int needed); 622static int count_consecutive_cells (pointer x, int needed);
606static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 623static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
607static pointer mk_number (SCHEME_P_ num n); 624static pointer mk_number (SCHEME_P_ const num n);
608static char *store_string (SCHEME_P_ int len, const char *str, char fill); 625static char *store_string (SCHEME_P_ int len, const char *str, char fill);
609static pointer mk_vector (SCHEME_P_ int len); 626static pointer mk_vector (SCHEME_P_ int len);
610static pointer mk_atom (SCHEME_P_ char *q); 627static pointer mk_atom (SCHEME_P_ char *q);
611static pointer mk_sharp_const (SCHEME_P_ char *name); 628static pointer mk_sharp_const (SCHEME_P_ char *name);
612 629
… …
646static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 663static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
647static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 664static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
648static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 665static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
649static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 666static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
650static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 667static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
651static void assign_syntax (SCHEME_P_ char *name); 668static void assign_syntax (SCHEME_P_ const char *name);
652static int syntaxnum (pointer p); 669static int syntaxnum (pointer p);
653static void assign_proc (SCHEME_P_ enum scheme_opcodes, char *name); 670static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
654 671
655static num 672static num
656num_add (num a, num b) 673num_add (num a, num b)
657{ 674{
658 num ret; 675 num ret;
659 676
660 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 677 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
661 678
662 if (num_is_fixnum (ret)) 679 if (num_is_fixnum (ret))
663 num_set_ivalue (ret, a.value.ivalue + b.value.ivalue); 680 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b));
664 else 681 else
665 num_set_rvalue (ret, num_rvalue (a) + num_rvalue (b)); 682 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b));
666 683
667 return ret; 684 return ret;
668} 685}
669 686
670static num 687static num
… …
673 num ret; 690 num ret;
674 691
675 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 692 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
676 693
677 if (num_is_fixnum (ret)) 694 if (num_is_fixnum (ret))
678 num_set_ivalue (ret, a.value.ivalue * b.value.ivalue); 695 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
679 else 696 else
680 num_set_rvalue (ret, num_rvalue (a) * num_rvalue (b)); 697 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
681 698
682 return ret; 699 return ret;
683} 700}
684 701
685static num 702static num
686num_div (num a, num b) 703num_div (num a, num b)
687{ 704{
688 num ret; 705 num ret;
689 706
690 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && a.value.ivalue % b.value.ivalue == 0); 707 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0);
691 708
692 if (num_is_fixnum (ret)) 709 if (num_is_fixnum (ret))
693 num_set_ivalue (ret, a.value.ivalue / b.value.ivalue); 710 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
694 else 711 else
695 num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); 712 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
696 713
697 return ret; 714 return ret;
698} 715}
699 716
700static num 717static num
… …
703 num ret; 720 num ret;
704 721
705 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 722 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
706 723
707 if (num_is_fixnum (ret)) 724 if (num_is_fixnum (ret))
708 num_set_ivalue (ret, a.value.ivalue / b.value.ivalue); 725 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
709 else 726 else
710 num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); 727 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
711 728
712 return ret; 729 return ret;
713} 730}
714 731
715static num 732static num
… …
718 num ret; 735 num ret;
719 736
720 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 737 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
721 738
722 if (num_is_fixnum (ret)) 739 if (num_is_fixnum (ret))
723 num_set_ivalue (ret, a.value.ivalue - b.value.ivalue); 740 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
724 else 741 else
725 num_set_rvalue (ret, num_rvalue (a) - num_rvalue (b)); 742 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
726 743
727 return ret; 744 return ret;
728} 745}
729 746
730static num 747static num
… …
732{ 749{
733 num ret; 750 num ret;
734 long e1, e2, res; 751 long e1, e2, res;
735 752
736 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 753 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
737 e1 = num_ivalue (a); 754 e1 = num_get_ivalue (a);
738 e2 = num_ivalue (b); 755 e2 = num_get_ivalue (b);
739 res = e1 % e2; 756 res = e1 % e2;
740 757
741 /* remainder should have same sign as second operand */ 758 /* remainder should have same sign as second operand */
742 if (res > 0) 759 if (res > 0)
743 { 760 {
… …
759{ 776{
760 num ret; 777 num ret;
761 long e1, e2, res; 778 long e1, e2, res;
762 779
763 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 780 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
764 e1 = num_ivalue (a); 781 e1 = num_get_ivalue (a);
765 e2 = num_ivalue (b); 782 e2 = num_get_ivalue (b);
766 res = e1 % e2; 783 res = e1 % e2;
767 784
768 /* modulo should have same sign as second operand */ 785 /* modulo should have same sign as second operand */
769 if (res * e2 < 0) 786 if (res * e2 < 0)
770 res += e2; 787 res += e2;
… …
778{ 795{
779 int ret; 796 int ret;
780 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 797 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
781 798
782 if (is_fixnum) 799 if (is_fixnum)
783 ret = a.value.ivalue == b.value.ivalue; 800 ret = num_get_ivalue (a) == num_get_ivalue (b);
784 else 801 else
785 ret = num_rvalue (a) == num_rvalue (b); 802 ret = num_get_rvalue (a) == num_get_rvalue (b);
786 803
787 return ret; 804 return ret;
788} 805}
789 806
790 807
… …
793{ 810{
794 int ret; 811 int ret;
795 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 812 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
796 813
797 if (is_fixnum) 814 if (is_fixnum)
798 ret = a.value.ivalue > b.value.ivalue; 815 ret = num_get_ivalue (a) > num_get_ivalue (b);
799 else 816 else
800 ret = num_rvalue (a) > num_rvalue (b); 817 ret = num_get_rvalue (a) > num_get_rvalue (b);
801 818
802 return ret; 819 return ret;
803} 820}
804 821
805static int 822static int
… …
813{ 830{
814 int ret; 831 int ret;
815 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); 832 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
816 833
817 if (is_fixnum) 834 if (is_fixnum)
818 ret = a.value.ivalue < b.value.ivalue; 835 ret = num_get_ivalue (a) < num_get_ivalue (b);
819 else 836 else
820 ret = num_rvalue (a) < num_rvalue (b); 837 ret = num_get_rvalue (a) < num_get_rvalue (b);
821 838
822 return ret; 839 return ret;
823} 840}
824 841
825static int 842static int
… …
927 SCHEME_V->fcells += segsize; 944 SCHEME_V->fcells += segsize;
928 last = newp + segsize - 1; 945 last = newp + segsize - 1;
929 946
930 for (p = newp; p <= last; p++) 947 for (p = newp; p <= last; p++)
931 { 948 {
932 set_typeflag (p, 0); 949 set_typeflag (p, T_FREE);
950 set_car (p, NIL);
933 set_cdr (p, p + 1); 951 set_cdr (p, p + 1);
934 set_car (p, NIL);
935 } 952 }
936 953
937 /* insert new cells in address order on free list */ 954 /* insert new cells in address order on free list */
938 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell) 955 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
939 { 956 {
… …
953 } 970 }
954 971
955 return n; 972 return n;
956} 973}
957 974
958/* get new cell. parameter a, b is marked by gc. */ 975/* get new cell. parameter a, b is marked by gc. */
959static INLINE pointer 976static INLINE pointer
960get_cell_x (SCHEME_P_ pointer a, pointer b) 977get_cell_x (SCHEME_P_ pointer a, pointer b)
961{ 978{
962 if (SCHEME_V->free_cell == NIL) 979 if (SCHEME_V->free_cell == NIL)
963 { 980 {
… …
1070 while (cdr (x) == x + 1) 1087 while (cdr (x) == x + 1)
1071 { 1088 {
1072 x = cdr (x); 1089 x = cdr (x);
1073 n++; 1090 n++;
1074 1091
1075 if (n > needed) 1092 if (n >= needed)
1076 return n; 1093 break;
1077 } 1094 }
1078 1095
1079 return n; 1096 return n;
1080} 1097}
1081 1098
1082static pointer 1099static pointer
1083find_consecutive_cells (SCHEME_P_ int n) 1100find_consecutive_cells (SCHEME_P_ int n)
1084{ 1101{
1085 pointer *pp;
1086 int cnt;
1087
1088 pp = &SCHEME_V->free_cell; 1102 pointer *pp = &SCHEME_V->free_cell;
1089 1103
1090 while (*pp != NIL) 1104 while (*pp != NIL)
1091 { 1105 {
1092 cnt = count_consecutive_cells (*pp, n); 1106 int cnt = count_consecutive_cells (*pp, n);
1093 1107
1094 if (cnt >= n) 1108 if (cnt >= n)
1095 { 1109 {
1096 pointer x = *pp; 1110 pointer x = *pp;
1097 1111
… …
1112static void 1126static void
1113push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 1127push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1114{ 1128{
1115 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 1129 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1116 1130
1117 set_typeflag (holder, T_PAIR | T_IMMUTABLE); 1131 set_typeflag (holder, T_PAIR);
1132 setimmutable (holder);
1118 set_car (holder, recent); 1133 set_car (holder, recent);
1119 set_cdr (holder, car (S_SINK)); 1134 set_cdr (holder, car (S_SINK));
1120 set_car (S_SINK, holder); 1135 set_car (S_SINK, holder);
1121} 1136}
1122 1137
… …
1164 1179
1165#if defined TSGRIND 1180#if defined TSGRIND
1166static void 1181static void
1167check_cell_alloced (pointer p, int expect_alloced) 1182check_cell_alloced (pointer p, int expect_alloced)
1168{ 1183{
1169 /* Can't use putstr(SCHEME_A_ str) because callers have no access to 1184 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1170 sc. */
1171 if (typeflag (p) & !expect_alloced) 1185 if (typeflag (p) & !expect_alloced)
1172 xwrstr ("Cell is already allocated!\n"); 1186 xwrstr ("Cell is already allocated!\n");
1173 1187
1174 if (!(typeflag (p)) & expect_alloced) 1188 if (!(typeflag (p)) & expect_alloced)
1175 xwrstr ("Cell is not allocated!\n"); 1189 xwrstr ("Cell is not allocated!\n");
… …
1217 1231
1218/* returns the new symbol */ 1232/* returns the new symbol */
1219static pointer 1233static pointer
1220oblist_add_by_name (SCHEME_P_ const char *name) 1234oblist_add_by_name (SCHEME_P_ const char *name)
1221{ 1235{
1222 pointer x;
1223 int location; 1236 int location;
1224 1237
1225 x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1238 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1226 set_typeflag (x, T_SYMBOL); 1239 set_typeflag (x, T_SYMBOL);
1227 setimmutable (car (x)); 1240 setimmutable (car (x));
1228 1241
1229 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist)); 1242 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist));
1230 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1243 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
… …
1341mk_character (SCHEME_P_ int c) 1354mk_character (SCHEME_P_ int c)
1342{ 1355{
1343 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1356 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1344 1357
1345 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1358 set_typeflag (x, (T_CHARACTER | T_ATOM));
1346 ivalue_unchecked (x) = c; 1359 ivalue_unchecked (x) = c & 0xff;
1347 set_num_integer (x); 1360 set_num_integer (x);
1348 return x; 1361 return x;
1349} 1362}
1350 1363
1351/* get number atom (integer) */ 1364/* get number atom (integer) */
… …
1370 set_num_real (x); 1383 set_num_real (x);
1371 return x; 1384 return x;
1372} 1385}
1373 1386
1374static pointer 1387static pointer
1375mk_number (SCHEME_P_ num n) 1388mk_number (SCHEME_P_ const num n)
1376{ 1389{
1377 if (num_is_fixnum (n)) 1390 if (num_is_fixnum (n))
1378 {
1379 return mk_integer (SCHEME_A_ num_ivalue (n)); 1391 return mk_integer (SCHEME_A_ num_get_ivalue (n));
1380 }
1381 else 1392 else
1382 {
1383 return mk_real (SCHEME_A_ num_rvalue (n)); 1393 return mk_real (SCHEME_A_ num_get_rvalue (n));
1384 }
1385} 1394}
1386 1395
1387/* allocate name to string area */ 1396/* allocate name to string area */
1388static char * 1397static char *
1389store_string (SCHEME_P_ int len_str, const char *str, char fill) 1398store_string (SCHEME_P_ int len_str, const char *str, char fill)
1390{ 1399{
1391 char *q;
1392
1393 q = (char *)malloc (len_str + 1); 1400 char *q = malloc (len_str + 1);
1394 1401
1395 if (q == 0) 1402 if (q == 0 && USE_ERROR_CHECKING)
1396 { 1403 {
1397#if USE_ERROR_CHECKING
1398 SCHEME_V->no_memory = 1; 1404 SCHEME_V->no_memory = 1;
1399 return SCHEME_V->strbuff; 1405 return SCHEME_V->strbuff;
1400#endif
1401 } 1406 }
1402 1407
1403 if (str) 1408 if (str)
1404 { 1409 {
1405 int l = strlen (str); 1410 int l = strlen (str);
1406 1411
1407 if (l > len_str) 1412 if (l > len_str)
1408 l = len_str; 1413 l = len_str;
1409 1414
1410 memcpy (q, str, l + 1); 1415 memcpy (q, str, l);
1411 q[l + 1] = 0; 1416 q[l] = 0;
1412 } 1417 }
1413 else 1418 else
1414 { 1419 {
1415 memset (q, fill, len_str); 1420 memset (q, fill, len_str);
1416 q[len_str] = 0; 1421 q[len_str] = 0;
… …
1493 1498
1494/* get new symbol */ 1499/* get new symbol */
1495INTERFACE pointer 1500INTERFACE pointer
1496mk_symbol (SCHEME_P_ const char *name) 1501mk_symbol (SCHEME_P_ const char *name)
1497{ 1502{
1498 pointer x;
1499
1500 /* first check oblist */ 1503 /* first check oblist */
1501 x = oblist_find_by_name (SCHEME_A_ name); 1504 pointer x = oblist_find_by_name (SCHEME_A_ name);
1502 1505
1503 if (x != NIL) 1506 if (x == NIL)
1504 return x;
1505 else
1506 {
1507 x = oblist_add_by_name (SCHEME_A_ name); 1507 x = oblist_add_by_name (SCHEME_A_ name);
1508
1508 return x; 1509 return x;
1509 }
1510} 1510}
1511 1511
1512INTERFACE pointer 1512INTERFACE pointer
1513gensym (SCHEME_P) 1513gensym (SCHEME_P)
1514{ 1514{
… …
1567 has_dec_point = 1; 1567 has_dec_point = 1;
1568 c = *p++; 1568 c = *p++;
1569 } 1569 }
1570 1570
1571 if (!isdigit (c)) 1571 if (!isdigit (c))
1572 {
1573 return mk_symbol (SCHEME_A_ strlwr (q)); 1572 return mk_symbol (SCHEME_A_ strlwr (q));
1574 }
1575 } 1573 }
1576 else if (c == '.') 1574 else if (c == '.')
1577 { 1575 {
1578 has_dec_point = 1; 1576 has_dec_point = 1;
1579 c = *p++; 1577 c = *p++;
1580 1578
1581 if (!isdigit (c)) 1579 if (!isdigit (c))
1582 {
1583 return mk_symbol (SCHEME_A_ strlwr (q)); 1580 return mk_symbol (SCHEME_A_ strlwr (q));
1584 }
1585 } 1581 }
1586 else if (!isdigit (c)) 1582 else if (!isdigit (c))
1587 {
1588 return mk_symbol (SCHEME_A_ strlwr (q)); 1583 return mk_symbol (SCHEME_A_ strlwr (q));
1589 }
1590 1584
1591 for (; (c = *p) != 0; ++p) 1585 for (; (c = *p) != 0; ++p)
1592 { 1586 {
1593 if (!isdigit (c)) 1587 if (!isdigit (c))
1594 { 1588 {
… …
1607 has_dec_point = 1; /* decimal point illegal 1601 has_dec_point = 1; /* decimal point illegal
1608 from now on */ 1602 from now on */
1609 p++; 1603 p++;
1610 1604
1611 if ((*p == '-') || (*p == '+') || isdigit (*p)) 1605 if ((*p == '-') || (*p == '+') || isdigit (*p))
1612 {
1613 continue; 1606 continue;
1614 }
1615 } 1607 }
1616 } 1608 }
1617 1609
1618 return mk_symbol (SCHEME_A_ strlwr (q)); 1610 return mk_symbol (SCHEME_A_ strlwr (q));
1619 } 1611 }
… …
1707static void 1699static void
1708mark (pointer a) 1700mark (pointer a)
1709{ 1701{
1710 pointer t, q, p; 1702 pointer t, q, p;
1711 1703
1712 t = (pointer) 0; 1704 t = 0;
1713 p = a; 1705 p = a;
1714E2: 1706E2:
1715 setmark (p); 1707 setmark (p);
1716 printf ("mark %p %x\n", p, p->flag);//D
1717 1708
1718 if (is_vector (p)) 1709 if (is_vector (p))
1719 { 1710 {
1720 int i; 1711 int i;
1721 int num = ivalue_unchecked (p) / 2 + ivalue_unchecked (p) % 2; 1712 int num = ivalue_unchecked (p) / 2 + ivalue_unchecked (p) % 2;
… …
1742 goto E2; 1733 goto E2;
1743 } 1734 }
1744 1735
1745E5: 1736E5:
1746 q = cdr (p); /* down cdr */ 1737 q = cdr (p); /* down cdr */
1747 printf ("mark+ %p\n", q, q->flag);//D
1748 1738
1749 if (q && !is_mark (q)) 1739 if (q && !is_mark (q))
1750 { 1740 {
1751 set_cdr (p, t); 1741 set_cdr (p, t);
1752 t = p; 1742 t = p;
1753 p = q; 1743 p = q;
1754 goto E2; 1744 goto E2;
1755 } 1745 }
1756 1746
1757E6: /* up. Undo the link switching from steps E4 and E5. */ 1747E6: /* up. Undo the link switching from steps E4 and E5. */
1758
1759 if (!t) 1748 if (!t)
1760 return; 1749 return;
1761 1750
1762 q = t; 1751 q = t;
1763 1752
… …
1831 if (is_mark (p)) 1820 if (is_mark (p))
1832 clrmark (p); 1821 clrmark (p);
1833 else 1822 else
1834 { 1823 {
1835 /* reclaim cell */ 1824 /* reclaim cell */
1836 if (typeflag (p) != 0) 1825 if (typeflag (p) != T_FREE)
1837 { 1826 {
1838 finalize_cell (SCHEME_A_ p); 1827 finalize_cell (SCHEME_A_ p);
1839 set_typeflag (p, 0); 1828 set_typeflag (p, T_FREE);
1840 set_car (p, NIL); 1829 set_car (p, NIL);
1841 } 1830 }
1842 1831
1843 ++SCHEME_V->fcells; 1832 ++SCHEME_V->fcells;
1844 set_cdr (p, SCHEME_V->free_cell); 1833 set_cdr (p, SCHEME_V->free_cell);
… …
2289 char *p = SCHEME_V->strbuff; 2278 char *p = SCHEME_V->strbuff;
2290 2279
2291 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2280 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2292 2281
2293 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2282 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2294 {
2295 *p = 0; 2283 *p = 0;
2296 }
2297 else 2284 else
2298 { 2285 {
2299 backchar (SCHEME_A_ p[-1]); 2286 backchar (SCHEME_A_ p[-1]);
2300 *--p = '\0'; 2287 *--p = '\0';
2301 } 2288 }
… …
2316 for (;;) 2303 for (;;)
2317 { 2304 {
2318 c = inchar (SCHEME_A); 2305 c = inchar (SCHEME_A);
2319 2306
2320 if (c == EOF || p - SCHEME_V->strbuff > sizeof (SCHEME_V->strbuff) - 1) 2307 if (c == EOF || p - SCHEME_V->strbuff > sizeof (SCHEME_V->strbuff) - 1)
2321 {
2322 return S_F; 2308 return S_F;
2323 }
2324 2309
2325 switch (state) 2310 switch (state)
2326 { 2311 {
2327 case st_ok: 2312 case st_ok:
2328 switch (c) 2313 switch (c)
… …
2396 c = toupper (c); 2381 c = toupper (c);
2397 2382
2398 if (c >= '0' && c <= 'F') 2383 if (c >= '0' && c <= 'F')
2399 { 2384 {
2400 if (c <= '9') 2385 if (c <= '9')
2401 {
2402 c1 = (c1 << 4) + c - '0'; 2386 c1 = (c1 << 4) + c - '0';
2403 }
2404 else 2387 else
2405 {
2406 c1 = (c1 << 4) + c - 'A' + 10; 2388 c1 = (c1 << 4) + c - 'A' + 10;
2407 }
2408 2389
2409 if (state == st_x1) 2390 if (state == st_x1)
2410 {
2411 state = st_x2; 2391 state = st_x2;
2412 }
2413 else 2392 else
2414 { 2393 {
2415 *p++ = c1; 2394 *p++ = c1;
2416 state = st_ok; 2395 state = st_ok;
2417 } 2396 }
2418 } 2397 }
2419 else 2398 else
2420 {
2421 return S_F; 2399 return S_F;
2422 }
2423 2400
2424 break; 2401 break;
2425 2402
2426 case st_oct1: 2403 case st_oct1:
2427 case st_oct2: 2404 case st_oct2:
… …
2458is_one_of (char *s, int c) 2435is_one_of (char *s, int c)
2459{ 2436{
2460 if (c == EOF) 2437 if (c == EOF)
2461 return 1; 2438 return 1;
2462 2439
2463 while (*s) 2440 return !!strchr (s, c);
2464 if (*s++ == c)
2465 return 1;
2466
2467 return 0;
2468} 2441}
2469 2442
2470/* skip white characters */ 2443/* skip white characters */
2471static INLINE int 2444static INLINE int
2472skipspace (SCHEME_P) 2445skipspace (SCHEME_P)
… …
2477 { 2450 {
2478 c = inchar (SCHEME_A); 2451 c = inchar (SCHEME_A);
2479#if SHOW_ERROR_LINE 2452#if SHOW_ERROR_LINE
2480 if (c == '\n') 2453 if (c == '\n')
2481 curr_line++; 2454 curr_line++;
2482
2483#endif 2455#endif
2484 } 2456 }
2485 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2457 while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
2486 2458
2487 /* record it */ 2459 /* record it */
… …
2524 2496
2525 if (is_one_of (" \n\t", c)) 2497 if (is_one_of (" \n\t", c))
2526 return TOK_DOT; 2498 return TOK_DOT;
2527 else 2499 else
2528 { 2500 {
2501 //TODO: ungetc twice in a row is not supported in C
2529 backchar (SCHEME_A_ c); 2502 backchar (SCHEME_A_ c);
2530 backchar (SCHEME_A_ '.'); 2503 backchar (SCHEME_A_ '.');
2531 return TOK_ATOM; 2504 return TOK_ATOM;
2532 } 2505 }
2533 2506
… …
2647 int d = *s / 16; 2620 int d = *s / 16;
2648 2621
2649 putcharacter (SCHEME_A_ 'x'); 2622 putcharacter (SCHEME_A_ 'x');
2650 2623
2651 if (d < 10) 2624 if (d < 10)
2652 {
2653 putcharacter (SCHEME_A_ d + '0'); 2625 putcharacter (SCHEME_A_ d + '0');
2654 }
2655 else 2626 else
2656 {
2657 putcharacter (SCHEME_A_ d - 10 + 'A'); 2627 putcharacter (SCHEME_A_ d - 10 + 'A');
2658 }
2659 2628
2660 d = *s % 16; 2629 d = *s % 16;
2661 2630
2662 if (d < 10) 2631 if (d < 10)
2663 {
2664 putcharacter (SCHEME_A_ d + '0'); 2632 putcharacter (SCHEME_A_ d + '0');
2665 }
2666 else 2633 else
2667 {
2668 putcharacter (SCHEME_A_ d - 10 + 'A'); 2634 putcharacter (SCHEME_A_ d - 10 + 'A');
2669 }
2670 } 2635 }
2671 } 2636 }
2672 } 2637 }
2673 else 2638 else
2674 {
2675 putcharacter (SCHEME_A_ * s); 2639 putcharacter (SCHEME_A_ * s);
2676 }
2677 2640
2678 s++; 2641 s++;
2679 } 2642 }
2680 2643
2681 putcharacter (SCHEME_A_ '"'); 2644 putcharacter (SCHEME_A_ '"');
… …
2898list_star (SCHEME_P_ pointer d) 2861list_star (SCHEME_P_ pointer d)
2899{ 2862{
2900 pointer p, q; 2863 pointer p, q;
2901 2864
2902 if (cdr (d) == NIL) 2865 if (cdr (d) == NIL)
2903 {
2904 return car (d); 2866 return car (d);
2905 }
2906 2867
2907 p = cons (car (d), cdr (d)); 2868 p = cons (car (d), cdr (d));
2908 q = p; 2869 q = p;
2909 2870
2910 while (cdr (cdr (p)) != NIL) 2871 while (cdr (cdr (p)) != NIL)
2911 { 2872 {
2912 d = cons (car (p), cdr (p)); 2873 d = cons (car (p), cdr (p));
2913 2874
2914 if (cdr (cdr (p)) != NIL) 2875 if (cdr (cdr (p)) != NIL)
2915 {
2916 p = cdr (d); 2876 p = cdr (d);
2917 }
2918 } 2877 }
2919 2878
2920 set_cdr (p, car (cdr (p))); 2879 set_cdr (p, car (cdr (p)));
2921 return q; 2880 return q;
2922} 2881}
… …
2936 2895
2937/* reverse list --- in-place */ 2896/* reverse list --- in-place */
2938static pointer 2897static pointer
2939reverse_in_place (SCHEME_P_ pointer term, pointer list) 2898reverse_in_place (SCHEME_P_ pointer term, pointer list)
2940{ 2899{
2941 pointer p = list, result = term, q; 2900 pointer result = term;
2901 pointer p = list;
2942 2902
2943 while (p != NIL) 2903 while (p != NIL)
2944 { 2904 {
2945 q = cdr (p); 2905 pointer q = cdr (p);
2946 set_cdr (p, result); 2906 set_cdr (p, result);
2947 result = p; 2907 result = p;
2948 p = q; 2908 p = q;
2949 } 2909 }
2950 2910
… …
3231 else 3191 else
3232 SCHEME_V->args = NIL; 3192 SCHEME_V->args = NIL;
3233 3193
3234 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); 3194 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
3235 setimmutable (car (SCHEME_V->args)); 3195 setimmutable (car (SCHEME_V->args));
3236 SCHEME_V->op = (int)OP_ERR0; 3196 SCHEME_V->op = OP_ERR0;
3237 return S_T; 3197 return S_T;
3238} 3198}
3239 3199
3240#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) 3200#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
3241#define Error_0(s) Error_1 (s, 0) 3201#define Error_0(s) Error_1 (s, 0)
3242 3202
3243/* Too small to turn into function */ 3203/* Too small to turn into function */
3244#define BEGIN do { 3204#define BEGIN do {
3245#define END } while (0) 3205#define END } while (0)
3246#define s_goto(a) BEGIN \ 3206#define s_goto(a) BEGIN \
3247 SCHEME_V->op = (int)(a); \ 3207 SCHEME_V->op = a; \
3248 return S_T; END 3208 return S_T; END
3249 3209
3250#define s_return(a) return xs_return(SCHEME_A_ a) 3210#define s_return(a) return xs_return (SCHEME_A_ a)
3251 3211
3252#ifndef USE_SCHEME_STACK 3212#ifndef USE_SCHEME_STACK
3253 3213
3254/* this structure holds all the interpreter's registers */ 3214/* this structure holds all the interpreter's registers */
3255struct dump_stack_frame 3215struct dump_stack_frame
… …
3274 SCHEME_V->dump_size += STACK_GROWTH; 3234 SCHEME_V->dump_size += STACK_GROWTH;
3275 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3235 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3276 } 3236 }
3277 3237
3278 next_frame = SCHEME_V->dump_base + nframes; 3238 next_frame = SCHEME_V->dump_base + nframes;
3239
3279 next_frame->op = op; 3240 next_frame->op = op;
3280 next_frame->args = args; 3241 next_frame->args = args;
3281 next_frame->envir = SCHEME_V->envir; 3242 next_frame->envir = SCHEME_V->envir;
3282 next_frame->code = code; 3243 next_frame->code = code;
3244
3283 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3245 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3284} 3246}
3285 3247
3286static pointer 3248static pointer
3287xs_return (SCHEME_P_ pointer a) 3249xs_return (SCHEME_P_ pointer a)
… …
3292 SCHEME_V->value = a; 3254 SCHEME_V->value = a;
3293 3255
3294 if (nframes <= 0) 3256 if (nframes <= 0)
3295 return NIL; 3257 return NIL;
3296 3258
3297 nframes--;
3298 frame = SCHEME_V->dump_base + nframes; 3259 frame = &SCHEME_V->dump_base[--nframes];
3299 SCHEME_V->op = frame->op; 3260 SCHEME_V->op = frame->op;
3300 SCHEME_V->args = frame->args; 3261 SCHEME_V->args = frame->args;
3301 SCHEME_V->envir = frame->envir; 3262 SCHEME_V->envir = frame->envir;
3302 SCHEME_V->code = frame->code; 3263 SCHEME_V->code = frame->code;
3303 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3264 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3304 3265
3305 return S_T; 3266 return S_T;
3306} 3267}
3307 3268
3308static INLINE void 3269static INLINE void
3309dump_stack_reset (SCHEME_P) 3270dump_stack_reset (SCHEME_P)
3310{ 3271{
3311 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3272 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3312 SCHEME_V->dump = (pointer)0; 3273 SCHEME_V->dump = (pointer)+0;
3313} 3274}
3314 3275
3315static INLINE void 3276static INLINE void
3316dump_stack_initialize (SCHEME_P) 3277dump_stack_initialize (SCHEME_P)
3317{ 3278{
3318 SCHEME_V->dump_size = 0; 3279 SCHEME_V->dump_size = 0;
3319 SCHEME_V->dump_base = NULL; 3280 SCHEME_V->dump_base = 0;
3320 dump_stack_reset (SCHEME_A); 3281 dump_stack_reset (SCHEME_A);
3321} 3282}
3322 3283
3323static void 3284static void
3324dump_stack_free (SCHEME_P) 3285dump_stack_free (SCHEME_P)
3325{ 3286{
3326 free (SCHEME_V->dump_base); 3287 free (SCHEME_V->dump_base);
3327 SCHEME_V->dump_base = NULL; 3288 SCHEME_V->dump_base = 0;
3328 SCHEME_V->dump = (pointer)0; 3289 SCHEME_V->dump = (pointer)0;
3329 SCHEME_V->dump_size = 0; 3290 SCHEME_V->dump_size = 0;
3330} 3291}
3331 3292
3332static void 3293static void
… …
3374 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3335 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3375 3336
3376 while (cont != NIL) 3337 while (cont != NIL)
3377 { 3338 {
3378 frame->op = ivalue (car (cont)); cont = cdr (cont); 3339 frame->op = ivalue (car (cont)); cont = cdr (cont);
3379 frame->args = car (cont) ; cont = cdr (cont); 3340 frame->args = car (cont) ; cont = cdr (cont);
3380 frame->envir = car (cont) ; cont = cdr (cont); 3341 frame->envir = car (cont) ; cont = cdr (cont);
3381 frame->code = car (cont) ; cont = cdr (cont); 3342 frame->code = car (cont) ; cont = cdr (cont);
3382 3343
3383 ++frame; 3344 ++frame;
3384 ++i; 3345 ++i;
3385 } 3346 }
3386 3347
… …
3415 SCHEME_V->value = a; 3376 SCHEME_V->value = a;
3416 3377
3417 if (dump == NIL) 3378 if (dump == NIL)
3418 return NIL; 3379 return NIL;
3419 3380
3420 SCHEME_V->op = ivalue (car (dump)); 3381 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3421 SCHEME_V->args = car (dump) ; dump = cdr (dump); 3382 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3422 SCHEME_V->envir = car (dump) ; dump = cdr (dump); 3383 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3423 SCHEME_V->code = car (dump) ; dump = cdr (dump); 3384 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3424 3385
3425 SCHEME_V->dump = dump; 3386 SCHEME_V->dump = dump;
3426 3387
3427 return S_T; 3388 return S_T;
3428} 3389}
… …
3525 3486
3526 case OP_READ_INTERNAL: /* internal read */ 3487 case OP_READ_INTERNAL: /* internal read */
3527 SCHEME_V->tok = token (SCHEME_A); 3488 SCHEME_V->tok = token (SCHEME_A);
3528 3489
3529 if (SCHEME_V->tok == TOK_EOF) 3490 if (SCHEME_V->tok == TOK_EOF)
3530 {
3531 s_return (S_EOF); 3491 s_return (S_EOF);
3532 }
3533 3492
3534 s_goto (OP_RDSEXPR); 3493 s_goto (OP_RDSEXPR);
3535 3494
3536 case OP_GENSYM: 3495 case OP_GENSYM:
3537 s_return (gensym (SCHEME_A)); 3496 s_return (gensym (SCHEME_A));
… …
3541 /* OP_VALUEPRINT is always pushed, because when changing from 3500 /* OP_VALUEPRINT is always pushed, because when changing from
3542 non-interactive to interactive mode, it needs to be 3501 non-interactive to interactive mode, it needs to be
3543 already on the stack */ 3502 already on the stack */
3544#if USE_TRACING 3503#if USE_TRACING
3545 if (SCHEME_V->tracing) 3504 if (SCHEME_V->tracing)
3546 {
3547 putstr (SCHEME_A_ "\nGives: "); 3505 putstr (SCHEME_A_ "\nGives: ");
3548 }
3549#endif 3506#endif
3550 3507
3551 if (file_interactive (SCHEME_A)) 3508 if (file_interactive (SCHEME_A))
3552 { 3509 {
3553 SCHEME_V->print_flag = 1; 3510 SCHEME_V->print_flag = 1;
3554 SCHEME_V->args = SCHEME_V->value; 3511 SCHEME_V->args = SCHEME_V->value;
3555 s_goto (OP_P0LIST); 3512 s_goto (OP_P0LIST);
3556 } 3513 }
3557 else 3514 else
3558 {
3559 s_return (SCHEME_V->value); 3515 s_return (SCHEME_V->value);
3560 }
3561 3516
3562 case OP_EVAL: /* main part of evaluation */ 3517 case OP_EVAL: /* main part of evaluation */
3563#if USE_TRACING 3518#if USE_TRACING
3564 if (SCHEME_V->tracing) 3519 if (SCHEME_V->tracing)
3565 { 3520 {
… …
3569 putstr (SCHEME_A_ "\nEval: "); 3524 putstr (SCHEME_A_ "\nEval: ");
3570 s_goto (OP_P0LIST); 3525 s_goto (OP_P0LIST);
3571 } 3526 }
3572 3527
3573 /* fall through */ 3528 /* fall through */
3529
3574 case OP_REAL_EVAL: 3530 case OP_REAL_EVAL:
3575#endif 3531#endif
3576 if (is_symbol (SCHEME_V->code)) /* symbol */ 3532 if (is_symbol (SCHEME_V->code)) /* symbol */
3577 { 3533 {
3578 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3534 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
… …
3654 putstr (SCHEME_A_ "\nApply to: "); 3610 putstr (SCHEME_A_ "\nApply to: ");
3655 s_goto (OP_P0LIST); 3611 s_goto (OP_P0LIST);
3656 } 3612 }
3657 3613
3658 /* fall through */ 3614 /* fall through */
3615
3659 case OP_REAL_APPLY: 3616 case OP_REAL_APPLY:
3660#endif 3617#endif
3661 if (is_proc (SCHEME_V->code)) 3618 if (is_proc (SCHEME_V->code))
3662 { 3619 {
3663 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3620 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
… …
3677 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); 3634 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3678 3635
3679 for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) 3636 for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y))
3680 { 3637 {
3681 if (y == NIL) 3638 if (y == NIL)
3682 {
3683 Error_0 ("not enough arguments"); 3639 Error_0 ("not enough arguments");
3684 }
3685 else 3640 else
3686 {
3687 new_slot_in_env (SCHEME_A_ car (x), car (y)); 3641 new_slot_in_env (SCHEME_A_ car (x), car (y));
3688 }
3689 } 3642 }
3690 3643
3691 if (x == NIL) 3644 if (x == NIL)
3692 { 3645 {
3693
3694 /*-- 3646 /*--
3695 * if (y != NIL) { 3647 * if (y != NIL) {
3696 * Error_0("too many arguments"); 3648 * Error_0("too many arguments");
3697 * } 3649 * }
3698 */ 3650 */
3699 } 3651 }
3700 else if (is_symbol (x)) 3652 else if (is_symbol (x))
3701 new_slot_in_env (SCHEME_A_ x, y); 3653 new_slot_in_env (SCHEME_A_ x, y);
3702 else 3654 else
3703 {
3704 Error_1 ("syntax error in closure: not a symbol:", x); 3655 Error_1 ("syntax error in closure: not a symbol:", x);
3705 }
3706 3656
3707 SCHEME_V->code = cdr (closure_code (SCHEME_V->code)); 3657 SCHEME_V->code = cdr (closure_code (SCHEME_V->code));
3708 SCHEME_V->args = NIL; 3658 SCHEME_V->args = NIL;
3709 s_goto (OP_BEGIN); 3659 s_goto (OP_BEGIN);
3710 } 3660 }
… …
3780 x = car (SCHEME_V->code); 3730 x = car (SCHEME_V->code);
3781 SCHEME_V->code = cadr (SCHEME_V->code); 3731 SCHEME_V->code = cadr (SCHEME_V->code);
3782 } 3732 }
3783 3733
3784 if (!is_symbol (x)) 3734 if (!is_symbol (x))
3785 {
3786 Error_0 ("variable is not a symbol"); 3735 Error_0 ("variable is not a symbol");
3787 }
3788 3736
3789 s_save (SCHEME_A_ OP_DEF1, NIL, x); 3737 s_save (SCHEME_A_ OP_DEF1, NIL, x);
3790 s_goto (OP_EVAL); 3738 s_goto (OP_EVAL);
3791 3739
3792 case OP_DEF1: /* define */ 3740 case OP_DEF1: /* define */
3793 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0); 3741 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);
3794 3742
3795 if (x != NIL) 3743 if (x != NIL)
3796 {
3797 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value); 3744 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
3798 }
3799 else 3745 else
3800 {
3801 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3746 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3802 }
3803 3747
3804 s_return (SCHEME_V->code); 3748 s_return (SCHEME_V->code);
3805 3749
3806 3750
3807 case OP_DEFP: /* defined? */ 3751 case OP_DEFP: /* defined? */
3808 x = SCHEME_V->envir; 3752 x = SCHEME_V->envir;
3809 3753
3810 if (cdr (SCHEME_V->args) != NIL) 3754 if (cdr (SCHEME_V->args) != NIL)
3811 {
3812 x = cadr (SCHEME_V->args); 3755 x = cadr (SCHEME_V->args);
3813 }
3814 3756
3815 s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); 3757 s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL);
3816 3758
3817 case OP_SET0: /* set! */ 3759 case OP_SET0: /* set! */
3818 if (is_immutable (car (SCHEME_V->code))) 3760 if (is_immutable (car (SCHEME_V->code)))
… …
3829 { 3771 {
3830 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value); 3772 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3831 s_return (SCHEME_V->value); 3773 s_return (SCHEME_V->value);
3832 } 3774 }
3833 else 3775 else
3834 {
3835 Error_1 ("set!: unbound variable:", SCHEME_V->code); 3776 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3836 }
3837 3777
3838 3778
3839 case OP_BEGIN: /* begin */ 3779 case OP_BEGIN: /* begin */
3840 if (!is_pair (SCHEME_V->code)) 3780 if (!is_pair (SCHEME_V->code))
3841 {
3842 s_return (SCHEME_V->code); 3781 s_return (SCHEME_V->code);
3843 }
3844 3782
3845 if (cdr (SCHEME_V->code) != NIL) 3783 if (cdr (SCHEME_V->code) != NIL)
3846 {
3847 s_save (SCHEME_A_ OP_BEGIN, NIL, cdr (SCHEME_V->code)); 3784 s_save (SCHEME_A_ OP_BEGIN, NIL, cdr (SCHEME_V->code));
3848 }
3849 3785
3850 SCHEME_V->code = car (SCHEME_V->code); 3786 SCHEME_V->code = car (SCHEME_V->code);
3851 s_goto (OP_EVAL); 3787 s_goto (OP_EVAL);
3852 3788
3853 case OP_IF0: /* if */ 3789 case OP_IF0: /* if */
… …
3874 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3810 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);
3875 3811
3876 if (is_pair (SCHEME_V->code)) /* continue */ 3812 if (is_pair (SCHEME_V->code)) /* continue */
3877 { 3813 {
3878 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3814 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3879 {
3880 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 3815 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3881 }
3882 3816
3883 s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); 3817 s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code));
3884 SCHEME_V->code = cadar (SCHEME_V->code); 3818 SCHEME_V->code = cadar (SCHEME_V->code);
3885 SCHEME_V->args = NIL; 3819 SCHEME_V->args = NIL;
3886 s_goto (OP_EVAL); 3820 s_goto (OP_EVAL);
… …
3896 case OP_LET2: /* let */ 3830 case OP_LET2: /* let */
3897 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3831 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3898 3832
3899 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; 3833 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args;
3900 y != NIL; x = cdr (x), y = cdr (y)) 3834 y != NIL; x = cdr (x), y = cdr (y))
3901 {
3902 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3835 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3903 }
3904 3836
3905 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3837 if (is_symbol (car (SCHEME_V->code))) /* named let */
3906 { 3838 {
3907 for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) 3839 for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x))
3908 { 3840 {
… …
3978 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3910 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);
3979 3911
3980 if (is_pair (SCHEME_V->code)) /* continue */ 3912 if (is_pair (SCHEME_V->code)) /* continue */
3981 { 3913 {
3982 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3914 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3983 {
3984 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); 3915 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3985 }
3986 3916
3987 s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); 3917 s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code));
3988 SCHEME_V->code = cadar (SCHEME_V->code); 3918 SCHEME_V->code = cadar (SCHEME_V->code);
3989 SCHEME_V->args = NIL; 3919 SCHEME_V->args = NIL;
3990 s_goto (OP_EVAL); 3920 s_goto (OP_EVAL);
… …
3997 s_goto (OP_LET2REC); 3927 s_goto (OP_LET2REC);
3998 } 3928 }
3999 3929
4000 case OP_LET2REC: /* letrec */ 3930 case OP_LET2REC: /* letrec */
4001 for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) 3931 for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y))
4002 {
4003 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3932 new_slot_in_env (SCHEME_A_ caar (x), car (y));
4004 }
4005 3933
4006 SCHEME_V->code = cdr (SCHEME_V->code); 3934 SCHEME_V->code = cdr (SCHEME_V->code);
4007 SCHEME_V->args = NIL; 3935 SCHEME_V->args = NIL;
4008 s_goto (OP_BEGIN); 3936 s_goto (OP_BEGIN);
4009 3937
4010 case OP_COND0: /* cond */ 3938 case OP_COND0: /* cond */
4011 if (!is_pair (SCHEME_V->code)) 3939 if (!is_pair (SCHEME_V->code))
4012 {
4013 Error_0 ("syntax error in cond"); 3940 Error_0 ("syntax error in cond");
4014 }
4015 3941
4016 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 3942 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
4017 SCHEME_V->code = caar (SCHEME_V->code); 3943 SCHEME_V->code = caar (SCHEME_V->code);
4018 s_goto (OP_EVAL); 3944 s_goto (OP_EVAL);
4019 3945
4020 case OP_COND1: /* cond */ 3946 case OP_COND1: /* cond */
4021 if (is_true (SCHEME_V->value)) 3947 if (is_true (SCHEME_V->value))
4022 { 3948 {
4023 if ((SCHEME_V->code = cdar (SCHEME_V->code)) == NIL) 3949 if ((SCHEME_V->code = cdar (SCHEME_V->code)) == NIL)
4024 {
4025 s_return (SCHEME_V->value); 3950 s_return (SCHEME_V->value);
4026 }
4027 3951
4028 if (car (SCHEME_V->code) == SCHEME_V->FEED_TO) 3952 if (car (SCHEME_V->code) == SCHEME_V->FEED_TO)
4029 { 3953 {
4030 if (!is_pair (cdr (SCHEME_V->code))) 3954 if (!is_pair (cdr (SCHEME_V->code)))
4031 {
4032 Error_0 ("syntax error in cond"); 3955 Error_0 ("syntax error in cond");
4033 }
4034 3956
4035 x = cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)); 3957 x = cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL));
4036 SCHEME_V->code = cons (cadr (SCHEME_V->code), cons (x, NIL)); 3958 SCHEME_V->code = cons (cadr (SCHEME_V->code), cons (x, NIL));
4037 s_goto (OP_EVAL); 3959 s_goto (OP_EVAL);
4038 } 3960 }
… …
4040 s_goto (OP_BEGIN); 3962 s_goto (OP_BEGIN);
4041 } 3963 }
4042 else 3964 else
4043 { 3965 {
4044 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 3966 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
4045 {
4046 s_return (NIL); 3967 s_return (NIL);
4047 }
4048 else 3968 else
4049 { 3969 {
4050 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 3970 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
4051 SCHEME_V->code = caar (SCHEME_V->code); 3971 SCHEME_V->code = caar (SCHEME_V->code);
4052 s_goto (OP_EVAL); 3972 s_goto (OP_EVAL);
… …
4058 set_typeflag (x, T_PROMISE); 3978 set_typeflag (x, T_PROMISE);
4059 s_return (x); 3979 s_return (x);
4060 3980
4061 case OP_AND0: /* and */ 3981 case OP_AND0: /* and */
4062 if (SCHEME_V->code == NIL) 3982 if (SCHEME_V->code == NIL)
4063 {
4064 s_return (S_T); 3983 s_return (S_T);
4065 }
4066 3984
4067 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 3985 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
4068 SCHEME_V->code = car (SCHEME_V->code); 3986 SCHEME_V->code = car (SCHEME_V->code);
4069 s_goto (OP_EVAL); 3987 s_goto (OP_EVAL);
4070 3988
4071 case OP_AND1: /* and */ 3989 case OP_AND1: /* and */
4072 if (is_false (SCHEME_V->value)) 3990 if (is_false (SCHEME_V->value))
4073 {
4074 s_return (SCHEME_V->value); 3991 s_return (SCHEME_V->value);
4075 }
4076 else if (SCHEME_V->code == NIL) 3992 else if (SCHEME_V->code == NIL)
4077 {
4078 s_return (SCHEME_V->value); 3993 s_return (SCHEME_V->value);
4079 }
4080 else 3994 else
4081 { 3995 {
4082 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 3996 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
4083 SCHEME_V->code = car (SCHEME_V->code); 3997 SCHEME_V->code = car (SCHEME_V->code);
4084 s_goto (OP_EVAL); 3998 s_goto (OP_EVAL);
4085 } 3999 }
4086 4000
4087 case OP_OR0: /* or */ 4001 case OP_OR0: /* or */
4088 if (SCHEME_V->code == NIL) 4002 if (SCHEME_V->code == NIL)
4089 {
4090 s_return (S_F); 4003 s_return (S_F);
4091 }
4092 4004
4093 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4005 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
4094 SCHEME_V->code = car (SCHEME_V->code); 4006 SCHEME_V->code = car (SCHEME_V->code);
4095 s_goto (OP_EVAL); 4007 s_goto (OP_EVAL);
4096 4008
4097 case OP_OR1: /* or */ 4009 case OP_OR1: /* or */
4098 if (is_true (SCHEME_V->value)) 4010 if (is_true (SCHEME_V->value))
4099 {
4100 s_return (SCHEME_V->value); 4011 s_return (SCHEME_V->value);
4101 }
4102 else if (SCHEME_V->code == NIL) 4012 else if (SCHEME_V->code == NIL)
4103 {
4104 s_return (SCHEME_V->value); 4013 s_return (SCHEME_V->value);
4105 }
4106 else 4014 else
4107 { 4015 {
4108 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4016 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
4109 SCHEME_V->code = car (SCHEME_V->code); 4017 SCHEME_V->code = car (SCHEME_V->code);
4110 s_goto (OP_EVAL); 4018 s_goto (OP_EVAL);
… …
4132 x = car (SCHEME_V->code); 4040 x = car (SCHEME_V->code);
4133 SCHEME_V->code = cadr (SCHEME_V->code); 4041 SCHEME_V->code = cadr (SCHEME_V->code);
4134 } 4042 }
4135 4043
4136 if (!is_symbol (x)) 4044 if (!is_symbol (x))
4137 {
4138 Error_0 ("variable is not a symbol"); 4045 Error_0 ("variable is not a symbol");
4139 }
4140 4046
4141 s_save (SCHEME_A_ OP_MACRO1, NIL, x); 4047 s_save (SCHEME_A_ OP_MACRO1, NIL, x);
4142 s_goto (OP_EVAL); 4048 s_goto (OP_EVAL);
4143 4049
4144 case OP_MACRO1: /* macro */ 4050 case OP_MACRO1: /* macro */
4145 set_typeflag (SCHEME_V->value, T_MACRO); 4051 set_typeflag (SCHEME_V->value, T_MACRO);
4146 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0); 4052 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);
4147 4053
4148 if (x != NIL) 4054 if (x != NIL)
4149 {
4150 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value); 4055 set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
4151 }
4152 else 4056 else
4153 {
4154 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 4057 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
4155 }
4156 4058
4157 s_return (SCHEME_V->code); 4059 s_return (SCHEME_V->code);
4158 4060
4159 case OP_CASE0: /* case */ 4061 case OP_CASE0: /* case */
4160 s_save (SCHEME_A_ OP_CASE1, NIL, cdr (SCHEME_V->code)); 4062 s_save (SCHEME_A_ OP_CASE1, NIL, cdr (SCHEME_V->code));
… …
4163 4065
4164 case OP_CASE1: /* case */ 4066 case OP_CASE1: /* case */
4165 for (x = SCHEME_V->code; x != NIL; x = cdr (x)) 4067 for (x = SCHEME_V->code; x != NIL; x = cdr (x))
4166 { 4068 {
4167 if (!is_pair (y = caar (x))) 4069 if (!is_pair (y = caar (x)))
4168 {
4169 break; 4070 break;
4170 }
4171 4071
4172 for (; y != NIL; y = cdr (y)) 4072 for (; y != NIL; y = cdr (y))
4173 { 4073 {
4174 if (eqv (car (y), SCHEME_V->value)) 4074 if (eqv (car (y), SCHEME_V->value))
4175 {
4176 break; 4075 break;
4177 }
4178 } 4076 }
4179 4077
4180 if (y != NIL) 4078 if (y != NIL)
4181 {
4182 break; 4079 break;
4183 }
4184 } 4080 }
4185 4081
4186 if (x != NIL) 4082 if (x != NIL)
4187 { 4083 {
4188 if (is_pair (caar (x))) 4084 if (is_pair (caar (x)))
… …
4196 SCHEME_V->code = caar (x); 4092 SCHEME_V->code = caar (x);
4197 s_goto (OP_EVAL); 4093 s_goto (OP_EVAL);
4198 } 4094 }
4199 } 4095 }
4200 else 4096 else
4201 {
4202 s_return (NIL); 4097 s_return (NIL);
4203 }
4204 4098
4205 case OP_CASE2: /* case */ 4099 case OP_CASE2: /* case */
4206 if (is_true (SCHEME_V->value)) 4100 if (is_true (SCHEME_V->value))
4207 {
4208 s_goto (OP_BEGIN); 4101 s_goto (OP_BEGIN);
4209 }
4210 else 4102 else
4211 {
4212 s_return (NIL); 4103 s_return (NIL);
4213 }
4214 4104
4215 case OP_PAPPLY: /* apply */ 4105 case OP_PAPPLY: /* apply */
4216 SCHEME_V->code = car (SCHEME_V->args); 4106 SCHEME_V->code = car (SCHEME_V->args);
4217 SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); 4107 SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args));
4218 /*SCHEME_V->args = cadr(SCHEME_V->args); */ 4108 /*SCHEME_V->args = cadr(SCHEME_V->args); */
4219 s_goto (OP_APPLY); 4109 s_goto (OP_APPLY);
4220 4110
4221 case OP_PEVAL: /* eval */ 4111 case OP_PEVAL: /* eval */
4222 if (cdr (SCHEME_V->args) != NIL) 4112 if (cdr (SCHEME_V->args) != NIL)
4223 {
4224 SCHEME_V->envir = cadr (SCHEME_V->args); 4113 SCHEME_V->envir = cadr (SCHEME_V->args);
4225 }
4226 4114
4227 SCHEME_V->code = car (SCHEME_V->args); 4115 SCHEME_V->code = car (SCHEME_V->args);
4228 s_goto (OP_EVAL); 4116 s_goto (OP_EVAL);
4229 4117
4230 case OP_CONTINUATION: /* call-with-current-continuation */ 4118 case OP_CONTINUATION: /* call-with-current-continuation */
… …
4252 4140
4253 case OP_INEX2EX: /* inexact->exact */ 4141 case OP_INEX2EX: /* inexact->exact */
4254 x = car (SCHEME_V->args); 4142 x = car (SCHEME_V->args);
4255 4143
4256 if (num_is_integer (x)) 4144 if (num_is_integer (x))
4257 {
4258 s_return (x); 4145 s_return (x);
4259 }
4260 else if (modf (rvalue_unchecked (x), &dd) == 0.0) 4146 else if (modf (rvalue_unchecked (x), &dd) == 0.0)
4261 {
4262 s_return (mk_integer (SCHEME_A_ ivalue (x))); 4147 s_return (mk_integer (SCHEME_A_ ivalue (x)));
4263 }
4264 else 4148 else
4265 {
4266 Error_1 ("inexact->exact: not integral:", x); 4149 Error_1 ("inexact->exact: not integral:", x);
4267 }
4268 4150
4269 case OP_EXP: 4151 case OP_EXP:
4270 x = car (SCHEME_V->args); 4152 x = car (SCHEME_V->args);
4271 s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4153 s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4272 4154
… …
4296 4178
4297 case OP_ATAN: 4179 case OP_ATAN:
4298 x = car (SCHEME_V->args); 4180 x = car (SCHEME_V->args);
4299 4181
4300 if (cdr (SCHEME_V->args) == NIL) 4182 if (cdr (SCHEME_V->args) == NIL)
4301 {
4302 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4183 s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
4303 }
4304 else 4184 else
4305 { 4185 {
4306 pointer y = cadr (SCHEME_V->args); 4186 pointer y = cadr (SCHEME_V->args);
4307 4187
4308 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); 4188 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
… …
4324 real_result = 0; 4204 real_result = 0;
4325 4205
4326 /* This 'if' is an R5RS compatibility fix. */ 4206 /* This 'if' is an R5RS compatibility fix. */
4327 /* NOTE: Remove this 'if' fix for R6RS. */ 4207 /* NOTE: Remove this 'if' fix for R6RS. */
4328 if (rvalue (x) == 0 && rvalue (y) < 0) 4208 if (rvalue (x) == 0 && rvalue (y) < 0)
4329 {
4330 result = 0.0; 4209 result = 0.0;
4331 }
4332 else 4210 else
4333 {
4334 result = pow (rvalue (x), rvalue (y)); 4211 result = pow (rvalue (x), rvalue (y));
4335 }
4336 4212
4337 /* Before returning integer result make sure we can. */ 4213 /* Before returning integer result make sure we can. */
4338 /* If the test fails, result is too big for integer. */ 4214 /* If the test fails, result is too big for integer. */
4339 if (!real_result) 4215 if (!real_result)
4340 { 4216 {
… …
4343 if (result != (RVALUE) result_as_long) 4219 if (result != (RVALUE) result_as_long)
4344 real_result = 1; 4220 real_result = 1;
4345 } 4221 }
4346 4222
4347 if (real_result) 4223 if (real_result)
4348 {
4349 s_return (mk_real (SCHEME_A_ result)); 4224 s_return (mk_real (SCHEME_A_ result));
4350 }
4351 else 4225 else
4352 {
4353 s_return (mk_integer (SCHEME_A_ result)); 4226 s_return (mk_integer (SCHEME_A_ result));
4354 }
4355 } 4227 }
4356 4228
4357 case OP_FLOOR: 4229 case OP_FLOOR:
4358 x = car (SCHEME_V->args); 4230 x = car (SCHEME_V->args);
4359 s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 4231 s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
… …
4368 4240
4369 x = car (SCHEME_V->args); 4241 x = car (SCHEME_V->args);
4370 rvalue_of_x = rvalue (x); 4242 rvalue_of_x = rvalue (x);
4371 4243
4372 if (rvalue_of_x > 0) 4244 if (rvalue_of_x > 0)
4373 {
4374 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); 4245 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4375 }
4376 else 4246 else
4377 {
4378 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x))); 4247 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4379 }
4380 } 4248 }
4381 4249
4382 case OP_ROUND: 4250 case OP_ROUND:
4383 x = car (SCHEME_V->args); 4251 x = car (SCHEME_V->args);
4384 4252
… …
4512 } 4380 }
4513 else 4381 else
4514 Error_0 ("set-cdr!: unable to alter immutable pair"); 4382 Error_0 ("set-cdr!: unable to alter immutable pair");
4515 4383
4516 case OP_CHAR2INT: /* char->integer */ 4384 case OP_CHAR2INT: /* char->integer */
4517 { 4385 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args))));
4518 char c;
4519
4520 c = (char) ivalue (car (SCHEME_V->args));
4521 s_return (mk_integer (SCHEME_A_ (unsigned char) c));
4522 }
4523 4386
4524 case OP_INT2CHAR: /* integer->char */ 4387 case OP_INT2CHAR: /* integer->char */
4525 {
4526 unsigned char c;
4527
4528 c = (unsigned char) ivalue (car (SCHEME_V->args));
4529 s_return (mk_character (SCHEME_A_ (char) c)); 4388 s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args))));
4530 }
4531 4389
4532 case OP_CHARUPCASE: 4390 case OP_CHARUPCASE:
4533 { 4391 {
4534 unsigned char c;
4535
4536 c = (unsigned char) ivalue (car (SCHEME_V->args)); 4392 unsigned char c = ivalue (car (SCHEME_V->args));
4537 c = toupper (c); 4393 c = toupper (c);
4538 s_return (mk_character (SCHEME_A_ (char) c)); 4394 s_return (mk_character (SCHEME_A_ c));
4539 } 4395 }
4540 4396
4541 case OP_CHARDNCASE: 4397 case OP_CHARDNCASE:
4542 { 4398 {
4543 unsigned char c;
4544
4545 c = (unsigned char) ivalue (car (SCHEME_V->args)); 4399 unsigned char c = ivalue (car (SCHEME_V->args));
4546 c = tolower (c); 4400 c = tolower (c);
4547 s_return (mk_character (SCHEME_A_ (char) c)); 4401 s_return (mk_character (SCHEME_A_ c));
4548 } 4402 }
4549 4403
4550 case OP_STR2SYM: /* string->symbol */ 4404 case OP_STR2SYM: /* string->symbol */
4551 s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); 4405 s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args))));
4552 4406
… …
4564 if (pf == 16 || pf == 10 || pf == 8 || pf == 2) 4418 if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4565 { 4419 {
4566 /* base is OK */ 4420 /* base is OK */
4567 } 4421 }
4568 else 4422 else
4569 {
4570 pf = -1; 4423 pf = -1;
4571 }
4572 } 4424 }
4573 4425
4574 if (pf < 0) 4426 if (pf < 0)
4575 {
4576 Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); 4427 Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args));
4577 }
4578 else if (*s == '#') /* no use of base! */ 4428 else if (*s == '#') /* no use of base! */
4579 {
4580 s_return (mk_sharp_const (SCHEME_A_ s + 1)); 4429 s_return (mk_sharp_const (SCHEME_A_ s + 1));
4581 }
4582 else 4430 else
4583 { 4431 {
4584 if (pf == 0 || pf == 10) 4432 if (pf == 0 || pf == 10)
4585 {
4586 s_return (mk_atom (SCHEME_A_ s)); 4433 s_return (mk_atom (SCHEME_A_ s));
4587 }
4588 else 4434 else
4589 { 4435 {
4590 char *ep; 4436 char *ep;
4591 long iv = strtol (s, &ep, (int) pf); 4437 long iv = strtol (s, &ep, (int) pf);
4592 4438
4593 if (*ep == 0) 4439 if (*ep == 0)
4594 {
4595 s_return (mk_integer (SCHEME_A_ iv)); 4440 s_return (mk_integer (SCHEME_A_ iv));
4596 }
4597 else 4441 else
4598 {
4599 s_return (S_F); 4442 s_return (S_F);
4600 }
4601 } 4443 }
4602 } 4444 }
4603 } 4445 }
4604 4446
4605 case OP_SYM2STR: /* symbol->string */ 4447 case OP_SYM2STR: /* symbol->string */
… …
4622 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) 4464 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4623 { 4465 {
4624 /* base is OK */ 4466 /* base is OK */
4625 } 4467 }
4626 else 4468 else
4627 {
4628 pf = -1; 4469 pf = -1;
4629 }
4630 } 4470 }
4631 4471
4632 if (pf < 0) 4472 if (pf < 0)
4633 {
4634 Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); 4473 Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args));
4635 }
4636 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) 4474 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4637 { 4475 {
4638 char *p; 4476 char *p;
4639 int len; 4477 int len;
4640 4478
4641 atom2str (SCHEME_A_ x, (int) pf, &p, &len); 4479 atom2str (SCHEME_A_ x, pf, &p, &len);
4642 s_return (mk_counted_string (SCHEME_A_ p, len)); 4480 s_return (mk_counted_string (SCHEME_A_ p, len));
4643 } 4481 }
4644 else 4482 else
4645 {
4646 Error_1 ("atom->string: not an atom:", x); 4483 Error_1 ("atom->string: not an atom:", x);
4647 }
4648 } 4484 }
4649 4485
4650 case OP_MKSTRING: /* make-string */ 4486 case OP_MKSTRING: /* make-string */
4651 { 4487 {
4652 int fill = ' '; 4488 int fill = ' ';
4653 int len; 4489 int len;
4654 4490
4655 len = ivalue (car (SCHEME_V->args)); 4491 len = ivalue (car (SCHEME_V->args));
4656 4492
4657 if (cdr (SCHEME_V->args) != NIL) 4493 if (cdr (SCHEME_V->args) != NIL)
4658 {
4659 fill = charvalue (cadr (SCHEME_V->args)); 4494 fill = charvalue (cadr (SCHEME_V->args));
4660 }
4661 4495
4662 s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); 4496 s_return (mk_empty_string (SCHEME_A_ len, (char) fill));
4663 } 4497 }
4664 4498
4665 case OP_STRLEN: /* string-length */ 4499 case OP_STRLEN: /* string-length */
… …
4673 str = strvalue (car (SCHEME_V->args)); 4507 str = strvalue (car (SCHEME_V->args));
4674 4508
4675 index = ivalue (cadr (SCHEME_V->args)); 4509 index = ivalue (cadr (SCHEME_V->args));
4676 4510
4677 if (index >= strlength (car (SCHEME_V->args))) 4511 if (index >= strlength (car (SCHEME_V->args)))
4678 {
4679 Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); 4512 Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args));
4680 }
4681 4513
4682 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); 4514 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index]));
4683 } 4515 }
4684 4516
4685 case OP_STRSET: /* string-set! */ 4517 case OP_STRSET: /* string-set! */
… …
4687 char *str; 4519 char *str;
4688 int index; 4520 int index;
4689 int c; 4521 int c;
4690 4522
4691 if (is_immutable (car (SCHEME_V->args))) 4523 if (is_immutable (car (SCHEME_V->args)))
4692 {
4693 Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); 4524 Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args));
4694 }
4695 4525
4696 str = strvalue (car (SCHEME_V->args)); 4526 str = strvalue (car (SCHEME_V->args));
4697 4527
4698 index = ivalue (cadr (SCHEME_V->args)); 4528 index = ivalue (cadr (SCHEME_V->args));
4699 4529
4700 if (index >= strlength (car (SCHEME_V->args))) 4530 if (index >= strlength (car (SCHEME_V->args)))
4701 {
4702 Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); 4531 Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args));
4703 }
4704 4532
4705 c = charvalue (caddr (SCHEME_V->args)); 4533 c = charvalue (caddr (SCHEME_V->args));
4706 4534
4707 str[index] = (char) c; 4535 str[index] = (char) c;
4708 s_return (car (SCHEME_V->args)); 4536 s_return (car (SCHEME_V->args));
… …
4715 pointer newstr; 4543 pointer newstr;
4716 char *pos; 4544 char *pos;
4717 4545
4718 /* compute needed length for new string */ 4546 /* compute needed length for new string */
4719 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4547 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4720 {
4721 len += strlength (car (x)); 4548 len += strlength (car (x));
4722 }
4723 4549
4724 newstr = mk_empty_string (SCHEME_A_ len, ' '); 4550 newstr = mk_empty_string (SCHEME_A_ len, ' ');
4725 4551
4726 /* store the contents of the argument strings into the new string */ 4552 /* store the contents of the argument strings into the new string */
4727 for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) 4553 for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4728 {
4729 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4554 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4730 }
4731 4555
4732 s_return (newstr); 4556 s_return (newstr);
4733 } 4557 }
4734 4558
4735 case OP_SUBSTR: /* substring */ 4559 case OP_SUBSTR: /* substring */
… …
4742 str = strvalue (car (SCHEME_V->args)); 4566 str = strvalue (car (SCHEME_V->args));
4743 4567
4744 index0 = ivalue (cadr (SCHEME_V->args)); 4568 index0 = ivalue (cadr (SCHEME_V->args));
4745 4569
4746 if (index0 > strlength (car (SCHEME_V->args))) 4570 if (index0 > strlength (car (SCHEME_V->args)))
4747 {
4748 Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); 4571 Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args));
4749 }
4750 4572
4751 if (cddr (SCHEME_V->args) != NIL) 4573 if (cddr (SCHEME_V->args) != NIL)
4752 { 4574 {
4753 index1 = ivalue (caddr (SCHEME_V->args)); 4575 index1 = ivalue (caddr (SCHEME_V->args));
4754 4576
4755 if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) 4577 if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0)
4756 {
4757 Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); 4578 Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args));
4758 }
4759 } 4579 }
4760 else 4580 else
4761 {
4762 index1 = strlength (car (SCHEME_V->args)); 4581 index1 = strlength (car (SCHEME_V->args));
4763 }
4764 4582
4765 len = index1 - index0; 4583 len = index1 - index0;
4766 x = mk_empty_string (SCHEME_A_ len, ' '); 4584 x = mk_empty_string (SCHEME_A_ len, ' ');
4767 memcpy (strvalue (x), str + index0, len); 4585 memcpy (strvalue (x), str + index0, len);
4768 strvalue (x)[len] = 0; 4586 strvalue (x)[len] = 0;
… …
4775 int i; 4593 int i;
4776 pointer vec; 4594 pointer vec;
4777 int len = list_length (SCHEME_A_ SCHEME_V->args); 4595 int len = list_length (SCHEME_A_ SCHEME_V->args);
4778 4596
4779 if (len < 0) 4597 if (len < 0)
4780 {
4781 Error_1 ("vector: not a proper list:", SCHEME_V->args); 4598 Error_1 ("vector: not a proper list:", SCHEME_V->args);
4782 }
4783 4599
4784 vec = mk_vector (SCHEME_A_ len); 4600 vec = mk_vector (SCHEME_A_ len);
4785 4601
4786#if USE_ERROR_CHECKING 4602#if USE_ERROR_CHECKING
4787 if (SCHEME_V->no_memory) 4603 if (SCHEME_V->no_memory)
… …
4826 int index; 4642 int index;
4827 4643
4828 index = ivalue (cadr (SCHEME_V->args)); 4644 index = ivalue (cadr (SCHEME_V->args));
4829 4645
4830 if (index >= ivalue (car (SCHEME_V->args))) 4646 if (index >= ivalue (car (SCHEME_V->args)))
4831 {
4832 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4647 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4833 }
4834 4648
4835 s_return (vector_elem (car (SCHEME_V->args), index)); 4649 s_return (vector_elem (car (SCHEME_V->args), index));
4836 } 4650 }
4837 4651
4838 case OP_VECSET: /* vector-set! */ 4652 case OP_VECSET: /* vector-set! */
4839 { 4653 {
4840 int index; 4654 int index;
4841 4655
4842 if (is_immutable (car (SCHEME_V->args))) 4656 if (is_immutable (car (SCHEME_V->args)))
4843 {
4844 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4657 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4845 }
4846 4658
4847 index = ivalue (cadr (SCHEME_V->args)); 4659 index = ivalue (cadr (SCHEME_V->args));
4848 4660
4849 if (index >= ivalue (car (SCHEME_V->args))) 4661 if (index >= ivalue (car (SCHEME_V->args)))
4850 {
4851 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4662 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4852 }
4853 4663
4854 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4664 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4855 s_return (car (SCHEME_V->args)); 4665 s_return (car (SCHEME_V->args));
4856 } 4666 }
4857 } 4667 }
… …
4967 x = cdr (x); 4777 x = cdr (x);
4968 4778
4969 for (; x != NIL; x = cdr (x)) 4779 for (; x != NIL; x = cdr (x))
4970 { 4780 {
4971 if (!comp_func (v, nvalue (car (x)))) 4781 if (!comp_func (v, nvalue (car (x))))
4972 {
4973 s_retbool (0); 4782 s_retbool (0);
4974 }
4975 4783
4976 v = nvalue (car (x)); 4784 v = nvalue (car (x));
4977 } 4785 }
4978 4786
4979 s_retbool (1); 4787 s_retbool (1);
… …
5072 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code); 4880 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
5073 SCHEME_V->args = NIL; 4881 SCHEME_V->args = NIL;
5074 s_goto (OP_APPLY); 4882 s_goto (OP_APPLY);
5075 } 4883 }
5076 else 4884 else
5077 {
5078 s_return (SCHEME_V->code); 4885 s_return (SCHEME_V->code);
5079 }
5080 4886
5081 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4887 case OP_SAVE_FORCED: /* Save forced value replacing promise */
5082 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4888 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));
5083 s_return (SCHEME_V->value); 4889 s_return (SCHEME_V->value);
5084 4890
… …
5148 else 4954 else
5149 { 4955 {
5150 putstr (SCHEME_A_ "\n"); 4956 putstr (SCHEME_A_ "\n");
5151 4957
5152 if (SCHEME_V->interactive_repl) 4958 if (SCHEME_V->interactive_repl)
5153 {
5154 s_goto (OP_T0LVL); 4959 s_goto (OP_T0LVL);
5155 }
5156 else 4960 else
5157 {
5158 return NIL; 4961 return NIL;
5159 }
5160 } 4962 }
5161 4963
5162 case OP_REVERSE: /* reverse */ 4964 case OP_REVERSE: /* reverse */
5163 s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); 4965 s_return (reverse (SCHEME_A_ car (SCHEME_V->args)));
5164 4966
… …
5187 4989
5188#if USE_PLIST 4990#if USE_PLIST
5189 4991
5190 case OP_PUT: /* put */ 4992 case OP_PUT: /* put */
5191 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4993 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args)))
5192 {
5193 Error_0 ("illegal use of put"); 4994 Error_0 ("illegal use of put");
5194 }
5195 4995
5196 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4996 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x))
5197 { 4997 {
5198 if (caar (x) == y) 4998 if (caar (x) == y)
5199 {
5200 break; 4999 break;
5201 }
5202 } 5000 }
5203 5001
5204 if (x != NIL) 5002 if (x != NIL)
5205 cdar (x) = caddr (SCHEME_V->args); 5003 cdar (x) = caddr (SCHEME_V->args);
5206 else 5004 else
… …
5283 } 5081 }
5284 5082
5285 p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); 5083 p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop);
5286 5084
5287 if (p == NIL) 5085 if (p == NIL)
5288 {
5289 s_return (S_F); 5086 s_return (S_F);
5290 }
5291 5087
5292 s_return (p); 5088 s_return (p);
5293 } 5089 }
5294 5090
5295# if USE_STRING_PORTS 5091# if USE_STRING_PORTS
… …
5313 5109
5314 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 5110 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)),
5315 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); 5111 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop);
5316 5112
5317 if (p == NIL) 5113 if (p == NIL)
5318 {
5319 s_return (S_F); 5114 s_return (S_F);
5320 }
5321 5115
5322 s_return (p); 5116 s_return (p);
5323 } 5117 }
5324 5118
5325 case OP_OPEN_OUTSTRING: /* open-output-string */ 5119 case OP_OPEN_OUTSTRING: /* open-output-string */
… …
5329 if (car (SCHEME_V->args) == NIL) 5123 if (car (SCHEME_V->args) == NIL)
5330 { 5124 {
5331 p = port_from_scratch (SCHEME_A); 5125 p = port_from_scratch (SCHEME_A);
5332 5126
5333 if (p == NIL) 5127 if (p == NIL)
5334 {
5335 s_return (S_F); 5128 s_return (S_F);
5336 }
5337 } 5129 }
5338 else 5130 else
5339 { 5131 {
5340 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 5132 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)),
5341 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); 5133 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output);
5342 5134
5343 if (p == NIL) 5135 if (p == NIL)
5344 {
5345 s_return (S_F); 5136 s_return (S_F);
5346 }
5347 } 5137 }
5348 5138
5349 s_return (p); 5139 s_return (p);
5350 } 5140 }
5351 5141
… …
5416 { 5206 {
5417 /* ========== reading part ========== */ 5207 /* ========== reading part ========== */
5418#if USE_PORTS 5208#if USE_PORTS
5419 case OP_READ: 5209 case OP_READ:
5420 if (!is_pair (SCHEME_V->args)) 5210 if (!is_pair (SCHEME_V->args))
5421 {
5422 s_goto (OP_READ_INTERNAL); 5211 s_goto (OP_READ_INTERNAL);
5423 }
5424 5212
5425 if (!is_inport (car (SCHEME_V->args))) 5213 if (!is_inport (car (SCHEME_V->args)))
5426 {
5427 Error_1 ("read: not an input port:", car (SCHEME_V->args)); 5214 Error_1 ("read: not an input port:", car (SCHEME_V->args));
5428 }
5429 5215
5430 if (car (SCHEME_V->args) == SCHEME_V->inport) 5216 if (car (SCHEME_V->args) == SCHEME_V->inport)
5431 {
5432 s_goto (OP_READ_INTERNAL); 5217 s_goto (OP_READ_INTERNAL);
5433 }
5434 5218
5435 x = SCHEME_V->inport; 5219 x = SCHEME_V->inport;
5436 SCHEME_V->inport = car (SCHEME_V->args); 5220 SCHEME_V->inport = car (SCHEME_V->args);
5437 x = cons (x, NIL); 5221 x = cons (x, NIL);
5438 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 5222 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
… …
5469 { 5253 {
5470 pointer p = SCHEME_V->inport; 5254 pointer p = SCHEME_V->inport;
5471 int res; 5255 int res;
5472 5256
5473 if (is_pair (SCHEME_V->args)) 5257 if (is_pair (SCHEME_V->args))
5474 {
5475 p = car (SCHEME_V->args); 5258 p = car (SCHEME_V->args);
5476 }
5477 5259
5478 res = p->object.port->kind & port_string; 5260 res = p->object.port->kind & port_string;
5479 5261
5480 s_retbool (res); 5262 s_retbool (res);
5481 } 5263 }
… …
5496 s_return (S_EOF); 5278 s_return (S_EOF);
5497 /* NOTREACHED */ 5279 /* NOTREACHED */
5498 5280
5499 case TOK_VEC: 5281 case TOK_VEC:
5500 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5282 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5501
5502 /* fall through */ 5283 /* fall through */
5284
5503 case TOK_LPAREN: 5285 case TOK_LPAREN:
5504 SCHEME_V->tok = token (SCHEME_A); 5286 SCHEME_V->tok = token (SCHEME_A);
5505 5287
5506 if (SCHEME_V->tok == TOK_RPAREN) 5288 if (SCHEME_V->tok == TOK_RPAREN)
5507 s_return (NIL); 5289 s_return (NIL);
… …
5527 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5309 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5528 SCHEME_V->tok = TOK_LPAREN; 5310 SCHEME_V->tok = TOK_LPAREN;
5529 s_goto (OP_RDSEXPR); 5311 s_goto (OP_RDSEXPR);
5530 } 5312 }
5531 else 5313 else
5532 {
5533 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5314 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5534 }
5535 5315
5536 s_goto (OP_RDSEXPR); 5316 s_goto (OP_RDSEXPR);
5537 5317
5538 case TOK_COMMA: 5318 case TOK_COMMA:
5539 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5319 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
… …
5581 } 5361 }
5582 5362
5583 break; 5363 break;
5584 5364
5585 case OP_RDLIST: 5365 case OP_RDLIST:
5586 {
5587 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 5366 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);
5588 SCHEME_V->tok = token (SCHEME_A); 5367 SCHEME_V->tok = token (SCHEME_A);
5589 5368
5590 if (SCHEME_V->tok == TOK_EOF) 5369 switch (SCHEME_V->tok)
5370 {
5371 case TOK_EOF:
5591 s_return (S_EOF); 5372 s_return (S_EOF);
5592 else if (SCHEME_V->tok == TOK_RPAREN) 5373
5374 case TOK_RPAREN:
5593 { 5375 {
5594 int c = inchar (SCHEME_A); 5376 int c = inchar (SCHEME_A);
5595 5377
5596 if (c != '\n') 5378 if (c != '\n')
5597 backchar (SCHEME_A_ c); 5379 backchar (SCHEME_A_ c);
5598
5599#if SHOW_ERROR_LINE 5380#if SHOW_ERROR_LINE
5600 else if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 5381 else if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
5601 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++; 5382 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;
5602
5603#endif 5383#endif
5384
5604 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5385 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5605 s_return (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args)); 5386 s_return (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args));
5606 } 5387 }
5607 else if (SCHEME_V->tok == TOK_DOT) 5388
5608 { 5389 case TOK_DOT:
5609 s_save (SCHEME_A_ OP_RDDOT, SCHEME_V->args, NIL); 5390 s_save (SCHEME_A_ OP_RDDOT, SCHEME_V->args, NIL);
5610 SCHEME_V->tok = token (SCHEME_A); 5391 SCHEME_V->tok = token (SCHEME_A);
5611 s_goto (OP_RDSEXPR); 5392 s_goto (OP_RDSEXPR);
5612 } 5393
5613 else 5394 default:
5614 {
5615 s_save (SCHEME_A_ OP_RDLIST, SCHEME_V->args, NIL);; 5395 s_save (SCHEME_A_ OP_RDLIST, SCHEME_V->args, NIL);
5616 s_goto (OP_RDSEXPR); 5396 s_goto (OP_RDSEXPR);
5617 } 5397 }
5618 }
5619 5398
5620 case OP_RDDOT: 5399 case OP_RDDOT:
5621 if (token (SCHEME_A) != TOK_RPAREN) 5400 if (token (SCHEME_A) != TOK_RPAREN)
5622 Error_0 ("syntax error: illegal dot expression"); 5401 Error_0 ("syntax error: illegal dot expression");
5623 else 5402
5624 {
5625 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5403 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5626 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); 5404 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args));
5627 }
5628 5405
5629 case OP_RDQUOTE: 5406 case OP_RDQUOTE:
5630 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); 5407 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5631 5408
5632 case OP_RDQQUOTE: 5409 case OP_RDQQUOTE:
… …
5898{ 5675{
5899 int n = procnum (x); 5676 int n = procnum (x);
5900 const char *name = dispatch_table[n].name; 5677 const char *name = dispatch_table[n].name;
5901 5678
5902 if (name == 0) 5679 if (name == 0)
5903 {
5904 name = "ILLEGAL!"; 5680 name = "ILLEGAL!";
5905 }
5906 5681
5907 return name; 5682 return name;
5908} 5683}
5909 5684
5910/* kernel of this interpreter */ 5685/* kernel of this interpreter */
… …
5915 5690
5916 for (;;) 5691 for (;;)
5917 { 5692 {
5918 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5693 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5919 5694
5920 if (pcd->name != 0) /* if built-in function, check arguments */ 5695 if (pcd->name) /* if built-in function, check arguments */
5921 { 5696 {
5697#if USE_ERROR_CHECKING
5922 char msg[STRBUFFSIZE]; 5698 char msg[STRBUFFSIZE];
5923 int ok = 1; 5699 int ok = 1;
5924 int n = list_length (SCHEME_A_ SCHEME_V->args); 5700 int n = list_length (SCHEME_A_ SCHEME_V->args);
5925 5701
5926#if USE_ERROR_CHECKING
5927 /* Check number of arguments */ 5702 /* Check number of arguments */
5928 if (n < pcd->min_arity) 5703 if (n < pcd->min_arity)
5929 { 5704 {
5930 ok = 0; 5705 ok = 0;
5931 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5706 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
… …
5940 } 5715 }
5941#endif 5716#endif
5942 5717
5943 if (ok) 5718 if (ok)
5944 { 5719 {
5945 if (pcd->arg_tests_encoding != 0) 5720 if (pcd->arg_tests_encoding && USE_ERROR_CHECKING)
5946 { 5721 {
5947 int i = 0; 5722 int i = 0;
5948 int j; 5723 int j;
5949 const char *t = pcd->arg_tests_encoding; 5724 const char *t = pcd->arg_tests_encoding;
5950 pointer arglist = SCHEME_V->args; 5725 pointer arglist = SCHEME_V->args;
… …
5965 if (!tests[j].fct (arg)) 5740 if (!tests[j].fct (arg))
5966 break; 5741 break;
5967 } 5742 }
5968 5743
5969 if (t[1] != 0) /* last test is replicated as necessary */ 5744 if (t[1] != 0) /* last test is replicated as necessary */
5970 {
5971 t++; 5745 t++;
5972 }
5973 5746
5974 arglist = cdr (arglist); 5747 arglist = cdr (arglist);
5975 i++; 5748 i++;
5976 } 5749 }
5977 while (i < n); 5750 while (i < n);
5978 5751
5979#if USE_ERROR_CHECKING
5980 if (i < n) 5752 if (i < n)
5981 { 5753 {
5982 ok = 0; 5754 ok = 0;
5983 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); 5755 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);
5984 } 5756 }
5985#endif
5986 } 5757 }
5987 } 5758 }
5988 5759
5989 if (!ok) 5760 if (!ok)
5990 { 5761 {
… …
5995 } 5766 }
5996 } 5767 }
5997 5768
5998 ok_to_freely_gc (SCHEME_A); 5769 ok_to_freely_gc (SCHEME_A);
5999 5770
6000 if (pcd->func (SCHEME_A_ (enum scheme_opcodes) SCHEME_V->op) == NIL) 5771 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)
6001 return; 5772 return;
6002 5773
6003#if USE_ERROR_CHECKING 5774#if USE_ERROR_CHECKING
6004 if (SCHEME_V->no_memory) 5775 if (SCHEME_V->no_memory)
6005 { 5776 {
… …
6011} 5782}
6012 5783
6013/* ========== Initialization of internal keywords ========== */ 5784/* ========== Initialization of internal keywords ========== */
6014 5785
6015static void 5786static void
6016assign_syntax (SCHEME_P_ char *name) 5787assign_syntax (SCHEME_P_ const char *name)
6017{ 5788{
6018 pointer x = oblist_add_by_name (SCHEME_A_ name); 5789 pointer x = oblist_add_by_name (SCHEME_A_ name);
6019 set_typeflag (x, typeflag (x) | T_SYNTAX); 5790 set_typeflag (x, typeflag (x) | T_SYNTAX);
6020} 5791}
6021 5792
6022static void 5793static void
6023assign_proc (SCHEME_P_ enum scheme_opcodes op, char *name) 5794assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
6024{ 5795{
6025 pointer x = mk_symbol (SCHEME_A_ name); 5796 pointer x = mk_symbol (SCHEME_A_ name);
6026 pointer y = mk_proc (SCHEME_A_ op); 5797 pointer y = mk_proc (SCHEME_A_ op);
6027 new_slot_in_env (SCHEME_A_ x, y); 5798 new_slot_in_env (SCHEME_A_ x, y);
6028} 5799}
… …
6030static pointer 5801static pointer
6031mk_proc (SCHEME_P_ enum scheme_opcodes op) 5802mk_proc (SCHEME_P_ enum scheme_opcodes op)
6032{ 5803{
6033 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5804 pointer y = get_cell (SCHEME_A_ NIL, NIL);
6034 set_typeflag (y, (T_PROC | T_ATOM)); 5805 set_typeflag (y, (T_PROC | T_ATOM));
6035 ivalue_unchecked (y) = (long) op; 5806 ivalue_unchecked (y) = op;
6036 set_num_integer (y); 5807 set_num_integer (y);
6037 return y; 5808 return y;
6038} 5809}
6039 5810
6040/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5811/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
… …
6158 } 5929 }
6159 5930
6160 SCHEME_V->gc_verbose = 0; 5931 SCHEME_V->gc_verbose = 0;
6161 dump_stack_initialize (SCHEME_A); 5932 dump_stack_initialize (SCHEME_A);
6162 SCHEME_V->code = NIL; 5933 SCHEME_V->code = NIL;
5934 SCHEME_V->args = NIL;
5935 SCHEME_V->envir = NIL;
6163 SCHEME_V->tracing = 0; 5936 SCHEME_V->tracing = 0;
6164 5937
6165 /* init NIL */ 5938 /* init NIL */
6166 set_typeflag (NIL, T_ATOM | MARK); 5939 set_typeflag (NIL, T_ATOM | T_MARK);
6167 set_car (NIL, NIL); 5940 set_car (NIL, NIL);
6168 set_cdr (NIL, NIL); 5941 set_cdr (NIL, NIL);
6169 /* init T */ 5942 /* init T */
6170 set_typeflag (S_T, T_ATOM | MARK); 5943 set_typeflag (S_T, T_ATOM | T_MARK);
6171 set_car (S_T, S_T); 5944 set_car (S_T, S_T);
6172 set_cdr (S_T, S_T); 5945 set_cdr (S_T, S_T);
6173 /* init F */ 5946 /* init F */
6174 set_typeflag (S_F, T_ATOM | MARK); 5947 set_typeflag (S_F, T_ATOM | T_MARK);
6175 set_car (S_F, S_F); 5948 set_car (S_F, S_F);
6176 set_cdr (S_F, S_F); 5949 set_cdr (S_F, S_F);
6177 /* init sink */ 5950 /* init sink */
6178 set_typeflag (S_SINK, T_PAIR | MARK); 5951 set_typeflag (S_SINK, T_PAIR | T_MARK);
6179 set_car (S_SINK, NIL); 5952 set_car (S_SINK, NIL);
6180 /* init c_nest */ 5953 /* init c_nest */
6181 SCHEME_V->c_nest = NIL; 5954 SCHEME_V->c_nest = NIL;
6182 5955
6183 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5956 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
… …
6186 SCHEME_V->global_env = SCHEME_V->envir; 5959 SCHEME_V->global_env = SCHEME_V->envir;
6187 /* init else */ 5960 /* init else */
6188 x = mk_symbol (SCHEME_A_ "else"); 5961 x = mk_symbol (SCHEME_A_ "else");
6189 new_slot_in_env (SCHEME_A_ x, S_T); 5962 new_slot_in_env (SCHEME_A_ x, S_T);
6190 5963
6191 assign_syntax (SCHEME_A_ "lambda"); 5964 {
6192 assign_syntax (SCHEME_A_ "quote"); 5965 static const char *syntax_names[] = {
6193 assign_syntax (SCHEME_A_ "define"); 5966 "lambda", "quote", "define", "if", "begin", "set!",
6194 assign_syntax (SCHEME_A_ "if"); 5967 "let", "let*", "letrec", "cond", "delay", "and",
6195 assign_syntax (SCHEME_A_ "begin"); 5968 "or", "cons-stream", "macro", "case"
6196 assign_syntax (SCHEME_A_ "set!"); 5969 };
6197 assign_syntax (SCHEME_A_ "let"); 5970
6198 assign_syntax (SCHEME_A_ "let*"); 5971 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
6199 assign_syntax (SCHEME_A_ "letrec");
6200 assign_syntax (SCHEME_A_ "cond");
6201 assign_syntax (SCHEME_A_ "delay");
6202 assign_syntax (SCHEME_A_ "and"); 5972 assign_syntax (SCHEME_A_ syntax_names[i]);
6203 assign_syntax (SCHEME_A_ "or"); 5973 }
6204 assign_syntax (SCHEME_A_ "cons-stream");
6205 assign_syntax (SCHEME_A_ "macro");
6206 assign_syntax (SCHEME_A_ "case");
6207 5974
6208 for (i = 0; i < n; i++) 5975 for (i = 0; i < n; i++)
6209 {
6210 if (dispatch_table[i].name != 0) 5976 if (dispatch_table[i].name != 0)
6211 {
6212 assign_proc (SCHEME_A_ (enum scheme_opcodes) i, dispatch_table[i].name); 5977 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
6213 }
6214 }
6215 5978
6216 /* initialization of global pointers to special symbols */ 5979 /* initialization of global pointers to special symbols */
6217 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5980 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
6218 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5981 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
6219 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5982 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
… …
6385 pointer x; 6148 pointer x;
6386 6149
6387 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6150 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
6388 6151
6389 if (x != NIL) 6152 if (x != NIL)
6390 {
6391 set_slot_in_env (SCHEME_A_ x, value); 6153 set_slot_in_env (SCHEME_A_ x, value);
6392 }
6393 else 6154 else
6394 {
6395 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6155 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
6396 }
6397} 6156}
6398 6157
6399#if !STANDALONE 6158#if !STANDALONE
6159
6400void 6160void
6401scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6161scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
6402{ 6162{
6403 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6163 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
6404} 6164}
… …
6407scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6167scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
6408{ 6168{
6409 int i; 6169 int i;
6410 6170
6411 for (i = 0; i < count; i++) 6171 for (i = 0; i < count; i++)
6412 {
6413 scheme_register_foreign_func (SCHEME_A_ list + i); 6172 scheme_register_foreign_func (SCHEME_A_ list + i);
6414 }
6415} 6173}
6416 6174
6417pointer 6175pointer
6418scheme_apply0 (SCHEME_P_ const char *procname) 6176scheme_apply0 (SCHEME_P_ const char *procname)
6419{ 6177{
… …
6476 SCHEME_V->interactive_repl = old_repl; 6234 SCHEME_V->interactive_repl = old_repl;
6477 restore_from_C_call (SCHEME_A); 6235 restore_from_C_call (SCHEME_A);
6478 return SCHEME_V->value; 6236 return SCHEME_V->value;
6479} 6237}
6480 6238
6481
6482#endif 6239#endif
6483 6240
6484/* ========== Main ========== */ 6241/* ========== Main ========== */
6485 6242
6486#if STANDALONE 6243#if STANDALONE
… …
6505main (int argc, char **argv) 6262main (int argc, char **argv)
6506{ 6263{
6507# endif 6264# endif
6508# if USE_MULTIPLICITY 6265# if USE_MULTIPLICITY
6509 scheme ssc; 6266 scheme ssc;
6510 scheme *const sc = &ssc; 6267 scheme *const SCHEME_V = &ssc;
6511# else 6268# else
6512# endif 6269# endif
6513 int fin; 6270 int fin;
6514 char *file_name = InitFile; 6271 char *file_name = InitFile;
6515 int retcode; 6272 int retcode;
6516 int isfile = 1; 6273 int isfile = 1;
6517
6518 if (argc == 1)
6519 xwrstr (banner);
6520 6274
6521 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6275 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6522 { 6276 {
6523 xwrstr ("Usage: tinyscheme -?\n"); 6277 xwrstr ("Usage: tinyscheme -?\n");
6524 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6278 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");
… …
6547 if (access (file_name, 0) != 0) 6301 if (access (file_name, 0) != 0)
6548 { 6302 {
6549 char *p = getenv ("TINYSCHEMEINIT"); 6303 char *p = getenv ("TINYSCHEMEINIT");
6550 6304
6551 if (p != 0) 6305 if (p != 0)
6552 {
6553 file_name = p; 6306 file_name = p;
6554 }
6555 } 6307 }
6556#endif 6308#endif
6557 6309
6558 do 6310 do
6559 { 6311 {

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines