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.19 by root, Thu Nov 26 21:36:11 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}
… …
3413 /* fall through */ 3414 /* fall through */
3414 3415
3415 case OP_REAL_APPLY: 3416 case OP_REAL_APPLY:
3416#endif 3417#endif
3417 if (is_proc (SCHEME_V->code)) 3418 if (is_proc (SCHEME_V->code))
3418 {
3419 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3419 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3420 }
3421 else if (is_foreign (SCHEME_V->code)) 3420 else if (is_foreign (SCHEME_V->code))
3422 { 3421 {
3423 /* Keep nested calls from GC'ing the arglist */ 3422 /* Keep nested calls from GC'ing the arglist */
3424 push_recent_alloc (SCHEME_A_ args, NIL); 3423 push_recent_alloc (SCHEME_A_ args, NIL);
3425 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3424 x = SCHEME_V->code->object.ff (SCHEME_A_ args);
… …
3592 3591
3593 case OP_IF1: /* if */ 3592 case OP_IF1: /* if */
3594 if (is_true (SCHEME_V->value)) 3593 if (is_true (SCHEME_V->value))
3595 SCHEME_V->code = car (SCHEME_V->code); 3594 SCHEME_V->code = car (SCHEME_V->code);
3596 else 3595 else
3597 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because 3596 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3598
3599 * car(NIL) = NIL */
3600 s_goto (OP_EVAL); 3597 s_goto (OP_EVAL);
3601 3598
3602 case OP_LET0: /* let */ 3599 case OP_LET0: /* let */
3603 SCHEME_V->args = NIL; 3600 SCHEME_V->args = NIL;
3604 SCHEME_V->value = SCHEME_V->code; 3601 SCHEME_V->value = SCHEME_V->code;
… …
4894} 4891}
4895 4892
4896static pointer 4893static pointer
4897opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4894opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4898{ 4895{
4896 pointer args = SCHEME_V->args;
4899 pointer x; 4897 pointer x;
4900 4898
4901 if (SCHEME_V->nesting != 0) 4899 if (SCHEME_V->nesting != 0)
4902 { 4900 {
4903 int n = SCHEME_V->nesting; 4901 int n = SCHEME_V->nesting;
… …
4910 switch (op) 4908 switch (op)
4911 { 4909 {
4912 /* ========== reading part ========== */ 4910 /* ========== reading part ========== */
4913#if USE_PORTS 4911#if USE_PORTS
4914 case OP_READ: 4912 case OP_READ:
4915 if (!is_pair (SCHEME_V->args)) 4913 if (!is_pair (args))
4916 s_goto (OP_READ_INTERNAL); 4914 s_goto (OP_READ_INTERNAL);
4917 4915
4918 if (!is_inport (car (SCHEME_V->args))) 4916 if (!is_inport (car (args)))
4919 Error_1 ("read: not an input port:", car (SCHEME_V->args)); 4917 Error_1 ("read: not an input port:", car (args));
4920 4918
4921 if (car (SCHEME_V->args) == SCHEME_V->inport) 4919 if (car (args) == SCHEME_V->inport)
4922 s_goto (OP_READ_INTERNAL); 4920 s_goto (OP_READ_INTERNAL);
4923 4921
4924 x = SCHEME_V->inport; 4922 x = SCHEME_V->inport;
4925 SCHEME_V->inport = car (SCHEME_V->args); 4923 SCHEME_V->inport = car (args);
4926 x = cons (x, NIL); 4924 x = cons (x, NIL);
4927 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4925 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4928 s_goto (OP_READ_INTERNAL); 4926 s_goto (OP_READ_INTERNAL);
4929 4927
4930 case OP_READ_CHAR: /* read-char */ 4928 case OP_READ_CHAR: /* read-char */
4931 case OP_PEEK_CHAR: /* peek-char */ 4929 case OP_PEEK_CHAR: /* peek-char */
4932 { 4930 {
4933 int c; 4931 int c;
4934 4932
4935 if (is_pair (SCHEME_V->args)) 4933 if (is_pair (args))
4936 { 4934 {
4937 if (car (SCHEME_V->args) != SCHEME_V->inport) 4935 if (car (args) != SCHEME_V->inport)
4938 { 4936 {
4939 x = SCHEME_V->inport; 4937 x = SCHEME_V->inport;
4940 x = cons (x, NIL); 4938 x = cons (x, NIL);
4941 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4939 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4942 SCHEME_V->inport = car (SCHEME_V->args); 4940 SCHEME_V->inport = car (args);
4943 } 4941 }
4944 } 4942 }
4945 4943
4946 c = inchar (SCHEME_A); 4944 c = inchar (SCHEME_A);
4947 4945
… …
4957 case OP_CHAR_READY: /* char-ready? */ 4955 case OP_CHAR_READY: /* char-ready? */
4958 { 4956 {
4959 pointer p = SCHEME_V->inport; 4957 pointer p = SCHEME_V->inport;
4960 int res; 4958 int res;
4961 4959
4962 if (is_pair (SCHEME_V->args)) 4960 if (is_pair (args))
4963 p = car (SCHEME_V->args); 4961 p = car (args);
4964 4962
4965 res = p->object.port->kind & port_string; 4963 res = p->object.port->kind & port_string;
4966 4964
4967 s_retbool (res); 4965 s_retbool (res);
4968 } 4966 }
4969 4967
4970 case OP_SET_INPORT: /* set-input-port */ 4968 case OP_SET_INPORT: /* set-input-port */
4971 SCHEME_V->inport = car (SCHEME_V->args); 4969 SCHEME_V->inport = car (args);
4972 s_return (SCHEME_V->value); 4970 s_return (SCHEME_V->value);
4973 4971
4974 case OP_SET_OUTPORT: /* set-output-port */ 4972 case OP_SET_OUTPORT: /* set-output-port */
4975 SCHEME_V->outport = car (SCHEME_V->args); 4973 SCHEME_V->outport = car (args);
4976 s_return (SCHEME_V->value); 4974 s_return (SCHEME_V->value);
4977#endif 4975#endif
4978 4976
4979 case OP_RDSEXPR: 4977 case OP_RDSEXPR:
4980 switch (SCHEME_V->tok) 4978 switch (SCHEME_V->tok)
… …
5066 } 5064 }
5067 5065
5068 break; 5066 break;
5069 5067
5070 case OP_RDLIST: 5068 case OP_RDLIST:
5071 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 5069 SCHEME_V->args = cons (SCHEME_V->value, args);
5072 SCHEME_V->tok = token (SCHEME_A); 5070 SCHEME_V->tok = token (SCHEME_A);
5073 5071
5074 switch (SCHEME_V->tok) 5072 switch (SCHEME_V->tok)
5075 { 5073 {
5076 case TOK_EOF: 5074 case TOK_EOF:
… …
5104 case OP_RDDOT: 5102 case OP_RDDOT:
5105 if (token (SCHEME_A) != TOK_RPAREN) 5103 if (token (SCHEME_A) != TOK_RPAREN)
5106 Error_0 ("syntax error: illegal dot expression"); 5104 Error_0 ("syntax error: illegal dot expression");
5107 5105
5108 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5106 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5109 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); 5107 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5110 5108
5111 case OP_RDQUOTE: 5109 case OP_RDQUOTE:
5112 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); 5110 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5113 5111
5114 case OP_RDQQUOTE: 5112 case OP_RDQQUOTE:
… …
5136 SCHEME_V->args = SCHEME_V->value; 5134 SCHEME_V->args = SCHEME_V->value;
5137 s_goto (OP_VECTOR); 5135 s_goto (OP_VECTOR);
5138 5136
5139 /* ========== printing part ========== */ 5137 /* ========== printing part ========== */
5140 case OP_P0LIST: 5138 case OP_P0LIST:
5141 if (is_vector (SCHEME_V->args)) 5139 if (is_vector (args))
5142 { 5140 {
5143 putstr (SCHEME_A_ "#("); 5141 putstr (SCHEME_A_ "#(");
5144 SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); 5142 SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5145 s_goto (OP_PVECFROM); 5143 s_goto (OP_PVECFROM);
5146 } 5144 }
5147 else if (is_environment (SCHEME_V->args)) 5145 else if (is_environment (args))
5148 { 5146 {
5149 putstr (SCHEME_A_ "#<ENVIRONMENT>"); 5147 putstr (SCHEME_A_ "#<ENVIRONMENT>");
5150 s_return (S_T); 5148 s_return (S_T);
5151 } 5149 }
5152 else if (!is_pair (SCHEME_V->args)) 5150 else if (!is_pair (args))
5153 { 5151 {
5154 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5152 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5155 s_return (S_T); 5153 s_return (S_T);
5156 } 5154 }
5157 else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5155 else
5158 { 5156 {
5157 pointer a = car (args);
5158 pointer b = cdr (args);
5159 int ok_abbr = ok_abbrev (b);
5160 SCHEME_V->args = car (b);
5161
5162 if (a == SCHEME_V->QUOTE && ok_abbr)
5159 putstr (SCHEME_A_ "'"); 5163 putstr (SCHEME_A_ "'");
5160 SCHEME_V->args = cadr (SCHEME_V->args); 5164 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5165 putstr (SCHEME_A_ "`");
5166 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5167 putstr (SCHEME_A_ ",");
5168 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5169 putstr (SCHEME_A_ ",@");
5170 else
5171 {
5172 putstr (SCHEME_A_ "(");
5173 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5174 SCHEME_V->args = a;
5175 }
5176
5161 s_goto (OP_P0LIST); 5177 s_goto (OP_P0LIST);
5162 } 5178 }
5163 else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5179
5180 case OP_P1LIST:
5181 if (is_pair (args))
5164 { 5182 {
5183 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5165 putstr (SCHEME_A_ "`"); 5184 putstr (SCHEME_A_ " ");
5166 SCHEME_V->args = cadr (SCHEME_V->args); 5185 SCHEME_V->args = car (args);
5167 s_goto (OP_P0LIST); 5186 s_goto (OP_P0LIST);
5168 } 5187 }
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)) 5188 else if (is_vector (args))
5198 { 5189 {
5199 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); 5190 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5200 putstr (SCHEME_A_ " . "); 5191 putstr (SCHEME_A_ " . ");
5201 s_goto (OP_P0LIST); 5192 s_goto (OP_P0LIST);
5202 } 5193 }
5203 else 5194 else
5204 { 5195 {
5205 if (SCHEME_V->args != NIL) 5196 if (args != NIL)
5206 { 5197 {
5207 putstr (SCHEME_A_ " . "); 5198 putstr (SCHEME_A_ " . ");
5208 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5199 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5209 } 5200 }
5210 5201
5211 putstr (SCHEME_A_ ")"); 5202 putstr (SCHEME_A_ ")");
5212 s_return (S_T); 5203 s_return (S_T);
5213 } 5204 }
5214 5205
5215 case OP_PVECFROM: 5206 case OP_PVECFROM:
5216 { 5207 {
5217 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5208 int i = ivalue_unchecked (cdr (args));
5218 pointer vec = car (SCHEME_V->args); 5209 pointer vec = car (args);
5219 int len = veclength (vec); 5210 int len = veclength (vec);
5220 5211
5221 if (i == len) 5212 if (i == len)
5222 { 5213 {
5223 putstr (SCHEME_A_ ")"); 5214 putstr (SCHEME_A_ ")");
… …
5225 } 5216 }
5226 else 5217 else
5227 { 5218 {
5228 pointer elem = vector_elem (vec, i); 5219 pointer elem = vector_elem (vec, i);
5229 5220
5230 ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; 5221 ivalue_unchecked (cdr (args)) = i + 1;
5231 s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); 5222 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5232 SCHEME_V->args = elem; 5223 SCHEME_V->args = elem;
5233 5224
5234 if (i > 0) 5225 if (i > 0)
5235 putstr (SCHEME_A_ " "); 5226 putstr (SCHEME_A_ " ");
5236 5227
… …
5243} 5234}
5244 5235
5245static pointer 5236static pointer
5246opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5237opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5247{ 5238{
5239 pointer args = SCHEME_V->args;
5240 pointer a = car (args);
5248 pointer x, y; 5241 pointer x, y;
5249 5242
5250 switch (op) 5243 switch (op)
5251 { 5244 {
5252 case OP_LIST_LENGTH: /* length *//* a.k */ 5245 case OP_LIST_LENGTH: /* length *//* a.k */
5253 { 5246 {
5254 long v = list_length (SCHEME_A_ car (SCHEME_V->args)); 5247 long v = list_length (SCHEME_A_ a);
5255 5248
5256 if (v < 0) 5249 if (v < 0)
5257 Error_1 ("length: not a list:", car (SCHEME_V->args)); 5250 Error_1 ("length: not a list:", a);
5258 5251
5259 s_return (mk_integer (SCHEME_A_ v)); 5252 s_return (mk_integer (SCHEME_A_ v));
5260 } 5253 }
5261 5254
5262 case OP_ASSQ: /* assq *//* a.k */ 5255 case OP_ASSQ: /* assq *//* a.k */
5263 x = car (SCHEME_V->args); 5256 x = a;
5264 5257
5265 for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) 5258 for (y = cadr (args); is_pair (y); y = cdr (y))
5266 { 5259 {
5267 if (!is_pair (car (y))) 5260 if (!is_pair (car (y)))
5268 Error_0 ("unable to handle non pair element"); 5261 Error_0 ("unable to handle non pair element");
5269 5262
5270 if (x == caar (y)) 5263 if (x == caar (y))
… …
5276 else 5269 else
5277 s_return (S_F); 5270 s_return (S_F);
5278 5271
5279 5272
5280 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5273 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5281 SCHEME_V->args = car (SCHEME_V->args); 5274 SCHEME_V->args = a;
5282 5275
5283 if (SCHEME_V->args == NIL) 5276 if (SCHEME_V->args == NIL)
5284 s_return (S_F); 5277 s_return (S_F);
5285 else if (is_closure (SCHEME_V->args)) 5278 else if (is_closure (SCHEME_V->args))
5286 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5279 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
… …
5292 case OP_CLOSUREP: /* closure? */ 5285 case OP_CLOSUREP: /* closure? */
5293 /* 5286 /*
5294 * Note, macro object is also a closure. 5287 * Note, macro object is also a closure.
5295 * Therefore, (closure? <#MACRO>) ==> #t 5288 * Therefore, (closure? <#MACRO>) ==> #t
5296 */ 5289 */
5297 s_retbool (is_closure (car (SCHEME_V->args))); 5290 s_retbool (is_closure (a));
5298 5291
5299 case OP_MACROP: /* macro? */ 5292 case OP_MACROP: /* macro? */
5300 s_retbool (is_macro (car (SCHEME_V->args))); 5293 s_retbool (is_macro (a));
5301 } 5294 }
5302 5295
5303 abort (); 5296 abort ();
5304} 5297}
5305 5298
5306typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5299typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5307 5300
5308typedef int (*test_predicate) (pointer); 5301typedef int (*test_predicate)(pointer);
5309static int 5302static int
5310is_any (pointer p) 5303is_any (pointer p)
5311{ 5304{
5312 return 1; 5305 return 1;
5313} 5306}
5314 5307
5315static int 5308static int
5316is_nonneg (pointer p) 5309is_nonneg (pointer p)
5317{ 5310{
5318 return ivalue (p) >= 0 && is_integer (p); 5311 return ivalue (p) >= 0 && is_integer (p);
5312}
5313
5314static int
5315tst_is_list (pointer p)
5316{
5317 return p == NIL || is_pair (p);
5319} 5318}
5320 5319
5321/* Correspond carefully with following defines! */ 5320/* Correspond carefully with following defines! */
5322static struct 5321static struct
5323{ 5322{
5324 test_predicate fct; 5323 test_predicate fct;
5325 const char *kind; 5324 const char *kind;
5326} tests[] = 5325} tests[] =
5327{ 5326{
5328 { 0, 0}, /* unused */ 5327 { is_any, 0 },
5329 { is_any, 0}, 5328 { is_string, "string" },
5330 { is_string, "string" }, 5329 { is_symbol, "symbol" },
5331 { is_symbol, "symbol" }, 5330 { is_port, "port" },
5332 { is_port, "port" },
5333 { is_inport, "input port" }, 5331 { is_inport, "input port" },
5334 { is_outport, "output port" }, 5332 { is_outport, "output port" },
5335 { is_environment, "environment" }, 5333 { is_environment, "environment" },
5336 { is_pair, "pair" }, 5334 { is_pair, "pair" },
5337 { 0, "pair or '()" }, 5335 { tst_is_list, "pair or '()" },
5338 { is_character, "character" }, 5336 { is_character, "character" },
5339 { is_vector, "vector" }, 5337 { is_vector, "vector" },
5340 { is_number, "number" }, 5338 { is_number, "number" },
5341 { is_integer, "integer" }, 5339 { is_integer, "integer" },
5342 { is_nonneg, "non-negative integer" } 5340 { is_nonneg, "non-negative integer" }
5343}; 5341};
5344 5342
5345#define TST_NONE 0 5343#define TST_NONE 0 /* TST_NONE used for standard procedures, for internal ops, 0 is used */
5346#define TST_ANY "\001" 5344#define TST_ANY "\001"
5347#define TST_STRING "\002" 5345#define TST_STRING "\002"
5348#define TST_SYMBOL "\003" 5346#define TST_SYMBOL "\003"
5349#define TST_PORT "\004" 5347#define TST_PORT "\004"
5350#define TST_INPORT "\005" 5348#define TST_INPORT "\005"
5351#define TST_OUTPORT "\006" 5349#define TST_OUTPORT "\006"
5352#define TST_ENVIRONMENT "\007" 5350#define TST_ENVIRONMENT "\007"
5353#define TST_PAIR "\010" 5351#define TST_PAIR "\010"
5354#define TST_LIST "\011" 5352#define TST_LIST "\011"
5355#define TST_CHAR "\012" 5353#define TST_CHAR "\012"
5356#define TST_VECTOR "\013" 5354#define TST_VECTOR "\013"
5357#define TST_NUMBER "\014" 5355#define TST_NUMBER "\014"
5358#define TST_INTEGER "\015" 5356#define TST_INTEGER "\015"
5359#define TST_NATURAL "\016" 5357#define TST_NATURAL "\016"
5360 5358
5361typedef struct 5359typedef struct
5362{ 5360{
5363 dispatch_func func; 5361 dispatch_func func;
5364 char *name; 5362 char *name;
5365 int min_arity; 5363 int min_arity;
5366 int max_arity; 5364 int max_arity;
5367 char *arg_tests_encoding; 5365 char arg_tests_encoding[3];
5368} op_code_info; 5366} op_code_info;
5369 5367
5370#define INF_ARG 0xffff 5368#define INF_ARG 0xffff
5371 5369
5372static op_code_info dispatch_table[] = { 5370static op_code_info dispatch_table[] = {
5373#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, 5371#define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest },
5374#include "opdefines.h" 5372#include "opdefines.h"
5373#undef OP_DEF
5375 {0} 5374 {0}
5376}; 5375};
5377 5376
5378static const char * 5377static const char *
5379procname (pointer x) 5378procname (pointer x)
… …
5418 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5417 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5419 } 5418 }
5420 5419
5421 if (ecb_expect_false (ok)) 5420 if (ecb_expect_false (ok))
5422 { 5421 {
5423 if (pcd->arg_tests_encoding) 5422 if (*pcd->arg_tests_encoding)
5424 { 5423 {
5425 int i = 0; 5424 int i = 0;
5426 int j; 5425 int j;
5427 const char *t = pcd->arg_tests_encoding; 5426 const char *t = pcd->arg_tests_encoding;
5428 pointer arglist = SCHEME_V->args; 5427 pointer arglist = SCHEME_V->args;
5429 5428
5430 do 5429 do
5431 { 5430 {
5432 pointer arg = car (arglist); 5431 pointer arg = car (arglist);
5433 5432
5434 j = (int) t[0]; 5433 j = t[0];
5435 5434
5436 if (j == TST_LIST[0]) 5435 if (!tests[j - 1].fct (arg))
5437 {
5438 if (arg != NIL && !is_pair (arg))
5439 break; 5436 break;
5440 }
5441 else
5442 {
5443 if (!tests[j].fct (arg))
5444 break;
5445 }
5446 5437
5447 if (t[1] != 0) /* last test is replicated as necessary */ 5438 if (t[1]) /* last test is replicated as necessary */
5448 t++; 5439 t++;
5449 5440
5450 arglist = cdr (arglist); 5441 arglist = cdr (arglist);
5451 i++; 5442 i++;
5452 } 5443 }

Diff Legend

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