… | |
… | |
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) |
275 | INTERFACE void fill_vector (pointer vec, pointer obj); |
275 | INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); |
276 | INTERFACE uint32_t vector_length (pointer vec); |
|
|
277 | INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); |
276 | INTERFACE pointer vector_get (pointer vec, uint32_t ielem); |
278 | INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); |
277 | INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); |
279 | |
|
|
280 | INTERFACE uint32_t |
|
|
281 | vector_length (pointer vec) |
|
|
282 | { |
|
|
283 | return vec->object.vector.length; |
|
|
284 | } |
|
|
285 | |
278 | |
286 | INTERFACE int |
279 | INTERFACE int |
287 | is_integer (pointer p) |
280 | is_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 | |
1146 | ecb_inline pointer |
1109 | ecb_inline pointer |
1147 | oblist_find_by_name (SCHEME_P_ const char *name) |
1110 | oblist_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 | |
1367 | INTERFACE void |
1330 | INTERFACE void |
1368 | fill_vector (pointer vec, pointer obj) |
1331 | fill_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 | |
1376 | INTERFACE pointer |
1339 | INTERFACE pointer |
1377 | vector_elem (pointer vec, uint32_t ielem) |
1340 | vector_get (pointer vec, uint32_t ielem) |
1378 | { |
1341 | { |
1379 | return vecvalue(vec)[ielem]; |
1342 | return vecvalue(vec)[ielem]; |
1380 | } |
1343 | } |
1381 | |
1344 | |
1382 | INTERFACE void |
1345 | INTERFACE void |
1383 | set_vector_elem (pointer vec, uint32_t ielem, pointer a) |
1346 | vector_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)) |
2927 | if (caar (y) == hdl) |
2890 | if (caar (y) == hdl) |
2928 | break; |
2891 | break; |
2929 | |
2892 | |
2930 | if (y != NIL) |
2893 | if (y != NIL) |
|
|
2894 | return car (y); |
|
|
2895 | |
|
|
2896 | if (!all) |
2931 | break; |
2897 | break; |
2932 | |
|
|
2933 | if (!all) |
|
|
2934 | return NIL; |
|
|
2935 | } |
2898 | } |
2936 | |
|
|
2937 | if (x != NIL) |
|
|
2938 | return car (y); |
|
|
2939 | |
2899 | |
2940 | return NIL; |
2900 | return NIL; |
2941 | } |
2901 | } |
2942 | |
2902 | |
2943 | #else /* USE_ALIST_ENV */ |
2903 | #else /* USE_ALIST_ENV */ |
… | |
… | |
4401 | if (SCHEME_V->no_memory) |
4361 | if (SCHEME_V->no_memory) |
4402 | s_return (S_SINK); |
4362 | s_return (S_SINK); |
4403 | #endif |
4363 | #endif |
4404 | |
4364 | |
4405 | for (x = args, i = 0; is_pair (x); x = cdr (x), i++) |
4365 | for (x = args, i = 0; is_pair (x); x = cdr (x), i++) |
4406 | set_vector_elem (vec, i, car (x)); |
4366 | vector_set (vec, i, car (x)); |
4407 | |
4367 | |
4408 | s_return (vec); |
4368 | s_return (vec); |
4409 | } |
4369 | } |
4410 | |
4370 | |
4411 | case OP_MKVECTOR: /* make-vector */ |
4371 | case OP_MKVECTOR: /* make-vector */ |
… | |
… | |
4423 | if (SCHEME_V->no_memory) |
4383 | if (SCHEME_V->no_memory) |
4424 | s_return (S_SINK); |
4384 | s_return (S_SINK); |
4425 | #endif |
4385 | #endif |
4426 | |
4386 | |
4427 | if (fill != NIL) |
4387 | if (fill != NIL) |
4428 | fill_vector (vec, fill); |
4388 | fill_vector (vec, 0, fill); |
4429 | |
4389 | |
4430 | s_return (vec); |
4390 | s_return (vec); |
4431 | } |
4391 | } |
4432 | |
4392 | |
4433 | case OP_VECLEN: /* vector-length */ |
4393 | case OP_VECLEN: /* vector-length */ |
… | |
… | |
4438 | int index = ivalue_unchecked (cadr (args)); |
4398 | int index = ivalue_unchecked (cadr (args)); |
4439 | |
4399 | |
4440 | if (index >= veclength (car (args)) && USE_ERROR_CHECKING) |
4400 | if (index >= veclength (car (args)) && USE_ERROR_CHECKING) |
4441 | Error_1 ("vector-ref: out of bounds:", cadr (args)); |
4401 | Error_1 ("vector-ref: out of bounds:", cadr (args)); |
4442 | |
4402 | |
4443 | s_return (vector_elem (x, index)); |
4403 | s_return (vector_get (x, index)); |
4444 | } |
4404 | } |
4445 | |
4405 | |
4446 | case OP_VECSET: /* vector-set! */ |
4406 | case OP_VECSET: /* vector-set! */ |
4447 | { |
4407 | { |
4448 | int index = ivalue_unchecked (cadr (args)); |
4408 | int index = ivalue_unchecked (cadr (args)); |
… | |
… | |
4451 | Error_1 ("vector-set!: unable to alter immutable vector:", x); |
4411 | Error_1 ("vector-set!: unable to alter immutable vector:", x); |
4452 | |
4412 | |
4453 | if (index >= veclength (car (args)) && USE_ERROR_CHECKING) |
4413 | if (index >= veclength (car (args)) && USE_ERROR_CHECKING) |
4454 | Error_1 ("vector-set!: out of bounds:", cadr (args)); |
4414 | Error_1 ("vector-set!: out of bounds:", cadr (args)); |
4455 | |
4415 | |
4456 | set_vector_elem (x, index, caddr (args)); |
4416 | vector_set (x, index, caddr (args)); |
4457 | s_return (x); |
4417 | s_return (x); |
4458 | } |
4418 | } |
4459 | } |
4419 | } |
4460 | |
4420 | |
4461 | if (USE_ERROR_CHECKING) abort (); |
4421 | if (USE_ERROR_CHECKING) abort (); |
… | |
… | |
5182 | putstr (SCHEME_A_ ")"); |
5142 | putstr (SCHEME_A_ ")"); |
5183 | s_return (S_T); |
5143 | s_return (S_T); |
5184 | } |
5144 | } |
5185 | else |
5145 | else |
5186 | { |
5146 | { |
5187 | pointer elem = vector_elem (vec, i); |
5147 | pointer elem = vector_get (vec, i); |
5188 | |
5148 | |
5189 | ivalue_unchecked (cdr (args)) = i + 1; |
5149 | ivalue_unchecked (cdr (args)) = i + 1; |
5190 | s_save (SCHEME_A_ OP_PVECFROM, args, NIL); |
5150 | s_save (SCHEME_A_ OP_PVECFROM, args, NIL); |
5191 | SCHEME_V->args = elem; |
5151 | SCHEME_V->args = elem; |
5192 | |
5152 | |
… | |
… | |
5430 | { |
5390 | { |
5431 | if (!tests[j - 1].fct (arg)) |
5391 | if (!tests[j - 1].fct (arg)) |
5432 | break; |
5392 | break; |
5433 | } |
5393 | } |
5434 | |
5394 | |
5435 | if (t[1]) /* last test is replicated as necessary */ |
5395 | if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */ |
5436 | t++; |
5396 | t++; |
5437 | |
5397 | |
5438 | arglist = cdr (arglist); |
5398 | arglist = cdr (arglist); |
5439 | i++; |
5399 | i++; |
5440 | } |
5400 | } |