1 :(before "End Primitive Recipe Declarations")
2 TO_LOCATION_ARRAY,
3 :(before "End Primitive Recipe Numbers")
4 put(Recipe_ordinal, "to-location-array", TO_LOCATION_ARRAY);
5 :(before "End Primitive Recipe Checks")
6 case TO_LOCATION_ARRAY: {
7 const recipe& caller = get(Recipe, r);
8 if (!is_address_of_array_of_numbers(inst.products.at(0))) {
9 ¦ raise << maybe(caller.name) << "product of 'to-location-array' has incorrect type: '" << inst.original_string << "'\n" << end();
10 ¦ break;
11 }
12 break;
13 }
14 :(code)
15 bool is_address_of_array_of_numbers(reagent x) {
16 canonize_type(x);
17 if (!is_compound_type_starting_with(x.type, "address")) return false;
18 drop_from_type(x, "address");
19 if (!is_compound_type_starting_with(x.type, "array")) return false;
20 drop_from_type(x, "array");
21 return x.type && x.type->atom && x.type->value == get(Type_ordinal, "number");
22 }
23 bool is_compound_type_starting_with(const type_tree* type, const string& expected_name) {
24 if (!type) return false;
25 if (type->atom) return false;
26 if (!type->left->atom) return false;
27 return type->left->value == get(Type_ordinal, expected_name);
28 }
29
30 :(before "End Primitive Recipe Implementations")
31 case TO_LOCATION_ARRAY: {
32 int array_size = SIZE(ingredients.at(0));
33 int allocation_size = array_size + 2;
34 ensure_space(allocation_size);
35 const int result = Current_routine->alloc;
36 products.resize(1);
37 products.at(0).push_back(result);
38
39 put(Memory, result, 0);
40
41 put(Memory, result+1, array_size);
42
43 for (int i = 0; i < array_size; ++i)
44 ¦ put(Memory, result+2+i, ingredients.at(0).at(i));
45 break;
46 }