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.27 by root, Sat Nov 28 05:13:08 2015 UTC vs.
Revision 1.28 by root, Sat Nov 28 08:09:04 2015 UTC

… …
270 return type (p) == T_VECTOR; 270 return type (p) == T_VECTOR;
271} 271}
272 272
273#define vecvalue(p) ((p)->object.vector.vvalue) 273#define vecvalue(p) ((p)->object.vector.vvalue)
274#define veclength(p) ((p)->object.vector.length) 274#define veclength(p) ((p)->object.vector.length)
275INTERFACE void fill_vector (pointer vec, pointer obj); 275INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
276INTERFACE uint32_t vector_length (pointer vec);
277INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 276INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
278INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 277INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
279
280INTERFACE uint32_t
281vector_length (pointer vec)
282{
283 return vec->object.vector.length;
284}
285 278
286INTERFACE int 279INTERFACE int
287is_integer (pointer p) 280is_integer (pointer p)
288{ 281{
289 return type (p) == T_INTEGER; 282 return type (p) == T_INTEGER;
… …
928 return k; 921 return k;
929 922
930 i = ++SCHEME_V->last_cell_seg; 923 i = ++SCHEME_V->last_cell_seg;
931 SCHEME_V->alloc_seg[i] = cp; 924 SCHEME_V->alloc_seg[i] = cp;
932 925
933 /* insert new segment in address order */
934 newp = (pointer)cp; 926 newp = (pointer)cp;
935 SCHEME_V->cell_seg[i] = newp; 927 SCHEME_V->cell_seg[i] = newp;
936 SCHEME_V->cell_segsize[i] = segsize; 928 SCHEME_V->cell_segsize[i] = segsize;
937
938 //TODO: insert, not swap
939 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
940 {
941 p = SCHEME_V->cell_seg[i];
942 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
943 SCHEME_V->cell_seg[i - 1] = p;
944
945 k = SCHEME_V->cell_segsize[i];
946 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
947 SCHEME_V->cell_segsize[i - 1] = k;
948
949 --i;
950 }
951
952 SCHEME_V->fcells += segsize; 929 SCHEME_V->fcells += segsize;
953 last = newp + segsize - 1; 930 last = newp + segsize - 1;
954 931
955 for (p = newp; p <= last; p++) 932 for (p = newp; p <= last; p++)
956 { 933 {
957 set_typeflag (p, T_PAIR); 934 set_typeflag (p, T_PAIR);
958 set_car (p, NIL); 935 set_car (p, NIL);
959 set_cdr (p, p + 1); 936 set_cdr (p, p + 1);
960 } 937 }
961 938
962 /* insert new cells in address order on free list */
963 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
964 {
965 set_cdr (last, SCHEME_V->free_cell); 939 set_cdr (last, SCHEME_V->free_cell);
966 SCHEME_V->free_cell = newp; 940 SCHEME_V->free_cell = newp;
967 }
968 else
969 {
970 p = SCHEME_V->free_cell;
971
972 while (cdr (p) != NIL && newp > cdr (p))
973 p = cdr (p);
974
975 set_cdr (last, cdr (p));
976 set_cdr (p, newp);
977 }
978 } 941 }
979 942
980 return n; 943 return n;
981} 944}
982 945
… …
1061 /* Record it as a vector so that gc understands it. */ 1024 /* Record it as a vector so that gc understands it. */
1062 set_typeflag (v, T_VECTOR | T_ATOM); 1025 set_typeflag (v, T_VECTOR | T_ATOM);
1063 1026
1064 v->object.vector.vvalue = e; 1027 v->object.vector.vvalue = e;
1065 v->object.vector.length = len; 1028 v->object.vector.length = len;
1066 fill_vector (v, init); 1029 fill_vector (v, 0, init);
1067 push_recent_alloc (SCHEME_A_ v, NIL); 1030 push_recent_alloc (SCHEME_A_ v, NIL);
1068 1031
1069 return v; 1032 return v;
1070} 1033}
1071 1034
… …
1137 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1100 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1138 set_typeflag (x, T_SYMBOL); 1101 set_typeflag (x, T_SYMBOL);
1139 setimmutable (car (x)); 1102 setimmutable (car (x));
1140 1103
1141 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1104 location = hash_fn (name, veclength (SCHEME_V->oblist));
1142 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1105 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1143 return x; 1106 return x;
1144} 1107}
1145 1108
1146ecb_inline pointer 1109ecb_inline pointer
1147oblist_find_by_name (SCHEME_P_ const char *name) 1110oblist_find_by_name (SCHEME_P_ const char *name)
… …
1150 pointer x; 1113 pointer x;
1151 char *s; 1114 char *s;
1152 1115
1153 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1116 location = hash_fn (name, veclength (SCHEME_V->oblist));
1154 1117
1155 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1118 for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1156 { 1119 {
1157 s = symname (car (x)); 1120 s = symname (car (x));
1158 1121
1159 /* case-insensitive, per R5RS section 2 */ 1122 /* case-insensitive, per R5RS section 2 */
1160 if (stricmp (name, s) == 0) 1123 if (stricmp (name, s) == 0)
… …
1170 int i; 1133 int i;
1171 pointer x; 1134 pointer x;
1172 pointer ob_list = NIL; 1135 pointer ob_list = NIL;
1173 1136
1174 for (i = 0; i < veclength (SCHEME_V->oblist); i++) 1137 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1175 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1138 for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1176 ob_list = cons (x, ob_list); 1139 ob_list = cons (x, ob_list);
1177 1140
1178 return ob_list; 1141 return ob_list;
1179} 1142}
1180 1143
… …
1363{ 1326{
1364 return get_vector_object (SCHEME_A_ len, NIL); 1327 return get_vector_object (SCHEME_A_ len, NIL);
1365} 1328}
1366 1329
1367INTERFACE void 1330INTERFACE void
1368fill_vector (pointer vec, pointer obj) 1331fill_vector (pointer vec, uint32_t start, pointer obj)
1369{ 1332{
1370 int i; 1333 int i;
1371 1334
1372 for (i = 0; i < vec->object.vector.length; i++) 1335 for (i = start; i < veclength (vec); i++)
1373 vecvalue (vec)[i] = obj; 1336 vecvalue (vec)[i] = obj;
1374} 1337}
1375 1338
1376INTERFACE pointer 1339INTERFACE pointer
1377vector_elem (pointer vec, uint32_t ielem) 1340vector_get (pointer vec, uint32_t ielem)
1378{ 1341{
1379 return vecvalue(vec)[ielem]; 1342 return vecvalue(vec)[ielem];
1380} 1343}
1381 1344
1382INTERFACE void 1345INTERFACE void
1383set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1346vector_set (pointer vec, uint32_t ielem, pointer a)
1384{ 1347{
1385 vecvalue(vec)[ielem] = a; 1348 vecvalue(vec)[ielem] = a;
1386} 1349}
1387 1350
1388/* get new symbol */ 1351/* get new symbol */
… …
1578 1541
1579 if (ecb_expect_false (is_vector (p))) 1542 if (ecb_expect_false (is_vector (p)))
1580 { 1543 {
1581 int i; 1544 int i;
1582 1545
1583 for (i = 0; i < p->object.vector.length; i++) 1546 for (i = 0; i < veclength (p); i++)
1584 mark (vecvalue (p)[i]); 1547 mark (vecvalue (p)[i]);
1585 } 1548 }
1586 1549
1587 if (is_atom (p)) 1550 if (is_atom (p))
1588 goto E6; 1551 goto E6;
… …
2899 2862
2900 if (is_vector (car (env))) 2863 if (is_vector (car (env)))
2901 { 2864 {
2902 int location = hash_fn (symname (variable), veclength (car (env))); 2865 int location = hash_fn (symname (variable), veclength (car (env)));
2903 2866
2904 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2867 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2905 } 2868 }
2906 else 2869 else
2907 set_car (env, immutable_cons (slot, car (env))); 2870 set_car (env, immutable_cons (slot, car (env)));
2908} 2871}
2909 2872
… …
2916 for (x = env; x != NIL; x = cdr (x)) 2879 for (x = env; x != NIL; x = cdr (x))
2917 { 2880 {
2918 if (is_vector (car (x))) 2881 if (is_vector (car (x)))
2919 { 2882 {
2920 location = hash_fn (symname (hdl), veclength (car (x))); 2883 location = hash_fn (symname (hdl), veclength (car (x)));
2921 y = vector_elem (car (x), location); 2884 y = vector_get (car (x), location);
2922 } 2885 }
2923 else 2886 else
2924 y = car (x); 2887 y = car (x);
2925 2888
2926 for (; y != NIL; y = cdr (y)) 2889 for (; y != NIL; y = cdr (y))
… …
4401 if (SCHEME_V->no_memory) 4364 if (SCHEME_V->no_memory)
4402 s_return (S_SINK); 4365 s_return (S_SINK);
4403#endif 4366#endif
4404 4367
4405 for (x = args, i = 0; is_pair (x); x = cdr (x), i++) 4368 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4406 set_vector_elem (vec, i, car (x)); 4369 vector_set (vec, i, car (x));
4407 4370
4408 s_return (vec); 4371 s_return (vec);
4409 } 4372 }
4410 4373
4411 case OP_MKVECTOR: /* make-vector */ 4374 case OP_MKVECTOR: /* make-vector */
… …
4423 if (SCHEME_V->no_memory) 4386 if (SCHEME_V->no_memory)
4424 s_return (S_SINK); 4387 s_return (S_SINK);
4425#endif 4388#endif
4426 4389
4427 if (fill != NIL) 4390 if (fill != NIL)
4428 fill_vector (vec, fill); 4391 fill_vector (vec, 0, fill);
4429 4392
4430 s_return (vec); 4393 s_return (vec);
4431 } 4394 }
4432 4395
4433 case OP_VECLEN: /* vector-length */ 4396 case OP_VECLEN: /* vector-length */
… …
4438 int index = ivalue_unchecked (cadr (args)); 4401 int index = ivalue_unchecked (cadr (args));
4439 4402
4440 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4403 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4441 Error_1 ("vector-ref: out of bounds:", cadr (args)); 4404 Error_1 ("vector-ref: out of bounds:", cadr (args));
4442 4405
4443 s_return (vector_elem (x, index)); 4406 s_return (vector_get (x, index));
4444 } 4407 }
4445 4408
4446 case OP_VECSET: /* vector-set! */ 4409 case OP_VECSET: /* vector-set! */
4447 { 4410 {
4448 int index = ivalue_unchecked (cadr (args)); 4411 int index = ivalue_unchecked (cadr (args));
… …
4451 Error_1 ("vector-set!: unable to alter immutable vector:", x); 4414 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4452 4415
4453 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4416 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4454 Error_1 ("vector-set!: out of bounds:", cadr (args)); 4417 Error_1 ("vector-set!: out of bounds:", cadr (args));
4455 4418
4456 set_vector_elem (x, index, caddr (args)); 4419 vector_set (x, index, caddr (args));
4457 s_return (x); 4420 s_return (x);
4458 } 4421 }
4459 } 4422 }
4460 4423
4461 if (USE_ERROR_CHECKING) abort (); 4424 if (USE_ERROR_CHECKING) abort ();
… …
5182 putstr (SCHEME_A_ ")"); 5145 putstr (SCHEME_A_ ")");
5183 s_return (S_T); 5146 s_return (S_T);
5184 } 5147 }
5185 else 5148 else
5186 { 5149 {
5187 pointer elem = vector_elem (vec, i); 5150 pointer elem = vector_get (vec, i);
5188 5151
5189 ivalue_unchecked (cdr (args)) = i + 1; 5152 ivalue_unchecked (cdr (args)) = i + 1;
5190 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5153 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5191 SCHEME_V->args = elem; 5154 SCHEME_V->args = elem;
5192 5155
… …
5430 { 5393 {
5431 if (!tests[j - 1].fct (arg)) 5394 if (!tests[j - 1].fct (arg))
5432 break; 5395 break;
5433 } 5396 }
5434 5397
5435 if (t[1]) /* last test is replicated as necessary */ 5398 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5436 t++; 5399 t++;
5437 5400
5438 arglist = cdr (arglist); 5401 arglist = cdr (arglist);
5439 i++; 5402 i++;
5440 } 5403 }

Diff Legend

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