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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.3 by root, Wed Nov 25 10:30:34 2015 UTC vs.
Revision 1.7 by root, Wed Nov 25 22:12:59 2015 UTC

1 1/*
2/* T I N Y S C H E M E 1 . 4 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)
3 * Dimitrios Souflis (dsouflis@acm.org) 8 * Dimitrios Souflis (dsouflis@acm.org)
4 * Based on MiniScheme (original credits follow) 9 * Based on MiniScheme (original credits follow)
5 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) 10 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
6 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 11 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
7 * (MINISCM) This version has been modified by R.C. Secrist. 12 * (MINISCM) This version has been modified by R.C. Secrist.
… …
128 c += 'a' - 'A'; 133 c += 'a' - 'A';
129 134
130 return c; 135 return c;
131} 136}
132 137
138static int
139xisdigit (char c)
140{
141 return c >= '0' && c <= '9';
142}
143
144#define toupper(c) xtoupper (c)
145#define tolower(c) xtolower (c)
146#define isdigit(c) xisdigit (c)
147
133#if USE_STRLWR 148#if USE_STRLWR
134static const char * 149static const char *
135strlwr (char *s) 150strlwr (char *s)
136{ 151{
137 const char *p = s; 152 const char *p = s;
… …
146} 161}
147#endif 162#endif
148 163
149#define stricmp(a,b) strcmp (a, b) 164#define stricmp(a,b) strcmp (a, b)
150#define strlwr(s) (s) 165#define strlwr(s) (s)
151#define toupper(c) xtoupper(c)
152#define tolower(c) xtolower(c)
153 166
154#ifndef prompt 167#ifndef prompt
155# define prompt "ts> " 168# define prompt "ts> "
156#endif 169#endif
157 170
… …
236is_vector (pointer p) 249is_vector (pointer p)
237{ 250{
238 return type (p) == T_VECTOR; 251 return type (p) == T_VECTOR;
239} 252}
240 253
254#define vecvalue(p) ((p)->object.vector.vvalue)
255#define veclength(p) ((p)->object.vector.length)
241INTERFACE void fill_vector (pointer vec, pointer obj); 256INTERFACE void fill_vector (pointer vec, pointer obj);
242INTERFACE uint32_t vector_length (pointer vec); 257INTERFACE uint32_t vector_length (pointer vec);
243INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 258INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 259INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245 260
… …
314{ 329{
315 return num_get_rvalue (p->object.number); 330 return num_get_rvalue (p->object.number);
316} 331}
317 332
318#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 333#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319#if USE_FLOAT 334#if USE_REAL
320# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 335# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321# define set_num_integer(p) (p)->object.number.is_fixnum=1; 336# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322# define set_num_real(p) (p)->object.number.is_fixnum=0; 337# define set_num_real(p) (p)->object.number.is_fixnum=0;
323#else 338#else
324# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 339# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
… …
486 return type (p) == T_ENVIRONMENT; 501 return type (p) == T_ENVIRONMENT;
487} 502}
488 503
489#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 504#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490 505
491#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492#define is_atom(p) (typeflag (p) & T_ATOM) 506#define is_atom(p) (typeflag (p) & T_ATOM)
493#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 507#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
494#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 508#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495 509
496#define is_mark(p) (typeflag (p) & T_MARK) 510#define is_mark(p) (typeflag (p) & T_MARK)
497#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 511#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
498#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 512#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
499
500#if 0
501static int
502is_atom(pointer p)
503{
504 if (!is_atom1(p) != !is_atom2(p))
505 printf ("atoms disagree %x\n", typeflag(p));
506
507 return is_atom2(p);
508}
509#endif
510 513
511INTERFACE INLINE int 514INTERFACE INLINE int
512is_immutable (pointer p) 515is_immutable (pointer p)
513{ 516{
514 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 517 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
875#endif 878#endif
876 879
877static int 880static int
878is_zero_rvalue (RVALUE x) 881is_zero_rvalue (RVALUE x)
879{ 882{
880#if USE_FLOAT 883#if USE_REAL
881 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 884 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
882#else 885#else
883 return x == 0; 886 return x == 0;
884#endif 887#endif
885} 888}
… …
1132 1135
1133 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1136 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134 set_typeflag (x, T_SYMBOL); 1137 set_typeflag (x, T_SYMBOL);
1135 setimmutable (car (x)); 1138 setimmutable (car (x));
1136 1139
1137 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1140 location = hash_fn (name, veclength (SCHEME_V->oblist));
1138 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1141 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1139 return x; 1142 return x;
1140} 1143}
1141 1144
1142static INLINE pointer 1145static INLINE pointer
… …
1144{ 1147{
1145 int location; 1148 int location;
1146 pointer x; 1149 pointer x;
1147 char *s; 1150 char *s;
1148 1151
1149 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1152 location = hash_fn (name, veclength (SCHEME_V->oblist));
1150 1153
1151 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1154 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1152 { 1155 {
1153 s = symname (car (x)); 1156 s = symname (car (x));
1154 1157
… …
1165{ 1168{
1166 int i; 1169 int i;
1167 pointer x; 1170 pointer x;
1168 pointer ob_list = NIL; 1171 pointer ob_list = NIL;
1169 1172
1170 for (i = 0; i < vector_length (SCHEME_V->oblist); i++) 1173 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1174 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1172 ob_list = cons (x, ob_list); 1175 ob_list = cons (x, ob_list);
1173 1176
1174 return ob_list; 1177 return ob_list;
1175} 1178}
… …
1358fill_vector (pointer vec, pointer obj) 1361fill_vector (pointer vec, pointer obj)
1359{ 1362{
1360 int i; 1363 int i;
1361 1364
1362 for (i = 0; i < vec->object.vector.length; i++) 1365 for (i = 0; i < vec->object.vector.length; i++)
1363 vec->object.vector.vvalue[i] = obj; 1366 vecvalue (vec)[i] = obj;
1364} 1367}
1365 1368
1366INTERFACE pointer 1369INTERFACE pointer
1367vector_elem (pointer vec, uint32_t ielem) 1370vector_elem (pointer vec, uint32_t ielem)
1368{ 1371{
1369 return vec->object.vector.vvalue[ielem]; 1372 return vecvalue(vec)[ielem];
1370} 1373}
1371 1374
1372INTERFACE void 1375INTERFACE void
1373set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1376set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374{ 1377{
1375 vec->object.vector.vvalue[ielem] = a; 1378 vecvalue(vec)[ielem] = a;
1376} 1379}
1377 1380
1378/* get new symbol */ 1381/* get new symbol */
1379INTERFACE pointer 1382INTERFACE pointer
1380mk_symbol (SCHEME_P_ const char *name) 1383mk_symbol (SCHEME_P_ const char *name)
… …
1488 1491
1489 return mk_symbol (SCHEME_A_ strlwr (q)); 1492 return mk_symbol (SCHEME_A_ strlwr (q));
1490 } 1493 }
1491 } 1494 }
1492 1495
1493#if USE_FLOAT 1496#if USE_REAL
1494 if (has_dec_point) 1497 if (has_dec_point)
1495 return mk_real (SCHEME_A_ atof (q)); 1498 return mk_real (SCHEME_A_ atof (q));
1496#endif 1499#endif
1497 1500
1498 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1501 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
… …
1588 if (is_vector (p)) 1591 if (is_vector (p))
1589 { 1592 {
1590 int i; 1593 int i;
1591 1594
1592 for (i = 0; i < p->object.vector.length; i++) 1595 for (i = 0; i < p->object.vector.length; i++)
1593 mark (p->object.vector.vvalue[i]); 1596 mark (vecvalue (p)[i]);
1594 } 1597 }
1595 1598
1596 if (is_atom (p)) 1599 if (is_atom (p))
1597 goto E6; 1600 goto E6;
1598 1601
… …
1719finalize_cell (SCHEME_P_ pointer a) 1722finalize_cell (SCHEME_P_ pointer a)
1720{ 1723{
1721 if (is_string (a)) 1724 if (is_string (a))
1722 free (strvalue (a)); 1725 free (strvalue (a));
1723 else if (is_vector (a)) 1726 else if (is_vector (a))
1724 free (a->object.vector.vvalue); 1727 free (vecvalue (a));
1725#if USE_PORTS 1728#if USE_PORTS
1726 else if (is_port (a)) 1729 else if (is_port (a))
1727 { 1730 {
1728 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1731 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729 port_close (SCHEME_A_ a, port_input | port_output); 1732 port_close (SCHEME_A_ a, port_input | port_output);
… …
2556 2559
2557 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2560 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2558 { 2561 {
2559 if (num_is_integer (l)) 2562 if (num_is_integer (l))
2560 xnum (p, ivalue_unchecked (l)); 2563 xnum (p, ivalue_unchecked (l));
2561#if USE_FLOAT 2564#if USE_REAL
2562 else 2565 else
2563 { 2566 {
2564 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2567 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565 /* r5rs says there must be a '.' (unless 'e'?) */ 2568 /* r5rs says there must be a '.' (unless 'e'?) */
2566 f = strcspn (p, ".e"); 2569 f = strcspn (p, ".e");
… …
2904{ 2907{
2905 pointer slot = immutable_cons (variable, value); 2908 pointer slot = immutable_cons (variable, value);
2906 2909
2907 if (is_vector (car (env))) 2910 if (is_vector (car (env)))
2908 { 2911 {
2909 int location = hash_fn (symname (variable), vector_length (car (env))); 2912 int location = hash_fn (symname (variable), veclength (car (env)));
2910 2913
2911 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2914 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2912 } 2915 }
2913 else 2916 else
2914 set_car (env, immutable_cons (slot, car (env))); 2917 set_car (env, immutable_cons (slot, car (env)));
… …
2922 2925
2923 for (x = env; x != NIL; x = cdr (x)) 2926 for (x = env; x != NIL; x = cdr (x))
2924 { 2927 {
2925 if (is_vector (car (x))) 2928 if (is_vector (car (x)))
2926 { 2929 {
2927 location = hash_fn (symname (hdl), vector_length (car (x))); 2930 location = hash_fn (symname (hdl), veclength (car (x)));
2928 y = vector_elem (car (x), location); 2931 y = vector_elem (car (x), location);
2929 } 2932 }
2930 else 2933 else
2931 y = car (x); 2934 y = car (x);
2932 2935
… …
3042#if USE_ERROR_HOOK 3045#if USE_ERROR_HOOK
3043 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 3046 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044 3047
3045 if (x != NIL) 3048 if (x != NIL)
3046 { 3049 {
3047 if (a) 3050 pointer code = a
3048 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3051 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049 else 3052 : NIL;
3050 SCHEME_V->code = NIL;
3051 3053
3052 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3054 code = cons (mk_string (SCHEME_A_ s), code);
3053 setimmutable (car (SCHEME_V->code)); 3055 setimmutable (car (code));
3054 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3056 SCHEME_V->code = cons (slot_value_in_env (x), code);
3055 SCHEME_V->op = OP_EVAL; 3057 SCHEME_V->op = OP_EVAL;
3056 3058
3057 return S_T; 3059 return S_T;
3058 } 3060 }
3059#endif 3061#endif
… …
3350 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3352 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3353 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352 s_goto (OP_READ_INTERNAL); 3354 s_goto (OP_READ_INTERNAL);
3353 3355
3354 case OP_T1LVL: /* top level */ 3356 case OP_T1LVL: /* top level */
3355 SCHEME_V->code = SCHEME_V->value; 3357 SCHEME_V->code = SCHEME_V->value;
3356 SCHEME_V->inport = SCHEME_V->save_inport; 3358 SCHEME_V->inport = SCHEME_V->save_inport;
3357 s_goto (OP_EVAL); 3359 s_goto (OP_EVAL);
3358 3360
3359 case OP_READ_INTERNAL: /* internal read */ 3361 case OP_READ_INTERNAL: /* internal read */
3360 SCHEME_V->tok = token (SCHEME_A); 3362 SCHEME_V->tok = token (SCHEME_A);
… …
3410 else 3412 else
3411 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3413 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412 } 3414 }
3413 else if (is_pair (SCHEME_V->code)) 3415 else if (is_pair (SCHEME_V->code))
3414 { 3416 {
3417 x = car (SCHEME_V->code);
3418
3415 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3419 if (is_syntax (x)) /* SYNTAX */
3416 { 3420 {
3417 SCHEME_V->code = cdr (SCHEME_V->code); 3421 SCHEME_V->code = cdr (SCHEME_V->code);
3418 s_goto (syntaxnum (x)); 3422 s_goto (syntaxnum (x));
3419 } 3423 }
3420 else /* first, eval top element and eval arguments */ 3424 else /* first, eval top element and eval arguments */
3421 { 3425 {
3422 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3426 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3423 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3427 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424 SCHEME_V->code = car (SCHEME_V->code); 3428 SCHEME_V->code = x;
3425 s_goto (OP_EVAL); 3429 s_goto (OP_EVAL);
3426 } 3430 }
3427 } 3431 }
3428 else 3432 else
3429 s_return (SCHEME_V->code); 3433 s_return (SCHEME_V->code);
… …
3987 SCHEME_V->code = car (SCHEME_V->args); 3991 SCHEME_V->code = car (SCHEME_V->args);
3988 s_goto (OP_EVAL); 3992 s_goto (OP_EVAL);
3989 3993
3990 case OP_CONTINUATION: /* call-with-current-continuation */ 3994 case OP_CONTINUATION: /* call-with-current-continuation */
3991 SCHEME_V->code = car (SCHEME_V->args); 3995 SCHEME_V->code = car (SCHEME_V->args);
3992 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3996 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993 s_goto (OP_APPLY); 3997 s_goto (OP_APPLY);
3994 } 3998 }
3995 3999
3996 return S_T; 4000 return S_T;
3997} 4001}
… …
4505 4509
4506 s_return (vec); 4510 s_return (vec);
4507 } 4511 }
4508 4512
4509 case OP_VECLEN: /* vector-length */ 4513 case OP_VECLEN: /* vector-length */
4510 s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args)))); 4514 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511 4515
4512 case OP_VECREF: /* vector-ref */ 4516 case OP_VECREF: /* vector-ref */
4513 { 4517 {
4514 int index; 4518 int index;
4515 4519
4516 index = ivalue (cadr (SCHEME_V->args)); 4520 index = ivalue (cadr (SCHEME_V->args));
4517 4521
4518 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4522 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4523 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520 4524
4521 s_return (vector_elem (car (SCHEME_V->args), index)); 4525 s_return (vector_elem (car (SCHEME_V->args), index));
4522 } 4526 }
4523 4527
… …
4528 if (is_immutable (car (SCHEME_V->args))) 4532 if (is_immutable (car (SCHEME_V->args)))
4529 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4533 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4530 4534
4531 index = ivalue (cadr (SCHEME_V->args)); 4535 index = ivalue (cadr (SCHEME_V->args));
4532 4536
4533 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4537 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4538 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535 4539
4536 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4540 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4537 s_return (car (SCHEME_V->args)); 4541 s_return (car (SCHEME_V->args));
4538 } 4542 }
… …
5381 5385
5382 case OP_PVECFROM: 5386 case OP_PVECFROM:
5383 { 5387 {
5384 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5388 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385 pointer vec = car (SCHEME_V->args); 5389 pointer vec = car (SCHEME_V->args);
5386 int len = vector_length (vec); 5390 int len = veclength (vec);
5387 5391
5388 if (i == len) 5392 if (i == len)
5389 { 5393 {
5390 putstr (SCHEME_A_ ")"); 5394 putstr (SCHEME_A_ ")");
5391 s_return (S_T); 5395 s_return (S_T);
… …
5562 5566
5563 for (;;) 5567 for (;;)
5564 { 5568 {
5565 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5569 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5566 5570
5571#if USE_ERROR_CHECKING
5567 if (pcd->name) /* if built-in function, check arguments */ 5572 if (pcd->name) /* if built-in function, check arguments */
5568 { 5573 {
5569#if USE_ERROR_CHECKING 5574 int ok = 1;
5570 char msg[STRBUFFSIZE]; 5575 char msg[STRBUFFSIZE];
5571 int ok = 1;
5572 int n = list_length (SCHEME_A_ SCHEME_V->args); 5576 int n = list_length (SCHEME_A_ SCHEME_V->args);
5573 5577
5574 /* Check number of arguments */ 5578 /* Check number of arguments */
5575 if (n < pcd->min_arity) 5579 if (n < pcd->min_arity)
5576 { 5580 {
… …
5583 { 5587 {
5584 ok = 0; 5588 ok = 0;
5585 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5589 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5586 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5590 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5587 } 5591 }
5588#endif
5589 5592
5590 if (ok) 5593 if (ok)
5591 { 5594 {
5592 if (pcd->arg_tests_encoding && USE_ERROR_CHECKING) 5595 if (pcd->arg_tests_encoding)
5593 { 5596 {
5594 int i = 0; 5597 int i = 0;
5595 int j; 5598 int j;
5596 const char *t = pcd->arg_tests_encoding; 5599 const char *t = pcd->arg_tests_encoding;
5597 pointer arglist = SCHEME_V->args; 5600 pointer arglist = SCHEME_V->args;
… …
5635 return; 5638 return;
5636 5639
5637 pcd = dispatch_table + SCHEME_V->op; 5640 pcd = dispatch_table + SCHEME_V->op;
5638 } 5641 }
5639 } 5642 }
5643#endif
5640 5644
5641 ok_to_freely_gc (SCHEME_A); 5645 ok_to_freely_gc (SCHEME_A);
5642 5646
5643 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5647 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)
5644 return; 5648 return;
5645 5649
5646#if USE_ERROR_CHECKING 5650 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647 if (SCHEME_V->no_memory)
5648 { 5651 {
5649 xwrstr ("No memory!\n"); 5652 xwrstr ("No memory!\n");
5650 return; 5653 return;
5651 } 5654 }
5652#endif
5653 } 5655 }
5654} 5656}
5655 5657
5656/* ========== Initialization of internal keywords ========== */ 5658/* ========== Initialization of internal keywords ========== */
5657 5659
… …
5817 set_cdr (S_T, S_T); 5819 set_cdr (S_T, S_T);
5818 /* init F */ 5820 /* init F */
5819 set_typeflag (S_F, T_ATOM | T_MARK); 5821 set_typeflag (S_F, T_ATOM | T_MARK);
5820 set_car (S_F, S_F); 5822 set_car (S_F, S_F);
5821 set_cdr (S_F, S_F); 5823 set_cdr (S_F, S_F);
5824 /* init EOF_OBJ */
5825 set_typeflag (S_EOF, T_ATOM | T_MARK);
5826 set_car (S_EOF, S_EOF);
5827 set_cdr (S_EOF, S_EOF);
5822 /* init sink */ 5828 /* init sink */
5823 set_typeflag (S_SINK, T_PAIR | T_MARK); 5829 set_typeflag (S_SINK, T_PAIR | T_MARK);
5824 set_car (S_SINK, NIL); 5830 set_car (S_SINK, NIL);
5831
5825 /* init c_nest */ 5832 /* init c_nest */
5826 SCHEME_V->c_nest = NIL; 5833 SCHEME_V->c_nest = NIL;
5827 5834
5828 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5835 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5829 /* init global_env */ 5836 /* init global_env */
… …
5847 for (i = 0; i < n; i++) 5854 for (i = 0; i < n; i++)
5848 if (dispatch_table[i].name != 0) 5855 if (dispatch_table[i].name != 0)
5849 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5856 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5850 5857
5851 /* initialization of global pointers to special symbols */ 5858 /* initialization of global pointers to special symbols */
5852 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5859 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5853 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5860 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5854 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5861 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5855 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5862 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5856 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5863 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5857 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5864 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5858 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5865 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5859 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5866 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5860 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5867 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5861 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5868 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5862 5869
5863 return !SCHEME_V->no_memory; 5870 return !SCHEME_V->no_memory;
5864} 5871}
5865 5872
… …
6112 6119
6113/* ========== Main ========== */ 6120/* ========== Main ========== */
6114 6121
6115#if STANDALONE 6122#if STANDALONE
6116 6123
6117# if defined(__APPLE__) && !defined (OSX)
6118int
6119main ()
6120{
6121 extern MacTS_main (int argc, char **argv);
6122 char **argv;
6123 int argc = ccommand (&argv);
6124
6125 MacTS_main (argc, argv);
6126 return 0;
6127}
6128
6129int
6130MacTS_main (int argc, char **argv)
6131{
6132# else
6133int 6124int
6134main (int argc, char **argv) 6125main (int argc, char **argv)
6135{ 6126{
6136# endif
6137# if USE_MULTIPLICITY 6127# if USE_MULTIPLICITY
6138 scheme ssc; 6128 scheme ssc;
6139 scheme *const SCHEME_V = &ssc; 6129 scheme *const SCHEME_V = &ssc;
6140# else 6130# else
6141# endif 6131# endif

Diff Legend

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