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.17 by root, Thu Nov 26 10:15:51 2015 UTC vs.
Revision 1.20 by root, Thu Nov 26 22:53:28 2015 UTC

… …
247 247
248#define strvalue(p) ((p)->object.string.svalue) 248#define strvalue(p) ((p)->object.string.svalue)
249#define strlength(p) ((p)->object.string.length) 249#define strlength(p) ((p)->object.string.length)
250 250
251INTERFACE int is_list (SCHEME_P_ pointer p); 251INTERFACE int is_list (SCHEME_P_ pointer p);
252
252INTERFACE INLINE int 253INTERFACE INLINE int
253is_vector (pointer p) 254is_vector (pointer p)
254{ 255{
255 return type (p) == T_VECTOR; 256 return type (p) == T_VECTOR;
256} 257}
… …
666static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); 667static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
667static pointer revappend (SCHEME_P_ pointer a, pointer b); 668static pointer revappend (SCHEME_P_ pointer a, pointer b);
668static pointer ss_get_cont (SCHEME_P); 669static pointer ss_get_cont (SCHEME_P);
669static void ss_set_cont (SCHEME_P_ pointer cont); 670static void ss_set_cont (SCHEME_P_ pointer cont);
670static void dump_stack_mark (SCHEME_P); 671static void dump_stack_mark (SCHEME_P);
671static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 672static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
673static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
672static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); 674static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
673static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
674static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 675static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
675static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 676static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
676static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 677static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
677static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 678static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
678static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 679static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
679static void assign_syntax (SCHEME_P_ const char *name); 680static void assign_syntax (SCHEME_P_ const char *name);
680static int syntaxnum (pointer p); 681static int syntaxnum (pointer p);
681static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 682static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
682 683
… …
2931 return cdr (slot); 2932 return cdr (slot);
2932} 2933}
2933 2934
2934/* ========== Evaluation Cycle ========== */ 2935/* ========== Evaluation Cycle ========== */
2935 2936
2936static pointer 2937static int
2937xError_1 (SCHEME_P_ const char *s, pointer a) 2938xError_1 (SCHEME_P_ const char *s, pointer a)
2938{ 2939{
2939#if USE_ERROR_HOOK 2940#if USE_ERROR_HOOK
2940 pointer x; 2941 pointer x;
2941 pointer hdl = SCHEME_V->ERROR_HOOK; 2942 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
2976 code = cons (mk_string (SCHEME_A_ s), code); 2977 code = cons (mk_string (SCHEME_A_ s), code);
2977 setimmutable (car (code)); 2978 setimmutable (car (code));
2978 SCHEME_V->code = cons (slot_value_in_env (x), code); 2979 SCHEME_V->code = cons (slot_value_in_env (x), code);
2979 SCHEME_V->op = OP_EVAL; 2980 SCHEME_V->op = OP_EVAL;
2980 2981
2981 return S_T; 2982 return 0;
2982 } 2983 }
2983#endif 2984#endif
2984 2985
2985 if (a) 2986 if (a)
2986 SCHEME_V->args = cons (a, NIL); 2987 SCHEME_V->args = cons (a, NIL);
… …
2988 SCHEME_V->args = NIL; 2989 SCHEME_V->args = NIL;
2989 2990
2990 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); 2991 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2991 setimmutable (car (SCHEME_V->args)); 2992 setimmutable (car (SCHEME_V->args));
2992 SCHEME_V->op = OP_ERR0; 2993 SCHEME_V->op = OP_ERR0;
2994
2993 return S_T; 2995 return 0;
2994} 2996}
2995 2997
2996#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) 2998#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2997#define Error_0(s) Error_1 (s, 0) 2999#define Error_0(s) Error_1 (s, 0)
2998 3000
2999/* Too small to turn into function */ 3001/* Too small to turn into function */
3000#define BEGIN do { 3002#define BEGIN do {
3001#define END } while (0) 3003#define END } while (0)
3002#define s_goto(a) BEGIN \ 3004#define s_goto(a) BEGIN \
3003 SCHEME_V->op = a; \ 3005 SCHEME_V->op = a; \
3004 return S_T; END 3006 return 0; END
3005 3007
3006#define s_return(a) return xs_return (SCHEME_A_ a) 3008#define s_return(a) return xs_return (SCHEME_A_ a)
3007 3009
3008#ifndef USE_SCHEME_STACK 3010#ifndef USE_SCHEME_STACK
3009 3011
… …
3039 next_frame->code = code; 3041 next_frame->code = code;
3040 3042
3041 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3043 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3042} 3044}
3043 3045
3044static pointer 3046static int
3045xs_return (SCHEME_P_ pointer a) 3047xs_return (SCHEME_P_ pointer a)
3046{ 3048{
3047 int nframes = (uintptr_t)SCHEME_V->dump; 3049 int nframes = (uintptr_t)SCHEME_V->dump;
3048 struct dump_stack_frame *frame; 3050 struct dump_stack_frame *frame;
3049 3051
3050 SCHEME_V->value = a; 3052 SCHEME_V->value = a;
3051 3053
3052 if (nframes <= 0) 3054 if (nframes <= 0)
3053 return NIL; 3055 return -1;
3054 3056
3055 frame = &SCHEME_V->dump_base[--nframes]; 3057 frame = &SCHEME_V->dump_base[--nframes];
3056 SCHEME_V->op = frame->op; 3058 SCHEME_V->op = frame->op;
3057 SCHEME_V->args = frame->args; 3059 SCHEME_V->args = frame->args;
3058 SCHEME_V->envir = frame->envir; 3060 SCHEME_V->envir = frame->envir;
3059 SCHEME_V->code = frame->code; 3061 SCHEME_V->code = frame->code;
3060 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3062 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3061 3063
3062 return S_T; 3064 return 0;
3063} 3065}
3064 3066
3065static INLINE void 3067static INLINE void
3066dump_stack_reset (SCHEME_P) 3068dump_stack_reset (SCHEME_P)
3067{ 3069{
… …
3162dump_stack_free (SCHEME_P) 3164dump_stack_free (SCHEME_P)
3163{ 3165{
3164 SCHEME_V->dump = NIL; 3166 SCHEME_V->dump = NIL;
3165} 3167}
3166 3168
3167static pointer 3169static int
3168xs_return (SCHEME_P_ pointer a) 3170xs_return (SCHEME_P_ pointer a)
3169{ 3171{
3170 pointer dump = SCHEME_V->dump; 3172 pointer dump = SCHEME_V->dump;
3171 3173
3172 SCHEME_V->value = a; 3174 SCHEME_V->value = a;
3173 3175
3174 if (dump == NIL) 3176 if (dump == NIL)
3175 return NIL; 3177 return -1;
3176 3178
3177 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); 3179 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3178 SCHEME_V->args = car (dump) ; dump = cdr (dump); 3180 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3179 SCHEME_V->envir = car (dump) ; dump = cdr (dump); 3181 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3180 SCHEME_V->code = car (dump) ; dump = cdr (dump); 3182 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3181 3183
3182 SCHEME_V->dump = dump; 3184 SCHEME_V->dump = dump;
3183 3185
3184 return S_T; 3186 return 0;
3185} 3187}
3186 3188
3187static void 3189static void
3188s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3190s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3189{ 3191{
… …
3214 3216
3215#endif 3217#endif
3216 3218
3217#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3219#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3218 3220
3219static pointer 3221static int
3220opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3222opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3221{ 3223{
3222 pointer args = SCHEME_V->args; 3224 pointer args = SCHEME_V->args;
3223 pointer x, y; 3225 pointer x, y;
3224 3226
… …
3413 /* fall through */ 3415 /* fall through */
3414 3416
3415 case OP_REAL_APPLY: 3417 case OP_REAL_APPLY:
3416#endif 3418#endif
3417 if (is_proc (SCHEME_V->code)) 3419 if (is_proc (SCHEME_V->code))
3418 {
3419 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3420 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3420 }
3421 else if (is_foreign (SCHEME_V->code)) 3421 else if (is_foreign (SCHEME_V->code))
3422 { 3422 {
3423 /* Keep nested calls from GC'ing the arglist */ 3423 /* Keep nested calls from GC'ing the arglist */
3424 push_recent_alloc (SCHEME_A_ args, NIL); 3424 push_recent_alloc (SCHEME_A_ args, NIL);
3425 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3425 x = SCHEME_V->code->object.ff (SCHEME_A_ args);
… …
3592 3592
3593 case OP_IF1: /* if */ 3593 case OP_IF1: /* if */
3594 if (is_true (SCHEME_V->value)) 3594 if (is_true (SCHEME_V->value))
3595 SCHEME_V->code = car (SCHEME_V->code); 3595 SCHEME_V->code = car (SCHEME_V->code);
3596 else 3596 else
3597 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because 3597 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3598
3599 * car(NIL) = NIL */
3600 s_goto (OP_EVAL); 3598 s_goto (OP_EVAL);
3601 3599
3602 case OP_LET0: /* let */ 3600 case OP_LET0: /* let */
3603 SCHEME_V->args = NIL; 3601 SCHEME_V->args = NIL;
3604 SCHEME_V->value = SCHEME_V->code; 3602 SCHEME_V->value = SCHEME_V->code;
… …
3917 } 3915 }
3918 3916
3919 abort (); 3917 abort ();
3920} 3918}
3921 3919
3922static pointer 3920static int
3923opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3921opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3924{ 3922{
3925 pointer args = SCHEME_V->args; 3923 pointer args = SCHEME_V->args;
3926 pointer x = car (args); 3924 pointer x = car (args);
3927 num v; 3925 num v;
3928 3926
… …
4421 set_vector_elem (x, index, caddr (args)); 4419 set_vector_elem (x, index, caddr (args));
4422 s_return (x); 4420 s_return (x);
4423 } 4421 }
4424 } 4422 }
4425 4423
4426 return S_T; 4424 abort ();
4427} 4425}
4428 4426
4429INTERFACE int 4427INTERFACE int
4430is_list (SCHEME_P_ pointer a) 4428is_list (SCHEME_P_ pointer a)
4431{ 4429{
… …
4478 return -1; 4476 return -1;
4479 } 4477 }
4480 } 4478 }
4481} 4479}
4482 4480
4483static pointer 4481static int
4484opexe_r (SCHEME_P_ enum scheme_opcodes op) 4482opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4485{ 4483{
4486 pointer x = SCHEME_V->args; 4484 pointer x = SCHEME_V->args;
4487 4485
4488 for (;;) 4486 for (;;)
4489 { 4487 {
… …
4509 } 4507 }
4510 4508
4511 s_return (S_T); 4509 s_return (S_T);
4512} 4510}
4513 4511
4514static pointer 4512static int
4515opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4513opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4516{ 4514{
4517 pointer args = SCHEME_V->args; 4515 pointer args = SCHEME_V->args;
4518 pointer a = car (args); 4516 pointer a = car (args);
4519 pointer d = cdr (args); 4517 pointer d = cdr (args);
… …
4565 } 4563 }
4566 4564
4567 s_retbool (r); 4565 s_retbool (r);
4568} 4566}
4569 4567
4570static pointer 4568static int
4571opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4569opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4572{ 4570{
4573 pointer args = SCHEME_V->args; 4571 pointer args = SCHEME_V->args;
4574 pointer a = car (args); 4572 pointer a = car (args);
4575 pointer x, y; 4573 pointer x, y;
… …
4661 putstr (SCHEME_A_ "\n"); 4659 putstr (SCHEME_A_ "\n");
4662 4660
4663 if (SCHEME_V->interactive_repl) 4661 if (SCHEME_V->interactive_repl)
4664 s_goto (OP_T0LVL); 4662 s_goto (OP_T0LVL);
4665 else 4663 else
4666 return NIL; 4664 return -1;
4667 } 4665 }
4668 4666
4669 case OP_REVERSE: /* reverse */ 4667 case OP_REVERSE: /* reverse */
4670 s_return (reverse (SCHEME_A_ a)); 4668 s_return (reverse (SCHEME_A_ a));
4671 4669
… …
4728 4726
4729 case OP_QUIT: /* quit */ 4727 case OP_QUIT: /* quit */
4730 if (is_pair (args)) 4728 if (is_pair (args))
4731 SCHEME_V->retcode = ivalue (a); 4729 SCHEME_V->retcode = ivalue (a);
4732 4730
4733 return NIL; 4731 return -1;
4734 4732
4735 case OP_GC: /* gc */ 4733 case OP_GC: /* gc */
4736 gc (SCHEME_A_ NIL, NIL); 4734 gc (SCHEME_A_ NIL, NIL);
4737 s_return (S_T); 4735 s_return (S_T);
4738 4736
… …
4891 } 4889 }
4892 4890
4893 abort (); 4891 abort ();
4894} 4892}
4895 4893
4896static pointer 4894static int
4897opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4895opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4898{ 4896{
4897 pointer args = SCHEME_V->args;
4899 pointer x; 4898 pointer x;
4900 4899
4901 if (SCHEME_V->nesting != 0) 4900 if (SCHEME_V->nesting != 0)
4902 { 4901 {
4903 int n = SCHEME_V->nesting; 4902 int n = SCHEME_V->nesting;
… …
4910 switch (op) 4909 switch (op)
4911 { 4910 {
4912 /* ========== reading part ========== */ 4911 /* ========== reading part ========== */
4913#if USE_PORTS 4912#if USE_PORTS
4914 case OP_READ: 4913 case OP_READ:
4915 if (!is_pair (SCHEME_V->args)) 4914 if (!is_pair (args))
4916 s_goto (OP_READ_INTERNAL); 4915 s_goto (OP_READ_INTERNAL);
4917 4916
4918 if (!is_inport (car (SCHEME_V->args))) 4917 if (!is_inport (car (args)))
4919 Error_1 ("read: not an input port:", car (SCHEME_V->args)); 4918 Error_1 ("read: not an input port:", car (args));
4920 4919
4921 if (car (SCHEME_V->args) == SCHEME_V->inport) 4920 if (car (args) == SCHEME_V->inport)
4922 s_goto (OP_READ_INTERNAL); 4921 s_goto (OP_READ_INTERNAL);
4923 4922
4924 x = SCHEME_V->inport; 4923 x = SCHEME_V->inport;
4925 SCHEME_V->inport = car (SCHEME_V->args); 4924 SCHEME_V->inport = car (args);
4926 x = cons (x, NIL); 4925 x = cons (x, NIL);
4927 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4926 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4928 s_goto (OP_READ_INTERNAL); 4927 s_goto (OP_READ_INTERNAL);
4929 4928
4930 case OP_READ_CHAR: /* read-char */ 4929 case OP_READ_CHAR: /* read-char */
4931 case OP_PEEK_CHAR: /* peek-char */ 4930 case OP_PEEK_CHAR: /* peek-char */
4932 { 4931 {
4933 int c; 4932 int c;
4934 4933
4935 if (is_pair (SCHEME_V->args)) 4934 if (is_pair (args))
4936 { 4935 {
4937 if (car (SCHEME_V->args) != SCHEME_V->inport) 4936 if (car (args) != SCHEME_V->inport)
4938 { 4937 {
4939 x = SCHEME_V->inport; 4938 x = SCHEME_V->inport;
4940 x = cons (x, NIL); 4939 x = cons (x, NIL);
4941 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4940 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4942 SCHEME_V->inport = car (SCHEME_V->args); 4941 SCHEME_V->inport = car (args);
4943 } 4942 }
4944 } 4943 }
4945 4944
4946 c = inchar (SCHEME_A); 4945 c = inchar (SCHEME_A);
4947 4946
… …
4957 case OP_CHAR_READY: /* char-ready? */ 4956 case OP_CHAR_READY: /* char-ready? */
4958 { 4957 {
4959 pointer p = SCHEME_V->inport; 4958 pointer p = SCHEME_V->inport;
4960 int res; 4959 int res;
4961 4960
4962 if (is_pair (SCHEME_V->args)) 4961 if (is_pair (args))
4963 p = car (SCHEME_V->args); 4962 p = car (args);
4964 4963
4965 res = p->object.port->kind & port_string; 4964 res = p->object.port->kind & port_string;
4966 4965
4967 s_retbool (res); 4966 s_retbool (res);
4968 } 4967 }
4969 4968
4970 case OP_SET_INPORT: /* set-input-port */ 4969 case OP_SET_INPORT: /* set-input-port */
4971 SCHEME_V->inport = car (SCHEME_V->args); 4970 SCHEME_V->inport = car (args);
4972 s_return (SCHEME_V->value); 4971 s_return (SCHEME_V->value);
4973 4972
4974 case OP_SET_OUTPORT: /* set-output-port */ 4973 case OP_SET_OUTPORT: /* set-output-port */
4975 SCHEME_V->outport = car (SCHEME_V->args); 4974 SCHEME_V->outport = car (args);
4976 s_return (SCHEME_V->value); 4975 s_return (SCHEME_V->value);
4977#endif 4976#endif
4978 4977
4979 case OP_RDSEXPR: 4978 case OP_RDSEXPR:
4980 switch (SCHEME_V->tok) 4979 switch (SCHEME_V->tok)
… …
5066 } 5065 }
5067 5066
5068 break; 5067 break;
5069 5068
5070 case OP_RDLIST: 5069 case OP_RDLIST:
5071 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 5070 SCHEME_V->args = cons (SCHEME_V->value, args);
5072 SCHEME_V->tok = token (SCHEME_A); 5071 SCHEME_V->tok = token (SCHEME_A);
5073 5072
5074 switch (SCHEME_V->tok) 5073 switch (SCHEME_V->tok)
5075 { 5074 {
5076 case TOK_EOF: 5075 case TOK_EOF:
… …
5104 case OP_RDDOT: 5103 case OP_RDDOT:
5105 if (token (SCHEME_A) != TOK_RPAREN) 5104 if (token (SCHEME_A) != TOK_RPAREN)
5106 Error_0 ("syntax error: illegal dot expression"); 5105 Error_0 ("syntax error: illegal dot expression");
5107 5106
5108 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5107 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5109 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); 5108 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5110 5109
5111 case OP_RDQUOTE: 5110 case OP_RDQUOTE:
5112 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); 5111 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5113 5112
5114 case OP_RDQQUOTE: 5113 case OP_RDQQUOTE:
… …
5136 SCHEME_V->args = SCHEME_V->value; 5135 SCHEME_V->args = SCHEME_V->value;
5137 s_goto (OP_VECTOR); 5136 s_goto (OP_VECTOR);
5138 5137
5139 /* ========== printing part ========== */ 5138 /* ========== printing part ========== */
5140 case OP_P0LIST: 5139 case OP_P0LIST:
5141 if (is_vector (SCHEME_V->args)) 5140 if (is_vector (args))
5142 { 5141 {
5143 putstr (SCHEME_A_ "#("); 5142 putstr (SCHEME_A_ "#(");
5144 SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); 5143 SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5145 s_goto (OP_PVECFROM); 5144 s_goto (OP_PVECFROM);
5146 } 5145 }
5147 else if (is_environment (SCHEME_V->args)) 5146 else if (is_environment (args))
5148 { 5147 {
5149 putstr (SCHEME_A_ "#<ENVIRONMENT>"); 5148 putstr (SCHEME_A_ "#<ENVIRONMENT>");
5150 s_return (S_T); 5149 s_return (S_T);
5151 } 5150 }
5152 else if (!is_pair (SCHEME_V->args)) 5151 else if (!is_pair (args))
5153 { 5152 {
5154 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5153 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5155 s_return (S_T); 5154 s_return (S_T);
5156 } 5155 }
5157 else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5156 else
5158 { 5157 {
5158 pointer a = car (args);
5159 pointer b = cdr (args);
5160 int ok_abbr = ok_abbrev (b);
5161 SCHEME_V->args = car (b);
5162
5163 if (a == SCHEME_V->QUOTE && ok_abbr)
5159 putstr (SCHEME_A_ "'"); 5164 putstr (SCHEME_A_ "'");
5160 SCHEME_V->args = cadr (SCHEME_V->args); 5165 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5166 putstr (SCHEME_A_ "`");
5167 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5168 putstr (SCHEME_A_ ",");
5169 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5170 putstr (SCHEME_A_ ",@");
5171 else
5172 {
5173 putstr (SCHEME_A_ "(");
5174 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5175 SCHEME_V->args = a;
5176 }
5177
5161 s_goto (OP_P0LIST); 5178 s_goto (OP_P0LIST);
5162 } 5179 }
5163 else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5180
5181 case OP_P1LIST:
5182 if (is_pair (args))
5164 { 5183 {
5184 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5165 putstr (SCHEME_A_ "`"); 5185 putstr (SCHEME_A_ " ");
5166 SCHEME_V->args = cadr (SCHEME_V->args); 5186 SCHEME_V->args = car (args);
5167 s_goto (OP_P0LIST); 5187 s_goto (OP_P0LIST);
5168 } 5188 }
5169 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
5170 {
5171 putstr (SCHEME_A_ ",");
5172 SCHEME_V->args = cadr (SCHEME_V->args);
5173 s_goto (OP_P0LIST);
5174 }
5175 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
5176 {
5177 putstr (SCHEME_A_ ",@");
5178 SCHEME_V->args = cadr (SCHEME_V->args);
5179 s_goto (OP_P0LIST);
5180 }
5181 else
5182 {
5183 putstr (SCHEME_A_ "(");
5184 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5185 SCHEME_V->args = car (SCHEME_V->args);
5186 s_goto (OP_P0LIST);
5187 }
5188
5189 case OP_P1LIST:
5190 if (is_pair (SCHEME_V->args))
5191 {
5192 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5193 putstr (SCHEME_A_ " ");
5194 SCHEME_V->args = car (SCHEME_V->args);
5195 s_goto (OP_P0LIST);
5196 }
5197 else if (is_vector (SCHEME_V->args)) 5189 else if (is_vector (args))
5198 { 5190 {
5199 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); 5191 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5200 putstr (SCHEME_A_ " . "); 5192 putstr (SCHEME_A_ " . ");
5201 s_goto (OP_P0LIST); 5193 s_goto (OP_P0LIST);
5202 } 5194 }
5203 else 5195 else
5204 { 5196 {
5205 if (SCHEME_V->args != NIL) 5197 if (args != NIL)
5206 { 5198 {
5207 putstr (SCHEME_A_ " . "); 5199 putstr (SCHEME_A_ " . ");
5208 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5200 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5209 } 5201 }
5210 5202
5211 putstr (SCHEME_A_ ")"); 5203 putstr (SCHEME_A_ ")");
5212 s_return (S_T); 5204 s_return (S_T);
5213 } 5205 }
5214 5206
5215 case OP_PVECFROM: 5207 case OP_PVECFROM:
5216 { 5208 {
5217 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5209 int i = ivalue_unchecked (cdr (args));
5218 pointer vec = car (SCHEME_V->args); 5210 pointer vec = car (args);
5219 int len = veclength (vec); 5211 int len = veclength (vec);
5220 5212
5221 if (i == len) 5213 if (i == len)
5222 { 5214 {
5223 putstr (SCHEME_A_ ")"); 5215 putstr (SCHEME_A_ ")");
… …
5225 } 5217 }
5226 else 5218 else
5227 { 5219 {
5228 pointer elem = vector_elem (vec, i); 5220 pointer elem = vector_elem (vec, i);
5229 5221
5230 ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; 5222 ivalue_unchecked (cdr (args)) = i + 1;
5231 s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); 5223 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5232 SCHEME_V->args = elem; 5224 SCHEME_V->args = elem;
5233 5225
5234 if (i > 0) 5226 if (i > 0)
5235 putstr (SCHEME_A_ " "); 5227 putstr (SCHEME_A_ " ");
5236 5228
… …
5240 } 5232 }
5241 5233
5242 abort (); 5234 abort ();
5243} 5235}
5244 5236
5245static pointer 5237static int
5246opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5238opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5247{ 5239{
5240 pointer args = SCHEME_V->args;
5241 pointer a = car (args);
5248 pointer x, y; 5242 pointer x, y;
5249 5243
5250 switch (op) 5244 switch (op)
5251 { 5245 {
5252 case OP_LIST_LENGTH: /* length *//* a.k */ 5246 case OP_LIST_LENGTH: /* length *//* a.k */
5253 { 5247 {
5254 long v = list_length (SCHEME_A_ car (SCHEME_V->args)); 5248 long v = list_length (SCHEME_A_ a);
5255 5249
5256 if (v < 0) 5250 if (v < 0)
5257 Error_1 ("length: not a list:", car (SCHEME_V->args)); 5251 Error_1 ("length: not a list:", a);
5258 5252
5259 s_return (mk_integer (SCHEME_A_ v)); 5253 s_return (mk_integer (SCHEME_A_ v));
5260 } 5254 }
5261 5255
5262 case OP_ASSQ: /* assq *//* a.k */ 5256 case OP_ASSQ: /* assq *//* a.k */
5263 x = car (SCHEME_V->args); 5257 x = a;
5264 5258
5265 for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) 5259 for (y = cadr (args); is_pair (y); y = cdr (y))
5266 { 5260 {
5267 if (!is_pair (car (y))) 5261 if (!is_pair (car (y)))
5268 Error_0 ("unable to handle non pair element"); 5262 Error_0 ("unable to handle non pair element");
5269 5263
5270 if (x == caar (y)) 5264 if (x == caar (y))
… …
5276 else 5270 else
5277 s_return (S_F); 5271 s_return (S_F);
5278 5272
5279 5273
5280 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5274 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5281 SCHEME_V->args = car (SCHEME_V->args); 5275 SCHEME_V->args = a;
5282 5276
5283 if (SCHEME_V->args == NIL) 5277 if (SCHEME_V->args == NIL)
5284 s_return (S_F); 5278 s_return (S_F);
5285 else if (is_closure (SCHEME_V->args)) 5279 else if (is_closure (SCHEME_V->args))
5286 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5280 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
… …
5292 case OP_CLOSUREP: /* closure? */ 5286 case OP_CLOSUREP: /* closure? */
5293 /* 5287 /*
5294 * Note, macro object is also a closure. 5288 * Note, macro object is also a closure.
5295 * Therefore, (closure? <#MACRO>) ==> #t 5289 * Therefore, (closure? <#MACRO>) ==> #t
5296 */ 5290 */
5297 s_retbool (is_closure (car (SCHEME_V->args))); 5291 s_retbool (is_closure (a));
5298 5292
5299 case OP_MACROP: /* macro? */ 5293 case OP_MACROP: /* macro? */
5300 s_retbool (is_macro (car (SCHEME_V->args))); 5294 s_retbool (is_macro (a));
5301 } 5295 }
5302 5296
5303 abort (); 5297 abort ();
5304} 5298}
5305 5299
5300/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5306typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5301typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5307 5302
5308typedef int (*test_predicate) (pointer); 5303typedef int (*test_predicate)(pointer);
5309static int 5304static int
5310is_any (pointer p) 5305is_any (pointer p)
5311{ 5306{
5312 return 1; 5307 return 1;
5313} 5308}
5314 5309
5315static int 5310static int
5316is_nonneg (pointer p) 5311is_nonneg (pointer p)
5317{ 5312{
5318 return ivalue (p) >= 0 && is_integer (p); 5313 return ivalue (p) >= 0 && is_integer (p);
5314}
5315
5316static int
5317tst_is_list (pointer p)
5318{
5319 return p == NIL || is_pair (p);
5319} 5320}
5320 5321
5321/* Correspond carefully with following defines! */ 5322/* Correspond carefully with following defines! */
5322static struct 5323static struct
5323{ 5324{
5324 test_predicate fct; 5325 test_predicate fct;
5325 const char *kind; 5326 const char *kind;
5326} tests[] = 5327} tests[] =
5327{ 5328{
5328 { 0, 0}, /* unused */ 5329 { is_any, 0 },
5329 { is_any, 0}, 5330 { is_string, "string" },
5330 { is_string, "string" }, 5331 { is_symbol, "symbol" },
5331 { is_symbol, "symbol" }, 5332 { is_port, "port" },
5332 { is_port, "port" },
5333 { is_inport, "input port" }, 5333 { is_inport, "input port" },
5334 { is_outport, "output port" }, 5334 { is_outport, "output port" },
5335 { is_environment, "environment" }, 5335 { is_environment, "environment" },
5336 { is_pair, "pair" }, 5336 { is_pair, "pair" },
5337 { 0, "pair or '()" }, 5337 { tst_is_list, "pair or '()" },
5338 { is_character, "character" }, 5338 { is_character, "character" },
5339 { is_vector, "vector" }, 5339 { is_vector, "vector" },
5340 { is_number, "number" }, 5340 { is_number, "number" },
5341 { is_integer, "integer" }, 5341 { is_integer, "integer" },
5342 { is_nonneg, "non-negative integer" } 5342 { is_nonneg, "non-negative integer" }
5343}; 5343};
5344 5344
5345#define TST_NONE 0 5345#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346#define TST_ANY "\001" 5346#define TST_ANY "\001"
5347#define TST_STRING "\002" 5347#define TST_STRING "\002"
5348#define TST_SYMBOL "\003" 5348#define TST_SYMBOL "\003"
5349#define TST_PORT "\004" 5349#define TST_PORT "\004"
5350#define TST_INPORT "\005" 5350#define TST_INPORT "\005"
5351#define TST_OUTPORT "\006" 5351#define TST_OUTPORT "\006"
5352#define TST_ENVIRONMENT "\007" 5352#define TST_ENVIRONMENT "\007"
5353#define TST_PAIR "\010" 5353#define TST_PAIR "\010"
5354#define TST_LIST "\011" 5354#define TST_LIST "\011"
5355#define TST_CHAR "\012" 5355#define TST_CHAR "\012"
5356#define TST_VECTOR "\013" 5356#define TST_VECTOR "\013"
5357#define TST_NUMBER "\014" 5357#define TST_NUMBER "\014"
5358#define TST_INTEGER "\015" 5358#define TST_INTEGER "\015"
5359#define TST_NATURAL "\016" 5359#define TST_NATURAL "\016"
5360
5361#define INF_ARG 0xff
5362#define UNNAMED_OP ""
5363
5364static const char opnames[] =
5365#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5366#include "opdefines.h"
5367#undef OP_DEF
5368;
5369
5370static const char *
5371opname (int idx)
5372{
5373 const char *name = opnames;
5374
5375 /* should do this at compile time, but would require external program, right? */
5376 while (idx--)
5377 name += strlen (name) + 1;
5378
5379 return *name ? name : "ILLEGAL";
5380}
5381
5382static const char *
5383procname (pointer x)
5384{
5385 return opname (procnum (x));
5386}
5360 5387
5361typedef struct 5388typedef struct
5362{ 5389{
5363 dispatch_func func; 5390 uint8_t func;
5364 char *name; 5391 /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5392 uint8_t builtin;
5365 int min_arity; 5393 uint8_t min_arity;
5366 int max_arity; 5394 uint8_t max_arity;
5367 char *arg_tests_encoding; 5395 char arg_tests_encoding[3];
5368} op_code_info; 5396} op_code_info;
5369 5397
5370#define INF_ARG 0xffff
5371
5372static op_code_info dispatch_table[] = { 5398static const op_code_info dispatch_table[] = {
5373#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, 5399#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5374#include "opdefines.h" 5400#include "opdefines.h"
5401#undef OP_DEF
5375 {0} 5402 {0}
5376}; 5403};
5377
5378static const char *
5379procname (pointer x)
5380{
5381 int n = procnum (x);
5382 const char *name = dispatch_table[n].name;
5383
5384 if (name == 0)
5385 name = "ILLEGAL!";
5386
5387 return name;
5388}
5389 5404
5390/* kernel of this interpreter */ 5405/* kernel of this interpreter */
5391static void 5406static void
5392Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5407Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5393{ 5408{
5394 SCHEME_V->op = op; 5409 SCHEME_V->op = op;
5395 5410
5396 for (;;) 5411 for (;;)
5397 { 5412 {
5398 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5413 const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5399 5414
5400#if USE_ERROR_CHECKING 5415#if USE_ERROR_CHECKING
5401 if (pcd->name) /* if built-in function, check arguments */ 5416 if (pcd->builtin) /* if built-in function, check arguments */
5402 { 5417 {
5403 int ok = 1; 5418 int ok = 1;
5404 char msg[STRBUFFSIZE]; 5419 char msg[STRBUFFSIZE];
5405 int n = list_length (SCHEME_A_ SCHEME_V->args); 5420 int n = list_length (SCHEME_A_ SCHEME_V->args);
5406 5421
5407 /* Check number of arguments */ 5422 /* Check number of arguments */
5408 if (ecb_expect_false (n < pcd->min_arity)) 5423 if (ecb_expect_false (n < pcd->min_arity))
5409 { 5424 {
5410 ok = 0; 5425 ok = 0;
5411 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5426 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5412 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5427 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5413 } 5428 }
5414 else if (ecb_expect_false (n > pcd->max_arity)) 5429 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5415 { 5430 {
5416 ok = 0; 5431 ok = 0;
5417 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5432 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5418 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5433 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5419 } 5434 }
5420 5435 else
5421 if (ecb_expect_false (ok))
5422 { 5436 {
5423 if (pcd->arg_tests_encoding) 5437 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5424 { 5438 {
5425 int i = 0; 5439 int i = 0;
5426 int j; 5440 int j;
5427 const char *t = pcd->arg_tests_encoding; 5441 const char *t = pcd->arg_tests_encoding;
5428 pointer arglist = SCHEME_V->args; 5442 pointer arglist = SCHEME_V->args;
5429 5443
5430 do 5444 do
5431 { 5445 {
5432 pointer arg = car (arglist); 5446 pointer arg = car (arglist);
5433 5447
5434 j = (int) t[0]; 5448 j = t[0];
5435 5449
5436 if (j == TST_LIST[0]) 5450 if (!tests[j - 1].fct (arg))
5437 {
5438 if (arg != NIL && !is_pair (arg))
5439 break; 5451 break;
5440 }
5441 else
5442 {
5443 if (!tests[j].fct (arg))
5444 break;
5445 }
5446 5452
5447 if (t[1] != 0) /* last test is replicated as necessary */ 5453 if (t[1]) /* last test is replicated as necessary */
5448 t++; 5454 t++;
5449 5455
5450 arglist = cdr (arglist); 5456 arglist = cdr (arglist);
5451 i++; 5457 i++;
5452 } 5458 }
5453 while (i < n); 5459 while (i < n);
5454 5460
5455 if (i < n) 5461 if (i < n)
5456 { 5462 {
5457 ok = 0; 5463 ok = 0;
5458 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); 5464 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
5459 } 5465 }
5460 } 5466 }
5461 } 5467 }
5462 5468
5463 if (!ok) 5469 if (!ok)
5464 { 5470 {
5471 /* tinyscheme tested for returncode, but Error_1 always diverts? */
5465 if (xError_1 (SCHEME_A_ msg, 0) == NIL) 5472 xError_1 (SCHEME_A_ msg, 0);
5466 return; 5473 continue;
5467
5468 pcd = dispatch_table + SCHEME_V->op;
5469 } 5474 }
5470 } 5475 }
5471#endif 5476#endif
5472 5477
5473 ok_to_freely_gc (SCHEME_A); 5478 ok_to_freely_gc (SCHEME_A);
5474 5479
5480 static const dispatch_func dispatch_funcs[] = {
5481 opexe_0,
5482 opexe_1,
5483 opexe_2,
5484 opexe_3,
5485 opexe_4,
5486 opexe_5,
5487 opexe_6,
5488 };
5489
5475 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)) 5490 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5476 return; 5491 return;
5477 5492
5478 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5493 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5479 { 5494 {
5480 xwrstr ("No memory!\n"); 5495 xwrstr ("No memory!\n");
… …
5677 5692
5678 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) 5693 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5679 assign_syntax (SCHEME_A_ syntax_names[i]); 5694 assign_syntax (SCHEME_A_ syntax_names[i]);
5680 } 5695 }
5681 5696
5697 // TODO: should iterate via strlen, to avoid n² complexity
5682 for (i = 0; i < n; i++) 5698 for (i = 0; i < n; i++)
5683 if (dispatch_table[i].name != 0) 5699 if (dispatch_table[i].builtin)
5684 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5700 assign_proc (SCHEME_A_ i, opname (i));
5685 5701
5686 /* initialization of global pointers to special symbols */ 5702 /* initialization of global pointers to special symbols */
5687 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5703 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5688 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5704 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5689 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5705 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");

Diff Legend

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