Anubis / Anubis

Commit 8b8316a28597cda32228131a49f8bb652746edd7

Authored by Alain Prouté
1 parent 2da69f10

'Nat' finished on the compiler side.

Showing 5 changed files with 1534 additions and 1445 deletions   Show diff stats
Inline Side-by-side
anubis_dev/compiler/src/compil.h
  Show/Hide comments   View file @8b8316a
... ... @@ -538,6 +538,16 @@ extern Expr linecol(void);
538 538 item(finished)\
539 539 item(anb_nat_10)\
540 540 item(anb_nat_16)\
  541 + item(del_stack_nat)\
  542 + item(unstore_copy_nat)\
  543 + item(copy_nat)\
  544 + item(vcopy_nat)\
  545 + item(del_nat)\
  546 + item(copy_stack_nat)\
  547 + item(put_micro_copy_nat)\
  548 + item(put_copy_nat)\
  549 + item(mvar_slots_del_nat)\
  550 + item(indirect_del_nat)\
541 551  
542 552  
543 553  
... ...
anubis_dev/compiler/src/compile.c
  Show/Hide comments   View file @8b8316a
... ... @@ -87,9 +87,9 @@ Expr mixed_copy_mask(Expr implem)
87 87 symbols which have been pushed. */
88 88  
89 89 static Expr get_push_rvs(Expr descr, /* description of type */
90   - Expr type,
91   - Expr env,
92   - Expr resurg_mask)
  90 + Expr type,
  91 + Expr env,
  92 + Expr resurg_mask)
93 93 {
94 94 Expr result = nil;
95 95 Expr alt_sort = car(descr);
... ... @@ -97,8 +97,8 @@ static Expr get_push_rvs(Expr descr, /* description of type */
97 97 int n; /* number of resurgent symbols */
98 98  
99 99 /* descr = (small_alt (<id> <offset> . <width>) ...)
100   - (mixed_alt (<id> <offset> . <width>) ...)
101   - (large_alt (<id> <offset> . <width>) ...)
  100 + (mixed_alt (<id> <offset> . <width>) ...)
  101 + (large_alt (<id> <offset> . <width>) ...)
102 102  
103 103 Resurgent symbol values are pushed in reverse order, so that the first one is on top of
104 104 the stack .
... ... @@ -164,6 +164,11 @@ static Expr get_push_rvs(Expr descr, /* description of type */
164 164 result = cons(cons(unstore_copy_function,
165 165 second(car(descr))+new_integer(depl)),
166 166 result);
  167 +
  168 + else if (comp_implem == type_Nat)
  169 + result = cons(cons(unstore_copy_nat,
  170 + second(car(descr))+new_integer(depl)),
  171 + result);
167 172  
168 173 else if (is_address_type(comp_implem,nil))
169 174 switch(car(comp_implem))
... ... @@ -320,6 +325,10 @@ static Expr get_del_rvs(Expr descr, Expr resurg_mask)
320 325 result = cons(cons(del_stack_function,
321 326 new_integer(0)),
322 327 result);
  328 + else if (comp_implem == type_Nat)
  329 + result = cons(cons(del_stack_nat,
  330 + new_integer(0)),
  331 + result);
323 332 else if (comp_implem == type_Listener)
324 333 result = cons(cons(del_stack_conn,
325 334 new_integer(0)),
... ... @@ -476,6 +485,11 @@ static Expr get_del_code_from_ctxt(Expr ctxt, Expr env)
476 485 new_integer(0)),
477 486 result);
478 487  
  488 + else if (implem == type_Nat)
  489 + result = cons(cons(del_stack_nat,
  490 + new_integer(0)),
  491 + result);
  492 +
479 493 /* if argument of mixed type: (del_stack_mixed 0 <mask> . <del
480 494 code addr>) */
481 495 else if (consp(implem) && car(implem) == mixed_type)
... ... @@ -528,6 +542,7 @@ Expr get_del_stack_instr(Expr type,
528 542  
529 543 else if (is_struct_ptr_type(type)) return mcons3(del_stack_struct_ptr,cdr(type),depth);
530 544 else if (is_functional_type(type)) return cons(del_stack_function,depth);
  545 + else if (type == type_Nat) return cons(del_stack_nat,depth);
531 546  
532 547 else if (is_address_type(type,nil))
533 548 switch(car(type))
... ... @@ -574,6 +589,7 @@ Expr get_copy_instr(Expr type,
574 589 else if (is_struct_ptr_type(type)) return copy_ptr;
575 590 else if (type == type_Listener) return copy_ptr;
576 591 else if (is_functional_type(type)) return copy_function;
  592 + else if (type == type_Nat) return copy_nat;
577 593 else if (is_global_address_type(type)) return copy_ptr;
578 594 else if (consp(type) && car(type) == type_Var) return copy_ptr;
579 595 else if (consp(type) && car(type) == type_MVar) return copy_ptr;
... ... @@ -602,6 +618,7 @@ Expr get_vcopy_instr(Expr type,
602 618 else if (is_struct_ptr_type(type)) return vcopy_ptr;
603 619 else if (type == type_Listener) return vcopy_ptr;
604 620 else if (is_functional_type(type)) return vcopy_function;
  621 + else if (type == type_Nat) return vcopy_nat;
605 622 else if (is_global_address_type(type)) return vcopy_ptr;
606 623 else if (consp(type) &&
607 624 car(type) == type_Var) return vcopy_ptr;
... ... @@ -632,6 +649,7 @@ Expr get_del_instr(Expr type,
632 649  
633 650 else if (is_struct_ptr_type(type)) return cons(del_struct_ptr,cdr(type));
634 651 else if (is_functional_type(type)) return del_function;
  652 + else if (type == type_Nat) return del_nat;
635 653 else if (is_global_address_type(type)) return del_conn;
636 654 else if (consp(type) && car(type) == type_Var)
637 655 {
... ... @@ -705,6 +723,9 @@ static Expr get_before_start_code(Expr ctxt, Expr env)
705 723 else if (is_functional_type(implem))
706 724 result = cons(cons(copy_stack_function,new_integer(depth)),result);
707 725  
  726 + else if (implem == type_Nat)
  727 + result = cons(cons(copy_stack_nat,new_integer(depth)),result);
  728 +
708 729 /* mixed type */
709 730 else if (consp(implem) && car(implem) == mixed_type)
710 731 result = cons(mcons3(copy_stack_mixed,
... ... @@ -777,6 +798,7 @@ static void check_end_code(Expr end_code)
777 798 instr == del_stack_var ||
778 799 instr == del_stack_mvar ||
779 800 instr == del_stack_function ||
  801 + instr == del_stack_nat ||
780 802 instr == ret))
781 803 internal_error("Unacceptable instruction in end_code",car(end_code));
782 804 }
... ... @@ -873,47 +895,48 @@ Expr shift_end_code(Expr end_code, Expr k)
873 895 while (consp(end_code))
874 896 {
875 897 switch (car(car(end_code)))
876   - {
877   - case comment:
878   - break;
  898 + {
  899 + case comment:
  900 + break;
879 901  
880   - case collapse: /* (collapse . depth) */
881   - case del_stack_ptr: /* (del_stack_ptr . depth) */
  902 + case collapse: /* (collapse . depth) */
  903 + case del_stack_ptr: /* (del_stack_ptr . depth) */
882 904 case del_stack_function: /* (del_stack_function . depth) */
883   - case del_stack_conn: /* idem */
884   - result = cons(cons(car(car(end_code)),
885   - cdr(car(end_code))+k),
886   - result);
887   - break;
  905 + case del_stack_nat: /* (del_stack_nat . depth) */
  906 + case del_stack_conn: /* idem */
  907 + result = cons(cons(car(car(end_code)),
  908 + cdr(car(end_code))+k),
  909 + result);
  910 + break;
888 911  
889 912 case del_stack_struct_ptr: /* (del_stack_struct_ptr <struct_id> . <depth>) */
890   - result = cons(mcons3(car(car(end_code)),
  913 + result = cons(mcons3(car(car(end_code)),
891 914 second(car(end_code)),
892   - cdr2(car(end_code))+k),
893   - result);
  915 + cdr2(car(end_code))+k),
  916 + result);
894 917 break;
895 918  
896   - case del_stack: /* (del_stack depth . addr) */
897   - case del_stack_mvar: /* (del_stack_mvar depth . addr) */
898   - case del_stack_var: /* (del_stack_var depth . content_del_code_addr) */
899   - case del_stack_mixed: /* (del_stack_mixed depth mask . addr) */
900   - result = cons(mcons3(car(car(end_code)),
901   - second(car(end_code))+k,
902   - cdr2(car(end_code))),
903   - result);
904   - break;
905   -
906   - case ret:
907   - break;
908   -
909   - default:
910   - assert(0);
911   - }
  919 + case del_stack: /* (del_stack depth . addr) */
  920 + case del_stack_mvar: /* (del_stack_mvar depth . addr) */
  921 + case del_stack_var: /* (del_stack_var depth . content_del_code_addr) */
  922 + case del_stack_mixed: /* (del_stack_mixed depth mask . addr) */
  923 + result = cons(mcons3(car(car(end_code)),
  924 + second(car(end_code))+k,
  925 + cdr2(car(end_code))),
  926 + result);
  927 + break;
  928 +
  929 + case ret:
  930 + break;
  931 +
  932 + default:
  933 + assert(0);
  934 + }
912 935 end_code = cdr(end_code);
913 936 }
914 937  
915 938 result = rappend(result,list2(cons(apply,k),
916   - cons(comment,new_string("this was a terminal call"))));
  939 + cons(comment,new_string("this was a terminal call"))));
917 940  
918 941 result = cons(cons(collapse,k),result);
919 942 result = cons(cons(comment,new_string("shifted end code")),result);
... ... @@ -1093,18 +1116,6 @@ static Expr closure_function_code_addr(Expr closure, Expr env)
1093 1116 nil),
1094 1117 code);
1095 1118  
1096   - /*
1097   - code = append(compile_term(cdr4(closure),
1098   - append(forth(closure),
1099   - list1(third(closure))),
1100   - env,
1101   - nil),
1102   - append(get_del_code_from_ctxt(append(forth(closure),
1103   - list1(cons(ret,new_integer(1)))),env),
1104   - list2(cons(del_stack_function,0),
1105   - cons(ret,new_integer(length(forth(closure)))))));
1106   - */
1107   -
1108 1119 if (next_closure_code >= max_closure_code)
1109 1120 {
1110 1121 max_closure_code += 500;
... ... @@ -1115,11 +1126,12 @@ static Expr closure_function_code_addr(Expr closure, Expr env)
1115 1126  
1116 1127 result = new_addr_name(labs_closure,next_closure_code);
1117 1128 closure_codes[next_closure_code].name = save(result);
1118   - closure_codes[next_closure_code].offline_code = save(
1119   - mcons3(cons(header,new_string("* * * closure code * * *")),
1120   - /* no 'odd_align' for a closure code ! */
1121   - cons(label,result),
1122   - code));
  1129 + closure_codes[next_closure_code].offline_code =
  1130 + save(
  1131 + mcons3(cons(header,new_string("* * * closure code * * *")),
  1132 + /* no 'odd_align' for a closure code ! */
  1133 + cons(label,result),
  1134 + code));
1123 1135  
1124 1136  
1125 1137 next_closure_code++;
... ... @@ -1137,36 +1149,36 @@ static Expr micro_ctxt_del_code_addr(Expr mctxt, Expr env)
1137 1149  
1138 1150 mctxt = reverse(mctxt);
1139 1151  
1140   - /* register a new micro context deletion code */
1141   - if (next_mctxt_del_code >= max_mctxt_del_code)
1142   - {
1143   - max_mctxt_del_code += 500;
1144   - mctxt_del_codes = (struct MCtxtDelCode_struct *)
1145   - reallocz(mctxt_del_codes,max_mctxt_del_code*sizeof(struct MCtxtDelCode_struct));
1146   - }
  1152 + /* register a new micro context deletion code */
  1153 + if (next_mctxt_del_code >= max_mctxt_del_code)
  1154 + {
  1155 + max_mctxt_del_code += 500;
  1156 + mctxt_del_codes = (struct MCtxtDelCode_struct *)
  1157 + reallocz(mctxt_del_codes,max_mctxt_del_code*sizeof(struct MCtxtDelCode_struct));
  1158 + }
1147 1159  
1148   - code = list3(free_seg_1,
1149   - pop2,
1150   - cons(ret,new_integer(1)));
1151   - while (consp(mctxt))
1152   - {
1153   - implemid = type_implementation_id(cdr(car(mctxt)),env);
1154   - code = append(component_del_code(implemid),code);
1155   - code = cons(cons(increment_del,new_integer(4)),code);
1156   - mctxt = cdr(mctxt);
1157   - }
  1160 + code = list3(free_seg_1,
  1161 + pop2,
  1162 + cons(ret,new_integer(1)));
  1163 + while (consp(mctxt))
  1164 + {
  1165 + implemid = type_implementation_id(cdr(car(mctxt)),env);
  1166 + code = append(component_del_code(implemid),code);
  1167 + code = cons(cons(increment_del,new_integer(4)),code);
  1168 + mctxt = cdr(mctxt);
  1169 + }
  1170 +
  1171 + result = new_addr_name(labs_mctxt_del_code,next_mctxt_del_code);
  1172 + code = mcons5(cons(header,new_string("* * * closure deletion code * * *")),
  1173 + cons(label,result),
  1174 + del_index_direct,
  1175 + cons(increment_del,new_integer(8)),
  1176 + code);
1158 1177  
1159   - result = new_addr_name(labs_mctxt_del_code,next_mctxt_del_code);
1160   - code = mcons5(cons(header,new_string("* * * closure deletion code * * *")),
1161   - cons(label,result),
1162   - del_index_direct,
1163   - cons(increment_del,new_integer(8)),
1164   - code);
1165   -
1166   - mctxt_del_codes[next_mctxt_del_code].name = save(result);
1167   - mctxt_del_codes[next_mctxt_del_code].offline_code = save(code);
1168   - next_mctxt_del_code++;
1169   - return result;
  1178 + mctxt_del_codes[next_mctxt_del_code].name = save(result);
  1179 + mctxt_del_codes[next_mctxt_del_code].offline_code = save(code);
  1180 + next_mctxt_del_code++;
  1181 + return result;
1170 1182 }
1171 1183  
1172 1184  
... ... @@ -1202,6 +1214,8 @@ static Expr get_put_micro_copy_instr(Expr x, Expr mctxt, int d, int i, Expr env)
1202 1214 return mcons4(put_micro_copy_indirect,new_integer(d),new_integer(j),new_integer(i));
1203 1215 else if (is_functional_type(type))
1204 1216 return mcons4(put_micro_copy_function,new_integer(d),new_integer(j),new_integer(i));
  1217 + else if (type == type_Nat)
  1218 + return mcons4(put_micro_copy_nat,new_integer(d),new_integer(j),new_integer(i));
1205 1219 else if (is_global_address_type(type))
1206 1220 return mcons4(put_micro_copy_indirect,new_integer(d),new_integer(j),new_integer(i));
1207 1221 else if (consp(type) && car(type) == type_Var)
... ... @@ -1258,6 +1272,8 @@ static Expr get_put_copy_instr(Expr x, Expr ctxt, int i, Expr env)
1258 1272 return mcons3(put_copy_indirect,new_integer(d),new_integer(i));
1259 1273 else if (is_functional_type(type))
1260 1274 return mcons3(put_copy_function,new_integer(d),new_integer(i));
  1275 + else if (type == type_Nat)
  1276 + return mcons3(put_copy_nat,new_integer(d),new_integer(i));
1261 1277 else if (is_global_address_type(type))
1262 1278 return mcons3(put_copy_indirect,new_integer(d),new_integer(i));
1263 1279 else if (consp(type) && car(type) == type_Var)
... ... @@ -1410,7 +1426,7 @@ Expr compile_term(Expr head,
1410 1426 case debug_avm:
1411 1427 /* compile case: (debug_avm <lc> . <head>) */
1412 1428 {
1413   - /* If <code> is the code generated for <head>,
  1429 + /* If <code> is the code generated for <head>,
1414 1430 we will have:
1415 1431  
1416 1432 start_debug_avm
... ... @@ -1420,10 +1436,10 @@ Expr compile_term(Expr head,
1420 1436  
1421 1437 so that <code> may be debugged. */
1422 1438  
1423   - Expr main_code = compile_term(cdr2(head),ctxt,env,nil);
1424   - code = cons(start_debug_avm,
1425   - append(main_code,
1426   - cons(stop_debug_avm,end_code)));
  1439 + Expr main_code = compile_term(cdr2(head),ctxt,env,nil);
  1440 + code = cons(start_debug_avm,
  1441 + append(main_code,
  1442 + cons(stop_debug_avm,end_code)));
1427 1443 }
1428 1444 break;
1429 1445  
... ... @@ -1432,12 +1448,12 @@ Expr compile_term(Expr head,
1432 1448 /* compile case: (terminal <lc> . <head>) */
1433 1449 {
1434 1450 /* Just test the presence of end code */
1435   - if (end_code == nil)
1436   - {
1437   - warn_line_col(second(head),"W001", msgtext_call_not_terminal[0]);
1438   - }
1439   - head = cdr2(head);
1440   - goto begin;
  1451 + if (end_code == nil)
  1452 + {
  1453 + warn_line_col(second(head),"W001", msgtext_call_not_terminal[0]);
  1454 + }
  1455 + head = cdr2(head);
  1456 + goto begin;
1441 1457 }
1442 1458 break;
1443 1459  
... ... @@ -1446,9 +1462,9 @@ Expr compile_term(Expr head,
1446 1462 case type_rep:
1447 1463 /* compile case: (type_rep <lc> . <type>) */
1448 1464 {
1449   - /* replace type by appropriate term */
1450   - head = type_to_term(substitute(cdr2(head),env));
1451   - goto begin;
  1465 + /* replace type by appropriate term */
  1466 + head = type_to_term(substitute(cdr2(head),env));
  1467 + goto begin;
1452 1468 }
1453 1469 break;
1454 1470 #endif
... ... @@ -1459,20 +1475,20 @@ Expr compile_term(Expr head,
1459 1475 case operation:
1460 1476 /* compile case: (operation <lc> <opid> <name> <parms> <type> . <types>) */
1461 1477 {
1462   - int opid = integer_value(third(head)); /* id of operation */
1463   - Expr parms = fifth(head); /* a list of types */
  1478 + int opid = integer_value(third(head)); /* id of operation */
  1479 + Expr parms = fifth(head); /* a list of types */
1464 1480  
1465 1481 /* Note: at that point 'parms' does not contain type parameters nor unknowns, but
1466 1482 actual types. This is because 'head' is an operation instance.
1467 1483 */
1468 1484  
1469   - /* get operation instance id */
1470   - int op_i_id = get_op_instance_id(second(head),opid,parms,env);
  1485 + /* get operation instance id */
  1486 + int op_i_id = get_op_instance_id(second(head),opid,parms,env);
1471 1487  
1472   - if (length(head) == 6) /* zero argument */
1473   - {
1474   - /* If operation has zero arguments, it is implicitly applied to zero arguments. We
1475   - generate the same code as for an applicative term:
  1488 + if (length(head) == 6) /* zero argument */
  1489 + {
  1490 + /* If operation has zero arguments, it is implicitly applied to zero arguments. We
  1491 + generate the same code as for an applicative term:
1476 1492  
1477 1493 (check_stack . 1)
1478 1494 (push_addr . e)
... ... @@ -1482,35 +1498,35 @@ Expr compile_term(Expr head,
1482 1498 end_code
1483 1499  
1484 1500 */
1485   - Expr e = new_addr_name(labs_none,0);
1486   - if ((code = compiled_ops[op_i_id].inline_code) != nil)
1487   - {
1488   - code = append(code,end_code);
1489   - }
1490   - else
1491   - {
1492   - if (end_code == nil)
1493   - code = mcons6(cons(check_stack,new_integer(1)),
1494   - cons(push_addr,e),
1495   - cons(address,compiled_ops[op_i_id].addr),
1496   - cons(apply,new_integer(0)),
1497   - cons(ret_point,e),
1498   - end_code);
1499   - else
1500   - code = mcons5(cons(check_stack,new_integer(1)),
  1501 + Expr e = new_addr_name(labs_none,0);
  1502 + if ((code = compiled_ops[op_i_id].inline_code) != nil)
  1503 + {
  1504 + code = append(code,end_code);
  1505 + }
  1506 + else
  1507 + {
  1508 + if (end_code == nil)
  1509 + code = mcons6(cons(check_stack,new_integer(1)),
  1510 + cons(push_addr,e),
  1511 + cons(address,compiled_ops[op_i_id].addr),
  1512 + cons(apply,new_integer(0)),
  1513 + cons(ret_point,e),
  1514 + end_code);
  1515 + else
  1516 + code = mcons5(cons(check_stack,new_integer(1)),
1501 1517 cons(comment,new_string("pushing a dummy address")),
1502   - cons(push_addr,e),
1503   - cons(address,compiled_ops[op_i_id].addr),
1504   - shift_end_code(end_code,new_integer(0)));
1505   - }
  1518 + cons(push_addr,e),
  1519 + cons(address,compiled_ops[op_i_id].addr),
  1520 + shift_end_code(end_code,new_integer(0)));
  1521 + }
1506 1522  
1507 1523 }
1508   - else /* at least one argument */
1509   - {
1510   - /* otherwise, we just produce the function, and put the end code */
1511   - code = cons(cons(address,compiled_ops[op_i_id].addr),
1512   - end_code);
1513   - }
  1524 + else /* at least one argument */
  1525 + {
  1526 + /* otherwise, we just produce the function, and put the end code */
  1527 + code = cons(cons(address,compiled_ops[op_i_id].addr),
  1528 + end_code);
  1529 + }
1514 1530 }
1515 1531 break;
1516 1532  
... ... @@ -1523,9 +1539,9 @@ Expr compile_term(Expr head,
1523 1539 case string:
1524 1540 /* compile case: (string <lc> . <string>) */
1525 1541 {
1526   - code = cons(cons(string,
1527   - get_string_addr(cdr2(head))),
1528   - end_code);
  1542 + code = cons(cons(string,
  1543 + get_string_addr(cdr2(head))),
  1544 + end_code);
1529 1545 }
1530 1546 break;
1531 1547  
... ... @@ -1570,8 +1586,8 @@ Expr compile_term(Expr head,
1570 1586 case small_datum:
1571 1587 /* compile case: (small_datum <type> . <Cint>) */
1572 1588 code = cons(cons(load_int32,
1573   - cdr2(head)),
1574   - end_code);
  1589 + cdr2(head)),
  1590 + end_code);
1575 1591 break;
1576 1592  
1577 1593  
... ... @@ -1581,10 +1597,10 @@ Expr compile_term(Expr head,
1581 1597 case fpnum:
1582 1598 /* compile case: (fpnum <lc> <int32 mantissa> . <int32 exponent>) */
1583 1599 {
1584   - code = cons(mcons3(load_float,
1585   - third(head),
1586   - cdr3(head)),
1587   - end_code);
  1600 + code = cons(mcons3(load_float,
  1601 + third(head),
  1602 + cdr3(head)),
  1603 + end_code);
1588 1604 }
1589 1605 break;
1590 1606  
... ... @@ -1601,15 +1617,15 @@ Expr compile_term(Expr head,
1601 1617 Warning: <i> is not significant and should be removed from 'local'
1602 1618 */
1603 1619 {
1604   - int i = 0;
  1620 + int i = 0;
1605 1621  
1606   - while (!(car(car(ctxt)) == second(head)) &&
  1622 + while (!(car(car(ctxt)) == second(head)) &&
1607 1623 !(car(car(ctxt)) == f_micro_ctxt && second(car(ctxt)) == second(head))
1608 1624 )
1609   - {
1610   - ctxt = cdr(ctxt);
1611   - i++;
1612   - }
  1625 + {
  1626 + ctxt = cdr(ctxt);
  1627 + i++;
  1628 + }
1613 1629 //assert(i == integer_value(third(head)));
1614 1630  
1615 1631 code = mcons3(mcons3(peek,second(head),new_integer(i)),
... ... @@ -1672,12 +1688,12 @@ Expr compile_term(Expr head,
1672 1688  
1673 1689 offset size content
1674 1690 ------------------------------------------------------------------
1675   - 0 4 counter
1676   - 4 4 address of function code
1677   - 8 4 address of micro context deletion code
  1691 + 0 4 counter
  1692 + 4 4 address of function code
  1693 + 8 4 address of micro context deletion code
1678 1694 12 4 first item in micro context
1679 1695 ...
1680   - 4 last item in micro context
  1696 + 4 last item in micro context
1681 1697  
1682 1698 the deletion code deletes a virtual copy of each item in the micro context, but does
1683 1699 not delete the closure itself.
... ... @@ -1729,13 +1745,13 @@ Expr compile_term(Expr head,
1729 1745 case app:
1730 1746 /* compile case: (app <lc> <op int head> . <int heads>) */
1731 1747 {
1732   - Expr args = reverse(cdr3(head)); /* arguments in reverse order (a_k,...,a_1) */
1733   - int k = length(args); /* number of arguments */
1734   - int op_instance_id;
1735   - Expr args_codes = nil; /* code for computing arguments */
  1748 + Expr args = reverse(cdr3(head)); /* arguments in reverse order (a_k,...,a_1) */
  1749 + int k = length(args); /* number of arguments */
  1750 + int op_instance_id;
  1751 + Expr args_codes = nil; /* code for computing arguments */
1736 1752  
1737 1753 Expr f_code = nil; /* code for function */
1738   - Expr arg_type; /* type of current argument */
  1754 + Expr arg_type; /* type of current argument */
1739 1755 int stack_needed = 0;
1740 1756  
1741 1757 /* Warn if alert encountered. */
... ... @@ -1745,24 +1761,24 @@ Expr compile_term(Expr head,
1745 1761 forth(third(head)) == pdstr_alert_handler)
1746 1762 {
1747 1763 warn_line_col(second(head),"W002",
1748   - msgtext_remove_alert[0]);
  1764 + msgtext_remove_alert[0]);
1749 1765 }
1750 1766  
1751   - /* <op int head> may be either (operation ...) or any other kind of term able to
1752   - represent a function (local symbol, applicative term, conditional, with-term,
1753   - ...). The code for the function is always inline except when <op int head> is
1754   - (operation ...) and if the operation instance has no inline code. */
  1767 + /* <op int head> may be either (operation ...) or any other kind of term able to
  1768 + represent a function (local symbol, applicative term, conditional, with-term,
  1769 + ...). The code for the function is always inline except when <op int head> is
  1770 + (operation ...) and if the operation instance has no inline code. */
1755 1771  
1756 1772 /* determine if f is inline or offline */
1757   - if (car(third(head)) == operation &&
  1773 + if (car(third(head)) == operation &&
1758 1774 (f_code =
1759   - compiled_ops[op_instance_id =
  1775 + compiled_ops[op_instance_id =
1760 1776 get_op_instance_id(second(third(head)),
1761 1777 integer_value(third(third(head))),
1762 1778 fifth(third(head)),
1763 1779 env)].inline_code) == nil)
1764   - {
1765   - /* the function is offline. The code is:
  1780 + {
  1781 + /* the function is offline. The code is:
1766 1782  
1767 1783 (check_stack . k+1+sup(...))
1768 1784 (push_addr . e)
... ... @@ -1775,7 +1791,7 @@ Expr compile_term(Expr head,
1775 1791 push
1776 1792 (address . f)
1777 1793 (apply . k)
1778   - (ret_point .e)
  1794 + (ret_point .e)
1779 1795 end_code
1780 1796  
1781 1797 However, in the case of offline equality, we must also keep fake copies of the two
... ... @@ -1800,9 +1816,9 @@ Expr compile_term(Expr head,
1800 1816 del_stack_instr for a2 ...
1801 1817 end_code
1802 1818  
1803   - */
  1819 + */
1804 1820  
1805   - Expr e = new_addr_name(labs_none,0);
  1821 + Expr e = new_addr_name(labs_none,0);
1806 1822  
1807 1823 if (forth(third(head)) == pdstr_eq)
1808 1824 { /* equality operation: our applicative term is:
... ... @@ -1910,121 +1926,121 @@ Expr compile_term(Expr head,
1910 1926 code = cons(cons(check_stack,new_integer(stack_needed+k+1)),code);
1911 1927 }
1912 1928  
1913   - }
1914   -
1915   - else
1916   - {
1917   - /* the function is inline. The code is the following if
1918   - car(third(head)) is 'operation':
1919   -
1920   - (check_stack . k+sup(...))
1921   - [ak]ctxt
1922   - push
1923   - [ak-1]((argument . Tk) . ctxt)
1924   - push
1925   - ...
1926   - [a1]((argument . T2) ... (argument . Tk) . ctxt)
1927   - push
1928   - [f]((argument . T1) ... (argument . Tk) . ctxt)
1929   -
1930   - Otherwise, it is the same one plus:
  1929 + }
1931 1930  
1932   - - 'push_address' instruction at the beginning,
1933   - - 'apply' and 'ret_point' instructions at the end.
  1931 + else
  1932 + {
  1933 + /* the function is inline. The code is the following if
  1934 + car(third(head)) is 'operation':
  1935 +
  1936 + (check_stack . k+sup(...))
  1937 + [ak]ctxt
  1938 + push
  1939 + [ak-1]((argument . Tk) . ctxt)
  1940 + push
  1941 + ...
  1942 + [a1]((argument . T2) ... (argument . Tk) . ctxt)
  1943 + push
  1944 + [f]((argument . T1) ... (argument . Tk) . ctxt)
  1945 +
  1946 + Otherwise, it is the same one plus:
  1947 +
  1948 + - 'push_address' instruction at the beginning,
  1949 + - 'apply' and 'ret_point' instructions at the end.
1934 1950 - and k+1 instead of k in check_stack.
1935 1951  
1936   - This is because the inline code from a compiled op struct is the code
1937   - executing the function itself, while the code comming from other terms is
1938   - the code producing the function, not the code executing the function.
  1952 + This is because the inline code from a compiled op struct is the code
  1953 + executing the function itself, while the code comming from other terms is
  1954 + the code producing the function, not the code executing the function.
1939 1955  
1940 1956 Of course, the end code must be added at the end.
1941 1957 */
1942   - Expr ret_addr = nil;
1943   -
1944   - if (car(third(head)) == operation)
1945   - {
1946   - code = end_code;
1947   - }
1948   - else
1949   - {
1950   - /* we may be here for example when the function is a local symbol */
1951   - ret_addr = new_addr_name(labs_none,0);
1952   -
1953   - if (end_code == nil)
1954   - code = mcons3(cons(apply,new_integer(k)),
1955   - cons(ret_point,ret_addr),
1956   - end_code);
1957   - else
1958   - code = shift_end_code(end_code,new_integer(k));
  1958 + Expr ret_addr = nil;
  1959 +
  1960 + if (car(third(head)) == operation)
  1961 + {
  1962 + code = end_code;
  1963 + }
  1964 + else
  1965 + {
  1966 + /* we may be here for example when the function is a local symbol */
  1967 + ret_addr = new_addr_name(labs_none,0);
  1968 +
  1969 + if (end_code == nil)
  1970 + code = mcons3(cons(apply,new_integer(k)),
  1971 + cons(ret_point,ret_addr),
  1972 + end_code);
  1973 + else
  1974 + code = shift_end_code(end_code,new_integer(k));
1959 1975  
1960   - ctxt = cons(cons(ret,ret_addr),ctxt);
1961   - }
  1976 + ctxt = cons(cons(ret,ret_addr),ctxt);
  1977 + }
1962 1978  
1963   - /* We generate the code for arguments before the code for
1964   - f, because of context expansion */
  1979 + /* We generate the code for arguments before the code for
  1980 + f, because of context expansion */
1965 1981  
1966   - while (consp(args)) /* are currently in reverse order */
1967   - {
1968   - /* we are computing the list of codes:
1969   - ([a1]((argument . T2)...ctxt) ... [ak]ctxt) */
  1982 + while (consp(args)) /* are currently in reverse order */
  1983 + {
  1984 + /* we are computing the list of codes:
  1985 + ([a1]((argument . T2)...ctxt) ... [ak]ctxt) */
1970 1986  
1971   - /* get type of argument */
  1987 + /* get type of argument */
1972 1988 arg_type = type_from_interpretation(car(args),env);
1973 1989  
1974   - /* compile argument */
1975   - args_codes = cons(compile_term(car(args),
  1990 + /* compile argument */
  1991 + args_codes = cons(compile_term(car(args),
1976 1992 ctxt,
1977 1993 env,
1978 1994 nil),
1979   - args_codes);
  1995 + args_codes);
1980 1996  
1981   - /* do for next argument */
1982   - args = cdr(args);
  1997 + /* do for next argument */
  1998 + args = cdr(args);
1983 1999  
1984   - /* update context */
1985   - ctxt = cons(cons(argument,arg_type),ctxt);
1986   - }
  2000 + /* update context */
  2001 + ctxt = cons(cons(argument,arg_type),ctxt);
  2002 + }
1987 2003  
1988   - /* args_codes contains codes for arguments in natural
1989   - order. We insert 'push' instruction, reversing the
1990   - order. Now ctxt is ((argument . T1) ... (argument . Tk)
1991   - . ctxt) */
  2004 + /* args_codes contains codes for arguments in natural
  2005 + order. We insert 'push' instruction, reversing the
  2006 + order. Now ctxt is ((argument . T1) ... (argument . Tk)
  2007 + . ctxt) */
1992 2008  
1993   - /* if f_code is non nil, the inline code for f is
1994   - available. Otherwise, f must be compiled (with no end code) */
1995   - if (f_code != nil)
  2009 + /* if f_code is non nil, the inline code for f is
  2010 + available. Otherwise, f must be compiled (with no end code) */
  2011 + if (f_code != nil)
1996 2012 {
1997 2013 stack_needed = sup(stack_needed,stack_needs(f_code));
1998 2014 code = append(remove_check_stack(f_code),code);
1999 2015 }
2000   - else
  2016 + else
2001 2017 {
2002 2018 f_code = compile_term(third(head),ctxt,env,nil);
2003 2019 stack_needed = sup(stack_needed,stack_needs(f_code));
2004 2020 code = append(remove_check_stack(f_code),code);
2005 2021 }
2006 2022  
2007   - /* Insert a view of the stack */
2008   - code = cons(mcons3(context,ctxt,env),code);
  2023 + /* Insert a view of the stack */
  2024 + code = cons(mcons3(context,ctxt,env),code);
2009 2025  
2010 2026 /* We insert arguments codes together with 'push'
2011   - instructions. */
2012   - while (consp(args_codes))
2013   - {
  2027 + instructions. */
  2028 + while (consp(args_codes))
  2029 + {
2014 2030 stack_needed = sup(stack_needed,stack_needs(car(args_codes)));
2015   - code = append(remove_check_stack(car(args_codes)),
2016   - cons(push,
2017   - code));
2018   - args_codes = cdr(args_codes);
2019   - }
  2031 + code = append(remove_check_stack(car(args_codes)),
  2032 + cons(push,
  2033 + code));
  2034 + args_codes = cdr(args_codes);
  2035 + }
2020 2036  
2021   - if (!(car(third(head)) == operation))
2022   - code = cons(cons(push_addr,ret_addr),
2023   - code);
  2037 + if (!(car(third(head)) == operation))
  2038 + code = cons(cons(push_addr,ret_addr),
  2039 + code);
2024 2040  
2025 2041 code = cons(cons(check_stack,new_integer(stack_needed+k+1)),code);
2026 2042  
2027   - }
  2043 + }
2028 2044 }
2029 2045 break;
2030 2046  
... ... @@ -2040,33 +2056,33 @@ Expr compile_term(Expr head,
2040 2056 /* compile case: (cond <lc> <int head> ((<name> (<var> . <type>) ...) <lc> . <int head>) ...) */
2041 2057 {
2042 2058  
2043   - /* the test is always compiled with no end code, because it is
  2059 + /* the test is always compiled with no end code, because it is
2044 2060 followed by the code of at least one case. */
2045   - Expr test_code = compile_term(third(head),ctxt,env,nil);
  2061 + Expr test_code = compile_term(third(head),ctxt,env,nil);
2046 2062  
2047   - /* get interpretations of cases */
2048   - Expr clause_ints = cdr3(head);
  2063 + /* get interpretations of cases */
  2064 + Expr clause_ints = cdr3(head);
2049 2065  
2050   - /* get implementation of type of test */
2051   - Expr test_type_implem =
2052   - implems[type_implementation_id(type_from_interpretation(third(head),env),env)].implem;
  2066 + /* get implementation of type of test */
  2067 + Expr test_type_implem =
  2068 + implems[type_implementation_id(type_from_interpretation(third(head),env),env)].implem;
2053 2069  
2054   - /* we need an end address only if end_code is 'nil' */
2055   - Expr end_addr = nil;
  2070 + /* we need an end address only if end_code is 'nil' */
  2071 + Expr end_addr = nil;
2056 2072  
2057 2073 /* We need case addresses when there are at least two cases */
2058   - Expr case_addrs = nil;
2059   - Expr case_codes = nil;
2060   - Expr aux, aux2;
2061   - Expr a, c;
  2074 + Expr case_addrs = nil;
  2075 + Expr case_codes = nil;
  2076 + Expr aux, aux2;
  2077 + Expr a, c;
2062 2078 int stack_needed = stack_needs(test_code);
2063 2079  
2064 2080  
2065   - if (length(clause_ints) == 1)
2066   - {
2067   - /*----------------- conditional with only one case ---------------------*/
  2081 + if (length(clause_ints) == 1)
  2082 + {
  2083 + /*----------------- conditional with only one case ---------------------*/
2068 2084  
2069   - /* The conditional:
  2085 + /* The conditional:
2070 2086  
2071 2087 (cond <lc> <test> ((<name> (<var> . <type>) ...) <lc> . <body>))
2072 2088  
... ... @@ -2075,7 +2091,7 @@ Expr compile_term(Expr head,
2075 2091 [<test>]ctxt puts value of <test> in R
2076 2092 ; no need for a switch
2077 2093 <case code>
2078   - */
  2094 + */
2079 2095 Expr case_code = compile_case(car(clause_ints),
2080 2096 type_from_interpretation(third(head),env),
2081 2097 car(cdr3(test_type_implem)),
... ... @@ -2085,17 +2101,17 @@ Expr compile_term(Expr head,
2085 2101  
2086 2102 stack_needed = sup(stack_needed,stack_needs(case_code));
2087 2103  
2088   - code = append(remove_check_stack(test_code),
2089   - remove_check_stack(case_code));
  2104 + code = append(remove_check_stack(test_code),
  2105 + remove_check_stack(case_code));
2090 2106  
2091 2107 if (stack_needed)
2092 2108 code = cons(cons(check_stack,new_integer(stack_needed)),code);
2093   - }
2094   - else
2095   - {
2096   - /*--------------- conditional with at least two cases --------------------*/
  2109 + }
  2110 + else
  2111 + {
  2112 + /*--------------- conditional with at least two cases --------------------*/
2097 2113  
2098   - /* the conditional is compiled as follows:
  2114 + /* the conditional is compiled as follows:
2099 2115  
2100 2116 [<test>]ctxt value of test in R
2101 2117 <get index instruction> index of alternative in I
... ... @@ -2113,38 +2129,38 @@ Expr compile_term(Expr head,
2113 2129 and the get index instruction is 'index_indirect'. Otherwise, it is
2114 2130 '(index_direct . bit_width)'.
2115 2131  
2116   - */
2117   -
2118   - if (end_code == nil) /* there is no end code */
2119   - {
2120   - end_addr = new_addr_name(labs_none,0);
2121   - code = list1(cons(label,end_addr));
2122   - }
2123   - else /* there is some end code */
2124   - {
2125   - code = nil;
2126   - }
2127   -
2128   - /* create case addresses and collect case codes */
2129   - aux = clause_ints; /* list of clauses */
2130   - aux2 = cdr3(test_type_implem); /* list of alt implems
2131   - (same length) */
2132   - case_codes = nil;
2133   - case_addrs = nil;
2134   - while (consp(aux))
2135   - {
  2132 + */
  2133 +
  2134 + if (end_code == nil) /* there is no end code */
  2135 + {
  2136 + end_addr = new_addr_name(labs_none,0);
  2137 + code = list1(cons(label,end_addr));
  2138 + }
  2139 + else /* there is some end code */
  2140 + {
  2141 + code = nil;
  2142 + }
  2143 +
  2144 + /* create case addresses and collect case codes */
  2145 + aux = clause_ints; /* list of clauses */
  2146 + aux2 = cdr3(test_type_implem); /* list of alt implems
  2147 + (same length) */
  2148 + case_codes = nil;
  2149 + case_addrs = nil;
  2150 + while (consp(aux))
  2151 + {
2136 2152 Expr case_code;
2137 2153  
2138   - /* create a new label */
2139   - a = new_addr_name(labs_none,0);
2140   - /* collect new address */
2141   - case_addrs = cons(a,case_addrs);
2142   - /* generate final 'jmp' (only if no end code) */
2143   - if (end_code == nil)
2144   - c = list1(cons(jmp,end_addr));
2145   - else
2146   - c = nil;
2147   - /* compile case */
  2154 + /* create a new label */
  2155 + a = new_addr_name(labs_none,0);
  2156 + /* collect new address */
  2157 + case_addrs = cons(a,case_addrs);
  2158 + /* generate final 'jmp' (only if no end code) */
  2159 + if (end_code == nil)
  2160 + c = list1(cons(jmp,end_addr));
  2161 + else
  2162 + c = nil;
  2163 + /* compile case */
2148 2164  
2149 2165 case_code = compile_case(car(aux),
2150 2166 type_from_interpretation(third(head),env),
... ... @@ -2155,27 +2171,27 @@ Expr compile_term(Expr head,
2155 2171  
2156 2172 stack_needed = sup(stack_needed,stack_needs(case_code));
2157 2173  
2158   - c = append(remove_check_stack(case_code),
2159   - c);
2160   -
2161   - /* add label for case */
2162   - c = cons(cons(label,a),c);
2163   - /* collect case code */
2164   - case_codes = append(c,case_codes);
2165   - /* do for next alternative/case */
2166   - aux = cdr(aux);
2167   - aux2 = cdr(aux2);
2168   - }
2169   -
2170   - /* append everything */
2171   - code = append(case_codes,code);
2172   - code = cons(cons(_switch,reverse(case_addrs)),code);
2173   - code = cons(car(test_type_implem) == large_type
2174   - ? index_indirect : cons(index_direct,third(test_type_implem)),code);
2175   - code = append(remove_check_stack(test_code),code);
  2174 + c = append(remove_check_stack(case_code),
  2175 + c);
  2176 +
  2177 + /* add label for case */
  2178 + c = cons(cons(label,a),c);
  2179 + /* collect case code */
  2180 + case_codes = append(c,case_codes);
  2181 + /* do for next alternative/case */
  2182 + aux = cdr(aux);
  2183 + aux2 = cdr(aux2);
  2184 + }
  2185 +
  2186 + /* append everything */
  2187 + code = append(case_codes,code);
  2188 + code = cons(cons(_switch,reverse(case_addrs)),code);
  2189 + code = cons(car(test_type_implem) == large_type
  2190 + ? index_indirect : cons(index_direct,third(test_type_implem)),code);
  2191 + code = append(remove_check_stack(test_code),code);
2176 2192 if (stack_needed)
2177 2193 code = cons(cons(check_stack,new_integer(stack_needed)),code);
2178   - }
  2194 + }
2179 2195 }
2180 2196 break;
2181 2197  
... ... @@ -2319,43 +2335,43 @@ Expr compile_term(Expr head,
2319 2335 /* compile case: (anb_read <lc> . <conn>) */
2320 2336  
2321 2337 {
2322   - Expr conn_type = type_from_interpretation(cdr2(head),env);
  2338 + Expr conn_type = type_from_interpretation(cdr2(head),env);
2323 2339  
2324   - assert(is_address_type(conn_type,env));
  2340 + assert(is_address_type(conn_type,env));
2325 2341  
2326   - switch (car(conn_type))
2327   - {
2328   - case type_RAddr:
2329   - case type_RWAddr:
2330   - {
2331   - /*
2332   - Far connections:
  2342 + switch (car(conn_type))
  2343 + {
  2344 + case type_RAddr:
  2345 + case type_RWAddr:
  2346 + {
  2347 + /*
  2348 + Far connections:
2333 2349  
2334   - [*f] = check_stack 1
2335   - [f]
2336   - push
2337   - <read code for type T>
2338   - del_stack_conn 0
2339   - end code
2340   -
2341   - where the type of the connection is (type_?Addr . T)
2342   - */
2343   -
2344   - Expr f_code = compile_term(cdr2(head),ctxt,env,nil);
2345   - Expr T = cdr(conn_type); /* type of datum in connection */
2346   - Expr r_code = read_code(T,env,cons(cons(argument,conn_type),ctxt));
2347   -
2348   - code = cons(cons(check_stack,
2349   - new_integer(sup(stack_needs(f_code),stack_needs(r_code)+1))),
2350   - append(remove_check_stack(f_code),
2351   - cons(push,
2352   - append(remove_check_stack(r_code),
2353   - cons(cons(del_stack_conn,new_integer(0)),end_code)))));
2354   - }
2355   - break;
2356   -
2357   - case type_Var:
2358   - {
  2350 + [*f] = check_stack 1
  2351 + [f]
  2352 + push
  2353 + <read code for type T>
  2354 + del_stack_conn 0
  2355 + end code
  2356 +
  2357 + where the type of the connection is (type_?Addr . T)
  2358 + */
  2359 +
  2360 + Expr f_code = compile_term(cdr2(head),ctxt,env,nil);
  2361 + Expr T = cdr(conn_type); /* type of datum in connection */
  2362 + Expr r_code = read_code(T,env,cons(cons(argument,conn_type),ctxt));
  2363 +
  2364 + code = cons(cons(check_stack,
  2365 + new_integer(sup(stack_needs(f_code),stack_needs(r_code)+1))),
  2366 + append(remove_check_stack(f_code),
  2367 + cons(push,
  2368 + append(remove_check_stack(r_code),
  2369 + cons(cons(del_stack_conn,new_integer(0)),end_code)))));
  2370 + }
  2371 + break;
  2372 +
  2373 + case type_Var:
  2374 + {
2359 2375 /*
2360 2376 Dynamic variable (type_Var):
2361 2377  
... ... @@ -2367,19 +2383,19 @@ Expr compile_term(Expr head,
2367 2383 del_stack Var(T) ...
2368 2384 end_code
2369 2385 */
2370   - Expr v_code = compile_term(cdr2(head),ctxt,env,nil);
2371   - Expr var_del_code_addr = get_del_code_addr(conn_type,env);
2372   -
2373   - code = mcons5(push,
2374   - get_vv,
2375   - get_copy_instr(cdr(conn_type),env),
2376   - mcons3(del_stack,new_integer(0),var_del_code_addr),
2377   - end_code);
2378   - code = append(remove_check_stack(v_code),code);
2379   - code = cons(cons(check_stack,new_integer(1+stack_needs(v_code))),
2380   - code);
2381   - }
2382   - break;
  2386 + Expr v_code = compile_term(cdr2(head),ctxt,env,nil);
  2387 + Expr var_del_code_addr = get_del_code_addr(conn_type,env);
  2388 +
  2389 + code = mcons5(push,
  2390 + get_vv,
  2391 + get_copy_instr(cdr(conn_type),env),
  2392 + mcons3(del_stack,new_integer(0),var_del_code_addr),
  2393 + end_code);
  2394 + code = append(remove_check_stack(v_code),code);
  2395 + code = cons(cons(check_stack,new_integer(1+stack_needs(v_code))),
  2396 + code);
  2397 + }
  2398 + break;
2383 2399  
2384 2400 case pseudo_type_MVar_Slot:
2385 2401 {
... ... @@ -2425,8 +2441,8 @@ Expr compile_term(Expr head,
2425 2441 }
2426 2442 break;
2427 2443  
2428   - case type_GAddr:
2429   - {
  2444 + case type_GAddr:
  2445 + {
2430 2446 /*
2431 2447 Global variable (type_GAddr):
2432 2448  
... ... @@ -2437,20 +2453,20 @@ Expr compile_term(Expr head,
2437 2453  
2438 2454 where T is the type of the datum in f.
2439 2455 */
2440   - Expr f_code = list1(cons(gv_address,get_gvar_index(cdr2(head))));
2441   - Expr T;
  2456 + Expr f_code = list1(cons(gv_address,get_gvar_index(cdr2(head))));
  2457 + Expr T;
2442 2458  
2443   - T = cdr(conn_type);
  2459 + T = cdr(conn_type);
2444 2460  
2445   - code = cons(get_copy_instr(T,env),end_code);
2446   - code = cons(get_gvv,code);
  2461 + code = cons(get_copy_instr(T,env),end_code);
  2462 + code = cons(get_gvv,code);
2447 2463 code = append(f_code,code);
2448   - }
2449   - break;
  2464 + }
  2465 + break;
2450 2466  
2451   - default:
2452   - assert(0);
2453   - }
  2467 + default:
  2468 + assert(0);
  2469 + }
2454 2470 }
2455 2471 break;
2456 2472  
... ... @@ -2462,12 +2478,12 @@ Expr compile_term(Expr head,
2462 2478 case anb_write:
2463 2479 /* compile case: (anb_write <lc> <conn> . <value>) */
2464 2480 {
2465   - Expr conn_type = type_from_interpretation(third(head),env);
  2481 + Expr conn_type = type_from_interpretation(third(head),env);
2466 2482  
2467   - switch (car(conn_type))
2468   - {
2469   - case type_WAddr:
2470   - case type_RWAddr:
  2483 + switch (car(conn_type))
  2484 + {
  2485 + case type_WAddr:
  2486 + case type_RWAddr:
2471 2487 /*
2472 2488 Far connection:
2473 2489  
... ... @@ -2484,37 +2500,37 @@ Expr compile_term(Expr head,
2484 2500 where the type of f is (type_?Addr . T), and the type
2485 2501 of a is T.
2486 2502 */
2487   - {
2488   - Expr T = type_from_interpretation(cdr3(head),env);
2489   - Expr f_code = compile_term(third(head),ctxt,env,nil);
2490   - Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
2491   - Expr w_code = write_code(T,
2492   - env,
2493   - mcons3(cons(argument,T),
2494   - cons(argument,conn_type),
2495   - ctxt));
2496   -
2497   - Expr a_del_code = get_del_code_from_ctxt(list2(cons(nil,T),
2498   - cons(ret,0)),env);
2499   -
2500   - int stack_needed = sup(stack_needs(f_code),
2501   - sup(stack_needs(a_code)+1,
2502   - stack_needs(w_code)+2));
2503   -
2504   - code = cons(cons(check_stack,new_integer(stack_needed)),
2505   - append(remove_check_stack(f_code),
2506   - cons(push,
2507   - append(remove_check_stack(a_code),
2508   - cons(push,
2509   - append(remove_check_stack(w_code),
2510   - append(a_del_code,
2511   - cons(cons(del_stack_conn,
2512   - new_integer(0)),
2513   - end_code))))))));
2514   - }
2515   - break;
2516   -
2517   - case type_Var:
  2503 + {
  2504 + Expr T = type_from_interpretation(cdr3(head),env);
  2505 + Expr f_code = compile_term(third(head),ctxt,env,nil);
  2506 + Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
  2507 + Expr w_code = write_code(T,
  2508 + env,
  2509 + mcons3(cons(argument,T),
  2510 + cons(argument,conn_type),
  2511 + ctxt));
  2512 +
  2513 + Expr a_del_code = get_del_code_from_ctxt(list2(cons(nil,T),
  2514 + cons(ret,0)),env);
  2515 +
  2516 + int stack_needed = sup(stack_needs(f_code),
  2517 + sup(stack_needs(a_code)+1,
  2518 + stack_needs(w_code)+2));
  2519 +
  2520 + code = cons(cons(check_stack,new_integer(stack_needed)),
  2521 + append(remove_check_stack(f_code),
  2522 + cons(push,
  2523 + append(remove_check_stack(a_code),
  2524 + cons(push,
  2525 + append(remove_check_stack(w_code),
  2526 + append(a_del_code,
  2527 + cons(cons(del_stack_conn,
  2528 + new_integer(0)),
  2529 + end_code))))))));
  2530 + }
  2531 + break;
  2532 +
  2533 + case type_Var:
2518 2534 /*
2519 2535 Dynamic variable (type_Var):
2520 2536  
... ... @@ -2530,7 +2546,7 @@ Expr compile_term(Expr head,
2530 2546 get_var_monitors n t z v ...
2531 2547 address var_change_code_label
2532 2548 apply 2 v ...
2533   - ret_point z:
  2549 + ret_point z:
2534 2550 glue_index 0 v ... 0 ('unique')
2535 2551 del_stack 0 Var(T) ...
2536 2552 end code
... ... @@ -2539,14 +2555,14 @@ Expr compile_term(Expr head,
2539 2555  
2540 2556  
2541 2557 */
2542   - {
  2558 + {
2543 2559 Expr z_addr = new_addr_name(labs_none,0);
2544   - Expr var_del_code_addr = get_del_code_addr(conn_type,env);
2545   - Expr v_code = compile_term(third(head),ctxt,env,nil);
2546   - Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
  2560 + Expr var_del_code_addr = get_del_code_addr(conn_type,env);
  2561 + Expr v_code = compile_term(third(head),ctxt,env,nil);
  2562 + Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
2547 2563 int stack_needed = sup(stack_needs(v_code),stack_needs(a_code))+4;
2548 2564  
2549   - code = cons(mcons3(del_stack,new_integer(0),var_del_code_addr),end_code);
  2565 + code = cons(mcons3(del_stack,new_integer(0),var_del_code_addr),end_code);
2550 2566 code = cons(cons(glue_index,new_integer(0)),code);
2551 2567  
2552 2568 //code = cons(stop_debug_avm,code);
... ... @@ -2560,37 +2576,37 @@ Expr compile_term(Expr head,
2560 2576 code = cons(get_var_monitors,code);
2561 2577 code = cons(cons(push_addr,z_addr),code);
2562 2578  
2563   - code = cons(get_del_instr(cdr(conn_type),env),code);
2564   - code = cons(xchg_vv,code);
2565   - code = append(remove_check_stack(a_code),code);
2566   - code = cons(push,code);
2567   - code = append(remove_check_stack(v_code),code);
2568   - code = cons(cons(check_stack,new_integer(stack_needed)),
2569   - code);
2570   - }
2571   - break;
  2579 + code = cons(get_del_instr(cdr(conn_type),env),code);
  2580 + code = cons(xchg_vv,code);
  2581 + code = append(remove_check_stack(a_code),code);
  2582 + code = cons(push,code);
  2583 + code = append(remove_check_stack(v_code),code);
  2584 + code = cons(cons(check_stack,new_integer(stack_needed)),
  2585 + code);
  2586 + }
  2587 + break;
2572 2588  
2573 2589 case pseudo_type_MVar_Slot:
2574 2590 /*
2575 2591 Multiple dynamic variable (type_MVar): R
2576 2592  
2577 2593 [mv(i) <- a] = check_stack 5 ...
2578   - [mv]ctxt mv
2579   - push mv ...
2580   - [i]((arg ...) . ctxt) i
2581   - push i mv ...
2582   - [a]((arg ...)(arg ...) . ctxt) i mv ... a
2583   - xchg_mvv i mv ... b (old value of mv(i))
2584   - del T i mv ... (empty)
2585   - push_address z z i mv ...
2586   - get_mvar_monitors n t z i mv ...
2587   - address mvar_change_code_label
2588   - apply 2
2589   - ret_point z: i mv ...
2590   - collapse 0 mv ...
2591   - del_stack_mvar 0 addr ...
2592   - glue_index 0 0 ('unique')
2593   - end_code
  2594 + [mv]ctxt mv
  2595 + push mv ...
  2596 + [i]((arg ...) . ctxt) i
  2597 + push i mv ...
  2598 + [a]((arg ...)(arg ...) . ctxt) i mv ... a
  2599 + xchg_mvv i mv ... b (old value of mv(i))
  2600 + del T i mv ... (empty)
  2601 + push_address z z i mv ...
  2602 + get_mvar_monitors n t z i mv ...
  2603 + address mvar_change_code_label
  2604 + apply 2
  2605 + ret_point z: i mv ...
  2606 + collapse 0 mv ...
  2607 + del_stack_mvar 0 addr ...
  2608 + glue_index 0 0 ('unique')
  2609 + end_code
2594 2610  
2595 2611 head must be: (anb_write <lc> (mvar_access <head mv> . <head i>) . <value>)
2596 2612 */
... ... @@ -2627,74 +2643,74 @@ Expr compile_term(Expr head,
2627 2643 code = cons(cons(address,mvar_change_code_label),code);
2628 2644 code = cons(get_mvar_monitors,code);
2629 2645 code = cons(cons(push_addr,z_addr),code);
2630   - code = cons(get_del_instr(cdr(conn_type),env),code);
2631   - code = cons(xchg_mvv,code);
2632   - code = append(remove_check_stack(a_code),code);
  2646 + code = cons(get_del_instr(cdr(conn_type),env),code);
  2647 + code = cons(xchg_mvv,code);
  2648 + code = append(remove_check_stack(a_code),code);
2633 2649 code = cons(push,code);
2634 2650 code = append(remove_check_stack(i_code),code);
2635 2651 code = cons(push,code);
2636 2652 code = append(remove_check_stack(mv_code),code);
2637   - code = cons(cons(check_stack,new_integer(stack_needed)),
2638   - code);
  2653 + code = cons(cons(check_stack,new_integer(stack_needed)),
  2654 + code);
2639 2655 }
2640 2656 break;
2641 2657  
2642   - case type_GAddr:
  2658 + case type_GAddr:
2643 2659 /*
2644 2660 Global variable connection:
2645 2661  
2646 2662 [f <- a] = check_stack 1
2647   - [a] compute the value to be written
2648   - push save it
2649   - [f] compute the address of the variable
2650   - xchg_gvv exchange values
2651   - del_T delete old value
2652   - (load_Int32 . 0) unique of One
  2663 + [a] compute the value to be written
  2664 + push save it
  2665 + [f] compute the address of the variable
  2666 + xchg_gvv exchange values
  2667 + del_T delete old value
  2668 + (load_Int32 . 0) unique of One
2653 2669  
2654 2670 where T is the type of 'a'.
2655 2671 */
2656   - {
2657   - Expr T = type_from_interpretation(cdr3(head),env);
2658   - Expr a_code = compile_term(cdr3(head),ctxt,env,nil);
  2672 + {
  2673 + Expr T = type_from_interpretation(cdr3(head),env);
  2674 + Expr a_code = compile_term(cdr3(head),ctxt,env,nil);
2659 2675 Expr f_code = list1(cons(gv_address,get_gvar_index(third(head))));
2660 2676 int stack_needed = sup(stack_needs(a_code),stack_needs(f_code)+1);
2661 2677  
2662   - code = cons(cons(load_int32,0),end_code);
2663   - code = cons(get_del_instr(T,env),code);
2664   - code = cons(xchg_gvv,code);
2665   - code = append(remove_check_stack(f_code),code);
2666   - code = cons(push,code);
2667   - code = append(remove_check_stack(a_code),code);
2668   - code = cons(cons(check_stack,new_integer(stack_needed)),code);
2669   - }
2670   - break;
2671   -
2672   - default:
2673   - assert(0);
2674   - }
  2678 + code = cons(cons(load_int32,0),end_code);
  2679 + code = cons(get_del_instr(T,env),code);
  2680 + code = cons(xchg_gvv,code);
  2681 + code = append(remove_check_stack(f_code),code);
  2682 + code = cons(push,code);
  2683 + code = append(remove_check_stack(a_code),code);
  2684 + code = cons(cons(check_stack,new_integer(stack_needed)),code);
  2685 + }
  2686 + break;
  2687 +
  2688 + default:
  2689 + assert(0);
  2690 + }
2675 2691 }
2676 2692 break;
2677 2693  
2678 2694 case anb_exchange:
2679 2695 /* compile case: (anb_exchange <lc> <conn> . <value>) */
2680 2696 {
2681   - /*
  2697 + /*
2682 2698  
2683 2699  
2684 2700 Dynamic variable (type_Var):
2685 2701  
2686 2702 [v <-> a] = check_stack 4 R
2687   - [v]ctxt ...
2688   - push v ...
2689   - [a]((arg ...)ctxt) v ... a
2690   - xchg_vv v ... b (old value of v)
2691   - push_addr z z v ...
2692   - get_var_monitors n t z v ...
2693   - address var_change_code_label
2694   - apply 2 v ...
2695   - ret_point z:
2696   - del_stack 0 Var(T) ...
2697   - end code
  2703 + [v]ctxt ...
  2704 + push v ...
  2705 + [a]((arg ...)ctxt) v ... a
  2706 + xchg_vv v ... b (old value of v)
  2707 + push_addr z z v ...
  2708 + get_var_monitors n t z v ...
  2709 + address var_change_code_label
  2710 + apply 2 v ...
  2711 + ret_point z:
  2712 + del_stack 0 Var(T) ...
  2713 + end code
2698 2714  
2699 2715 Global variable connection:
2700 2716  
... ... @@ -2707,19 +2723,19 @@ Expr compile_term(Expr head,
2707 2723 where T is the type of 'a'.
2708 2724 */
2709 2725  
2710   - Expr conn_type = type_from_interpretation(third(head),env);
  2726 + Expr conn_type = type_from_interpretation(third(head),env);
2711 2727  
2712   - switch (car(conn_type))
2713   - {
2714   - case type_Var:
2715   - {
  2728 + switch (car(conn_type))
  2729 + {
  2730 + case type_Var:
  2731 + {
2716 2732 Expr z_addr = new_addr_name(labs_none,0);
2717   - Expr var_del_code_addr = get_del_code_addr(conn_type,env);
2718   - Expr v_code = compile_term(third(head),ctxt,env,nil);
2719   - Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
  2733 + Expr var_del_code_addr = get_del_code_addr(conn_type,env);
  2734 + Expr v_code = compile_term(third(head),ctxt,env,nil);
  2735 + Expr a_code = compile_term(cdr3(head),cons(cons(argument,conn_type),ctxt),env,nil);
2720 2736 int stack_needed = sup(stack_needs(v_code),stack_needs(a_code))+4;
2721 2737  
2722   - code = cons(mcons3(del_stack,new_integer(0),var_del_code_addr),end_code);
  2738 + code = cons(mcons3(del_stack,new_integer(0),var_del_code_addr),end_code);
2723 2739  
2724 2740 //code = cons(stop_debug_avm,code);
2725 2741  
... ... @@ -2732,31 +2748,31 @@ Expr compile_term(Expr head,
2732 2748 code = cons(get_var_monitors,code);
2733 2749 code = cons(cons(push_addr,z_addr),code);
2734 2750  
2735   - code = cons(xchg_vv,code);
2736   - code = append(remove_check_stack(a_code),code);
2737   - code = cons(push,code);
2738   - code = append(remove_check_stack(v_code),code);
2739   - code = cons(cons(check_stack,new_integer(stack_needed)),
2740   - code);
2741   - }
2742   - break;
2743   - case type_GAddr:
2744   - {
2745   - Expr a_code = compile_term(cdr3(head),ctxt,env,nil);
  2751 + code = cons(xchg_vv,code);
  2752 + code = append(remove_check_stack(a_code),code);
  2753 + code = cons(push,code);
  2754 + code = append(remove_check_stack(v_code),code);
  2755 + code = cons(cons(check_stack,new_integer(stack_needed)),
  2756 + code);
  2757 + }
  2758 + break;
  2759 + case type_GAddr:
  2760 + {
  2761 + Expr a_code = compile_term(cdr3(head),ctxt,env,nil);
2746 2762 Expr f_code = list1(cons(gv_address,get_gvar_index(third(head))));
2747 2763 int stack_needed = sup(stack_needs(a_code),stack_needs(f_code)+1);
2748 2764  
2749   - code = cons(xchg_gvv,code);
2750   - code = append(remove_check_stack(f_code),code);
2751   - code = cons(push,code);
2752   - code = append(remove_check_stack(a_code),code);
2753   - code = cons(cons(check_stack,new_integer(stack_needed)),code);
2754   - }
2755   - break;
2756   -
2757   - default:
2758   - assert(0);
2759   - }
  2765 + code = cons(xchg_gvv,code);
  2766 + code = append(remove_check_stack(f_code),code);
  2767 + code = cons(push,code);
  2768 + code = append(remove_check_stack(a_code),code);
  2769 + code = cons(cons(check_stack,new_integer(stack_needed)),code);
  2770 + }
  2771 + break;
  2772 +
  2773 + default:
  2774 + assert(0);
  2775 + }
2760 2776 }
2761 2777 break;
2762 2778  
... ... @@ -2805,7 +2821,7 @@ Expr compile_term(Expr head,
2805 2821  
2806 2822 case wait_for:
2807 2823 {
2808   - /* compile case: (wait_for <lc> <head (condition)> <head (milliseconds)>
  2824 + /* compile case: (wait_for <lc> <head (condition)> <head (milliseconds)>
2809 2825 . <head (after)>) */
2810 2826  
2811 2827 /*
... ... @@ -2820,24 +2836,24 @@ Expr compile_term(Expr head,
2820 2836 pop_1 pop the delay
2821 2837 [after] otherwise continue
2822 2838  
2823   - */
2824   - Expr a = new_addr_name(labs_none,0);
2825   - Expr cond_code = compile_term(third(head),
  2839 + */
  2840 + Expr a = new_addr_name(labs_none,0);
  2841 + Expr cond_code = compile_term(third(head),
2826 2842 cons(cons(argument,type_Int32),ctxt),env,nil);
2827 2843 Expr ms_code = compile_term(forth(head),ctxt,env,nil);
2828   - Expr after_code = compile_term(cdr4(head),ctxt,env,end_code);
  2844 + Expr after_code = compile_term(cdr4(head),ctxt,env,end_code);
2829 2845 int stack_needed = sup(stack_needs(cond_code)+1,sup(stack_needs(ms_code),stack_needs(after_code)));
2830 2846  
2831   - code = mcons3(cons(jmp_false,a),
  2847 + code = mcons3(cons(jmp_false,a),
2832 2848 pop1,
2833   - remove_check_stack(after_code));
  2849 + remove_check_stack(after_code));
2834 2850  
2835   - code = append(remove_check_stack(cond_code),code);
  2851 + code = append(remove_check_stack(cond_code),code);
2836 2852  
2837   - code = mcons4(push,
  2853 + code = mcons4(push,
2838 2854 cons(label,a),
2839   - give_up,
2840   - code);
  2855 + give_up,
  2856 + code);
2841 2857  
2842 2858 code = append(ms_code,code);
2843 2859  
... ... @@ -2859,7 +2875,7 @@ Expr compile_term(Expr head,
2859 2875  
2860 2876 <d virtual copies in stack of parent machine>
2861 2877 start d a start a machine with d items in the stack
2862   - and jump to 'a'
  2878 + and jump to 'a'
2863 2879  
2864 2880 push_addr b create and initialize variables
2865 2881 initialization_address
... ... @@ -2878,9 +2894,9 @@ Expr compile_term(Expr head,
2878 2894 [body]
2879 2895  
2880 2896  
2881   - When 'finished' is executed, there are still 2 words in the stack. Indeed,
2882   - 'get_del_code_from_ctxt' does not generate an instruction for deleting the last 'ret'
2883   - of the context. Furthermore, an initial 0 has been pushed into the stack by 'start'.
  2897 + When 'finished' is executed, there are still 2 words in the stack. Indeed,
  2898 + 'get_del_code_from_ctxt' does not generate an instruction for deleting the last 'ret'
  2899 + of the context. Furthermore, an initial 0 has been pushed into the stack by 'start'.
2884 2900  
2885 2901 */
2886 2902 int d = length(ctxt);
... ... @@ -2921,7 +2937,7 @@ Expr compile_term(Expr head,
2921 2937  
2922 2938 case serialize:
2923 2939 {
2924   - /* head = (serialize <lc> . <term>) */
  2940 + /* head = (serialize <lc> . <term>) */
2925 2941  
2926 2942 /*
2927 2943 should produce:
... ... @@ -2941,22 +2957,22 @@ Expr compile_term(Expr head,
2941 2957 <end code>
2942 2958  
2943 2959 */
2944   - Expr term_code = compile_term(cdr2(head),ctxt,env,nil);
2945   - Expr term_type = type_from_interpretation(cdr2(head),env);
2946   - Expr implem_id = type_implementation_id(term_type,env);
2947   - Expr implem_code_addr = implems[implem_id].addr;
2948   -
2949   - if (same_type(term_type,env,type_ByteArray,nil))
2950   - code = end_code;
2951   - else
2952   - code = mcons6(push,
2953   - mcons3(context,cons(cons(argument,term_type),ctxt),env),
2954   - cons(serialize,implem_code_addr),
2955   - cons(revert_to_computing,new_integer(type_width(term_type,env))),
2956   - get_del_stack_instr(term_type,env,new_integer(0)),
2957   - end_code);
2958   -
2959   - code = append(term_code,code);
  2960 + Expr term_code = compile_term(cdr2(head),ctxt,env,nil);
  2961 + Expr term_type = type_from_interpretation(cdr2(head),env);
  2962 + Expr implem_id = type_implementation_id(term_type,env);
  2963 + Expr implem_code_addr = implems[implem_id].addr;
  2964 +
  2965 + if (same_type(term_type,env,type_ByteArray,nil))
  2966 + code = end_code;
  2967 + else
  2968 + code = mcons6(push,
  2969 + mcons3(context,cons(cons(argument,term_type),ctxt),env),
  2970 + cons(serialize,implem_code_addr),
  2971 + cons(revert_to_computing,new_integer(type_width(term_type,env))),
  2972 + get_del_stack_instr(term_type,env,new_integer(0)),
  2973 + end_code);
  2974 +
  2975 + code = append(term_code,code);
2960 2976 }
2961 2977 break;
2962 2978  
... ... @@ -2966,7 +2982,7 @@ Expr compile_term(Expr head,
2966 2982  
2967 2983 case unserialize: /* (unserialize <lc> <type> . <head>) *///
2968 2984 {
2969   - /*
  2985 + /*
2970 2986  
2971 2987 Unserializing is a state of the virtual machine, and works as follows.
2972 2988  
... ... @@ -2985,7 +3001,7 @@ Expr compile_term(Expr head,
2985 3001 What 'unserialize' does is just:
2986 3002  
2987 3003 1. put (the address of) 'b' into the 'serial_buf' register, and
2988   - initialize related registers (serial_size and serial_next),
  3004 + initialize related registers (serial_size and serial_next),
2989 3005 2. put 0 in the flag 'unserial_failed'
2990 3006 3. push a return address 'r',
2991 3007 4. put the machine in the state 'unserializing',
... ... @@ -3011,10 +3027,10 @@ Expr compile_term(Expr head,
3011 3027 In both cases, we get a datum 'd' of type 'T'. However,
3012 3028  
3013 3029 - if 'unserial_failed' is 0, d is the datum successfully extracted from the byte
3014   - array,
  3030 + array,
3015 3031  
3016 3032 - if 'unserial_failed' is 1, d is a valid datum of type T, at least from the point
3017   - of view of the garbage collector. Nevertheless, it is non significant.
  3033 + of view of the garbage collector. Nevertheless, it is non significant.
3018 3034  
3019 3035 The return address 'r' has been removed from the stack. The byte array 'b' is
3020 3036 still in the 'serial_buf' register.
... ... @@ -3098,30 +3114,30 @@ Expr compile_term(Expr head,
3098 3114 success 32 needed to put the byte array into a 'success'
3099 3115 <end code>
3100 3116  
3101   - */
3102   - Expr term_code = compile_term(cdr3(head),ctxt,env,nil);
3103   - Expr type = third(head);
3104   - Expr implem_id;
3105   - Expr implem_code_addr;
  3117 + */
  3118 + Expr term_code = compile_term(cdr3(head),ctxt,env,nil);
  3119 + Expr type = third(head);
  3120 + Expr implem_id;
  3121 + Expr implem_code_addr;
3106 3122  
3107   - /* type must be 'Maybe(T)' */
3108   - assert(consp(type) && car(type) == app_ts && second(type) == pdstr_Maybe);
  3123 + /* type must be 'Maybe(T)' */
  3124 + assert(consp(type) && car(type) == app_ts && second(type) == pdstr_Maybe);
3109 3125  
3110   - /* the type of interest to us is T */
3111   - type = third(type);
3112   - implem_id = type_implementation_id(type,env);
3113   - implem_code_addr = implems[implem_id].addr;
  3126 + /* the type of interest to us is T */
  3127 + type = third(type);
  3128 + implem_id = type_implementation_id(type,env);
  3129 + implem_code_addr = implems[implem_id].addr;
3114 3130  
3115   - if (same_type(type,env,type_ByteArray,nil))
3116   - code = cons(cons(success,new_integer(mw)),
  3131 + if (same_type(type,env,type_ByteArray,nil))
  3132 + code = cons(cons(success,new_integer(mw)),
3117 3133 end_code);
3118   - else
3119   - code = mcons4(cons(unserialize,implem_code_addr),
3120   - cons(revert_to_computing,new_integer(type_width(type,env))),
3121   - get_del_stack_instr(type,env,new_integer(0)),
3122   - end_code);
  3134 + else
  3135 + code = mcons4(cons(unserialize,implem_code_addr),
  3136 + cons(revert_to_computing,new_integer(type_width(type,env))),
  3137 + get_del_stack_instr(type,env,new_integer(0)),
  3138 + end_code);
3123 3139  
3124   - code = append(term_code,code);
  3140 + code = append(term_code,code);
3125 3141 }
3126 3142 break;
3127 3143  
... ... @@ -3494,13 +3510,14 @@ int get_op_instance_id(Expr lc,
3494 3510 cons(cons(comment,new_string(ccbuf)),
3495 3511 c_code));
3496 3512  
3497   - compiled_ops[i].offline_code = save(
3498   - cons(cons(header,op_comment(opid)),
3499   - mcons3(odd_align,
3500   - cons(label,addr),
3501   - cons(cons(comment,new_string("constructor offline code")),
3502   - append(c_code,
3503   - list1(cons(ret,new_integer(arity))))))));
  3513 + compiled_ops[i].offline_code =
  3514 + save(
  3515 + cons(cons(header,op_comment(opid)),
  3516 + mcons3(odd_align,
  3517 + cons(label,addr),
  3518 + cons(cons(comment,new_string("constructor offline code")),
  3519 + append(c_code,
  3520 + list1(cons(ret,new_integer(arity))))))));
3504 3521 }
3505 3522  
3506 3523 else
... ... @@ -3563,19 +3580,19 @@ Expr constructor_code_1(Expr alt, int alt_index)
3563 3580  
3564 3581 case small_alt:
3565 3582 {
3566   - alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
  3583 + alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
3567 3584  
3568   - result = nil;
  3585 + result = nil;
3569 3586 i = length(alt);
3570   - while(consp(alt))
3571   - {
3572   - result = cons(cons(glue,second(car(alt))),result);
3573   - alt = cdr(alt);
3574   - i--;
3575   - }
3576   - return cons(cons(glue_index,new_integer(alt_index)),
3577   - hard_reverse(result)
3578   - /* result */
  3587 + while(consp(alt))
  3588 + {
  3589 + result = cons(cons(glue,second(car(alt))),result);
  3590 + alt = cdr(alt);
  3591 + i--;
  3592 + }
  3593 + return cons(cons(glue_index,new_integer(alt_index)),
  3594 + hard_reverse(result)
  3595 + /* result */
3579 3596 );
3580 3597 }
3581 3598 break;
... ... @@ -3584,25 +3601,25 @@ Expr constructor_code_1(Expr alt, int alt_index)
3584 3601  
3585 3602 case mixed_alt:
3586 3603 {
3587   - int n, d;
3588   - Expr aux;
3589   - alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
  3604 + int n, d;
  3605 + Expr aux;
  3606 + alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
3590 3607  
3591 3608  
3592   - /* Computing the size of the segment to allocate: it is
  3609 + /* Computing the size of the segment to allocate: it is
3593 3610 4 + w1 + ... + wk. */
3594   - aux = alt;
3595   - n = d = 4;
3596   - while (consp(aux))
3597   - {
3598   - n += integer_value(cdr2(car(aux)));
3599   - aux = cdr(aux);
3600   - }
3601   -
3602   - /* making the constructor code */
3603   - result = nil;
3604   - while(consp(alt))
3605   - {
  3611 + aux = alt;
  3612 + n = d = 4;
  3613 + while (consp(aux))
  3614 + {
  3615 + n += integer_value(cdr2(car(aux)));
  3616 + aux = cdr(aux);
  3617 + }
  3618 +
  3619 + /* making the constructor code */
  3620 + result = nil;
  3621 + while(consp(alt))
  3622 + {
3606 3623 result = cons(cons(cdr2(car(alt)) == new_integer(0)
3607 3624 ?
3608 3625 store_0
... ... @@ -3618,12 +3635,12 @@ Expr constructor_code_1(Expr alt, int alt_index)
3618 3635 store_4,
3619 3636 second(car(alt))+new_integer(d)),
3620 3637 result);
3621   - alt = cdr(alt);
3622   - }
3623   - result = cons(cons(alloc,new_integer(n)),
3624   - append(hard_reverse(result),
3625   - list1(cons(glue_mixed_index,new_integer(alt_index)))));
3626   - return result;
  3638 + alt = cdr(alt);
  3639 + }
  3640 + result = cons(cons(alloc,new_integer(n)),
  3641 + append(hard_reverse(result),
  3642 + list1(cons(glue_mixed_index,new_integer(alt_index)))));
  3643 + return result;
3627 3644 }
3628 3645 break;
3629 3646  
... ... @@ -3631,26 +3648,26 @@ Expr constructor_code_1(Expr alt, int alt_index)
3631 3648  
3632 3649 case large_alt:
3633 3650 {
3634   - int n, d;
3635   - Expr aux;
3636   - alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
  3651 + int n, d;
  3652 + Expr aux;
  3653 + alt = cdr(alt); /* alt = ((i1 o1 . w1) ... (ik ok . wk)) */
3637 3654  
3638 3655  
3639   - /* Computing the size of the segment to allocate: it is
  3656 + /* Computing the size of the segment to allocate: it is
3640 3657 4 + 1 + w1 + ... + wk. */
3641   - aux = alt;
3642   - n = d = 4+1;
3643   - while (consp(aux))
3644   - {
3645   - n += integer_value(cdr2(car(aux)));
3646   - aux = cdr(aux);
3647   - }
3648   - /* n is the number of bytes to allocate */
3649   -
3650   - /* making the constructor code */
3651   - result = nil;
3652   - while(consp(alt))
3653   - {
  3658 + aux = alt;
  3659 + n = d = 4+1;
  3660 + while (consp(aux))
  3661 + {
  3662 + n += integer_value(cdr2(car(aux)));
  3663 + aux = cdr(aux);
  3664 + }
  3665 + /* n is the number of bytes to allocate */
  3666 +
  3667 + /* making the constructor code */
  3668 + result = nil;
  3669 + while(consp(alt))
  3670 + {
3654 3671 result = cons(cons(cdr2(car(alt)) == new_integer(0)
3655 3672 ?
3656 3673 store_0
... ... @@ -3666,13 +3683,13 @@ Expr constructor_code_1(Expr alt, int alt_index)
3666 3683 store_4,
3667 3684 second(car(alt))+new_integer(d)),
3668 3685 result);
3669   - alt = cdr(alt);
3670   - }
  3686 + alt = cdr(alt);
  3687 + }
3671 3688  
3672   - result = cons(cons(alloc,new_integer(n)),
3673   - cons(cons(store_index,new_integer(alt_index)),
3674   - hard_reverse(result)));
3675   - return result;
  3689 + result = cons(cons(alloc,new_integer(n)),
  3690 + cons(cons(store_index,new_integer(alt_index)),
  3691 + hard_reverse(result)));
  3692 + return result;
3676 3693 }
3677 3694 break;
3678 3695  
... ...
anubis_dev/compiler/src/delcode.c
  Show/Hide comments   View file @8b8316a
... ... @@ -61,6 +61,7 @@ static Expr get_mvar_slots_del_instr(Expr type, Expr env)
61 61 else if (type == type_Listener) return mvar_slots_del_conn;
62 62 else if (is_struct_ptr_type(type)) return cons(mvar_slots_del_struct_ptr,cdr(type));
63 63 else if (is_functional_type(type)) return mvar_slots_del_function;
  64 + else if (type == type_Nat) return mvar_slots_del_nat;
64 65 else if (is_address_type(type,nil))
65 66 switch(car(type))
66 67 {
... ... @@ -132,7 +133,7 @@ Expr get_del_code_addr(Expr type,
132 133 for (i = 0; i < next_del_code; i++)
133 134 {
134 135 if (same_type(type,env,del_codes[i].type,del_codes[i].env))
135   - return del_codes[i].addr;
  136 + return del_codes[i].addr;
136 137 }
137 138  
138 139 /* The delete code has not yet been computed */
... ... @@ -159,40 +160,40 @@ Expr get_del_code_addr(Expr type,
159 160  
160 161 /* The delete code for a type T is a not regular subroutine. When called the stack is:
161 162  
162   - datum to be deleted
163   - return address
164   - ...
  163 + datum to be deleted
  164 + return address
  165 + ...
165 166  
166   - and R must not be modified by the deletion procedure. This datum to be deleted is
167   - a pointer for a large type, and a mixture of a pointer and an index for a mixed
168   - type.
  167 + and R must not be modified by the deletion procedure. This datum to be deleted is
  168 + a pointer for a large type, and a mixture of a pointer and an index for a mixed
  169 + type.
169 170  
170   - For large and mixed types, the first thing to do is to determine the alternative of
171   - the datum. This is achieved by (del_index_direct) for mixed types, and by
172   - (del_index_indirect) for large types. These instruction put the index of the
173   - alternative of the datum into I. Furthermore, the index is masked out for a mixed
174   - type. Also the instruction duplicates the pointer on top of stack. Then the stack
175   - is:
  171 + For large and mixed types, the first thing to do is to determine the alternative of
  172 + the datum. This is achieved by (del_index_direct) for mixed types, and by
  173 + (del_index_indirect) for large types. These instruction put the index of the
  174 + alternative of the datum into I. Furthermore, the index is masked out for a mixed
  175 + type. Also the instruction duplicates the pointer on top of stack. Then the stack
  176 + is:
176 177  
177   - pointer to data segment
178   - pointer to data segment
179   - return address
180   - ...
  178 + pointer to data segment
  179 + pointer to data segment
  180 + return address
  181 + ...
181 182  
182   - Duplicating the pointer is needed, because we need both to walk into the data
183   - segment, and to free it at the end.
  183 + Duplicating the pointer is needed, because we need both to walk into the data
  184 + segment, and to free it at the end.
184 185  
185   - Next, we have a 'switch' which branches to the code for the right alternative.
  186 + Next, we have a 'switch' which branches to the code for the right alternative.
186 187  
187   - For a small alternative, the code is just a 'invalid' instruction, since the
188   - deletion code is never called for a small datum. If this happens, this means that
189   - the code is corrupted, and this will stop the virtual machine.
  188 + For a small alternative, the code is just a 'invalid' instruction, since the
  189 + deletion code is never called for a small datum. If this happens, this means that
  190 + the code is corrupted, and this will stop the virtual machine.
190 191  
191   - For a mixed or a large alternative, we need a deletion code which virtually deletes
192   - all components in the data segment. It is produced by another procedure below. This
193   - code increments the pointer on top of stack. When this is done, the data segment
194   - is freed (by 'free_seg_1') which finds the pointer just below the top of stack, the
195   - stack pointer is decremented by 2, and a '(ret . 1)' is performed.
  192 + For a mixed or a large alternative, we need a deletion code which virtually deletes
  193 + all components in the data segment. It is produced by another procedure below. This
  194 + code increments the pointer on top of stack. When this is done, the data segment
  195 + is freed (by 'free_seg_1') which finds the pointer just below the top of stack, the
  196 + stack pointer is decremented by 2, and a '(ret . 1)' is performed.
196 197 */
197 198  
198 199 if (consp(type) && car(type) == type_Var)
... ... @@ -200,10 +201,10 @@ Expr get_del_code_addr(Expr type,
200 201 /* The deletion code is as follows:
201 202  
202 203 label ?: v r ...
203   - free_var_seg c r ... free var segment and replace it by its
204   - content
205   - del_stack_instr(T) r ...
206   - ret ...
  204 + free_var_seg c r ... free var segment and replace it by its
  205 + content
  206 + del_stack_instr(T) r ...
  207 + ret ...
207 208 */
208 209 Expr result = nil;
209 210  
... ... @@ -215,7 +216,7 @@ Expr get_del_code_addr(Expr type,
215 216 free_var_seg,
216 217 get_del_stack_instr(cdr(type),env,new_integer(0)),
217 218 cons(ret,new_integer(1))
218   - );
  219 + );
219 220  
220 221 del_codes[i].offline_code = save(result);
221 222 }
... ... @@ -223,23 +224,23 @@ Expr get_del_code_addr(Expr type,
223 224 else if (consp(type) && car(type) == type_MVar)
224 225 {
225 226 /* The deletion code is as follows:
226   - 1. get the number 'n' of slots
227   - 2. virtually delete each slot
228   - 3. delete the handlers table
229   - 4. delete the segment
  227 + 1. get the number 'n' of slots
  228 + 2. virtually delete each slot
  229 + 3. delete the handlers table
  230 + 4. delete the segment
230 231  
231   - label ?: mv r ...
  232 + label ?: mv r ...
232 233 push_mvar_length n mv r ...
233 234 mvar_slots_del_? ... mv r ...
234 235 free_mvar_seg r ...
235 236 ret ...
236 237  
237   - where addr is the address of deletioncode for the data in the slots.
  238 + where addr is the address of deletioncode for the data in the slots.
238 239  
239   - If there is no deletion code for the data in the slots, the deletion code for the
240   - multiple variable is:
  240 + If there is no deletion code for the data in the slots, the deletion code for the
  241 + multiple variable is:
241 242  
242   - label ?: mv r ...
  243 + label ?: mv r ...
243 244 free_mvar_seg r ...
244 245 ret ...
245 246 */
... ... @@ -273,66 +274,66 @@ Expr get_del_code_addr(Expr type,
273 274  
274 275 else
275 276 {
276   - Expr alts = cdr3(implem);
277   - Expr case_addrs = nil;
278   - Expr aux;
279   - Expr result = nil;
280   - Expr alts_codes = nil;
281   -
282   - /* get a list of addresses for cases */
283   - aux = alts;
284   - while (consp(aux))
285   - {
286   - case_addrs = cons(new_addr_name(labs_none,0),case_addrs);
287   - aux = cdr(aux);
288   - }
289   -
290   - /* get the codes for alternatives */
291   - while (consp(alts))
292   - {
293   - alts_codes = cons(alt_del_code(car(alts),
294   - env),
295   - alts_codes);
296   - alts = cdr(alts);
297   - }
298   -
299   - /* record codes for alternatives with their labels */
300   - aux = case_addrs;
301   - while (consp(alts_codes))
302   - {
303   - result = cons(cons(label,car(aux)),append(car(alts_codes),result));
304   - alts_codes = cdr(alts_codes);
305   - aux = cdr(aux);
306   - }
307   -
308   - /* add a switch */
309   - result = cons(cons(_switch,reverse(case_addrs)),result);
310   -
311   - /* add the 'index' instruction */
312   - if (type_sort == large_type)
313   - {
314   - result = cons(del_index_indirect,result);
315   - }
316   - else
317   - {
318   - result = cons(del_index_direct,result);
319   - }
  277 + Expr alts = cdr3(implem);
  278 + Expr case_addrs = nil;
  279 + Expr aux;
  280 + Expr result = nil;
  281 + Expr alts_codes = nil;
  282 +
  283 + /* get a list of addresses for cases */
  284 + aux = alts;
  285 + while (consp(aux))
  286 + {
  287 + case_addrs = cons(new_addr_name(labs_none,0),case_addrs);
  288 + aux = cdr(aux);
  289 + }
  290 +
  291 + /* get the codes for alternatives */
  292 + while (consp(alts))
  293 + {
  294 + alts_codes = cons(alt_del_code(car(alts),
  295 + env),
  296 + alts_codes);
  297 + alts = cdr(alts);
  298 + }
  299 +
  300 + /* record codes for alternatives with their labels */
  301 + aux = case_addrs;
  302 + while (consp(alts_codes))
  303 + {
  304 + result = cons(cons(label,car(aux)),append(car(alts_codes),result));
  305 + alts_codes = cdr(alts_codes);
  306 + aux = cdr(aux);
  307 + }
  308 +
  309 + /* add a switch */
  310 + result = cons(cons(_switch,reverse(case_addrs)),result);
  311 +
  312 + /* add the 'index' instruction */
  313 + if (type_sort == large_type)
  314 + {
  315 + result = cons(del_index_indirect,result);
  316 + }
  317 + else
  318 + {
  319 + result = cons(del_index_direct,result);
  320 + }
320 321  
321 322 /* if deleting a monitoring ticket insert a 'remove_monitor' */
322 323 if (consp(type) && car(type) == app_ts && second(type) == pdstr_MonitoringTicket)
323 324 result = cons(remove_monitor,
324 325 result);
325 326  
326   - /* add the label of the subroutine */
327   - result = mcons4(cons(header,new_string("* * * deletion code * * *")),
328   - cons(label,del_codes[i].addr),
329   - mcons3(context,list2(cons(argument,type),
330   - cons(ret,new_integer(1))),
331   - env),
332   - result);
333   -
334   - /* store the offline code */
335   - del_codes[i].offline_code = save(result);
  327 + /* add the label of the subroutine */
  328 + result = mcons4(cons(header,new_string("* * * deletion code * * *")),
  329 + cons(label,del_codes[i].addr),
  330 + mcons3(context,list2(cons(argument,type),
  331 + cons(ret,new_integer(1))),
  332 + env),
  333 + result);
  334 +
  335 + /* store the offline code */
  336 + del_codes[i].offline_code = save(result);
336 337 }
337 338  
338 339 /* return address of deletion code */
... ... @@ -352,6 +353,7 @@ Expr get_del_code_addr(Expr type,
352 353 (indirect_del_var . <addr>)
353 354 (indirect_del_struct_ptr . <id>)
354 355 (indirect_del_function)
  356 + (indirect_del_nat)
355 357 (indirect_del . <addr>)
356 358 (indirect_del_mixed <mask> . <addr>)
357 359 (indirect_del_mvar . <addr>)
... ... @@ -383,33 +385,33 @@ Expr component_del_code(int id)
383 385 case type_WAddr:
384 386 case type_RWAddr:
385 387 return list1(indirect_del_conn);
386   - break;
  388 + break;
387 389 case type_Var:
388   - {
389   - Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
  390 + {
  391 + Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
390 392 /* del_code_addr is the address of deletion code for type 'Var(T)', not for type
391 393 'T'. It is never 'nil'. */
392   - assert(del_code_addr != nil);
  394 + assert(del_code_addr != nil);
393 395 return list1(cons(indirect_del_var,del_code_addr));
394   - }
395   - break;
  396 + }
  397 + break;
396 398  
397 399 case type_MVar:
398   - {
  400 + {
399 401 /* del_code_addr is the address of deletion code for type 'MVar(T)', not for
400 402 type 'T'. It is never 'nil'. */
401   - Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
402   - assert(del_code_addr != nil);
  403 + Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
  404 + assert(del_code_addr != nil);
403 405 return list1(cons(indirect_del_mvar,del_code_addr));
404   - }
405   - break;
  406 + }
  407 + break;
406 408  
407 409 case type_GAddr:
408   - return nil;
409   - break;
  410 + return nil;
  411 + break;
410 412  
411 413 default:
412   - assert(0);
  414 + assert(0);
413 415 }
414 416  
415 417 if (is_struct_ptr_type(implem))
... ... @@ -418,6 +420,9 @@ Expr component_del_code(int id)
418 420 if (is_functional_type(implem)) /* functional type */
419 421 return list1(indirect_del_function);
420 422  
  423 + if (implem == type_Nat)
  424 + return list1(indirect_del_nat);
  425 +
421 426 if (!consp(implem))
422 427 {
423 428 internal_error("Cannot understand implementation",implem);
... ... @@ -429,19 +434,19 @@ Expr component_del_code(int id)
429 434  
430 435 case large_type:
431 436 {
432   - /* we have to delete virtually the datum whose manipulation word is pointed to
433   - from the top of stack. This word is a pointer, except in the mixed case, where
434   - it may be a manipulation word of a small datum, or a pointer glued to an index.
435   - We use a indirect_del or indirect_del_mixed instruction. */
436   - return list1(cons(indirect_del,
  437 + /* we have to delete virtually the datum whose manipulation word is pointed to
  438 + from the top of stack. This word is a pointer, except in the mixed case, where
  439 + it may be a manipulation word of a small datum, or a pointer glued to an index.
  440 + We use a indirect_del or indirect_del_mixed instruction. */
  441 + return list1(cons(indirect_del,
437 442 get_del_code_addr(implems[id].type,implems[id].env)));
438 443 }
439 444 case mixed_type:
440 445 return list1(mcons3(indirect_del_mixed,
441   - mixed_copy_mask(implem),
442   - get_del_code_addr(implems[id].type,implems[id].env)));
  446 + mixed_copy_mask(implem),
  447 + get_del_code_addr(implems[id].type,implems[id].env)));
443 448  
444   - default:
  449 + default:
445 450 assert(0);
446 451 return nil;
447 452 }
... ... @@ -464,23 +469,23 @@ static Expr alt_del_code(Expr alt_implem,
464 469 code_offset--;
465 470 case large_alt:
466 471 {
467   - /* get geometry of components in reverse order */
468   - Expr geoms = reverse(cdr(alt_implem));
469   - /* each geometry has the form: (<imp> <offset> . <width>) */
  472 + /* get geometry of components in reverse order */
  473 + Expr geoms = reverse(cdr(alt_implem));
  474 + /* each geometry has the form: (<imp> <offset> . <width>) */
470 475  
471   - Expr result = list3(free_seg_1,
  476 + Expr result = list3(free_seg_1,
472 477 pop2,
473 478 cons(ret,new_integer(1)));
474   - Expr prevw;
  479 + Expr prevw;
475 480  
476   - while (consp(geoms))
477   - {
  481 + while (consp(geoms))
  482 + {
478 483 Expr util;
479 484  
480   - if (!consp(cdr(geoms)))
481   - prevw = new_integer(code_offset);
482   - else
483   - prevw = cdr2(car(cdr(geoms)));
  485 + if (!consp(cdr(geoms)))
  486 + prevw = new_integer(code_offset);
  487 + else
  488 + prevw = cdr2(car(cdr(geoms)));
484 489  
485 490 util = append(component_del_code(integer_value(car(car(geoms)))),
486 491 result);
... ... @@ -491,11 +496,11 @@ static Expr alt_del_code(Expr alt_implem,
491 496 else
492 497 result = util;
493 498  
494   - geoms = cdr(geoms);
495   - }
  499 + geoms = cdr(geoms);
  500 + }
496 501  
497 502  
498   - return result;
  503 + return result;
499 504 }
500 505 default:
501 506 assert(0);
... ...
anubis_dev/compiler/src/typewidth.c
  Show/Hide comments   View file @8b8316a
... ... @@ -181,8 +181,6 @@ int type_width(Expr type,
181 181 assert(type != key_not_found);
182 182 }
183 183  
184   - if (type == type_Int32) return mw+1;
185   -
186 184 if (is_primitive_type(type))
187 185 return mw+1;
188 186  
... ...
anubis_dev/compiler/src/vminstr.c
  Show/Hide comments   View file @8b8316a
... ... @@ -195,6 +195,7 @@ int instruction_size(Expr instr, int offset)
195 195 case unstore_copy:
196 196 case unstore_copy_ptr:
197 197 case unstore_copy_function:
  198 + case unstore_copy_nat:
198 199 case alloc:
199 200 case increment_del:
200 201 case increment_eq:
... ... @@ -202,6 +203,7 @@ int instruction_size(Expr instr, int offset)
202 203 case vcopy_mixed:
203 204 case copy_stack_ptr:
204 205 case copy_stack_function:
  206 + case copy_stack_nat:
205 207 case mixed_alt_begin:
206 208 case large_alt_begin:
207 209 case mixed_alt_end:
... ... @@ -219,12 +221,14 @@ int instruction_size(Expr instr, int offset)
219 221 case put_copy_direct:
220 222 case put_copy_indirect:
221 223 case put_copy_function:
  224 + case put_copy_nat:
222 225 return 3;
223 226  
224 227 case put_copy_mixed:
225 228 case put_micro_copy_direct:
226 229 case put_micro_copy_indirect:
227 230 case put_micro_copy_function:
  231 + case put_micro_copy_nat:
228 232 return 4;
229 233  
230 234 // case load:
... ... @@ -255,6 +259,7 @@ int instruction_size(Expr instr, int offset)
255 259 case del_stack_ptr:
256 260 case del_stack_conn:
257 261 case del_stack_function:
  262 + case del_stack_nat:
258 263 case init_gv:
259 264 case serialize:
260 265 case unserialize:
... ... @@ -307,7 +312,11 @@ int instruction_size(Expr instr, int offset)
307 312 return 5;
308 313  
309 314 case load_nat_big:
310   - return 9 + length(cdr(instr));
  315 + {
  316 + U32 n = length(cdr(instr));
  317 + while (n&3) n++;
  318 + return 9 + n;
  319 + }
311 320  
312 321 case type_mixed_switch:
313 322 return 3 + 4*length(cdr2(instr));
... ... @@ -359,7 +368,9 @@ int instruction_size(Expr instr, int offset)
359 368 case del_index_indirect:
360 369 case indirect_del_ptr:
361 370 case indirect_del_function:
  371 + case indirect_del_nat:
362 372 case del_function:
  373 + case del_nat:
363 374 case indirect_del_conn:
364 375 case invalid:
365 376 case free_var_seg:
... ... @@ -382,8 +393,9 @@ int instruction_size(Expr instr, int offset)
382 393 case copy:
383 394 case copy_ptr:
384 395 case copy_function:
  396 + case copy_nat:
385 397 case vcopy_ptr:
386   - case vcopy_function:
  398 + case vcopy_nat:
387 399 case vcopy_null:
388 400 case index_indirect:
389 401 case free_seg_0:
... ... @@ -399,6 +411,7 @@ int instruction_size(Expr instr, int offset)
399 411 case mvar_slots_del_conn:
400 412 case mvar_slots_del_ptr:
401 413 case mvar_slots_del_function:
  414 + case mvar_slots_del_nat:
402 415 case finish:
403 416 case get_gvv:
404 417 case xchg_gvv:
... ... @@ -500,409 +513,432 @@ void translate_instruction(U8 **ptr,
500 513 case context:
501 514 case code_for:
502 515 case type_list:
503   - break;
  516 + break;
504 517  
505 518 case apply: /* (apply . k) */
506   - *((*ptr)++) = i_apply;
507   - *((*ptr)++) = (U8)(integer_value(cdr(instr)));
508   - break;
  519 + *((*ptr)++) = i_apply;
  520 + *((*ptr)++) = (U8)(integer_value(cdr(instr)));
  521 + break;
509 522  
510 523 case ret:
511   - *((*ptr)++) = i_ret;
512   - break;
  524 + *((*ptr)++) = i_ret;
  525 + break;
513 526  
514 527 case copy_stack_ptr: /* (copy_stack_ptr . <depth>) */
515 528 *((*ptr)++) = i_copy_stack_ptr;
516   - *((*ptr)++) = integer_value(cdr(instr));
517   - break;
  529 + *((*ptr)++) = integer_value(cdr(instr));
  530 + break;
518 531  
519 532 case copy_stack_function: /* (copy_stack_function . <depth>) */
520 533 *((*ptr)++) = i_copy_stack_function;
521   - *((*ptr)++) = integer_value(cdr(instr));
522   - break;
  534 + *((*ptr)++) = integer_value(cdr(instr));
  535 + break;
  536 +
  537 + case copy_stack_nat: /* (copy_stack_nat . <depth>) */
  538 + *((*ptr)++) = i_copy_stack_nat;
  539 + *((*ptr)++) = integer_value(cdr(instr));
  540 + break;
523 541  
524 542 case mixed_alt_begin: /* (mixed_alt_begin . <byte width>) */
525 543 *((*ptr)++) = i_mixed_alt_begin;
526   - *((*ptr)++) = integer_value(cdr(instr));
527   - break;
  544 + *((*ptr)++) = integer_value(cdr(instr));
  545 + break;
528 546  
529 547 case large_alt_begin: /* (large_alt_begin . <byte width>) */
530 548 *((*ptr)++) = i_large_alt_begin;
531   - *((*ptr)++) = integer_value(cdr(instr));
532   - break;
  549 + *((*ptr)++) = integer_value(cdr(instr));
  550 + break;
533 551  
534 552 case mixed_alt_end: /* (mixed_alt_end . <index>) */
535 553 *((*ptr)++) = i_mixed_alt_end;
536   - *((*ptr)++) = integer_value(cdr(instr));
537   - break;
  554 + *((*ptr)++) = integer_value(cdr(instr));
  555 + break;
538 556  
539 557 case large_alt_end: /* (large_alt_end . <index>) */
540 558 *((*ptr)++) = i_large_alt_end;
541   - *((*ptr)++) = integer_value(cdr(instr));
542   - break;
  559 + *((*ptr)++) = integer_value(cdr(instr));
  560 + break;
543 561  
544 562 case revert_to_computing: /* (revert_to_computing . <type width>) */
545   - *((*ptr)++) = i_revert_to_computing;
546   - *((*ptr)++) = integer_value(cdr(instr));
547   - break;
  563 + *((*ptr)++) = i_revert_to_computing;
  564 + *((*ptr)++) = integer_value(cdr(instr));
  565 + break;
548 566  
549 567 case success: /* (success . <type width>) */
550   - *((*ptr)++) = i_success;
551   - *((*ptr)++) = integer_value(cdr(instr));
552   - break;
  568 + *((*ptr)++) = i_success;
  569 + *((*ptr)++) = integer_value(cdr(instr));
  570 + break;
553 571  
554 572 case glue_index: /* (glue_index . i) */
555   - *((*ptr)++) = i_glue_index;
556   - *((*ptr)++) = integer_value(cdr(instr));
557   - break;
  573 + *((*ptr)++) = i_glue_index;
  574 + *((*ptr)++) = integer_value(cdr(instr));
  575 + break;
558 576  
559 577 case glue: /* (glue . bw) */
560   - *((*ptr)++) = i_glue;
561   - *((*ptr)++) = integer_value(cdr(instr));
562   - break;
  578 + *((*ptr)++) = i_glue;
  579 + *((*ptr)++) = integer_value(cdr(instr));
  580 + break;
563 581  
564 582 case store_index: /* (store_index . i) */
565   - *((*ptr)++) = i_store_index;
566   - *((*ptr)++) = integer_value(cdr(instr));
567   - break;
  583 + *((*ptr)++) = i_store_index;
  584 + *((*ptr)++) = integer_value(cdr(instr));
  585 + break;
568 586  
569 587 case store_0:
570   - *((*ptr)++) = i_store_0;
571   - *((*ptr)++) = integer_value(cdr(instr));
572   - break;
  588 + *((*ptr)++) = i_store_0;
  589 + *((*ptr)++) = integer_value(cdr(instr));
  590 + break;
573 591  
574 592 case store_1:
575   - *((*ptr)++) = i_store_1;
576   - *((*ptr)++) = integer_value(cdr(instr));
577   - break;
  593 + *((*ptr)++) = i_store_1;
  594 + *((*ptr)++) = integer_value(cdr(instr));
  595 + break;
578 596  
579 597 case store_2:
580   - *((*ptr)++) = i_store_2;
581   - *((*ptr)++) = integer_value(cdr(instr));
582   - break;
  598 + *((*ptr)++) = i_store_2;
  599 + *((*ptr)++) = integer_value(cdr(instr));
  600 + break;
583 601  
584 602 case store_4:
585   - *((*ptr)++) = i_store_4;
586   - *((*ptr)++) = integer_value(cdr(instr));
587   - break;
  603 + *((*ptr)++) = i_store_4;
  604 + *((*ptr)++) = integer_value(cdr(instr));
  605 + break;
588 606  
589 607 case glue_mixed_index: /* (glue_mixed_index . i) */
590   - *((*ptr)++) = i_glue_mixed_index;
591   - *((*ptr)++) = integer_value(cdr(instr));
592   - break;
  608 + *((*ptr)++) = i_glue_mixed_index;
  609 + *((*ptr)++) = integer_value(cdr(instr));
  610 + break;
593 611  
594 612 case index_direct: /* (index_direct . <bit width>) */
595   - *((*ptr)++) = i_index_direct;
596   - *((*ptr)++) = integer_value(cdr(instr));
597   - break;
  613 + *((*ptr)++) = i_index_direct;
  614 + *((*ptr)++) = integer_value(cdr(instr));
  615 + break;
598 616  
599 617 case alt_number_direct: /* (alt_number_direct . <bit width>) */
600   - *((*ptr)++) = i_alt_number_direct;
601   - *((*ptr)++) = integer_value(cdr(instr));
602   - break;
  618 + *((*ptr)++) = i_alt_number_direct;
  619 + *((*ptr)++) = integer_value(cdr(instr));
  620 + break;
603 621  
604 622 case increment_del: /* (increment_del . <byte width>) */
605   - *((*ptr)++) = i_increment_del;
606   - *((*ptr)++) = integer_value(cdr(instr));
607   - break;
  623 + *((*ptr)++) = i_increment_del;
  624 + *((*ptr)++) = integer_value(cdr(instr));
  625 + break;
608 626  
609 627 case increment_eq: /* (increment_eq . <byte width>) */
610   - *((*ptr)++) = i_increment_eq;
611   - *((*ptr)++) = integer_value(cdr(instr));
612   - break;
  628 + *((*ptr)++) = i_increment_eq;
  629 + *((*ptr)++) = integer_value(cdr(instr));
  630 + break;
613 631  
614 632 case unglue: /* (unglue <bit width> . <right shift>) */
615   - *((*ptr)++) = i_unglue;
616   - *((*ptr)++) = integer_value(second(instr));
617   - *((*ptr)++) = integer_value(cdr2(instr));
618   - break;
  633 + *((*ptr)++) = i_unglue;
  634 + *((*ptr)++) = integer_value(second(instr));
  635 + *((*ptr)++) = integer_value(cdr2(instr));
  636 + break;
619 637  
620 638 case unstore: /* (unstore <offset> . [0|1|2|4]) -->
621 639 unstore_? <offset> */
622   - {
623   - int i = integer_value(cdr2(instr));
624   - int i_code = i == 0 ? i_unstore_0 : i == 1 ? i_unstore_1 : i == 2 ? i_unstore_2 : i_unstore_4;
625   - *((*ptr)++) = i_code;
626   - *((*ptr)++) = integer_value(second(instr));
627   - }
628   - break;
  640 + {
  641 + int i = integer_value(cdr2(instr));
  642 + int i_code = i == 0 ? i_unstore_0 : i == 1 ? i_unstore_1 : i == 2 ? i_unstore_2 : i_unstore_4;
  643 + *((*ptr)++) = i_code;
  644 + *((*ptr)++) = integer_value(second(instr));
  645 + }
  646 + break;
629 647  
630 648  
631 649 case unstore_copy: /* (unstore_copy . <offset>) */
632   - *((*ptr)++) = i_unstore_copy;
633   - *((*ptr)++) = integer_value(cdr(instr));
634   - break;
  650 + *((*ptr)++) = i_unstore_copy;
  651 + *((*ptr)++) = integer_value(cdr(instr));
  652 + break;
635 653  
636 654 case unstore_copy_mixed: /* (unstore_copy_mixed <offset> . <mask>) */
637   - *((*ptr)++) = i_unstore_copy_mixed;
638   - *((*ptr)++) = integer_value(second(instr));
639   - *((*ptr)++) = integer_value(cdr2(instr));
640   - break;
  655 + *((*ptr)++) = i_unstore_copy_mixed;
  656 + *((*ptr)++) = integer_value(second(instr));
  657 + *((*ptr)++) = integer_value(cdr2(instr));
  658 + break;
641 659  
642 660 case copy_stack_mixed: /* (copy_stack_mixed <depth> . <mask>) */
643   - *((*ptr)++) = i_copy_stack_mixed;
644   - *((*ptr)++) = integer_value(second(instr));
645   - *((*ptr)++) = integer_value(cdr2(instr));
646   - break;
  661 + *((*ptr)++) = i_copy_stack_mixed;
  662 + *((*ptr)++) = integer_value(second(instr));
  663 + *((*ptr)++) = integer_value(cdr2(instr));
  664 + break;
647 665  
648 666 case put_copy_direct: /* (put_copy_direct <depth> . <pos>) */
649   - *((*ptr)++) = i_put_copy_direct;
650   - *((*ptr)++) = integer_value(second(instr));
651   - *((*ptr)++) = integer_value(cdr2(instr));
652   - break;
  667 + *((*ptr)++) = i_put_copy_direct;
  668 + *((*ptr)++) = integer_value(second(instr));
  669 + *((*ptr)++) = integer_value(cdr2(instr));
  670 + break;
653 671  
654 672 case put_copy_indirect: /* (put_copy_indirect <depth> . <pos>) */
655   - *((*ptr)++) = i_put_copy_indirect;
656   - *((*ptr)++) = integer_value(second(instr));
657   - *((*ptr)++) = integer_value(cdr2(instr));
658   - break;
  673 + *((*ptr)++) = i_put_copy_indirect;
  674 + *((*ptr)++) = integer_value(second(instr));
  675 + *((*ptr)++) = integer_value(cdr2(instr));
  676 + break;
659 677  
660 678 case put_copy_function: /* (put_copy_function <depth> . <pos>) */
661   - *((*ptr)++) = i_put_copy_function;
662   - *((*ptr)++) = integer_value(second(instr));
663   - *((*ptr)++) = integer_value(cdr2(instr));
664   - break;
  679 + *((*ptr)++) = i_put_copy_function;
  680 + *((*ptr)++) = integer_value(second(instr));
  681 + *((*ptr)++) = integer_value(cdr2(instr));
  682 + break;
  683 +
  684 + case put_copy_nat: /* (put_copy_nat <depth> . <pos>) */
  685 + *((*ptr)++) = i_put_copy_nat;
  686 + *((*ptr)++) = integer_value(second(instr));
  687 + *((*ptr)++) = integer_value(cdr2(instr));
  688 + break;
665 689  
666 690 case put_copy_mixed: /* (put_copy_mixed <mask> <depth> . <pos>) */
667   - *((*ptr)++) = i_put_copy_mixed;
668   - *((*ptr)++) = integer_value(second(instr));
669   - *((*ptr)++) = integer_value(third(instr));
670   - *((*ptr)++) = integer_value(cdr3(instr));
671   - break;
  691 + *((*ptr)++) = i_put_copy_mixed;
  692 + *((*ptr)++) = integer_value(second(instr));
  693 + *((*ptr)++) = integer_value(third(instr));
  694 + *((*ptr)++) = integer_value(cdr3(instr));
  695 + break;
672 696  
673 697 case put_micro_copy_direct: /* (put_micro_copy_direct <depth> <micro depth> . <pos>) */
674   - *((*ptr)++) = i_put_micro_copy_direct;
675   - *((*ptr)++) = integer_value(second(instr));
676   - *((*ptr)++) = integer_value(third(instr));
677   - *((*ptr)++) = integer_value(cdr3(instr));
678   - break;
  698 + *((*ptr)++) = i_put_micro_copy_direct;
  699 + *((*ptr)++) = integer_value(second(instr));
  700 + *((*ptr)++) = integer_value(third(instr));
  701 + *((*ptr)++) = integer_value(cdr3(instr));
  702 + break;
679 703  
680 704 case put_micro_copy_indirect: /* (put_micro_copy_indirect <depth> <micro depth> . <pos>) */
681   - *((*ptr)++) = i_put_micro_copy_indirect;
682   - *((*ptr)++) = integer_value(second(instr));
683   - *((*ptr)++) = integer_value(third(instr));
684   - *((*ptr)++) = integer_value(cdr3(instr));
685   - break;
  705 + *((*ptr)++) = i_put_micro_copy_indirect;
  706 + *((*ptr)++) = integer_value(second(instr));
  707 + *((*ptr)++) = integer_value(third(instr));
  708 + *((*ptr)++) = integer_value(cdr3(instr));
  709 + break;
686 710  
687 711 case put_micro_copy_function: /* (put_micro_copy_function <depth> <micro_depth> . <pos>) */
688   - *((*ptr)++) = i_put_micro_copy_function;
689   - *((*ptr)++) = integer_value(second(instr));
690   - *((*ptr)++) = integer_value(third(instr));
691   - *((*ptr)++) = integer_value(cdr3(instr));
692   - break;
  712 + *((*ptr)++) = i_put_micro_copy_function;
  713 + *((*ptr)++) = integer_value(second(instr));
  714 + *((*ptr)++) = integer_value(third(instr));
  715 + *((*ptr)++) = integer_value(cdr3(instr));
  716 + break;
  717 +
  718 + case put_micro_copy_nat: /* (put_micro_copy_nat <depth> <micro_depth> . <pos>) */
  719 + *((*ptr)++) = i_put_micro_copy_nat;
  720 + *((*ptr)++) = integer_value(second(instr));
  721 + *((*ptr)++) = integer_value(third(instr));
  722 + *((*ptr)++) = integer_value(cdr3(instr));
  723 + break;
693 724  
694 725 case put_micro_copy_mixed: /* (put_micro_copy_mixed <mask> <depth> <micro depth> . <pos>) */
695   - *((*ptr)++) = i_put_micro_copy_mixed;
696   - *((*ptr)++) = integer_value(second(instr));
697   - *((*ptr)++) = integer_value(third(instr));
698   - *((*ptr)++) = integer_value(forth(instr));
699   - *((*ptr)++) = integer_value(cdr4(instr));
700   - break;
  726 + *((*ptr)++) = i_put_micro_copy_mixed;
  727 + *((*ptr)++) = integer_value(second(instr));
  728 + *((*ptr)++) = integer_value(third(instr));
  729 + *((*ptr)++) = integer_value(forth(instr));
  730 + *((*ptr)++) = integer_value(cdr4(instr));
  731 + break;
701 732  
702 733 case unstore_copy_ptr: /* (unstore_copy_ptr . <offset>) */
703   - *((*ptr)++) = i_unstore_copy_ptr;
704   - *((*ptr)++) = integer_value(cdr(instr));
705   - break;
  734 + *((*ptr)++) = i_unstore_copy_ptr;
  735 + *((*ptr)++) = integer_value(cdr(instr));
  736 + break;
706 737  
707 738 case unstore_copy_function: /* (unstore_copy_function . <offset>) */
708   - *((*ptr)++) = i_unstore_copy_function;
709   - *((*ptr)++) = integer_value(cdr(instr));
710   - break;
  739 + *((*ptr)++) = i_unstore_copy_function;
  740 + *((*ptr)++) = integer_value(cdr(instr));
  741 + break;
  742 +
  743 + case unstore_copy_nat: /* (unstore_copy_nat . <offset>) */
  744 + *((*ptr)++) = i_unstore_copy_nat;
  745 + *((*ptr)++) = integer_value(cdr(instr));
  746 + break;
711 747  
712 748 case alloc: /* (alloc . <num bytes>) -->
713 749 i_alloc <num words>-2 */
714   - {
715   - int i = integer_value(cdr(instr));
716   - if ((i & 3) == 0) i--;
717   - i = (i>>2) - 1; /* <num words>-2 */
718   - *((*ptr)++) = i_alloc;
719   - *((*ptr)++) = (U8)i;
720   - }
721   - break;
  750 + {
  751 + int i = integer_value(cdr(instr));
  752 + if ((i & 3) == 0) i--;
  753 + i = (i>>2) - 1; /* <num words>-2 */
  754 + *((*ptr)++) = i_alloc;
  755 + *((*ptr)++) = (U8)i;
  756 + }
  757 + break;
722 758  
723 759  
724 760 #ifdef never_defined
725 761 case load: /* (load . <address>) */
726   - *((*ptr)++) = i_load;
727   - *(((U32 *)(*ptr))++) = offsets[integer_value(cdr(instr))];
728   - break;
  762 + *((*ptr)++) = i_load;
  763 + *(((U32 *)(*ptr))++) = offsets[integer_value(cdr(instr))];
  764 + break;
729 765 #endif
730 766  
731 767 case load_int32: /* (load_int32 . <Cint>) */
732   - *((*ptr)++) = i_load_int32;
733   - *(((U32 *)(*ptr))) = cdr(instr); /* this is a <Cint> */
734   - *ptr += sizeof(U32);
735   - break;
  768 + *((*ptr)++) = i_load_int32;
  769 + *(((U32 *)(*ptr))) = cdr(instr); /* this is a <Cint> */
  770 + *ptr += sizeof(U32);
  771 + break;
736 772  
737 773 case check_stack: /* (check_stack . n) */
738 774 *((*ptr)++) = i_check_stack;
739   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
740   - *ptr += sizeof(U32);
741   - break;
  775 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  776 + *ptr += sizeof(U32);
  777 + break;
742 778  
743 779 case push_addr: /* (push_addr . a) */
744 780 *((*ptr)++) = i_push_addr;
745   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
746   - *ptr += sizeof(U32);
747   - break;
  781 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  782 + *ptr += sizeof(U32);
  783 + break;
748 784  
749 785 case select_index_direct: /* (select_index_direct bw index . addr) */
750   - *((*ptr)++) = i_select_index_direct;
751   - *((*ptr)++) = (U8)(integer_value(second(instr)));
752   - *((*ptr)++) = (U8)(integer_value(third(instr)));
753   - *(((U32 *)(*ptr))) = (U32)(offsets[integer_value(cdr3(instr))]);
754   - *ptr += sizeof(U32);
755   - break;
  786 + *((*ptr)++) = i_select_index_direct;
  787 + *((*ptr)++) = (U8)(integer_value(second(instr)));
  788 + *((*ptr)++) = (U8)(integer_value(third(instr)));
  789 + *(((U32 *)(*ptr))) = (U32)(offsets[integer_value(cdr3(instr))]);
  790 + *ptr += sizeof(U32);
  791 + break;
756 792  
757 793 case select_index_indirect: /* (select_index_indirect index . addr) */
758   - *((*ptr)++) = i_select_index_indirect;
759   - *((*ptr)++) = (U8)(integer_value(second(instr)));
760   - *(((U32 *)(*ptr))) = (U32)(offsets[integer_value(cdr2(instr))]);
761   - *ptr += sizeof(U32);
762   - break;
  794 + *((*ptr)++) = i_select_index_indirect;
  795 + *((*ptr)++) = (U8)(integer_value(second(instr)));
  796 + *(((U32 *)(*ptr))) = (U32)(offsets[integer_value(cdr2(instr))]);
  797 + *ptr += sizeof(U32);
  798 + break;
763 799  
764   - /* the following may cause a problem because floats are perhaps
  800 + /* the following may cause a problem because floats are perhaps
765 801 not portable */
766 802 case load_float: /* (load_float <int32 mantissa> . <int32 exponent>) */
767   - *((*ptr)++) = i_load_float;
768   - *(((U32 *)(*ptr))) = integer_value(second(instr)); /* mantissa (always positive) */
769   - *ptr += sizeof(U32);
770   - *(((U32 *)(*ptr))) = integer_value(cdr2(instr)); /* exponent (signed) */
771   - *ptr += sizeof(U32);
772   - break;
  803 + *((*ptr)++) = i_load_float;
  804 + *(((U32 *)(*ptr))) = integer_value(second(instr)); /* mantissa (always positive) */
  805 + *ptr += sizeof(U32);
  806 + *(((U32 *)(*ptr))) = integer_value(cdr2(instr)); /* exponent (signed) */
  807 + *ptr += sizeof(U32);
  808 + break;
773 809  
774 810 case collapse:
775   - *((*ptr)++) = i_collapse;
776   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
777   - *ptr += sizeof(U32);
778   - break;
  811 + *((*ptr)++) = i_collapse;
  812 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  813 + *ptr += sizeof(U32);
  814 + break;
779 815  
780 816 case create_vars: /* (create_vars . <number of variables>) */
781   - *((*ptr)++) = i_create_vars;
782   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
783   - *ptr += sizeof(U32);
784   - break;
  817 + *((*ptr)++) = i_create_vars;
  818 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  819 + *ptr += sizeof(U32);
  820 + break;
785 821  
786 822 case copy_mixed:
787   - *((*ptr)++) = i_copy_mixed;
788   - *((*ptr)++) = integer_value(cdr(instr));
789   - break;
  823 + *((*ptr)++) = i_copy_mixed;
  824 + *((*ptr)++) = integer_value(cdr(instr));
  825 + break;
790 826  
791 827 case vcopy_mixed:
792   - *((*ptr)++) = i_vcopy_mixed;
793   - *((*ptr)++) = integer_value(cdr(instr));
794   - break;
  828 + *((*ptr)++) = i_vcopy_mixed;
  829 + *((*ptr)++) = integer_value(cdr(instr));
  830 + break;
795 831  
796 832 case type_small_alt: /* (type_small_alt n1 ... n_k) -> i_type_small_alt (U32)k n1 ... nk */
797   - *((*ptr)++) = i_type_small_alt;
798   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
799   - *ptr += sizeof(U32);
  833 + *((*ptr)++) = i_type_small_alt;
  834 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  835 + *ptr += sizeof(U32);
800 836 {
801 837 aux = cdr(instr);
802 838 while (consp(aux))
803 839 {
804   - *((*ptr)++) = (U8)integer_value(car(aux));
  840 + *((*ptr)++) = (U8)integer_value(car(aux));
805 841 aux = cdr(aux);
806 842 }
807 843 }
808 844 break;
809 845  
810 846 case type_8: /* idem */
811   - *((*ptr)++) = i_type_8;
812   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
813   - *ptr += sizeof(U32);
  847 + *((*ptr)++) = i_type_8;
  848 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  849 + *ptr += sizeof(U32);
814 850 //debug(instr);
815 851 {
816 852 aux = cdr(instr);
817 853 while (consp(aux))
818 854 {
819   - *((*ptr)++) = (U8)integer_value(car(aux));
  855 + *((*ptr)++) = (U8)integer_value(car(aux));
820 856 aux = cdr(aux);
821 857 }
822 858 }
823 859 break;
824 860  
825 861 case type_16: /* idem */
826   - *((*ptr)++) = i_type_16;
827   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
828   - *ptr += sizeof(U32);
  862 + *((*ptr)++) = i_type_16;
  863 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  864 + *ptr += sizeof(U32);
829 865 {
830 866 aux = cdr(instr);
831 867 while (consp(aux))
832 868 {
833   - *((*ptr)++) = (U8)integer_value(car(aux));
  869 + *((*ptr)++) = (U8)integer_value(car(aux));
834 870 aux = cdr(aux);
835 871 }
836 872 }
837 873 break;
838 874  
839 875 case type_32: /* idem */
840   - *((*ptr)++) = i_type_32;
841   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
842   - *ptr += sizeof(U32);
  876 + *((*ptr)++) = i_type_32;
  877 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  878 + *ptr += sizeof(U32);
843 879 {
844 880 aux = cdr(instr);
845 881 while (consp(aux))
846 882 {
847   - *((*ptr)++) = (U8)integer_value(car(aux));
  883 + *((*ptr)++) = (U8)integer_value(car(aux));
848 884 aux = cdr(aux);
849 885 }
850 886 }
851 887 break;
852 888  
853 889 case indirect_type_8: /* idem */
854   - *((*ptr)++) = i_indirect_type_8;
855   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
856   - *ptr += sizeof(U32);
  890 + *((*ptr)++) = i_indirect_type_8;
  891 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  892 + *ptr += sizeof(U32);
857 893 {
858 894 aux = cdr(instr);
859 895 while (consp(aux))
860 896 {
861   - *((*ptr)++) = (U8)integer_value(car(aux));
  897 + *((*ptr)++) = (U8)integer_value(car(aux));
862 898 aux = cdr(aux);
863 899 }
864 900 }
865 901 break;
866 902  
867 903 case indirect_type_16: /* idem */
868   - *((*ptr)++) = i_indirect_type_16;
869   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
870   - *ptr += sizeof(U32);
  904 + *((*ptr)++) = i_indirect_type_16;
  905 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  906 + *ptr += sizeof(U32);
871 907 {
872 908 aux = cdr(instr);
873 909 while (consp(aux))
874 910 {
875   - *((*ptr)++) = (U8)integer_value(car(aux));
  911 + *((*ptr)++) = (U8)integer_value(car(aux));
876 912 aux = cdr(aux);
877 913 }
878 914 }
879 915 break;
880 916  
881 917 case indirect_type_32: /* idem */
882   - *((*ptr)++) = i_indirect_type_32;
883   - *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
884   - *ptr += sizeof(U32);
  918 + *((*ptr)++) = i_indirect_type_32;
  919 + *(((U32 *)(*ptr))) = (U32)length(cdr(instr));
  920 + *ptr += sizeof(U32);
885 921 {
886 922 aux = cdr(instr);
887 923 while (consp(aux))
888 924 {
889   - *((*ptr)++) = (U8)integer_value(car(aux));
  925 + *((*ptr)++) = (U8)integer_value(car(aux));
890 926 aux = cdr(aux);
891 927 }
892 928 }
893 929 break;
894 930  
895 931 case string: /* (string . <index>) */
896   - *((*ptr)++) = i_string;
897   - *(((U32 *)(*ptr))) = len =
898   - strlen(string_content(compiled_strings[integer_value(cdr(instr))].string));
899   - *ptr += sizeof(U32);
  932 + *((*ptr)++) = i_string;
  933 + *(((U32 *)(*ptr))) = len =
  934 + strlen(string_content(compiled_strings[integer_value(cdr(instr))].string));
  935 + *ptr += sizeof(U32);
900 936 *(((U32 *)(*ptr))) = 0; /* null counter => permanent string */
901   - *ptr += sizeof(U32);
902   - for (i = 0; i < len; i++)
903   - *((*ptr)++) = 172^((string_content(compiled_strings[integer_value(cdr(instr))].string))[i]);
904   - *((*ptr)++) = 172;
905   - break;
  937 + *ptr += sizeof(U32);
  938 + for (i = 0; i < len; i++)
  939 + *((*ptr)++) = 172^((string_content(compiled_strings[integer_value(cdr(instr))].string))[i]);
  940 + *((*ptr)++) = 172;
  941 + break;
906 942  
907 943 case program: /* (program instruction ... instruction) */
908 944 {
... ... @@ -910,389 +946,396 @@ void translate_instruction(U8 **ptr,
910 946 while(consp(prog))
911 947 {
912 948 translate_instruction(ptr,module_flags,offsets,car(prog),
913   - initialization_address_value,variables_deletion_address_value);
  949 + initialization_address_value,variables_deletion_address_value);
914 950 prog = cdr(prog);
915 951 }
916 952 }
917 953 break;
918 954  
919 955 case address: /* (address . <address>) */
920   - *((*ptr)++) = i_address;
921   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
922   - *ptr += sizeof(U32);
923   - break;
  956 + *((*ptr)++) = i_address;
  957 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  958 + *ptr += sizeof(U32);
  959 + break;
924 960  
925 961 case gv_address: /* (gv_address . <index>) */
926   - *((*ptr)++) = i_gv_address;
927   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
928   - *ptr += sizeof(U32);
929   - break;
  962 + *((*ptr)++) = i_gv_address;
  963 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  964 + *ptr += sizeof(U32);
  965 + break;
930 966  
931 967 case call: /* (call <address> . <n>) */
932   - *((*ptr)++) = i_call;
933   - *(((U32 *)(*ptr))) = offsets[integer_value(second(instr))];
934   - *ptr += sizeof(U32);
935   - break;
  968 + *((*ptr)++) = i_call;
  969 + *(((U32 *)(*ptr))) = offsets[integer_value(second(instr))];
  970 + *ptr += sizeof(U32);
  971 + break;
936 972  
937 973 case indirect_del: /* (indirect_del . <address>) */
938   - *((*ptr)++) = i_indirect_del;
939   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
940   - *ptr += sizeof(U32);
941   - break;
  974 + *((*ptr)++) = i_indirect_del;
  975 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  976 + *ptr += sizeof(U32);
  977 + break;
942 978  
943 979 case indirect_del_mvar: /* (indirect_del_mvar . <address>) */
944   - *((*ptr)++) = i_indirect_del_mvar;
945   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
946   - *ptr += sizeof(U32);
947   - break;
  980 + *((*ptr)++) = i_indirect_del_mvar;
  981 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  982 + *ptr += sizeof(U32);
  983 + break;
948 984  
949 985 case del_mixed: /* (del_mixed <mask> . <address>) */
950   - *((*ptr)++) = i_del_mixed;
951   - *((*ptr)++) = integer_value(second(instr));
952   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
953   - *ptr += sizeof(U32);
954   - break;
  986 + *((*ptr)++) = i_del_mixed;
  987 + *((*ptr)++) = integer_value(second(instr));
  988 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  989 + *ptr += sizeof(U32);
  990 + break;
955 991  
956 992 case mvar_slots_del_mixed: /* (mvar_slots_del_mixed <mask> . <address>) */
957   - *((*ptr)++) = i_mvar_slots_del_mixed;
958   - *((*ptr)++) = integer_value(second(instr));
959   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
960   - *ptr += sizeof(U32);
961   - break;
  993 + *((*ptr)++) = i_mvar_slots_del_mixed;
  994 + *((*ptr)++) = integer_value(second(instr));
  995 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  996 + *ptr += sizeof(U32);
  997 + break;
962 998  
963 999 case type_mixed: /* (type_mixed <mask> . <address>) */
964   - *((*ptr)++) = i_type_mixed;
965   - *((*ptr)++) = integer_value(second(instr));
966   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
967   - *ptr += sizeof(U32);
968   - break;
  1000 + *((*ptr)++) = i_type_mixed;
  1001 + *((*ptr)++) = integer_value(second(instr));
  1002 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1003 + *ptr += sizeof(U32);
  1004 + break;
969 1005  
970 1006 case indirect_type_mixed: /* (indirect_type_mixed <mask> . <address>) */
971   - *((*ptr)++) = i_indirect_type_mixed;
972   - *((*ptr)++) = integer_value(second(instr));
973   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
974   - *ptr += sizeof(U32);
975   - break;
  1007 + *((*ptr)++) = i_indirect_type_mixed;
  1008 + *((*ptr)++) = integer_value(second(instr));
  1009 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1010 + *ptr += sizeof(U32);
  1011 + break;
976 1012  
977 1013 case indirect_del_mixed: /* (indirect_del_mixed <mask> . <address>) */
978   - *((*ptr)++) = i_indirect_del_mixed;
979   - *((*ptr)++) = integer_value(second(instr));
980   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
981   - *ptr += sizeof(U32);
982   - break;
  1014 + *((*ptr)++) = i_indirect_del_mixed;
  1015 + *((*ptr)++) = integer_value(second(instr));
  1016 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1017 + *ptr += sizeof(U32);
  1018 + break;
983 1019  
984 1020 case indirect_del_struct_ptr: /* (indirect_del_struct_ptr . <struct id>) */
985   - *((*ptr)++) = i_indirect_del_struct_ptr;
986   - *((*ptr)++) = integer_value(cdr(instr));
987   - break;
  1021 + *((*ptr)++) = i_indirect_del_struct_ptr;
  1022 + *((*ptr)++) = integer_value(cdr(instr));
  1023 + break;
988 1024  
989 1025 case mvar_slots_del_struct_ptr: /* (mvar_slots_del_struct_ptr . <struct id>) */
990   - *((*ptr)++) = i_mvar_slots_del_struct_ptr;
991   - *((*ptr)++) = integer_value(cdr(instr));
992   - break;
  1026 + *((*ptr)++) = i_mvar_slots_del_struct_ptr;
  1027 + *((*ptr)++) = integer_value(cdr(instr));
  1028 + break;
993 1029  
994 1030 case jmp: /* (jmp . <address>) */
995   - *((*ptr)++) = i_jmp;
996   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
997   - *ptr += sizeof(U32);
998   - break;
  1031 + *((*ptr)++) = i_jmp;
  1032 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1033 + *ptr += sizeof(U32);
  1034 + break;
999 1035  
1000 1036 case false_jmp: /* (false_jmp . <address>) */
1001   - *((*ptr)++) = i_false_jmp;
1002   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1003   - *ptr += sizeof(U32);
1004   - break;
  1037 + *((*ptr)++) = i_false_jmp;
  1038 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1039 + *ptr += sizeof(U32);
  1040 + break;
1005 1041  
1006 1042 case jmp_false: /* (jmp_false . <address>) */
1007   - *((*ptr)++) = i_jmp_false;
1008   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1009   - *ptr += sizeof(U32);
1010   - break;
  1043 + *((*ptr)++) = i_jmp_false;
  1044 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1045 + *ptr += sizeof(U32);
  1046 + break;
1011 1047  
1012 1048 case true_jmp: /* (true_jmp . <address>) */
1013   - *((*ptr)++) = i_true_jmp;
1014   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1015   - *ptr += sizeof(U32);
1016   - break;
  1049 + *((*ptr)++) = i_true_jmp;
  1050 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1051 + *ptr += sizeof(U32);
  1052 + break;
1017 1053  
1018 1054 case jmp_eq_stack: /* (jmp_eq_stack . <address>) */
1019   - *((*ptr)++) = i_jmp_eq_stack;
1020   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1021   - *ptr += sizeof(U32);
1022   - break;
  1055 + *((*ptr)++) = i_jmp_eq_stack;
  1056 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1057 + *ptr += sizeof(U32);
  1058 + break;
1023 1059  
1024 1060 case jmp_neq_indexes_large: /* (jmp_neq_indexes_large . <address>) */
1025   - *((*ptr)++) = i_jmp_neq_indexes_large;
1026   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1027   - *ptr += sizeof(U32);
1028   - break;
  1061 + *((*ptr)++) = i_jmp_neq_indexes_large;
  1062 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1063 + *ptr += sizeof(U32);
  1064 + break;
1029 1065  
1030 1066 case jmp_neq_string: /* (jmp_neq_string . <address>) */
1031   - *((*ptr)++) = i_jmp_neq_string;
1032   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1033   - *ptr += sizeof(U32);
1034   - break;
  1067 + *((*ptr)++) = i_jmp_neq_string;
  1068 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1069 + *ptr += sizeof(U32);
  1070 + break;
1035 1071  
1036 1072 case jmp_neq_byte_array: /* (jmp_neq_byte_array . <address>) */
1037   - *((*ptr)++) = i_jmp_neq_byte_array;
1038   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1039   - *ptr += sizeof(U32);
1040   - break;
  1073 + *((*ptr)++) = i_jmp_neq_byte_array;
  1074 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1075 + *ptr += sizeof(U32);
  1076 + break;
1041 1077  
1042 1078 case jmp_neq_indexes_mixed: /* (jmp_neq_indexes_mixed <width> <mask> . <address>) */
1043   - *((*ptr)++) = i_jmp_neq_indexes_mixed;
1044   - *((*ptr)++) = (U8)integer_value(second(instr));
1045   - *((*ptr)++) = (U8)integer_value(third(instr));
1046   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr3(instr))];
1047   - *ptr += sizeof(U32);
1048   - break;
  1079 + *((*ptr)++) = i_jmp_neq_indexes_mixed;
  1080 + *((*ptr)++) = (U8)integer_value(second(instr));
  1081 + *((*ptr)++) = (U8)integer_value(third(instr));
  1082 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr3(instr))];
  1083 + *ptr += sizeof(U32);
  1084 + break;
1049 1085  
1050 1086 case jmp_neq: /* (jmp_neq <byte width> . <address>)
1051 1087 i_jmp_neq_? <address> */
1052   - {
1053   - int i = integer_value(second(instr));
1054   - Expr i_instr = i == 0 ? i_jmp_neq_0 :
1055   - i == 1 ? i_jmp_neq_1 :
1056   - i == 2 ? i_jmp_neq_2 :
1057   - i == 4 ? i_jmp_neq_4 :
1058   - (assert(0),0);
1059   - *((*ptr)++) = i_instr;
1060   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
1061   - *ptr += sizeof(U32);
1062   - }
1063   - break;
  1088 + {
  1089 + int i = integer_value(second(instr));
  1090 + Expr i_instr = i == 0 ? i_jmp_neq_0 :
  1091 + i == 1 ? i_jmp_neq_1 :
  1092 + i == 2 ? i_jmp_neq_2 :
  1093 + i == 4 ? i_jmp_neq_4 :
  1094 + (assert(0),0);
  1095 + *((*ptr)++) = i_instr;
  1096 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1097 + *ptr += sizeof(U32);
  1098 + }
  1099 + break;
1064 1100  
1065 1101 case peek: /* (peek x . k) */
1066   - *((*ptr)++) = i_peek;
1067   - *(((U32 *)(*ptr))) = integer_value(cdr2(instr));
1068   - *ptr += sizeof(U32);
1069   - break;
  1102 + *((*ptr)++) = i_peek;
  1103 + *(((U32 *)(*ptr))) = integer_value(cdr2(instr));
  1104 + *ptr += sizeof(U32);
  1105 + break;
1070 1106  
1071 1107 case micro_peek: /* (micro_peek x d . k) */
1072   - *((*ptr)++) = i_micro_peek;
1073   - *(((U32 *)(*ptr))) = integer_value(third(instr));
1074   - *ptr += sizeof(U32);
1075   - *(((U32 *)(*ptr))) = integer_value(cdr3(instr));
1076   - *ptr += sizeof(U32);
1077   - break;
  1108 + *((*ptr)++) = i_micro_peek;
  1109 + *(((U32 *)(*ptr))) = integer_value(third(instr));
  1110 + *ptr += sizeof(U32);
  1111 + *(((U32 *)(*ptr))) = integer_value(cdr3(instr));
  1112 + *ptr += sizeof(U32);
  1113 + break;
1078 1114  
1079 1115 case put_closure_labels: /* (put_closure_labels f . d) */
1080   - *((*ptr)++) = i_put_closure_labels;
1081   - *(((U32 *)(*ptr))) = offsets[integer_value(second(instr))];
1082   - *ptr += sizeof(U32);
1083   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
1084   - *ptr += sizeof(U32);
1085   - break;
  1116 + *((*ptr)++) = i_put_closure_labels;
  1117 + *(((U32 *)(*ptr))) = offsets[integer_value(second(instr))];
  1118 + *ptr += sizeof(U32);
  1119 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1120 + *ptr += sizeof(U32);
  1121 + break;
1086 1122  
1087 1123 case unprotect: /* (unprotect . <addr>) */
1088   - *((*ptr)++) = i_unprotect;
1089   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1090   - *ptr += sizeof(U32);
1091   - break;
  1124 + *((*ptr)++) = i_unprotect;
  1125 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1126 + *ptr += sizeof(U32);
  1127 + break;
1092 1128  
1093 1129 case get_var_handler: /* (get_var_handler . <addr>) */
1094   - *((*ptr)++) = i_get_var_handler;
1095   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1096   - *ptr += sizeof(U32);
1097   - break;
  1130 + *((*ptr)++) = i_get_var_handler;
  1131 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1132 + *ptr += sizeof(U32);
  1133 + break;
1098 1134  
1099 1135 case get_mvar_handler: /* (get_mvar_handler . <addr>) */
1100   - *((*ptr)++) = i_get_mvar_handler;
1101   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1102   - *ptr += sizeof(U32);
1103   - break;
  1136 + *((*ptr)++) = i_get_mvar_handler;
  1137 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1138 + *ptr += sizeof(U32);
  1139 + break;
1104 1140  
1105 1141 case mvar_slots_del: /* (mvar_slots_del . <addr>) */
1106   - *((*ptr)++) = i_mvar_slots_del;
1107   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1108   - *ptr += sizeof(U32);
1109   - break;
  1142 + *((*ptr)++) = i_mvar_slots_del;
  1143 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1144 + *ptr += sizeof(U32);
  1145 + break;
1110 1146  
1111 1147 case eq: /* (eq . k) */
1112   - *((*ptr)++) = i_eq;
1113   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1114   - *ptr += sizeof(U32);
1115   - break;
  1148 + *((*ptr)++) = i_eq;
  1149 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1150 + *ptr += sizeof(U32);
  1151 + break;
1116 1152  
1117 1153 case print_string: /* (print_string . <depth>) */
1118   - *((*ptr)++) = i_print_string;
1119   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1120   - *ptr += sizeof(U32);
1121   - break;
  1154 + *((*ptr)++) = i_print_string;
  1155 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1156 + *ptr += sizeof(U32);
  1157 + break;
1122 1158  
1123 1159 case del_stack_ptr: /* (del_stack_ptr . <depth>) */
1124   - *((*ptr)++) = i_del_stack_ptr;
1125   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1126   - *ptr += sizeof(U32);
1127   - break;
  1160 + *((*ptr)++) = i_del_stack_ptr;
  1161 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1162 + *ptr += sizeof(U32);
  1163 + break;
1128 1164  
1129 1165 case del_stack_function: /* (del_stack_function . <depth>) */
1130   - *((*ptr)++) = i_del_stack_function;
1131   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1132   - *ptr += sizeof(U32);
1133   - break;
  1166 + *((*ptr)++) = i_del_stack_function;
  1167 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1168 + *ptr += sizeof(U32);
  1169 + break;
  1170 +
  1171 + case del_stack_nat: /* (del_stack_nat . <depth>) */
  1172 + *((*ptr)++) = i_del_stack_nat;
  1173 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1174 + *ptr += sizeof(U32);
  1175 + break;
1134 1176  
1135 1177 case del_stack_struct_ptr: /* (del_stack_struct_ptr <struct id> . <depth>) */
1136   - *((*ptr)++) = i_del_stack_struct_ptr;
  1178 + *((*ptr)++) = i_del_stack_struct_ptr;
1137 1179 *((*ptr)++) = integer_value(second(instr));
1138   - *(((U32 *)(*ptr))) = integer_value(cdr2(instr));
1139   - *ptr += sizeof(U32);
1140   - break;
  1180 + *(((U32 *)(*ptr))) = integer_value(cdr2(instr));
  1181 + *ptr += sizeof(U32);
  1182 + break;
1141 1183  
1142 1184 case del_stack_conn: /* (del_stack_conn . <depth>) */
1143   - *((*ptr)++) = i_del_stack_conn;
1144   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1145   - *ptr += sizeof(U32);
1146   - break;
  1185 + *((*ptr)++) = i_del_stack_conn;
  1186 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1187 + *ptr += sizeof(U32);
  1188 + break;
1147 1189  
1148 1190 case print_int32: /* (print_int32 . <depth>) */
1149   - *((*ptr)++) = i_print_int32;
1150   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1151   - *ptr += sizeof(U32);
1152   - break;
  1191 + *((*ptr)++) = i_print_int32;
  1192 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1193 + *ptr += sizeof(U32);
  1194 + break;
1153 1195  
1154 1196 case del: /* (del . <addr>) */
1155   - *((*ptr)++) = i_del;
1156   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1157   - *ptr += sizeof(U32);
1158   - break;
  1197 + *((*ptr)++) = i_del;
  1198 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1199 + *ptr += sizeof(U32);
  1200 + break;
1159 1201  
1160 1202 case mvar_slots_del_var: /* (mvar_slots_del_var . <addr>) */
1161   - *((*ptr)++) = i_mvar_slots_del_var;
1162   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1163   - *ptr += sizeof(U32);
1164   - break;
  1203 + *((*ptr)++) = i_mvar_slots_del_var;
  1204 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1205 + *ptr += sizeof(U32);
  1206 + break;
1165 1207  
1166 1208 case mvar_slots_del_mvar: /* (mvar_slots_del_mvar . <addr>) */
1167   - *((*ptr)++) = i_mvar_slots_del_mvar;
1168   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1169   - *ptr += sizeof(U32);
1170   - break;
  1209 + *((*ptr)++) = i_mvar_slots_del_mvar;
  1210 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1211 + *ptr += sizeof(U32);
  1212 + break;
1171 1213  
1172 1214 case del_stack: /* (del_stack <depth> . <addr>) */
1173   - *((*ptr)++) = i_del_stack;
1174   - *(((U32 *)(*ptr))) = integer_value(second(instr));
1175   - *ptr += sizeof(U32);
1176   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
1177   - *ptr += sizeof(U32);
1178   - break;
  1215 + *((*ptr)++) = i_del_stack;
  1216 + *(((U32 *)(*ptr))) = integer_value(second(instr));
  1217 + *ptr += sizeof(U32);
  1218 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1219 + *ptr += sizeof(U32);
  1220 + break;
1179 1221  
1180 1222 case del_stack_mvar: /* (del_stack_mvar <depth> . <addr>) */
1181   - *((*ptr)++) = i_del_stack_mvar;
1182   - *(((U32 *)(*ptr))) = integer_value(second(instr));
1183   - *ptr += sizeof(U32);
1184   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
1185   - *ptr += sizeof(U32);
1186   - break;
  1223 + *((*ptr)++) = i_del_stack_mvar;
  1224 + *(((U32 *)(*ptr))) = integer_value(second(instr));
  1225 + *ptr += sizeof(U32);
  1226 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1227 + *ptr += sizeof(U32);
  1228 + break;
1187 1229  
1188 1230 case del_stack_mixed: /* (del_stack_mixed <depth> <mask> . <addr>) */
1189   - *((*ptr)++) = i_del_stack_mixed;
1190   - *(((U32 *)(*ptr))) = integer_value(second(instr));
1191   - *ptr += sizeof(U32);
1192   - *((*ptr)++) = integer_value(third(instr));
1193   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr3(instr))];
1194   - *ptr += sizeof(U32);
1195   - break;
  1231 + *((*ptr)++) = i_del_stack_mixed;
  1232 + *(((U32 *)(*ptr))) = integer_value(second(instr));
  1233 + *ptr += sizeof(U32);
  1234 + *((*ptr)++) = integer_value(third(instr));
  1235 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr3(instr))];
  1236 + *ptr += sizeof(U32);
  1237 + break;
1196 1238  
1197 1239 case init_gv: /* (init_gv . <index>) */
1198   - *((*ptr)++) = i_init_gv;
1199   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1200   - *ptr += sizeof(U32);
1201   - break;
  1240 + *((*ptr)++) = i_init_gv;
  1241 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1242 + *ptr += sizeof(U32);
  1243 + break;
1202 1244  
1203 1245 case serialize: /* (serialize . <addr>) */
1204   - *((*ptr)++) = i_serialize;
1205   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1206   - *ptr += sizeof(U32);
1207   - break;
  1246 + *((*ptr)++) = i_serialize;
  1247 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1248 + *ptr += sizeof(U32);
  1249 + break;
1208 1250  
1209 1251 case unserialize: /* (unserialize . <addr>) */
1210   - *((*ptr)++) = i_unserialize;
1211   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1212   - *ptr += sizeof(U32);
1213   - break;
  1252 + *((*ptr)++) = i_unserialize;
  1253 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1254 + *ptr += sizeof(U32);
  1255 + break;
1214 1256  
1215 1257 case type_large: /* (type_large . <addr>) */
1216   - *((*ptr)++) = i_type_large;
1217   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1218   - *ptr += sizeof(U32);
1219   - break;
  1258 + *((*ptr)++) = i_type_large;
  1259 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1260 + *ptr += sizeof(U32);
  1261 + break;
1220 1262  
1221 1263 case indirect_type_large: /* (indirect_type_large . <addr>) */
1222   - *((*ptr)++) = i_indirect_type_large;
1223   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1224   - *ptr += sizeof(U32);
1225   - break;
  1264 + *((*ptr)++) = i_indirect_type_large;
  1265 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1266 + *ptr += sizeof(U32);
  1267 + break;
1226 1268  
1227 1269 case dec3: /* (dec3 . <addr>) */
1228   - *((*ptr)++) = i_dec3;
1229   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
1230   - *ptr += sizeof(U32);
1231   - break;
  1270 + *((*ptr)++) = i_dec3;
  1271 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr(instr))];
  1272 + *ptr += sizeof(U32);
  1273 + break;
1232 1274  
1233 1275 case start: /* (start <depth> . <addr>) */
1234   - *((*ptr)++) = i_start;
1235   - *((*ptr)++) = integer_value(second(instr));
1236   - *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
1237   - *ptr += sizeof(U32);
1238   - break;
  1276 + *((*ptr)++) = i_start;
  1277 + *((*ptr)++) = integer_value(second(instr));
  1278 + *(((U32 *)(*ptr))) = offsets[integer_value(cdr2(instr))];
  1279 + *ptr += sizeof(U32);
  1280 + break;
1239 1281  
1240 1282 case _switch: /* (switch a1 ... ak) -->
1241 1283 i_switch k a1 ... ak */
1242   - {
1243   - *((*ptr)++) = i_switch;
1244   - instr = cdr(instr);
1245   - *((*ptr)++) = (U8)length(instr);
1246   - while(consp(instr))
1247   - {
1248   - *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
1249   - *ptr += sizeof(U32);
1250   - instr = cdr(instr);
1251   - }
1252   - }
1253   - break;
  1284 + {
  1285 + *((*ptr)++) = i_switch;
  1286 + instr = cdr(instr);
  1287 + *((*ptr)++) = (U8)length(instr);
  1288 + while(consp(instr))
  1289 + {
  1290 + *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
  1291 + *ptr += sizeof(U32);
  1292 + instr = cdr(instr);
  1293 + }
  1294 + }
  1295 + break;
1254 1296  
1255 1297 case del_gv: /* (del_gv . index) */
1256   - *((*ptr)++) = i_del_gv;
1257   - *(((U32 *)(*ptr))) = integer_value(cdr(instr));
1258   - *ptr += sizeof(U32);
1259   - break;
  1298 + *((*ptr)++) = i_del_gv;
  1299 + *(((U32 *)(*ptr))) = integer_value(cdr(instr));
  1300 + *ptr += sizeof(U32);
  1301 + break;
1260 1302  
1261 1303 case type_mixed_switch:
1262   - {
1263   - *((*ptr)++) = i_type_mixed_switch;
1264   - instr = cdr(instr);
1265   - *((*ptr)++) = (U8)integer_value(car(instr));
1266   - instr = cdr(instr);
1267   - *((*ptr)++) = (U8)length(instr);
1268   - while(consp(instr))
1269   - {
1270   - *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
1271   - *ptr += sizeof(U32);
1272   - instr = cdr(instr);
1273   - }
1274   - }
1275   - break;
  1304 + {
  1305 + *((*ptr)++) = i_type_mixed_switch;
  1306 + instr = cdr(instr);
  1307 + *((*ptr)++) = (U8)integer_value(car(instr));
  1308 + instr = cdr(instr);
  1309 + *((*ptr)++) = (U8)length(instr);
  1310 + while(consp(instr))
  1311 + {
  1312 + *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
  1313 + *ptr += sizeof(U32);
  1314 + instr = cdr(instr);
  1315 + }
  1316 + }
  1317 + break;
1276 1318  
1277 1319 case type_large_switch:
1278   - {
1279   - *((*ptr)++) = i_type_large_switch;
1280   - instr = cdr(instr);
1281   - *((*ptr)++) = (U8)length(instr);
1282   - while(consp(instr))
1283   - {
1284   - *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
1285   - *ptr += sizeof(U32);
1286   - instr = cdr(instr);
1287   - }
1288   - }
1289   - break;
  1320 + {
  1321 + *((*ptr)++) = i_type_large_switch;
  1322 + instr = cdr(instr);
  1323 + *((*ptr)++) = (U8)length(instr);
  1324 + while(consp(instr))
  1325 + {
  1326 + *(((U32 *)(*ptr))) = offsets[integer_value(car(instr))];
  1327 + *ptr += sizeof(U32);
  1328 + instr = cdr(instr);
  1329 + }
  1330 + }
  1331 + break;
1290 1332  
1291 1333  
1292 1334 case load_nat_small: /* (load_nat_small <bigits>) */
1293 1335 {
1294 1336 *((*ptr)++) = i_load_nat_small;
1295   - *(((U32 *)(*ptr))) = int32_value(cdr(instr));
  1337 + *(((U32 *)(*ptr))) = (((int32_value(cdr(instr)))<<1)|1);
  1338 + /* the right representation of the small nat 'n' is '(n<<1)|1' */
1296 1339 *ptr += sizeof(U32);
1297 1340 }
1298 1341 break;
... ... @@ -1330,8 +1373,8 @@ void translate_instruction(U8 **ptr,
1330 1373  
1331 1374 case load_module: /* (load_module . description) */
1332 1375 {
1333   - *((*ptr)++) = i_load_module;
1334   - instr = cdr(instr);
  1376 + *((*ptr)++) = i_load_module;
  1377 + instr = cdr(instr);
1335 1378 *(((U32 *)(*ptr))) = length(instr);
1336 1379 *ptr += sizeof(U32);
1337 1380 while(consp(instr))
... ... @@ -1349,12 +1392,12 @@ void translate_instruction(U8 **ptr,
1349 1392 *(((U32 *)(*ptr))) = cdr(instr);\
1350 1393 *ptr += sizeof(U32);\
1351 1394 break;
1352   - syscall32_list
  1395 + syscall32_list
1353 1396 #undef sc32_item
1354 1397  
1355 1398  
1356   - default:
1357   - internal_error("Cannot translate instruction",instr);
  1399 + default:
  1400 + internal_error("Cannot translate instruction",instr);
1358 1401 }
1359 1402 else
1360 1403 switch(instr)
... ... @@ -1363,390 +1406,406 @@ void translate_instruction(U8 **ptr,
1363 1406 break;
1364 1407  
1365 1408 case initialization_address: /* initialization_address */
1366   - *((*ptr)++) = i_address;
1367   - *(((U32 *)(*ptr))) = offsets[integer_value(initialization_address_value)];
1368   - *ptr += sizeof(U32);
1369   - break;
  1409 + *((*ptr)++) = i_address;
  1410 + *(((U32 *)(*ptr))) = offsets[integer_value(initialization_address_value)];
  1411 + *ptr += sizeof(U32);
  1412 + break;
1370 1413  
1371 1414 case variables_deletion_address: /* variables_deletion_address */
1372   - *((*ptr)++) = i_address;
1373   - *(((U32 *)(*ptr))) = offsets[integer_value(variables_deletion_address_value)];
1374   - *ptr += sizeof(U32);
1375   - break;
  1415 + *((*ptr)++) = i_address;
  1416 + *(((U32 *)(*ptr))) = offsets[integer_value(variables_deletion_address_value)];
  1417 + *ptr += sizeof(U32);
  1418 + break;
1376 1419  
1377 1420 case ret_if_zero:
1378   - *((*ptr)++) = i_ret_if_zero;
1379   - break;
  1421 + *((*ptr)++) = i_ret_if_zero;
  1422 + break;
1380 1423  
1381 1424 case get_var_monitors:
1382   - *((*ptr)++) = i_get_var_monitors;
1383   - break;
  1425 + *((*ptr)++) = i_get_var_monitors;
  1426 + break;
1384 1427  
1385 1428 case get_mvar_monitors:
1386   - *((*ptr)++) = i_get_mvar_monitors;
1387   - break;
  1429 + *((*ptr)++) = i_get_mvar_monitors;
  1430 + break;
1388 1431  
1389 1432 case del_index_direct:
1390   - *((*ptr)++) = i_del_index_direct;
1391   - break;
  1433 + *((*ptr)++) = i_del_index_direct;
  1434 + break;
1392 1435  
1393 1436 case del_index_indirect:
1394   - *((*ptr)++) = i_del_index_indirect;
1395   - break;
  1437 + *((*ptr)++) = i_del_index_indirect;
  1438 + break;
1396 1439  
1397 1440 case indirect_del_ptr:
1398   - *((*ptr)++) = i_indirect_del_ptr;
1399   - break;
  1441 + *((*ptr)++) = i_indirect_del_ptr;
  1442 + break;
1400 1443  
1401 1444 case del_function:
1402   - *((*ptr)++) = i_del_function;
1403   - break;
  1445 + *((*ptr)++) = i_del_function;
  1446 + break;
  1447 +
  1448 + case del_nat:
  1449 + *((*ptr)++) = i_del_nat;
  1450 + break;
1404 1451  
1405 1452 case mvar_slots_del_function:
1406   - *((*ptr)++) = i_mvar_slots_del_function;
1407   - break;
  1453 + *((*ptr)++) = i_mvar_slots_del_function;
  1454 + break;
  1455 +
  1456 + case mvar_slots_del_nat:
  1457 + *((*ptr)++) = i_mvar_slots_del_nat;
  1458 + break;
1408 1459  
1409 1460 case indirect_del_function:
1410   - *((*ptr)++) = i_indirect_del_function;
1411   - break;
  1461 + *((*ptr)++) = i_indirect_del_function;
  1462 + break;
  1463 +
  1464 + case indirect_del_nat:
  1465 + *((*ptr)++) = i_indirect_del_nat;
  1466 + break;
1412 1467  
1413 1468 case indirect_del_conn:
1414   - *((*ptr)++) = i_indirect_del_conn;
1415   - break;
  1469 + *((*ptr)++) = i_indirect_del_conn;
  1470 + break;
1416 1471  
1417 1472 case mvar_slots_del_conn:
1418   - *((*ptr)++) = i_mvar_slots_del_conn;
1419   - break;
  1473 + *((*ptr)++) = i_mvar_slots_del_conn;
  1474 + break;
1420 1475  
1421 1476 case push:
1422   - *((*ptr)++) = i_push;
1423   - break;
  1477 + *((*ptr)++) = i_push;
  1478 + break;
1424 1479  
1425 1480 case push_mvar_length:
1426   - *((*ptr)++) = i_push_mvar_length;
1427   - break;
  1481 + *((*ptr)++) = i_push_mvar_length;
  1482 + break;
1428 1483  
1429 1484 case remove_monitor:
1430   - *((*ptr)++) = i_remove_monitor;
1431   - break;
  1485 + *((*ptr)++) = i_remove_monitor;
  1486 + break;
1432 1487  
1433 1488 case unlock:
1434   - *((*ptr)++) = i_unlock;
1435   - break;
  1489 + *((*ptr)++) = i_unlock;
  1490 + break;
1436 1491  
1437 1492 case odd_align:
1438 1493 if (!(((int)(*ptr))&1)) /* 'ptr' is equal to instruction offset mod 4 */
1439 1494 *((*ptr)++) = i_odd_align;
1440   - break;
  1495 + break;
1441 1496  
1442 1497 case lock:
1443   - *((*ptr)++) = i_lock;
1444   - break;
  1498 + *((*ptr)++) = i_lock;
  1499 + break;
1445 1500  
1446 1501 case eq_string:
1447   - *((*ptr)++) = i_eq_string;
1448   - break;
  1502 + *((*ptr)++) = i_eq_string;
  1503 + break;
1449 1504  
1450 1505 case eq_byte_array:
1451   - *((*ptr)++) = i_eq_byte_array;
1452   - break;
  1506 + *((*ptr)++) = i_eq_byte_array;
  1507 + break;
1453 1508  
1454 1509 case invalid:
1455   - *((*ptr)++) = i_invalid;
1456   - break;
  1510 + *((*ptr)++) = i_invalid;
  1511 + break;
1457 1512  
1458 1513 case free_var_seg:
1459   - *((*ptr)++) = i_free_var_seg;
1460   - break;
  1514 + *((*ptr)++) = i_free_var_seg;
  1515 + break;
1461 1516  
1462 1517 case free_mvar_seg:
1463   - *((*ptr)++) = i_free_mvar_seg;
1464   - break;
  1518 + *((*ptr)++) = i_free_mvar_seg;
  1519 + break;
1465 1520  
1466 1521 case create_var:
1467   - *((*ptr)++) = i_create_var;
1468   - break;
  1522 + *((*ptr)++) = i_create_var;
  1523 + break;
1469 1524  
1470 1525 case create_mvar:
1471   - *((*ptr)++) = i_create_mvar;
1472   - break;
  1526 + *((*ptr)++) = i_create_mvar;
  1527 + break;
1473 1528  
1474 1529 case get_vv:
1475   - *((*ptr)++) = i_get_vv;
1476   - break;
  1530 + *((*ptr)++) = i_get_vv;
  1531 + break;
1477 1532  
1478 1533 case get_mvv:
1479   - *((*ptr)++) = i_get_mvv;
1480   - break;
  1534 + *((*ptr)++) = i_get_mvv;
  1535 + break;
1481 1536  
1482 1537 case xchg_vv:
1483   - *((*ptr)++) = i_xchg_vv;
1484   - break;
  1538 + *((*ptr)++) = i_xchg_vv;
  1539 + break;
1485 1540  
1486 1541 case xchg_mvv:
1487   - *((*ptr)++) = i_xchg_mvv;
1488   - break;
  1542 + *((*ptr)++) = i_xchg_mvv;
  1543 + break;
1489 1544  
1490 1545 case pop2:
1491   - *((*ptr)++) = i_pop2;
1492   - break;
  1546 + *((*ptr)++) = i_pop2;
  1547 + break;
1493 1548  
1494 1549 case pop3:
1495   - *((*ptr)++) = i_pop3;
1496   - break;
  1550 + *((*ptr)++) = i_pop3;
  1551 + break;
1497 1552  
1498 1553 case pop1:
1499   - *((*ptr)++) = i_pop1;
1500   - break;
  1554 + *((*ptr)++) = i_pop1;
  1555 + break;
1501 1556  
1502 1557 case swap:
1503   - *((*ptr)++) = i_swap;
1504   - break;
  1558 + *((*ptr)++) = i_swap;
  1559 + break;
1505 1560  
1506 1561 case push_eq_data:
1507   - *((*ptr)++) = i_push_eq_data;
1508   - break;
  1562 + *((*ptr)++) = i_push_eq_data;
  1563 + break;
1509 1564  
1510 1565 case push_before_eq:
1511   - *((*ptr)++) = i_push_before_eq;
1512   - break;
  1566 + *((*ptr)++) = i_push_before_eq;
  1567 + break;
1513 1568  
1514 1569 case copy:
1515   - *((*ptr)++) = i_copy;
1516   - break;
  1570 + *((*ptr)++) = i_copy;
  1571 + break;
1517 1572  
1518 1573 case copy_ptr:
1519   - *((*ptr)++) = i_copy_ptr;
1520   - break;
  1574 + *((*ptr)++) = i_copy_ptr;
  1575 + break;
1521 1576  
1522 1577 case copy_function:
1523   - *((*ptr)++) = i_copy_function;
1524   - break;
  1578 + *((*ptr)++) = i_copy_function;
  1579 + break;
  1580 +
  1581 + case copy_nat:
  1582 + *((*ptr)++) = i_copy_nat;
  1583 + break;
1525 1584  
1526 1585 case vcopy_ptr:
1527   - *((*ptr)++) = i_vcopy_ptr;
1528   - break;
  1586 + *((*ptr)++) = i_vcopy_ptr;
  1587 + break;
1529 1588  
1530 1589 case vcopy_null:
1531   - *((*ptr)++) = i_vcopy_null;
1532   - break;
  1590 + *((*ptr)++) = i_vcopy_null;
  1591 + break;
1533 1592  
1534 1593 case index_indirect:
1535   - *((*ptr)++) = i_index_indirect;
1536   - break;
  1594 + *((*ptr)++) = i_index_indirect;
  1595 + break;
1537 1596  
1538 1597 case free_seg_0:
1539   - *((*ptr)++) = i_free_seg_0;
1540   - break;
  1598 + *((*ptr)++) = i_free_seg_0;
  1599 + break;
1541 1600  
1542 1601 case free_seg_1:
1543   - *((*ptr)++) = i_free_seg_1;
1544   - break;
  1602 + *((*ptr)++) = i_free_seg_1;
  1603 + break;
1545 1604  
1546 1605 case connect_file_R:
1547   - *((*ptr)++) = i_connect_file_R;
1548   - break;
  1606 + *((*ptr)++) = i_connect_file_R;
  1607 + break;
1549 1608  
1550 1609 case connect_file_W:
1551   - *((*ptr)++) = i_connect_file_W;
1552   - break;
  1610 + *((*ptr)++) = i_connect_file_W;
  1611 + break;
1553 1612  
1554 1613 case connect_file_RW:
1555   - *((*ptr)++) = i_connect_file_RW;
1556   - break;
  1614 + *((*ptr)++) = i_connect_file_RW;
  1615 + break;
1557 1616  
1558 1617 case connect_IP_RW:
1559   - *((*ptr)++) = i_connect_IP_RW;
1560   - break;
  1618 + *((*ptr)++) = i_connect_IP_RW;
  1619 + break;
1561 1620  
1562 1621 case read_Int8:
1563   - *((*ptr)++) = i_read_Int8;
1564   - break;
  1622 + *((*ptr)++) = i_read_Int8;
  1623 + break;
1565 1624  
1566 1625 case write_Int8:
1567   - *((*ptr)++) = i_write_Int8;
1568   - break;
  1626 + *((*ptr)++) = i_write_Int8;
  1627 + break;
1569 1628  
1570 1629 case implode:
1571   - *((*ptr)++) = i_implode;
1572   - break;
  1630 + *((*ptr)++) = i_implode;
  1631 + break;
1573 1632  
1574 1633 case explode:
1575   - *((*ptr)++) = i_explode;
1576   - break;
  1634 + *((*ptr)++) = i_explode;
  1635 + break;
1577 1636  
1578 1637 case int8_to_int32:
1579   - *((*ptr)++) = i_int8_to_int32;
1580   - break;
  1638 + *((*ptr)++) = i_int8_to_int32;
  1639 + break;
1581 1640  
1582 1641 case truncate_to_int8:
1583   - *((*ptr)++) = i_truncate_to_int8;
1584   - break;
  1642 + *((*ptr)++) = i_truncate_to_int8;
  1643 + break;
1585 1644  
1586 1645 case now:
1587   - *((*ptr)++) = i_now;
1588   - break;
  1646 + *((*ptr)++) = i_now;
  1647 + break;
1589 1648  
1590 1649 case convert_time_from_int:
1591   - *((*ptr)++) = i_convert_time_from_int;
1592   - break;
  1650 + *((*ptr)++) = i_convert_time_from_int;
  1651 + break;
1593 1652  
1594 1653 case convert_time_to_int:
1595   - *((*ptr)++) = i_convert_time_to_int;
1596   - break;
  1654 + *((*ptr)++) = i_convert_time_to_int;
  1655 + break;
1597 1656  
1598 1657 case give_up:
1599   - *((*ptr)++) = i_give_up;
1600   - break;
  1658 + *((*ptr)++) = i_give_up;
  1659 + break;
1601 1660  
1602 1661 case start_debug_avm:
1603   - *((*ptr)++) = i_start_debug_avm;
1604   - break;
  1662 + *((*ptr)++) = i_start_debug_avm;
  1663 + break;
1605 1664  
1606 1665 case protect:
1607   - *((*ptr)++) = i_protect;
1608   - *((*ptr)++) = 0;
1609   - break;
  1666 + *((*ptr)++) = i_protect;
  1667 + *((*ptr)++) = 0;
  1668 + break;
1610 1669  
1611 1670 case stop_debug_avm:
1612   - *((*ptr)++) = i_stop_debug_avm;
1613   - break;
  1671 + *((*ptr)++) = i_stop_debug_avm;
  1672 + break;
1614 1673  
1615 1674 case del_ptr:
1616   - *((*ptr)++) = i_del_ptr;
1617   - break;
  1675 + *((*ptr)++) = i_del_ptr;
  1676 + break;
1618 1677  
1619 1678 case mvar_slots_del_ptr:
1620   - *((*ptr)++) = i_mvar_slots_del_ptr;
1621   - break;
  1679 + *((*ptr)++) = i_mvar_slots_del_ptr;
  1680 + break;
1622 1681  
1623 1682 case del:
1624   - *((*ptr)++) = i_del;
1625   - break;
  1683 + *((*ptr)++) = i_del;
  1684 + break;
1626 1685  
1627 1686 case del_conn:
1628   - *((*ptr)++) = i_del_conn;
1629   - break;
  1687 + *((*ptr)++) = i_del_conn;
  1688 + break;
1630 1689  
1631 1690 case finish:
1632   - *((*ptr)++) = i_finish;
1633   - break;
  1691 + *((*ptr)++) = i_finish;
  1692 + break;
1634 1693  
1635 1694 case listener:
1636   - *((*ptr)++) = i_listener;
1637   - break;
  1695 + *((*ptr)++) = i_listener;
  1696 + break;
1638 1697  
1639 1698 case accept_connection:
1640   - *((*ptr)++) = i_accept_connection;
1641   - break;
  1699 + *((*ptr)++) = i_accept_connection;
  1700 + break;
1642 1701  
1643 1702 case listener_shutdown:
1644   - *((*ptr)++) = i_listener_shutdown;
1645   - break;
  1703 + *((*ptr)++) = i_listener_shutdown;
  1704 + break;
1646 1705  
1647 1706 case listener_is_down:
1648   - *((*ptr)++) = i_listener_is_down;
1649   - break;
  1707 + *((*ptr)++) = i_listener_is_down;
  1708 + break;
1650 1709  
1651 1710 case do_alert:
1652   - *((*ptr)++) = i_do_alert;
1653   - break;
  1711 + *((*ptr)++) = i_do_alert;
  1712 + break;
1654 1713  
1655 1714 case get_gvv:
1656   - *((*ptr)++) = i_get_gvv;
1657   - break;
  1715 + *((*ptr)++) = i_get_gvv;
  1716 + break;
1658 1717  
1659 1718 case xchg_gvv:
1660   - *((*ptr)++) = i_xchg_gvv;
1661   - break;
  1719 + *((*ptr)++) = i_xchg_gvv;
  1720 + break;
1662 1721  
1663 1722 case byte_array_to_ascii:
1664   - *((*ptr)++) = i_byte_array_to_ascii;
1665   - break;
  1723 + *((*ptr)++) = i_byte_array_to_ascii;
  1724 + break;
1666 1725  
1667 1726 case byte_array_to_string:
1668   - *((*ptr)++) = i_byte_array_to_string;
1669   - break;
  1727 + *((*ptr)++) = i_byte_array_to_string;
  1728 + break;
1670 1729  
1671   - /* primitive types pseudo-instructions */
  1730 + /* primitive types pseudo-instructions */
1672 1731 #define item(n) case n: *((*ptr)++) = i_##n; break;
1673   - primitive_types_list
  1732 + primitive_types_list
1674 1733 #undef item
1675 1734 #define item(n) case indirect_##n: *((*ptr)++) = i_indirect_##n; break;
1676   - primitive_types_list
  1735 + primitive_types_list
1677 1736 #undef item
1678 1737  
1679   - case type_0:
1680   - *((*ptr)++) = i_type_0;
1681   - break;
  1738 + case type_0:
  1739 + *((*ptr)++) = i_type_0;
  1740 + break;
1682 1741  
1683 1742 case indirect_type_0:
1684   - *((*ptr)++) = i_indirect_type_0;
1685   - break;
  1743 + *((*ptr)++) = i_indirect_type_0;
  1744 + break;
1686 1745  
1687 1746 case dns:
1688   - *((*ptr)++) = i_dns;
1689   - break;
  1747 + *((*ptr)++) = i_dns;
  1748 + break;
1690 1749  
1691 1750 case write_file:
1692   - *((*ptr)++) = i_write_file;
1693   - break;
  1751 + *((*ptr)++) = i_write_file;
  1752 + break;
1694 1753  
1695 1754 case read_file:
1696   - *((*ptr)++) = i_read_file;
1697   - break;
  1755 + *((*ptr)++) = i_read_file;
  1756 + break;
1698 1757  
1699 1758 case file_size:
1700   - *((*ptr)++) = i_file_size;
1701   - break;
  1759 + *((*ptr)++) = i_file_size;
  1760 + break;
1702 1761  
1703 1762 case byte_array_length:
1704   - *((*ptr)++) = i_byte_array_length;
1705   - break;
  1763 + *((*ptr)++) = i_byte_array_length;
  1764 + break;
1706 1765  
1707 1766 case md5_hash:
1708   - *((*ptr)++) = i_md5_hash;
1709   - break;
  1767 + *((*ptr)++) = i_md5_hash;
  1768 + break;
1710 1769  
1711 1770 case sha1_hash:
1712   - *((*ptr)++) = i_sha1_hash;
1713   - break;
  1771 + *((*ptr)++) = i_sha1_hash;
  1772 + break;
1714 1773  
1715 1774 case get_file_mode:
1716   - *((*ptr)++) = i_get_file_mode;
1717   - break;
  1775 + *((*ptr)++) = i_get_file_mode;
  1776 + break;
1718 1777  
1719 1778 case set_file_mode:
1720   - *((*ptr)++) = i_set_file_mode;
1721   - break;
  1779 + *((*ptr)++) = i_set_file_mode;
  1780 + break;
1722 1781  
1723 1782 case alt_number_indirect:
1724   - *((*ptr)++) = i_alt_number_indirect;
1725   - break;
  1783 + *((*ptr)++) = i_alt_number_indirect;
  1784 + break;
1726 1785  
1727 1786  
1728 1787  
1729   - /* system calls */
  1788 + /* system calls */
1730 1789  
1731 1790  
1732 1791 #define sc_item(n,f) case n: *module_flags |= f; \
1733 1792 *((*ptr)++) = i_syscall; *(((U16 *)(*ptr))) = sc_##n; *ptr += sizeof(U16); break;
1734   - syscall_list
  1793 + syscall_list
1735 1794 #undef sc_item
1736 1795  
1737 1796  
1738 1797  
1739 1798  
1740   - case location:
1741   - *((*ptr)++) = 0;
1742   - *((*ptr)++) = 0;
1743   - *((*ptr)++) = 0;
1744   - *((*ptr)++) = 0;
1745   - break;
  1799 + case location:
  1800 + *((*ptr)++) = 0;
  1801 + *((*ptr)++) = 0;
  1802 + *((*ptr)++) = 0;
  1803 + *((*ptr)++) = 0;
  1804 + break;
1746 1805  
1747 1806  
1748 1807 default:
1749   - internal_error("Cannot translate instruction",instr);
  1808 + internal_error("Cannot translate instruction",instr);
1750 1809 }
1751 1810 }
1752 1811  
... ...