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

Comparing microscheme/scheme.c (file contents):
Revision 1.17 by root, Thu Nov 26 10:15:51 2015 UTC vs.
Revision 1.18 by root, Thu Nov 26 21:32:16 2015 UTC

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

Diff Legend

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