1 //: Go from an address to the payload it points at using /lookup.
  2 //:
  3 //: The tests in this layer use unsafe operations so as to stay decoupled from
  4 //: 'new'.
  5 
  6 :(scenario copy_indirect)
  7 def main [
  8   # skip alloc id for 10:&:num
  9   11:num <- copy 20
 10   # skip alloc id for payload
 11   21:num <- copy 94
 12   # Treat locations 10 and 11 as an address to look up, pointing at the
 13   # payload in locations 20 and 21.
 14   30:num <- copy 10:&:num/lookup
 15 ]
 16 +mem: storing 94 in location 30
 17 
 18 :(before "End Preprocess read_memory(x)")
 19 canonize(x);
 20 
 21 //: similarly, write to addresses pointing at other locations using the
 22 //: 'lookup' property
 23 :(scenario store_indirect)
 24 def main [
 25   # skip alloc id for 10:&:num
 26   11:num <- copy 10
 27   10:&:num/lookup <- copy 94
 28 ]
 29 +mem: storing 94 in location 11
 30 
 31 :(before "End Preprocess write_memory(x, data)")
 32 canonize(x);
 33 
 34 //: writes to address 0 always loudly fail
 35 :(scenario store_to_0_fails)
 36 % Hide_errors = true;
 37 def main [
 38   10:&:num <- copy null
 39   10:&:num/lookup <- copy 94
 40 ]
 41 -mem: storing 94 in location 0
 42 +error: main: tried to lookup 0 in '10:&:num/lookup <- copy 94'
 43 
 44 //: attempts to /lookup address 0 always loudly fail
 45 :(scenario lookup_0_fails)
 46 % Hide_errors = true;
 47 def main [
 48   10:&:num <- copy null
 49   20:num <- copy 10:&:num/lookup
 50 ]
 51 +error: main: tried to lookup 0 in '20:num <- copy 10:&:num/lookup'
 52 
 53 :(scenario lookup_0_dumps_callstack)
 54 % Hide_errors = true;
 55 def main [
 56   foo null
 57 ]
 58 def foo [
 59   10:&:num <- next-input
 60   20:num <- copy 10:&:num/lookup
 61 ]
 62 +error: foo: tried to lookup 0 in '20:num <- copy 10:&:num/lookup'
 63 +error:   called from main: foo null
 64 
 65 :(code)
 66 void canonize(reagent& x) {
 67   if (is_literal(x)) return;
 68   // Begin canonize(x) Lookups
 69   while (has_property(x, "lookup"))
 70     lookup_memory(x);
 71 }
 72 
 73 void lookup_memory(reagent& x) {
 74   if (!x.type || x.type->atom || x.type->left->value != Address_type_ordinal) {
 75     raise << maybe(current_recipe_name()) << "tried to lookup '" << x.original_string << "' but it isn't an address\n" << end();
 76     dump_callstack();
 77     return;
 78   }
 79   // compute value
 80   if (x.value == 0) {
 81     raise << maybe(current_recipe_name()) << "tried to lookup 0\n" << end();
 82     dump_callstack();
 83     return;
 84   }
 85   lookup_memory_core(x, /*check_for_null*/true);
 86 }
 87 
 88 void lookup_memory_core(reagent& x, bool check_for_null) {
 89   double address = x.value + /*skip alloc id in address*/1;
 90   double new_value = get_or_insert(Memory, address);
 91   trace("mem") << "location " << address << " contains " << no_scientific(new_value) << end();
 92   // check for null
 93   if (check_for_null && new_value == 0) {
 94     if (Current_routine) {
 95       raise << maybe(current_recipe_name()) << "tried to lookup 0 in '" << to_original_string(current_instruction()) << "'\n" << end();
 96       dump_callstack();
 97     }
 98     else {
 99       raise << "tried to lookup 0\n" << end();
100     }
101   }
102   // validate alloc-id
103   double alloc_id_in_address = get_or_insert(Memory, x.value);
104   double alloc_id_in_payload = get_or_insert(Memory, new_value);
105 //?   cerr << x.value << ": " << alloc_id_in_address << " vs " << new_value << ": " << alloc_id_in_payload << '\n';
106   if (alloc_id_in_address != alloc_id_in_payload) {
107       raise << maybe(current_recipe_name()) << "address is already abandoned in '" << to_original_string(current_instruction()) << "'\n" << end();
108       dump_callstack();
109   }
110   // all well; complete the lookup
111   x.set_value(new_value+/*skip alloc id in payload*/1);
112   drop_from_type(x, "address");
113   drop_one_lookup(x);
114 }
115 
116 :(after "Begin types_coercible(reagent to, reagent from)")
117 if (!canonize_type(to)) return false;
118 if (!canonize_type(from)) return false;
119 :(after "Begin types_match(reagent to, reagent from)")
120 if (!canonize_type(to)) return false;
121 if (!canonize_type(from)) return false;
122 :(after "Begin types_strictly_match(reagent to, reagent from)")
123 if (!canonize_type(to)) return false;
124 if (!canonize_type(from)) return false;
125 
126 :(before "End Preprocess is_mu_array(reagent r)")
127 if (!canonize_type(r)) return false;
128 
129 :(before "End Preprocess is_mu_address(reagent r)")
130 if (!canonize_type(r)) return false;
131 
132 :(before "End Preprocess is_mu_number(reagent r)")
133 if (!canonize_type(r)) return false;
134 :(before "End Preprocess is_mu_boolean(reagent r)")
135 if (!canonize_type(r)) return false;
136 :(before "End Preprocess is_mu_character(reagent r)")
137 if (!canonize_type(r)) return false;
138 
139 :(after "Update product While Type-checking Merge")
140 if (!canonize_type(product)) continue;
141 
142 :(before "End Compute Call Ingredient")
143 canonize_type(ingredient);
144 :(before "End Preprocess NEXT_INGREDIENT product")
145 canonize_type(product);
146 :(before "End Check RETURN Copy(lhs, rhs)
147 canonize_type(lhs);
148 canonize_type(rhs);
149 
150 :(code)
151 bool canonize_type(reagent& r) {
152   while (has_property(r, "lookup")) {
153     if (!r.type || r.type->atom || !r.type->left || !r.type->left->atom || r.type->left->value != Address_type_ordinal) {
154       raise << "cannot perform lookup on '" << r.name << "' because it has non-address type " << to_string(r.type) << '\n' << end();
155       return false;
156     }
157     drop_from_type(r, "address");
158     drop_one_lookup(r);
159   }
160   return true;
161 }
162 
163 void drop_one_lookup(reagent& r) {
164   for (vector<pair<string, string_tree*> >::iterator p = r.properties.begin();  p != r.properties.end();  ++p) {
165     if (p->first == "lookup") {
166       r.properties.erase(p);
167       return;
168     }
169   }
170   assert(false);
171 }
172 
173 //: Tedious fixup to support addresses in container/array instructions of previous layers.
174 //: Most instructions don't require fixup if they use the 'ingredients' and
175 //: 'products' variables in run_current_routine().
176 
177 :(scenario get_indirect)
178 def main [
179   # skip alloc id for 10:&:point
180   11:num <- copy 20
181   # skip alloc id for payload
182   21:num <- copy 94
183   22:num <- copy 95
184   30:num <- get 10:&:point/lookup, 0:offset
185 ]
186 +mem: storing 94 in location 30
187 
188 :(scenario get_indirect2)
189 def main [
190   # skip alloc id for 10:&:point
191   11:num <- copy 20
192   # skip alloc id for payload
193   21:num <- copy 94
194   22:num <- copy 95
195   # skip alloc id for destination
196   31:num <- copy 40
197   30:&:num/lookup <- get 10:&:point/lookup, 0:offset
198 ]
199 +mem: storing 94 in location 41
200 
201 :(scenario include_nonlookup_properties)
202 def main [
203   # skip alloc id for 10:&:point
204   11:num <- copy 20
205   # skip alloc id for payload
206   21:num <- copy 94
207   22:num <- copy 95
208   30:num <- get 10:&:point/lookup/foo, 0:offset
209 ]
210 +mem: storing 94 in location 30
211 
212 :(after "Update GET base in Check")
213 if (!canonize_type(base)) break;
214 :(after "Update GET product in Check")
215 if (!canonize_type(product)) break;
216 :(after "Update GET base in Run")
217 canonize(base);
218 
219 :(scenario put_indirect)
220 def main [
221   # skip alloc id for 10:&:point
222   11:num <- copy 20
223   # skip alloc id for payload
224   21:num <- copy 94
225   22:num <- copy 95
226   10:&:point/lookup <- put 10:&:point/lookup, 0:offset, 96
227 ]
228 +mem: storing 96 in location 21
229 
230 :(after "Update PUT base in Check")
231 if (!canonize_type(base)) break;
232 :(after "Update PUT offset in Check")
233 if (!canonize_type(offset)) break;
234 :(after "Update PUT base in Run")
235 canonize(base);
236 
237 :(scenario put_product_error_with_lookup)
238 % Hide_errors = true;
239 def main [
240   # skip alloc id for 10:&:point
241   11:num <- copy 20
242   # skip alloc id for payload
243   21:num <- copy 94
244   22:num <- copy 95
245   10:&:point <- put 10:&:point/lookup, x:offset, 96
246 ]
247 +error: main: product of 'put' must be first ingredient '10:&:point/lookup', but got '10:&:point'
248 
249 :(before "End PUT Product Checks")
250 reagent/*copy*/ p = inst.products.at(0);
251 if (!canonize_type(p)) break;  // error raised elsewhere
252 reagent/*copy*/ i = inst.ingredients.at(0);
253 if (!canonize_type(i)) break;  // error raised elsewhere
254 if (!types_strictly_match(p, i)) {
255   raise << maybe(get(Recipe, r).name) << "product of 'put' must be first ingredient '" << inst.ingredients.at(0).original_string << "', but got '" << inst.products.at(0).original_string << "'\n" << end();
256   break;
257 }
258 
259 :(scenario new_error)
260 % Hide_errors = true;
261 def main [
262   1:num/raw <- new num:type
263 ]
264 +error: main: product of 'new' has incorrect type: '1:num/raw <- new num:type'
265 
266 :(after "Update NEW product in Check")
267 canonize_type(product);
268 
269 :(scenario copy_array_indirect)
270 def main [
271   # skip alloc id for 10:&:@:num
272   11:num <- copy 20
273   # skip alloc id for payload
274   21:num <- copy 3  # array length
275   22:num <- copy 94
276   23:num <- copy 95
277   24:num <- copy 96
278   30:@:num <- copy 10:&:@:num/lookup
279 ]
280 +mem: storing 3 in location 30
281 +mem: storing 94 in location 31
282 +mem: storing 95 in location 32
283 +mem: storing 96 in location 33
284 
285 :(scenario create_array_indirect)
286 def main [
287   # skip alloc id for 10:&:@:num:3
288   11:num <- copy 3000
289   10:&:array:num:3/lookup <- create-array
290 ]
291 +mem: storing 3 in location 3001
292 
293 :(after "Update CREATE_ARRAY product in Check")
294 if (!canonize_type(product)) break;
295 :(after "Update CREATE_ARRAY product in Run")
296 canonize(product);
297 
298 :(scenario index_indirect)
299 def main [
300   # skip alloc id for 10:&:@:num
301   11:num <- copy 20
302   # skip alloc id for payload
303   21:num <- copy 3  # array length
304   22:num <- copy 94
305   23:num <- copy 95
306   24:num <- copy 96
307   30:num <- index 10:&:@:num/lookup, 1
308 ]
309 +mem: storing 95 in location 30
310 
311 :(before "Update INDEX base in Check")
312 if (!canonize_type(base)) break;
313 :(before "Update INDEX index in Check")
314 if (!canonize_type(index)) break;
315 :(before "Update INDEX product in Check")
316 if (!canonize_type(product)) break;
317 
318 :(before "Update INDEX base in Run")
319 canonize(base);
320 :(before "Update INDEX index in Run")
321 canonize(index);
322 
323 :(scenario put_index_indirect)
324 def main [
325   # skip alloc id for 10:&:@:num
326   11:num <- copy 20
327   # skip alloc id for payload
328   21:num <- copy 3  # array length
329   22:num <- copy 94
330   23:num <- copy 95
331   24:num <- copy 96
332   10:&:@:num/lookup <- put-index 10:&:@:num/lookup, 1, 97
333 ]
334 +mem: storing 97 in location 23
335 
336 :(scenario put_index_indirect_2)
337 def main [
338   10:num <- copy 3  # array length
339   11:num <- copy 94
340   12:num <- copy 95
341   13:num <- copy 96
342   # skip alloc id for address
343   21:num <- copy 30
344   # skip alloc id for payload
345   31:num <- copy 1  # index
346   10:@:num <- put-index 10:@:num, 20:&:num/lookup, 97
347 ]
348 +mem: storing 97 in location 12
349 
350 :(scenario put_index_product_error_with_lookup)
351 % Hide_errors = true;
352 def main [
353   # skip alloc id for 10:&:@:num
354   11:num <- copy 20
355   # skip alloc id for payload
356   21:num <- copy 3  # array length
357   22:num <- copy 94
358   23:num <- copy 95
359   24:num <- copy 96
360   10:&:@:num <- put-index 10:&:@:num/lookup, 1, 34
361 ]
362 +error: main: product of 'put-index' must be first ingredient '10:&:@:num/lookup', but got '10:&:@:num'
363 
364 :(before "End PUT_INDEX Product Checks")
365 reagent/*copy*/ p = inst.products.at(0);
366 if (!canonize_type(p)) break;  // error raised elsewhere
367 reagent/*copy*/ i = inst.ingredients.at(0);
368 if (!canonize_type(i)) break;  // error raised elsewhere
369 if (!types_strictly_match(p, i)) {
370   raise << maybe(get(Recipe, r).name) << "product of 'put-index' must be first ingredient '" << inst.ingredients.at(0).original_string << "', but got '" << inst.products.at(0).original_string << "'\n" << end();
371   break;
372 }
373 
374 :(scenario dilated_reagent_in_static_array)
375 def main [
376   {1: (array (& num) 3)} <- create-array
377   10:&:num <- new num:type
378   {1: (array (& num) 3)} <- put-index {1: (array (& num) 3)}, 0, 10:&:num
379   *10:&:num <- copy 94
380   20:num <- copy *10:&:num
381 ]
382 +run: creating array from 7 locations
383 +mem: storing 94 in location 20
384 
385 :(before "Update PUT_INDEX base in Check")
386 if (!canonize_type(base)) break;
387 :(before "Update PUT_INDEX index in Check")
388 if (!canonize_type(index)) break;
389 :(before "Update PUT_INDEX value in Check")
390 if (!canonize_type(value)) break;
391 
392 :(before "Update PUT_INDEX base in Run")
393 canonize(base);
394 :(before "Update PUT_INDEX index in Run")
395 canonize(index);
396 
397 :(scenario length_indirect)
398 def main [
399   # skip alloc id for 10:&:@:num
400   11:num <- copy 20
401   # skip alloc id for payload
402   21:num <- copy 3  # array length
403   22:num <- copy 94
404   23:num <- copy 95
405   24:num <- copy 96
406   30:num <- length 10:&:array:num/lookup
407 ]
408 +mem: storing 3 in location 30
409 
410 :(before "Update LENGTH array in Check")
411 if (!canonize_type(array)) break;
412 :(before "Update LENGTH array in Run")
413 canonize(array);
414 
415 :(scenario maybe_convert_indirect)
416 def main [
417   # skip alloc id for 10:&:number-or-point
418   11:num <- copy 20
419   # skip alloc id for payload
420   21:number-or-point <- merge 0/number, 94
421   30:num, 31:bool <- maybe-convert 10:&:number-or-point/lookup, i:variant
422 ]
423 +mem: storing 1 in location 31
424 +mem: storing 94 in location 30
425 
426 :(scenario maybe_convert_indirect_2)
427 def main [
428   # skip alloc id for 10:&:number-or-point
429   11:num <- copy 20
430   # skip alloc id for payload
431   21:number-or-point <- merge 0/number, 94
432   # skip alloc id for 30:&:num
433   31:num <- copy 40
434   30:&:num/lookup, 50:bool <- maybe-convert 10:&:number-or-point/lookup, i:variant
435 ]
436 +mem: storing 1 in location 50
437 +mem: storing 94 in location 41
438 
439 :(scenario maybe_convert_indirect_3)
440 def main [
441   # skip alloc id for 10:&:number-or-point
442   11:num <- copy 20
443   # skip alloc id for payload
444   21:number-or-point <- merge 0/number, 94
445   # skip alloc id for 30:&:bool
446   31:num <- copy 40
447   50:num, 30:&:bool/lookup <- maybe-convert 10:&:number-or-point/lookup, i:variant
448 ]
449 +mem: storing 1 in location 41
450 +mem: storing 94 in location 50
451 
452 :(before "Update MAYBE_CONVERT base in Check")
453 if (!canonize_type(base)) break;
454 :(before "Update MAYBE_CONVERT product in Check")
455 if (!canonize_type(product)) break;
456 :(before "Update MAYBE_CONVERT status in Check")
457 if (!canonize_type(status)) break;
458 
459 :(before "Update MAYBE_CONVERT base in Run")
460 canonize(base);
461 :(before "Update MAYBE_CONVERT product in Run")
462 canonize(product);
463 :(before "Update MAYBE_CONVERT status in Run")
464 canonize(status);
465 
466 :(scenario merge_exclusive_container_indirect)
467 def main [
468   # skip alloc id for 10:&:number-or-point
469   11:num <- copy 20
470   10:&:number-or-point/lookup <- merge 0/number, 34
471 ]
472 # skip alloc id
473 +mem: storing 0 in location 21
474 +mem: storing 34 in location 22
475 
476 :(before "Update size_mismatch Check for MERGE(x)
477 canonize(x);
478 
479 //: abbreviation for '/lookup': a prefix '*'
480 
481 :(scenario lookup_abbreviation)
482 def main [
483   # skip alloc id for 10:&:num
484   11:num <- copy 20
485   # skip alloc id for payload
486   21:num <- copy 94
487   30:num <- copy *10:&:num
488 ]
489 +parse: ingredient: {10: ("&" "num"), "lookup": ()}
490 +mem: storing 94 in location 30
491 
492 :(before "End Parsing reagent")
493 {
494   while (starts_with(name, "*")) {
495     name.erase(0, 1);
496     properties.push_back(pair<string, string_tree*>("lookup", NULL));
497   }
498   if (name.empty())
499     raise << "illegal name '" << original_string << "'\n" << end();
500 }
501 
502 //:: helpers for debugging
503 
504 :(before "End Primitive Recipe Declarations")
505 _DUMP,
506 :(before "End Primitive Recipe Numbers")
507 put(Recipe_ordinal, "$dump", _DUMP);
508 :(before "End Primitive Recipe Implementations")
509 case _DUMP: {
510   reagent/*copy*/ after_canonize = current_instruction().ingredients.at(0);
511   canonize(after_canonize);
512   cerr << maybe(current_recipe_name()) << current_instruction().ingredients.at(0).name << ' ' << no_scientific(current_instruction().ingredients.at(0).value) << " => " << no_scientific(after_canonize.value) << " => " << no_scientific(get_or_insert(Memory, after_canonize.value)) << '\n';
513   break;
514 }
515 
516 //: grab an address, and then dump its value at intervals
517 //: useful for tracking down memory corruption (writing to an out-of-bounds address)
518 :(before "End Globals")
519 int Bar = -1;
520 :(before "End Primitive Recipe Declarations")
521 _BAR,
522 :(before "End Primitive Recipe Numbers")
523 put(Recipe_ordinal, "$bar", _BAR);
524 :(before "End Primitive Recipe Implementations")
525 case _BAR: {
526   if (current_instruction().ingredients.empty()) {
527     if (Bar != -1) cerr << Bar << ": " << no_scientific(get_or_insert(Memory, Bar)) << '\n';
528     else cerr << '\n';
529   }
530   else {
531     reagent/*copy*/ tmp = current_instruction().ingredients.at(0);
532     canonize(tmp);
533     Bar = tmp.value;
534   }
535   break;
536 }