… | |
… | |
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 | |
251 | INTERFACE int is_list (SCHEME_P_ pointer p); |
251 | INTERFACE int is_list (SCHEME_P_ pointer p); |
|
|
252 | |
252 | INTERFACE INLINE int |
253 | INTERFACE INLINE int |
253 | is_vector (pointer p) |
254 | is_vector (pointer p) |
254 | { |
255 | { |
255 | return type (p) == T_VECTOR; |
256 | return type (p) == T_VECTOR; |
256 | } |
257 | } |
… | |
… | |
666 | static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); |
667 | static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); |
667 | static pointer revappend (SCHEME_P_ pointer a, pointer b); |
668 | static pointer revappend (SCHEME_P_ pointer a, pointer b); |
668 | static pointer ss_get_cont (SCHEME_P); |
669 | static pointer ss_get_cont (SCHEME_P); |
669 | static void ss_set_cont (SCHEME_P_ pointer cont); |
670 | static void ss_set_cont (SCHEME_P_ pointer cont); |
670 | static void dump_stack_mark (SCHEME_P); |
671 | static void dump_stack_mark (SCHEME_P); |
671 | static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); |
672 | static int opexe_0 (SCHEME_P_ enum scheme_opcodes op); |
|
|
673 | static int opexe_1 (SCHEME_P_ enum scheme_opcodes op); |
672 | static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); |
674 | static int opexe_2 (SCHEME_P_ enum scheme_opcodes op); |
673 | static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op); |
|
|
674 | static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); |
675 | static int opexe_3 (SCHEME_P_ enum scheme_opcodes op); |
675 | static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); |
676 | static int opexe_4 (SCHEME_P_ enum scheme_opcodes op); |
676 | static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); |
677 | static int opexe_5 (SCHEME_P_ enum scheme_opcodes op); |
677 | static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); |
678 | static int opexe_6 (SCHEME_P_ enum scheme_opcodes op); |
678 | static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); |
679 | static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); |
679 | static void assign_syntax (SCHEME_P_ const char *name); |
680 | static void assign_syntax (SCHEME_P_ const char *name); |
680 | static int syntaxnum (pointer p); |
681 | static int syntaxnum (pointer p); |
681 | static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); |
682 | static 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 | |
2936 | static pointer |
2937 | static int |
2937 | xError_1 (SCHEME_P_ const char *s, pointer a) |
2938 | xError_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 | |
3044 | static pointer |
3046 | static int |
3045 | xs_return (SCHEME_P_ pointer a) |
3047 | xs_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 | |
3065 | static INLINE void |
3067 | static INLINE void |
3066 | dump_stack_reset (SCHEME_P) |
3068 | dump_stack_reset (SCHEME_P) |
3067 | { |
3069 | { |
… | |
… | |
3162 | dump_stack_free (SCHEME_P) |
3164 | dump_stack_free (SCHEME_P) |
3163 | { |
3165 | { |
3164 | SCHEME_V->dump = NIL; |
3166 | SCHEME_V->dump = NIL; |
3165 | } |
3167 | } |
3166 | |
3168 | |
3167 | static pointer |
3169 | static int |
3168 | xs_return (SCHEME_P_ pointer a) |
3170 | xs_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 | |
3187 | static void |
3189 | static void |
3188 | s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) |
3190 | s_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 | |
3219 | static pointer |
3221 | static int |
3220 | opexe_0 (SCHEME_P_ enum scheme_opcodes op) |
3222 | opexe_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 | |
3922 | static pointer |
3920 | static int |
3923 | opexe_2 (SCHEME_P_ enum scheme_opcodes op) |
3921 | opexe_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 | |
4429 | INTERFACE int |
4427 | INTERFACE int |
4430 | is_list (SCHEME_P_ pointer a) |
4428 | is_list (SCHEME_P_ pointer a) |
4431 | { |
4429 | { |
… | |
… | |
4478 | return -1; |
4476 | return -1; |
4479 | } |
4477 | } |
4480 | } |
4478 | } |
4481 | } |
4479 | } |
4482 | |
4480 | |
4483 | static pointer |
4481 | static int |
4484 | opexe_r (SCHEME_P_ enum scheme_opcodes op) |
4482 | opexe_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 | |
4514 | static pointer |
4512 | static int |
4515 | opexe_3 (SCHEME_P_ enum scheme_opcodes op) |
4513 | opexe_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 | |
4570 | static pointer |
4568 | static int |
4571 | opexe_4 (SCHEME_P_ enum scheme_opcodes op) |
4569 | opexe_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 | |
4896 | static pointer |
4894 | static int |
4897 | opexe_5 (SCHEME_P_ enum scheme_opcodes op) |
4895 | opexe_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 | |
5245 | static pointer |
5237 | static int |
5246 | opexe_6 (SCHEME_P_ enum scheme_opcodes op) |
5238 | opexe_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 */ |
5306 | typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); |
5301 | typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); |
5307 | |
5302 | |
5308 | typedef int (*test_predicate) (pointer); |
5303 | typedef int (*test_predicate)(pointer); |
5309 | static int |
5304 | static int |
5310 | is_any (pointer p) |
5305 | is_any (pointer p) |
5311 | { |
5306 | { |
5312 | return 1; |
5307 | return 1; |
5313 | } |
5308 | } |
5314 | |
5309 | |
5315 | static int |
5310 | static int |
5316 | is_nonneg (pointer p) |
5311 | is_nonneg (pointer p) |
5317 | { |
5312 | { |
5318 | return ivalue (p) >= 0 && is_integer (p); |
5313 | return ivalue (p) >= 0 && is_integer (p); |
|
|
5314 | } |
|
|
5315 | |
|
|
5316 | static int |
|
|
5317 | tst_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! */ |
5322 | static struct |
5323 | static 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 | |
|
|
5364 | static 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 | |
|
|
5370 | static const char * |
|
|
5371 | opname (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 | |
|
|
5382 | static const char * |
|
|
5383 | procname (pointer x) |
|
|
5384 | { |
|
|
5385 | return opname (procnum (x)); |
|
|
5386 | } |
5360 | |
5387 | |
5361 | typedef struct |
5388 | typedef 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 | |
|
|
5372 | static op_code_info dispatch_table[] = { |
5398 | static 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 | |
|
|
5378 | static const char * |
|
|
5379 | procname (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 */ |
5391 | static void |
5406 | static void |
5392 | Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) |
5407 | Eval_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; |
|
|
5404 | char msg[STRBUFFSIZE]; |
5418 | char msg[STRBUFFSIZE]; |
5405 | int n = list_length (SCHEME_A_ SCHEME_V->args); |
5419 | int n = list_length (SCHEME_A_ SCHEME_V->args); |
5406 | |
5420 | |
5407 | /* Check number of arguments */ |
5421 | /* Check number of arguments */ |
5408 | if (ecb_expect_false (n < pcd->min_arity)) |
5422 | if (ecb_expect_false (n < pcd->min_arity)) |
5409 | { |
5423 | { |
5410 | ok = 0; |
|
|
5411 | snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", |
5424 | snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", |
5412 | pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); |
5425 | opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); |
|
|
5426 | xError_1 (SCHEME_A_ msg, 0); |
|
|
5427 | continue; |
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; |
|
|
5417 | snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", |
5431 | snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", |
5418 | pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); |
5432 | opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); |
|
|
5433 | xError_1 (SCHEME_A_ msg, 0); |
|
|
5434 | continue; |
5419 | } |
5435 | } |
5420 | |
5436 | else |
5421 | if (ecb_expect_false (ok)) |
|
|
5422 | { |
5437 | { |
5423 | if (pcd->arg_tests_encoding) |
5438 | if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */ |
5424 | { |
5439 | { |
5425 | int i = 0; |
5440 | int i = 0; |
5426 | int j; |
5441 | int j; |
5427 | const char *t = pcd->arg_tests_encoding; |
5442 | const char *t = pcd->arg_tests_encoding; |
5428 | pointer arglist = SCHEME_V->args; |
5443 | pointer arglist = SCHEME_V->args; |
5429 | |
5444 | |
5430 | do |
5445 | do |
5431 | { |
5446 | { |
5432 | pointer arg = car (arglist); |
5447 | pointer arg = car (arglist); |
5433 | |
5448 | |
5434 | j = (int) t[0]; |
5449 | j = t[0]; |
5435 | |
5450 | |
5436 | if (j == TST_LIST[0]) |
5451 | if (!tests[j - 1].fct (arg)) |
5437 | { |
|
|
5438 | if (arg != NIL && !is_pair (arg)) |
|
|
5439 | break; |
5452 | break; |
5440 | } |
|
|
5441 | else |
|
|
5442 | { |
|
|
5443 | if (!tests[j].fct (arg)) |
|
|
5444 | break; |
|
|
5445 | } |
|
|
5446 | |
5453 | |
5447 | if (t[1] != 0) /* last test is replicated as necessary */ |
5454 | if (t[1]) /* last test is replicated as necessary */ |
5448 | t++; |
5455 | t++; |
5449 | |
5456 | |
5450 | arglist = cdr (arglist); |
5457 | arglist = cdr (arglist); |
5451 | i++; |
5458 | i++; |
5452 | } |
5459 | } |
5453 | while (i < n); |
5460 | while (i < n); |
5454 | |
5461 | |
5455 | if (i < n) |
5462 | if (i < n) |
5456 | { |
5463 | { |
5457 | 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); |
|
|
5465 | xError_1 (SCHEME_A_ msg, 0); |
|
|
5466 | continue; |
5459 | } |
5467 | } |
5460 | } |
5468 | } |
5461 | } |
5469 | } |
5462 | |
|
|
5463 | if (!ok) |
|
|
5464 | { |
|
|
5465 | if (xError_1 (SCHEME_A_ msg, 0) == NIL) |
|
|
5466 | return; |
|
|
5467 | |
|
|
5468 | pcd = dispatch_table + SCHEME_V->op; |
|
|
5469 | } |
|
|
5470 | } |
5470 | } |
5471 | #endif |
5471 | #endif |
5472 | |
5472 | |
5473 | ok_to_freely_gc (SCHEME_A); |
5473 | ok_to_freely_gc (SCHEME_A); |
5474 | |
5474 | |
|
|
5475 | static const dispatch_func dispatch_funcs[] = { |
|
|
5476 | opexe_0, |
|
|
5477 | opexe_1, |
|
|
5478 | opexe_2, |
|
|
5479 | opexe_3, |
|
|
5480 | opexe_4, |
|
|
5481 | opexe_5, |
|
|
5482 | opexe_6, |
|
|
5483 | }; |
|
|
5484 | |
5475 | if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)) |
5485 | if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) |
5476 | return; |
5486 | return; |
5477 | |
5487 | |
5478 | if (SCHEME_V->no_memory && USE_ERROR_CHECKING) |
5488 | if (SCHEME_V->no_memory && USE_ERROR_CHECKING) |
5479 | { |
5489 | { |
5480 | xwrstr ("No memory!\n"); |
5490 | xwrstr ("No memory!\n"); |
… | |
… | |
5677 | |
5687 | |
5678 | for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) |
5688 | for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) |
5679 | assign_syntax (SCHEME_A_ syntax_names[i]); |
5689 | assign_syntax (SCHEME_A_ syntax_names[i]); |
5680 | } |
5690 | } |
5681 | |
5691 | |
|
|
5692 | // TODO: should iterate via strlen, to avoid n² complexity |
5682 | for (i = 0; i < n; i++) |
5693 | for (i = 0; i < n; i++) |
5683 | if (dispatch_table[i].name != 0) |
5694 | if (dispatch_table[i].builtin) |
5684 | assign_proc (SCHEME_A_ i, dispatch_table[i].name); |
5695 | assign_proc (SCHEME_A_ i, opname (i)); |
5685 | |
5696 | |
5686 | /* initialization of global pointers to special symbols */ |
5697 | /* initialization of global pointers to special symbols */ |
5687 | SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); |
5698 | SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); |
5688 | SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); |
5699 | SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); |
5689 | SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); |
5700 | SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); |