mirror of
https://github.com/ganelson/inform.git
synced 2024-07-02 23:14:57 +03:00
1045 lines
43 KiB
OpenEdge ABL
1045 lines
43 KiB
OpenEdge ABL
[I6TargetCode::] Inform 6 Code.
|
|
|
|
To generate I6 routines of imperative code.
|
|
|
|
@ =
|
|
void I6TargetCode::create_generator(code_generator *gtr) {
|
|
METHOD_ADD(gtr, DECLARE_FUNCTION_MTID, I6TargetCode::declare_function);
|
|
METHOD_ADD(gtr, PLACE_LABEL_MTID, I6TargetCode::place_label);
|
|
METHOD_ADD(gtr, EVALUATE_LABEL_MTID, I6TargetCode::evaluate_label);
|
|
METHOD_ADD(gtr, INVOKE_PRIMITIVE_MTID, I6TargetCode::invoke_primitive);
|
|
METHOD_ADD(gtr, INVOKE_FUNCTION_MTID, I6TargetCode::invoke_function);
|
|
METHOD_ADD(gtr, INVOKE_OPCODE_MTID, I6TargetCode::invoke_opcode);
|
|
METHOD_ADD(gtr, ASSEMBLY_MARKER_MTID, I6TargetCode::assembly_marker);
|
|
}
|
|
|
|
@h Functions.
|
|
Inform 6 originated as an assembler briefly called "zass", and its assembly-language
|
|
character can still be seen in the way functions are declared:
|
|
= (text as Inform 6)
|
|
[ FunctionName local1 local2 local3 ... localn;
|
|
...
|
|
];
|
|
=
|
|
Here |local1|, |local2|, ..., |localn| are all of the local variables accessible
|
|
from the function; the earliest will be used as call parameters, all subsequent
|
|
ones being initially zero.
|
|
|
|
=
|
|
void I6TargetCode::declare_function(code_generator *gtr, code_generation *gen,
|
|
vanilla_function *vf) {
|
|
segmentation_pos saved = CodeGen::select(gen, functions_I7CGS);
|
|
if (vf == NULL) internal_error("no vg");
|
|
text_stream *fn_name = vf->identifier;
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
@<Open the function@>;
|
|
|
|
if (Str::eq(fn_name, I"Main")) @<Inject code at the top of Main@>;
|
|
if (Str::eq(fn_name, I"DebugAction")) @<Inject code at the top of DebugAction@>;
|
|
if (Str::eq(fn_name, I"DebugAttribute")) @<Inject code at the top of DebugAttribute@>;
|
|
if (Str::eq(fn_name, I"DebugProperty")) @<Inject code at the top of DebugProperty@>;
|
|
if (Str::eq(fn_name, I"FINAL_CODE_STARTUP_R")) @<Inject code at the top of FINAL_CODE_STARTUP_R@>;
|
|
|
|
Vanilla::node(gen, vf->function_body); /* This compiles the body of the function */
|
|
|
|
@<Close the function@>;
|
|
CodeGen::deselect(gen, saved);
|
|
}
|
|
|
|
@<Open the function@> =
|
|
WRITE("[ %S", fn_name);
|
|
text_stream *var_name;
|
|
LOOP_OVER_LINKED_LIST(var_name, text_stream, vf->locals)
|
|
WRITE(" %S", var_name);
|
|
WRITE(";\n"); INDENT;
|
|
|
|
@<Close the function@> =
|
|
OUTDENT; WRITE("];\n");
|
|
|
|
@ A few functions will be sneakily rewritten in passing. This is done to handle
|
|
specific features of the Z or Glulx virtual machines which do not meaningfully
|
|
exist in any wider cross-platform way. Although this could all be done by having
|
|
a slightly more elaborate linker and then including the code below in kits
|
|
(as was indeed done during 2020), it's really better that the Inter tree not
|
|
have to refer to eldritch Z-only symbols like |#largest_object| or Glulx-only
|
|
symbols like |#g$self|.
|
|
|
|
@<Inject code at the top of Main@> =
|
|
WRITE("#ifdef TARGET_ZCODE; max_z_object = #largest_object - 255; #endif;\n");
|
|
|
|
@<Inject code at the top of DebugAction@> =
|
|
WRITE("#ifdef TARGET_GLULX;\n");
|
|
WRITE("if (a < 4096) {\n");
|
|
WRITE(" if (a < 0 || a >= #identifiers_table-->7) print \"<invalid action \", a, \">\";\n");
|
|
WRITE(" else {\n");
|
|
WRITE(" str = #identifiers_table-->6;\n");
|
|
WRITE(" str = str-->a;\n");
|
|
WRITE(" if (str) print (string) str; else print \"<unnamed action \", a, \">\";\n");
|
|
WRITE(" return;\n");
|
|
WRITE(" }\n");
|
|
WRITE("}\n");
|
|
WRITE("#endif;\n");
|
|
WRITE("#ifdef TARGET_ZCODE;\n");
|
|
WRITE("if (a < 4096) {\n");
|
|
WRITE(" anames = #identifiers_table;\n");
|
|
WRITE(" anames = anames + 2*(anames-->0) + 2*48;\n");
|
|
WRITE(" print (string) anames-->a;\n");
|
|
WRITE(" return;\n");
|
|
WRITE("}\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@<Inject code at the top of DebugAttribute@> =
|
|
I6_GEN_DATA(DebugAttribute_seen) = TRUE;
|
|
WRITE("#ifdef TARGET_GLULX;\n");
|
|
WRITE("if (a < 0 || a >= NUM_ATTR_BYTES*8) print \"<invalid attribute \", a, \">\";\n");
|
|
WRITE("else {\n");
|
|
WRITE(" str = #identifiers_table-->4;\n");
|
|
WRITE(" str = str-->a;\n");
|
|
WRITE(" if (str) print (string) str; else print \"<unnamed attribute \", a, \">\";\n");
|
|
WRITE("}\n");
|
|
WRITE("return;\n");
|
|
WRITE("#endif;\n");
|
|
WRITE("#ifdef TARGET_ZCODE;\n");
|
|
WRITE("if (a < 0 || a >= 48) print \"<invalid attribute \", a, \">\";\n");
|
|
WRITE("else {\n");
|
|
WRITE(" anames = #identifiers_table; anames = anames + 2*(anames-->0);\n");
|
|
WRITE(" print (string) anames-->a;\n");
|
|
WRITE("}\n");
|
|
WRITE("return;\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@<Inject code at the top of DebugProperty@> =
|
|
WRITE("print (property) p;\n");
|
|
WRITE("return;\n");
|
|
|
|
@ This enables a speed optimisation in the Glulx virtual machine which
|
|
reimplements some of the veneer functions in "hardware". If it weren't here,
|
|
or if the Gestalt said that the VM didn't support this after all, no harm would
|
|
be done except for a slight slowdown.
|
|
|
|
@<Inject code at the top of FINAL_CODE_STARTUP_R@> =
|
|
WRITE("#ifdef TARGET_GLULX;\n");
|
|
WRITE("@gestalt 9 0 res;\n");
|
|
WRITE("if (res == 0) rfalse;\n");
|
|
WRITE("addr = #classes_table;\n");
|
|
WRITE("@accelparam 0 addr;\n");
|
|
WRITE("@accelparam 1 INDIV_PROP_START;\n");
|
|
WRITE("@accelparam 2 Class;\n");
|
|
WRITE("@accelparam 3 Object;\n");
|
|
WRITE("@accelparam 4 Routine;\n");
|
|
WRITE("@accelparam 5 String;\n");
|
|
WRITE("addr = #globals_array + WORDSIZE * #g$self;\n");
|
|
WRITE("@accelparam 6 addr;\n");
|
|
WRITE("@accelparam 7 NUM_ATTR_BYTES;\n");
|
|
WRITE("addr = #cpv__start;\n");
|
|
WRITE("@accelparam 8 addr;\n");
|
|
WRITE("@accelfunc 1 Z__Region;\n");
|
|
WRITE("@accelfunc 2 CP__Tab;\n");
|
|
WRITE("@accelfunc 3 RA__Pr;\n");
|
|
WRITE("@accelfunc 4 RL__Pr;\n");
|
|
WRITE("@accelfunc 5 OC__Cl;\n");
|
|
WRITE("@accelfunc 6 RV__Pr;\n");
|
|
WRITE("@accelfunc 7 OP__Pr;\n");
|
|
WRITE("#endif;\n");
|
|
WRITE("rfalse;\n");
|
|
|
|
@h Labels.
|
|
Labels in Inform 6 are |jump| destinations, much as in C they are |goto| destinations.
|
|
A full stop indicates where they are positioned:
|
|
= (text as Inform 6)
|
|
if (whatever) jump Catastrophe;
|
|
...
|
|
.Catastrophe;
|
|
...
|
|
=
|
|
Inter identifiers for labels also start with full stops. So:
|
|
|
|
=
|
|
void I6TargetCode::place_label(code_generator *gtr, code_generation *gen,
|
|
text_stream *label_name) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
WRITE("%S;\n", label_name);
|
|
}
|
|
void I6TargetCode::evaluate_label(code_generator *gtr, code_generation *gen,
|
|
text_stream *label_name) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
LOOP_THROUGH_TEXT(pos, label_name)
|
|
if (Str::get(pos) != '.')
|
|
PUT(Str::get(pos));
|
|
}
|
|
|
|
@h Function invocations.
|
|
Or in other words, function calls. These are easy: the syntax is exactly what
|
|
it would be for C.
|
|
|
|
=
|
|
void I6TargetCode::invoke_function(code_generator *gtr, code_generation *gen,
|
|
inter_tree_node *P, vanilla_function *vf, int void_context) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
WRITE("%S(", vf->identifier);
|
|
int c = 0;
|
|
LOOP_THROUGH_INTER_CHILDREN(F, P) {
|
|
if (c++ > 0) WRITE(", ");
|
|
Vanilla::node(gen, F);
|
|
}
|
|
WRITE(")");
|
|
if (void_context) WRITE(";\n");
|
|
}
|
|
|
|
@h Assembly language.
|
|
In general, we make no attempt to police the supposedly valid assembly language
|
|
given to us here. Glulx has one set, Z another. Any assembly language in the Inter
|
|
tree results from kit material; and if the author of such a kit tries to use an
|
|
invalid opcode, then the result won't compile under I6, but none of that is our
|
|
business here.
|
|
|
|
The |@aread| opcode is a valid Z-machine opcode, but owing to the way I6 handles
|
|
the irreconcilable change in syntax for the same opcode in V3 and V4-5 of the
|
|
Z-machine specification, there is no good way to assemble it using |@| notation
|
|
unless we want to save the result. (See the Z-Machine Standards Document.)
|
|
As a dodge, we use the Inform 6 statement |read X Y| instead.
|
|
|
|
=
|
|
void I6TargetCode::invoke_opcode(code_generator *gtr, code_generation *gen,
|
|
text_stream *opcode, int operand_count, inter_tree_node **operands,
|
|
inter_tree_node *label, int label_sense) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
if (Str::eq(opcode, I"@aread")) WRITE("read");
|
|
else WRITE("%S", opcode);
|
|
for (int opc = 0; opc < operand_count; opc++) {
|
|
WRITE(" ");
|
|
Vanilla::node(gen, operands[opc]);
|
|
}
|
|
if (label) {
|
|
WRITE(" ?");
|
|
if (label_sense == FALSE) WRITE("~");
|
|
Vanilla::node(gen, label);
|
|
}
|
|
WRITE(";\n");
|
|
}
|
|
|
|
void I6TargetCode::assembly_marker(code_generator *gtr, code_generation *gen, inter_ti marker) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
switch (marker) {
|
|
case ASM_ARROW_ASMMARKER: WRITE("->"); break;
|
|
case ASM_SP_ASMMARKER: WRITE("sp"); break;
|
|
case ASM_RTRUE_ASMMARKER: WRITE("?rtrue"); break;
|
|
case ASM_RFALSE_ASMMARKER: WRITE("?rfalse"); break;
|
|
case ASM_NEG_ASMMARKER: WRITE("~"); break;
|
|
case ASM_NEG_RTRUE_ASMMARKER: WRITE("?~rtrue"); break;
|
|
case ASM_NEG_RFALSE_ASMMARKER: WRITE("?~rfalse"); break;
|
|
default:
|
|
WRITE_TO(STDERR, "Unimplemented assembly marker is '%d'\n", marker);
|
|
internal_error("unimplemented assembly marker");
|
|
}
|
|
}
|
|
|
|
@h Primitives.
|
|
|
|
=
|
|
void I6TargetCode::invoke_primitive(code_generator *gtr, code_generation *gen,
|
|
inter_symbol *prim_name, inter_tree_node *P, int void_context) {
|
|
inter_tree *I = gen->from;
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
inter_ti bip = Primitives::to_BIP(I, prim_name);
|
|
|
|
int suppress_terminal_semicolon = (void_context)?FALSE:TRUE;
|
|
switch (bip) {
|
|
@<Basic arithmetic and logical operations@>;
|
|
@<Storing or otherwise changing values@>;
|
|
@<VM stack access@>;
|
|
@<Control structures@>;
|
|
@<Indirect function calls@>;
|
|
@<Method calls@>;
|
|
@<Property value access@>;
|
|
@<Textual output@>;
|
|
@<The VM object tree@>;
|
|
default:
|
|
WRITE_TO(STDERR, "Unimplemented primitive is '%S'\n",
|
|
InterSymbol::identifier(prim_name));
|
|
internal_error("unimplemented prim");
|
|
}
|
|
if (suppress_terminal_semicolon == FALSE) WRITE(";\n");
|
|
}
|
|
|
|
@ Mostly easy, because the Inter primitives here were so closely modelled on
|
|
their Inform 6 analogues in the first place.
|
|
|
|
For example, although |!alternative| is a very unusual linguistic feature --
|
|
it allows alternatives in several conditions, e.g., |if (x == 1 or 2 or 3) ...| --
|
|
it corresponds directly to the |or| keyword of Inform 6, so generating it is trivial.
|
|
|
|
@<Basic arithmetic and logical operations@> =
|
|
case PLUS_BIP: WRITE("("); VNODE_1C; WRITE(" + "); VNODE_2C; WRITE(")"); break;
|
|
case MINUS_BIP: WRITE("("); VNODE_1C; WRITE(" - "); VNODE_2C; WRITE(")"); break;
|
|
case UNARYMINUS_BIP: WRITE("(-("); VNODE_1C; WRITE("))"); break;
|
|
case TIMES_BIP: WRITE("("); VNODE_1C; WRITE("*"); VNODE_2C; WRITE(")"); break;
|
|
case DIVIDE_BIP: WRITE("("); VNODE_1C; WRITE("/"); VNODE_2C; WRITE(")"); break;
|
|
case MODULO_BIP: WRITE("("); VNODE_1C; WRITE("%%"); VNODE_2C; WRITE(")"); break;
|
|
case BITWISEAND_BIP: WRITE("(("); VNODE_1C; WRITE(")&("); VNODE_2C; WRITE("))"); break;
|
|
case BITWISEOR_BIP: WRITE("(("); VNODE_1C; WRITE(")|("); VNODE_2C; WRITE("))"); break;
|
|
case BITWISENOT_BIP: WRITE("(~("); VNODE_1C; WRITE("))"); break;
|
|
case NOT_BIP: WRITE("(~~("); VNODE_1C; WRITE("))"); break;
|
|
case AND_BIP: WRITE("(("); VNODE_1C; WRITE(") && ("); VNODE_2C; WRITE("))"); break;
|
|
case OR_BIP: WRITE("(("); VNODE_1C; WRITE(") || ("); VNODE_2C; WRITE("))"); break;
|
|
case EQ_BIP: WRITE("("); VNODE_1C; WRITE(" == "); VNODE_2C; WRITE(")"); break;
|
|
case NE_BIP: WRITE("("); VNODE_1C; WRITE(" ~= "); VNODE_2C; WRITE(")"); break;
|
|
case GT_BIP: WRITE("("); VNODE_1C; WRITE(" > "); VNODE_2C; WRITE(")"); break;
|
|
case GE_BIP: WRITE("("); VNODE_1C; WRITE(" >= "); VNODE_2C; WRITE(")"); break;
|
|
case LT_BIP: WRITE("("); VNODE_1C; WRITE(" < "); VNODE_2C; WRITE(")"); break;
|
|
case LE_BIP: WRITE("("); VNODE_1C; WRITE(" <= "); VNODE_2C; WRITE(")"); break;
|
|
case OFCLASS_BIP: WRITE("("); VNODE_1C; WRITE(" ofclass "); VNODE_2C; WRITE(")"); break;
|
|
case IN_BIP: WRITE("("); VNODE_1C; WRITE(" in "); VNODE_2C; WRITE(")"); break;
|
|
case NOTIN_BIP: WRITE("("); VNODE_1C; WRITE(" notin "); VNODE_2C; WRITE(")"); break;
|
|
case LOOKUP_BIP: WRITE("("); VNODE_1C; WRITE("-->("); VNODE_2C; WRITE("))"); break;
|
|
case LOOKUPBYTE_BIP: WRITE("("); VNODE_1C; WRITE("->("); VNODE_2C; WRITE("))"); break;
|
|
case ALTERNATIVE_BIP: VNODE_1C; WRITE(" or "); VNODE_2C; break;
|
|
case SEQUENTIAL_BIP: WRITE("("); VNODE_1C; WRITE(","); VNODE_2C; WRITE(")"); break;
|
|
case TERNARYSEQUENTIAL_BIP: @<Generate primitive for ternarysequential@>; break;
|
|
case RANDOM_BIP: WRITE("random("); VNODE_1C; WRITE(")"); break;
|
|
|
|
@ But the unfortunate |!ternarysequential a b c| needs some gymnastics. It
|
|
would be trivial to generate to C with the serial comma operator: |(a, b, c)|
|
|
evaluates |a|, then throws that away and evaluates |b|, then throws that away
|
|
too and returns the value of |c|.
|
|
|
|
The same effect is annoyingly difficult to get out of the sometimes shaky I6
|
|
compiler's expression parser. I6 does support the comma operator, so at first
|
|
sight |(a, b, c)| ought to work in I6, too. And it does, right up to the point
|
|
where some of the token values themselves include invocations of functions. It
|
|
is a known infelicity of the I6 syntax analyser that it won't always allow the
|
|
serial comma to be mixed in the same expression with the function argument
|
|
comma: for example in the case |(a(b, c), d)|, where the first comma constructs
|
|
a list of arguments and the second is the operator. (Many such expressions work
|
|
fine in I6 -- but not all.)
|
|
|
|
That being so, we use the following circumlocution:
|
|
= (text as Inform 6)
|
|
(c) + 0*((b) + (a))
|
|
=
|
|
Because I6 evaluates the leaves in an expression tree right-to-left, not
|
|
left-to-right, the parameter assignments happen first, then the conditions,
|
|
then the result.
|
|
|
|
@<Generate primitive for ternarysequential@> =
|
|
WRITE("(\n"); INDENT;
|
|
WRITE("! This evaluates last\n"); VNODE_3C;
|
|
OUTDENT; WRITE("+\n"); INDENT;
|
|
WRITE("0*(\n"); INDENT;
|
|
WRITE("! This evaluates second\n");
|
|
WRITE("((\n"); INDENT; VNODE_2C;
|
|
OUTDENT; WRITE("\n))\n");
|
|
OUTDENT; WRITE("+\n"); INDENT;
|
|
WRITE("! This evaluate first\n");
|
|
WRITE("("); VNODE_1C; WRITE(")");
|
|
OUTDENT; WRITE(")\n");
|
|
OUTDENT; WRITE(")\n");
|
|
|
|
@ These are the seven primitives which change a storage item given by a
|
|
reference, which is always the first child of the primitive node. It might,
|
|
for example, be a global variable, or a memory location.
|
|
|
|
@<Storing or otherwise changing values@> =
|
|
case STORE_BIP: @<Perform a store@>; break;
|
|
case PREINCREMENT_BIP: @<Perform a store@>; break;
|
|
case POSTINCREMENT_BIP: @<Perform a store@>; break;
|
|
case PREDECREMENT_BIP: @<Perform a store@>; break;
|
|
case POSTDECREMENT_BIP: @<Perform a store@>; break;
|
|
case SETBIT_BIP: @<Perform a store@>; break;
|
|
case CLEARBIT_BIP: @<Perform a store@>; break;
|
|
|
|
@<Perform a store@> =
|
|
inter_tree_node *storage_ref = InterTree::first_child(P);
|
|
if (storage_ref->W.instruction[0] == REFERENCE_IST)
|
|
storage_ref = InterTree::first_child(storage_ref);
|
|
if ((ReferenceInstruction::node_is_ref_to(gen->from, InterTree::first_child(P),
|
|
PROPERTYVALUE_BIP)) &&
|
|
(I6TargetCode::pval_case(storage_ref) != I6G_CAN_PROVE_IS_OBJ_PROPERTY)) {
|
|
@<Alter a property value@>;
|
|
} else {
|
|
@<Alter some other storage@>;
|
|
}
|
|
|
|
@ The easy case first: here, whatever the storage is (for example, a variable),
|
|
it's one that we can simply treat as an lvalue in Inform 6 (for example, by giving
|
|
its variable name). For example, the memory location |A-->3| can be assigned to,
|
|
or can have |++| or |--| applied to it in I6.
|
|
|
|
Note that this case even includes some property values: if we can see that |P|
|
|
is the explicit name of a property we are storing in a VM-property, then we can
|
|
use |O.P| as an Inform 6 lvalue, and all is well, and we then end up with code
|
|
such as |++(O.P)|.
|
|
|
|
@<Alter some other storage@> =
|
|
switch (bip) {
|
|
case PREINCREMENT_BIP: WRITE("++("); VNODE_1C; WRITE(")"); break;
|
|
case POSTINCREMENT_BIP: WRITE("("); VNODE_1C; WRITE(")++"); break;
|
|
case PREDECREMENT_BIP: WRITE("--("); VNODE_1C; WRITE(")"); break;
|
|
case POSTDECREMENT_BIP: WRITE("("); VNODE_1C; WRITE(")--"); break;
|
|
case STORE_BIP: WRITE("("); VNODE_1C; WRITE(" = "); VNODE_2C; WRITE(")"); break;
|
|
case SETBIT_BIP: VNODE_1C; WRITE(" = "); VNODE_1C; WRITE(" | "); VNODE_2C; break;
|
|
case CLEARBIT_BIP: VNODE_1C; WRITE(" = "); VNODE_1C; WRITE(" &~ ("); VNODE_2C; WRITE(")"); break;
|
|
}
|
|
|
|
@ But not all property values can be written as Inform 6 lvalues. If the I7
|
|
property P is being stored as a VM-attribute A, then there is no lvalue which
|
|
expresses the value of A for an object O: instead one must use |give O A| to
|
|
set it, |give O ~A| to unset it, and |(O has A)| to test it. And there will
|
|
also be cases where P cannot be identified at compile-time, so that we have no
|
|
way to know whether it will be stored as a VM-attribute or not.
|
|
|
|
To handle these two cases, then, we will compile an attempt to store or modify
|
|
a property value either as a |give| statement -- if we can prove P is being
|
|
stored in a VM-attribute -- or else as a function call to a general-purpose
|
|
function called |_final_change_property|.
|
|
|
|
@<Alter a property value@> =
|
|
inter_tree_node *VP = InterTree::second_child(P);
|
|
int set = NOT_APPLICABLE;
|
|
if (Inode::is(VP, VAL_IST)) {
|
|
inter_pair val = ValInstruction::value(VP);
|
|
if (InterValuePairs::is_number(val)) {
|
|
if (InterValuePairs::is_zero(val)) set = FALSE;
|
|
else if (InterValuePairs::is_one(val)) set = TRUE;
|
|
}
|
|
}
|
|
|
|
int c = I6TargetCode::pval_case(storage_ref);
|
|
if ((c == I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE) && (bip == STORE_BIP) && (set == TRUE)) {
|
|
WRITE("give "); Vanilla::node(gen, InterTree::second_child(storage_ref));
|
|
WRITE(" %S", I6TargetCode::inner_name(gen, InterTree::third_child(storage_ref)));
|
|
} else if ((c == I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE) && (bip == STORE_BIP) && (set == FALSE)) {
|
|
WRITE("give "); Vanilla::node(gen, InterTree::second_child(storage_ref));
|
|
WRITE(" ~%S", I6TargetCode::inner_name(gen, InterTree::third_child(storage_ref)));
|
|
} else {
|
|
WRITE("(");
|
|
switch (bip) {
|
|
case STORE_BIP: WRITE("_final_store_property"); break;
|
|
case PREINCREMENT_BIP: WRITE("_final_preinc_property"); break;
|
|
case POSTINCREMENT_BIP: WRITE("_final_postinc_property"); break;
|
|
case PREDECREMENT_BIP: WRITE("_final_predec_property"); break;
|
|
case POSTDECREMENT_BIP: WRITE("_final_postdec_property"); break;
|
|
case SETBIT_BIP: WRITE("_final_setbit_property"); break;
|
|
case CLEARBIT_BIP: WRITE("_final_clearbit_property"); break;
|
|
}
|
|
WRITE("(");
|
|
Vanilla::node(gen, InterTree::first_child(storage_ref));
|
|
WRITE(",");
|
|
Vanilla::node(gen, InterTree::second_child(storage_ref));
|
|
WRITE(",");
|
|
Vanilla::node(gen, InterTree::third_child(storage_ref));
|
|
switch (bip) {
|
|
case STORE_BIP: WRITE(", "); VNODE_2C; break;
|
|
case SETBIT_BIP: WRITE(", "); VNODE_2C; break;
|
|
case CLEARBIT_BIP: WRITE(", "); VNODE_2C; break;
|
|
}
|
|
WRITE("))");
|
|
}
|
|
|
|
@ Reading property values is easier. The general case, similarly, is to call a
|
|
function for this, but an important optimisation collapses this to the use of
|
|
the |has| or |.| operators in I6 where we can prove at compile-time that the
|
|
property in question is stored as a VM-attribute (resp., a VM-property) of
|
|
what is definitely a VM-object. This optimisation results in faster code.
|
|
|
|
@<Property value access@> =
|
|
case PROPERTYEXISTS_BIP:
|
|
I6_GEN_DATA(value_ranges_needed) = TRUE;
|
|
I6_GEN_DATA(value_property_holders_needed) = TRUE;
|
|
WRITE("(_final_propertyexists("); VNODE_1C; WRITE(", "); VNODE_2C; WRITE(", ");
|
|
VNODE_3C; WRITE("))"); break;
|
|
case PROPERTYARRAY_BIP: WRITE("(_final_propertyarray("); VNODE_1C; WRITE(", ");
|
|
VNODE_2C; WRITE(", "); VNODE_3C; WRITE("))"); break;
|
|
case PROPERTYLENGTH_BIP: WRITE("(_final_propertylength("); VNODE_1C; WRITE(", ");
|
|
VNODE_2C; WRITE(", "); VNODE_3C; WRITE("))"); break;
|
|
case PROPERTYVALUE_BIP: {
|
|
inter_tree_node *KP = InterTree::first_child(P);
|
|
inter_tree_node *OP = InterTree::second_child(P);
|
|
inter_tree_node *PP = InterTree::third_child(P);
|
|
switch (I6TargetCode::pval_case(P)) {
|
|
case I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE:
|
|
WRITE("("); VNODE_2C;
|
|
WRITE(" has %S", I6TargetCode::inner_name(gen, PP)); WRITE(")"); break;
|
|
case I6G_CAN_PROVE_IS_OBJ_PROPERTY:
|
|
WRITE("("); VNODE_2C;
|
|
WRITE(".%S", I6TargetCode::inner_name(gen, PP)); WRITE(")"); break;
|
|
case I6G_CANNOT_PROVE:
|
|
I6_GEN_DATA(value_property_holders_needed) = TRUE;
|
|
I6TargetCode::eval_property_list(gen, KP, OP, PP, 0); break;
|
|
}
|
|
break;
|
|
}
|
|
|
|
@ In the most general case of |!propertyvalue|, we will end up calling the function
|
|
|_final_propertyvalue|. But we don't do so right away because, annoyingly, |!propertyvalue|
|
|
can have |!alternative| children supplied. We might find this, for example:
|
|
= (text as Inter)
|
|
inv !if
|
|
inv !propertyvalue
|
|
val K_object harmonium
|
|
inv !alternative
|
|
val K_value P_sonorous
|
|
val K_value P_muted
|
|
=
|
|
...arising from kit code such as |if (harmonium has sonorous or muted) ...|.
|
|
This only seldom arises, so perhaps we can be given for handling it less than
|
|
optimally in all cases. We turn it into:
|
|
= (text as Inform 6)
|
|
if (((or_tmp_var = harmonium) && (or_tmp_var has sonorous)) ||
|
|
(or_tmp_var has muted))
|
|
=
|
|
Note that |or_tmp_var| is used here so that the left operand, i.e., the object,
|
|
is evaluated only once -- in case there are side-effects of the evaluation.
|
|
|
|
=
|
|
void I6TargetCode::eval_property_list(code_generation *gen, inter_tree_node *K,
|
|
inter_tree_node *X, inter_tree_node *Y, int depth) {
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
if (Inode::is(Y, INV_IST)) {
|
|
if (InvInstruction::method(Y) == PRIMITIVE_INVMETH) {
|
|
inter_symbol *prim = InvInstruction::primitive(Y);
|
|
inter_ti ybip = Primitives::to_BIP(gen->from, prim);
|
|
if (ybip == ALTERNATIVE_BIP) {
|
|
if (depth == 0) { WRITE("((or_tmp_var = "); Vanilla::node(gen, X); WRITE(") && (("); }
|
|
I6TargetCode::eval_property_list(gen, K, NULL, InterTree::first_child(Y), depth+1);
|
|
WRITE(") || (");
|
|
I6TargetCode::eval_property_list(gen, K, NULL, InterTree::second_child(Y), depth+1);
|
|
if (depth == 0) { WRITE(")))"); }
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
switch (I6TargetCode::pval_case_inner(K, Y)) {
|
|
case I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE:
|
|
WRITE("("); if (X) Vanilla::node(gen, X); else WRITE("or_tmp_var");
|
|
WRITE(" has %S", I6TargetCode::inner_name(gen, Y)); WRITE(")"); break;
|
|
case I6G_CAN_PROVE_IS_OBJ_PROPERTY:
|
|
WRITE("("); if (X) Vanilla::node(gen, X); else WRITE("or_tmp_var");
|
|
WRITE(".%S", I6TargetCode::inner_name(gen, Y)); WRITE(")"); break;
|
|
case I6G_CANNOT_PROVE:
|
|
WRITE("_final_propertyvalue(");
|
|
Vanilla::node(gen, K);
|
|
WRITE(", ");
|
|
if (X) Vanilla::node(gen, X); else WRITE("or_tmp_var");
|
|
WRITE(", ");
|
|
Vanilla::node(gen, Y);
|
|
WRITE(")"); break;
|
|
}
|
|
}
|
|
|
|
@<VM stack access@> =
|
|
case PUSH_BIP: WRITE("@push "); VNODE_1C; break;
|
|
case PULL_BIP: WRITE("@pull "); VNODE_1C; break;
|
|
|
|
@<Control structures@> =
|
|
case BREAK_BIP: WRITE("break"); break;
|
|
case CONTINUE_BIP: WRITE("continue"); break;
|
|
case RETURN_BIP: @<Generate primitive for return@>; break;
|
|
case JUMP_BIP: WRITE("jump "); VNODE_1C; break;
|
|
case QUIT_BIP: WRITE("quit"); break;
|
|
case RESTORE_BIP: WRITE("restore "); VNODE_1C; break;
|
|
case IF_BIP: @<Generate primitive for if@>; break;
|
|
case IFDEBUG_BIP: @<Generate primitive for ifdebug@>; break;
|
|
case IFSTRICT_BIP: @<Generate primitive for ifstrict@>; break;
|
|
case IFELSE_BIP: @<Generate primitive for ifelse@>; break;
|
|
case WHILE_BIP: @<Generate primitive for while@>; break;
|
|
case DO_BIP: @<Generate primitive for do@>; break;
|
|
case FOR_BIP: @<Generate primitive for for@>; break;
|
|
case OBJECTLOOP_BIP: @<Generate primitive for objectloop@>; break;
|
|
case OBJECTLOOPX_BIP: @<Generate primitive for objectloopx@>; break;
|
|
case SWITCH_BIP: @<Generate primitive for switch@>; break;
|
|
case CASE_BIP: @<Generate primitive for case@>; break;
|
|
case ALTERNATIVECASE_BIP: VNODE_1C; WRITE(", "); VNODE_2C; break;
|
|
case DEFAULT_BIP: @<Generate primitive for default@>; break;
|
|
|
|
@<Generate primitive for return@> =
|
|
int rboolean = NOT_APPLICABLE;
|
|
inter_tree_node *V = InterTree::first_child(P);
|
|
if (Inode::is(V, VAL_IST)) {
|
|
inter_pair val = ValInstruction::value(V);
|
|
if (InterValuePairs::is_zero(val)) rboolean = FALSE;
|
|
else if (InterValuePairs::is_one(val)) rboolean = TRUE;
|
|
}
|
|
switch (rboolean) {
|
|
case FALSE: WRITE("rfalse"); break;
|
|
case TRUE: WRITE("rtrue"); break;
|
|
case NOT_APPLICABLE: WRITE("return "); Vanilla::node(gen, V); break;
|
|
}
|
|
|
|
@<Generate primitive for if@> =
|
|
WRITE("if ("); VNODE_1C; WRITE(") {\n"); INDENT; VNODE_2C;
|
|
OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for ifdebug@> =
|
|
WRITE("#ifdef DEBUG;\n"); INDENT; VNODE_1C; OUTDENT; WRITE("#endif;\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for ifstrict@> =
|
|
WRITE("#ifdef STRICT_MODE;\n"); INDENT; VNODE_1C; OUTDENT; WRITE("#endif;\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for ifelse@> =
|
|
WRITE("if ("); VNODE_1C; WRITE(") {\n"); INDENT; VNODE_2C; OUTDENT;
|
|
WRITE("} else {\n"); INDENT; VNODE_3C; OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for while@> =
|
|
WRITE("while ("); VNODE_1C; WRITE(") {\n"); INDENT; VNODE_2C; OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for do@> =
|
|
WRITE("do {"); VNODE_2C; WRITE("} until (\n"); INDENT; VNODE_1C; OUTDENT; WRITE(")\n");
|
|
|
|
@<Generate primitive for for@> =
|
|
WRITE("for (");
|
|
inter_tree_node *INIT = InterTree::first_child(P);
|
|
if (!((Inode::is(INIT, VAL_IST)) &&
|
|
(InterValuePairs::is_number(ValInstruction::value(INIT))) &&
|
|
(InterValuePairs::to_number(ValInstruction::value(INIT)) == 1)))
|
|
VNODE_1C;
|
|
WRITE(":"); VNODE_2C;
|
|
WRITE(":");
|
|
inter_tree_node *U = InterTree::third_child(P);
|
|
if (Inode::isnt(U, VAL_IST))
|
|
Vanilla::node(gen, U);
|
|
WRITE(") {\n"); INDENT; VNODE_4C;
|
|
OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for objectloop@> =
|
|
int in_flag = FALSE;
|
|
inter_tree_node *U = InterTree::third_child(P);
|
|
if ((Inode::is(U, INV_IST)) &&
|
|
(InvInstruction::method(U) == PRIMITIVE_INVMETH)) {
|
|
inter_symbol *prim = InvInstruction::primitive(U);
|
|
if ((prim) && (Primitives::to_BIP(I, prim) == IN_BIP)) in_flag = TRUE;
|
|
}
|
|
|
|
WRITE("objectloop ");
|
|
if (in_flag == FALSE) {
|
|
WRITE("("); VNODE_1C; WRITE(" ofclass "); VNODE_2C;
|
|
WRITE(" && ");
|
|
} VNODE_3C;
|
|
if (in_flag == FALSE) {
|
|
WRITE(")");
|
|
}
|
|
WRITE(" {\n"); INDENT; VNODE_4C;
|
|
OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for objectloopx@> =
|
|
WRITE("objectloop ("); VNODE_1C; WRITE(" ofclass "); VNODE_2C;
|
|
WRITE(") {\n"); INDENT; VNODE_3C; OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for switch@> =
|
|
WRITE("switch ("); VNODE_1C;
|
|
WRITE(") {\n"); INDENT; VNODE_2C; OUTDENT; WRITE("}\n");
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for case@> =
|
|
VNODE_1C; WRITE(":\n"); INDENT; VNODE_2C; WRITE(";\n"); OUTDENT;
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@<Generate primitive for default@> =
|
|
WRITE("default:\n"); INDENT; VNODE_1C; WRITE(";\n"); OUTDENT;
|
|
suppress_terminal_semicolon = TRUE;
|
|
|
|
@ In Inform 6, as in C, a function which returns a value can be called in a void
|
|
context (in which case its return value is thrown away); the syntax for calling
|
|
a void function is identical to that for calling a value-returning function, so
|
|
we can treat |INDIRECT0V_BIP| as the same as |INDIRECT0_BIP|, and so on.
|
|
|
|
@<Indirect function calls@> =
|
|
case INDIRECT0_BIP: case INDIRECT0V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")()"); break;
|
|
case INDIRECT1_BIP: case INDIRECT1V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")("); VNODE_2C; WRITE(")"); break;
|
|
case INDIRECT2_BIP: case INDIRECT2V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")("); VNODE_2C; WRITE(","); VNODE_3C; WRITE(")");
|
|
break;
|
|
case INDIRECT3_BIP: case INDIRECT3V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")("); VNODE_2C; WRITE(","); VNODE_3C; WRITE(",");
|
|
VNODE_4C; WRITE(")"); break;
|
|
case INDIRECT4_BIP: case INDIRECT4V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")("); VNODE_2C; WRITE(","); VNODE_3C; WRITE(",");
|
|
VNODE_4C; WRITE(","); VNODE_5C; WRITE(")"); break;
|
|
case INDIRECT5_BIP: case INDIRECT5V_BIP:
|
|
WRITE("("); VNODE_1C; WRITE(")("); VNODE_2C; WRITE(","); VNODE_3C; WRITE(",");
|
|
VNODE_4C; WRITE(","); VNODE_5C; WRITE(","); VNODE_6C; WRITE(")"); break;
|
|
case EXTERNALCALL_BIP: internal_error("external calls impossible in Inform 6"); break;
|
|
|
|
@ Message calls are handled with functions (see below) in case the user is trying
|
|
to send a message to a property stored in an attribute, or something like that.
|
|
|
|
@<Method calls@> =
|
|
case MESSAGE0_BIP: WRITE("_final_message0("); VNODE_1C; WRITE(", "); VNODE_2C; WRITE(")"); break;
|
|
case MESSAGE1_BIP: WRITE("_final_message1("); VNODE_1C; WRITE(", "); VNODE_2C; WRITE(", ");
|
|
VNODE_3C; WRITE(")"); break;
|
|
case MESSAGE2_BIP: WRITE("_final_message2("); VNODE_1C; WRITE(", "); VNODE_2C; WRITE(", ");
|
|
VNODE_3C; WRITE(","); VNODE_4C; WRITE(")"); break;
|
|
case MESSAGE3_BIP: WRITE("_final_message3("); VNODE_1C; WRITE(", "); VNODE_2C; WRITE(", ");
|
|
VNODE_3C; WRITE(","); VNODE_4C; WRITE(","); VNODE_5C; WRITE(")"); break;
|
|
|
|
@ Note that the only styles permitted are those from the original Z-machine, which
|
|
is about the level of technology of a 1970s teletype. The |!style| number must be
|
|
a constant 1, 2 or 3, or else plain roman is all you get.
|
|
|
|
@<Textual output@> =
|
|
case PRINT_BIP: WRITE("print "); CodeGen::lt_mode(gen, PRINTING_LTM);
|
|
VNODE_1C; CodeGen::lt_mode(gen, REGULAR_LTM); break;
|
|
case PRINTCHAR_BIP: WRITE("print (char) "); VNODE_1C; break;
|
|
case PRINTNL_BIP: WRITE("new_line"); break;
|
|
case PRINTOBJ_BIP: WRITE("print (object) "); VNODE_1C; break;
|
|
case PRINTNUMBER_BIP: WRITE("print "); VNODE_1C; break;
|
|
case PRINTDWORD_BIP: WRITE("print (address) "); VNODE_1C; break;
|
|
case PRINTSTRING_BIP: WRITE("print (string) "); VNODE_1C; break;
|
|
case BOX_BIP: WRITE("box "); CodeGen::lt_mode(gen, BOX_LTM);
|
|
VNODE_1C; CodeGen::lt_mode(gen, REGULAR_LTM); break;
|
|
case SPACES_BIP: WRITE("spaces "); VNODE_1C; break;
|
|
case FONT_BIP:
|
|
WRITE("if ("); VNODE_1C; WRITE(") { font on; } else { font off; }");
|
|
suppress_terminal_semicolon = TRUE;
|
|
break;
|
|
case STYLE_BIP: {
|
|
inter_tree_node *N = InterTree::first_child(P);
|
|
inter_pair pair = ValInstruction::value(N);
|
|
inter_ti style = InterValuePairs::to_number(pair);
|
|
switch (style) {
|
|
case 1: WRITE("style bold"); break;
|
|
case 2: WRITE("style underline"); break;
|
|
case 3: WRITE("style reverse"); break;
|
|
default: WRITE("style roman");
|
|
}
|
|
break;
|
|
}
|
|
case ENABLEPRINTING_BIP:
|
|
WRITE("#ifdef TARGET_GLULX;\n");
|
|
WRITE("@setiosys 2 0; ! Set to use Glk\n");
|
|
WRITE("@push 201; ! = GG_MAINWIN_ROCK;\n");
|
|
WRITE("@push 3; ! = wintype_TextBuffer\n");
|
|
WRITE("@push 0;\n");
|
|
WRITE("@push 0;\n");
|
|
WRITE("@push 0;\n");
|
|
WRITE("@glk 35 5 sp; ! glk_window_open, pushing a window ID\n");
|
|
WRITE("@glk 47 1 0; ! glk_set_window to that window ID\n");
|
|
WRITE("#endif;\n");
|
|
break;
|
|
|
|
@<The VM object tree@> =
|
|
case MOVE_BIP: WRITE("move "); VNODE_1C; WRITE(" to "); VNODE_2C; break;
|
|
case REMOVE_BIP: WRITE("remove "); VNODE_1C; break;
|
|
case CHILD_BIP: WRITE("child("); VNODE_1C; WRITE(")"); break;
|
|
case CHILDREN_BIP: WRITE("children("); VNODE_1C; WRITE(")"); break;
|
|
case PARENT_BIP: WRITE("parent("); VNODE_1C; WRITE(")"); break;
|
|
case SIBLING_BIP: WRITE("sibling("); VNODE_1C; WRITE(")"); break;
|
|
case METACLASS_BIP: WRITE("metaclass("); VNODE_1C; WRITE(")"); break;
|
|
|
|
@h Support code for property accesses.
|
|
In the following, |prop_node| is a |VAL_IST| identifying the property being
|
|
accessed: we return the "inner name" as text, if we can find one. This will only
|
|
happen if the node evaluates to a named symbol which is the name of a property.
|
|
See //Vanilla Objects// for more on inner names.
|
|
|
|
=
|
|
text_stream *I6TargetCode::inner_name(code_generation *gen, inter_tree_node *prop_node) {
|
|
inter_symbol *prop_symbol = NULL;
|
|
if (Inode::is(prop_node, VAL_IST)) {
|
|
inter_pair val = ValInstruction::value(prop_node);
|
|
if (InterValuePairs::is_symbolic(val))
|
|
prop_symbol = InterValuePairs::to_symbol_at(val, prop_node);
|
|
}
|
|
if ((prop_symbol) && (InterSymbol::get_flag(prop_symbol, ATTRIBUTE_MARK_ISYMF))) {
|
|
return VanillaObjects::inner_property_name(gen, prop_symbol);
|
|
} else if ((prop_symbol) && (Inode::is(prop_symbol->definition, PROPERTY_IST))) {
|
|
return VanillaObjects::inner_property_name(gen, prop_symbol);
|
|
} else {
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
@ |I6TargetCode::pval_case| applies to a |!propertyvalue| invocation node. That
|
|
has three children: the kind, the object/owner, and the property itself. We
|
|
look at the node and try to see if it's one of the two easy cases which enable
|
|
more efficient code to be compiled (see above): in fact, it almost always is.
|
|
|
|
(*) We return |I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE| if the kind is definitely |OBJECT_TY|
|
|
and the property is stored in a VM-attribute;
|
|
(*) Or |I6G_CAN_PROVE_IS_OBJ_PROPERTY| if the kind is definitely |OBJECT_TY|
|
|
and the property is stored in a VM-property;
|
|
(*) Or |I6G_CANNOT_PROVE| if we don't know.
|
|
|
|
@d I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE 1
|
|
@d I6G_CAN_PROVE_IS_OBJ_PROPERTY 2
|
|
@d I6G_CANNOT_PROVE 3
|
|
|
|
=
|
|
int I6TargetCode::pval_case(inter_tree_node *P) {
|
|
while (Inode::is(P, REFERENCE_IST)) P = InterTree::first_child(P);
|
|
inter_tree_node *prop_node = InterTree::third_child(P);
|
|
return I6TargetCode::pval_case_inner(InterTree::first_child(P), prop_node);
|
|
}
|
|
|
|
int I6TargetCode::pval_case_inner(inter_tree_node *kind_node, inter_tree_node *prop_node) {
|
|
inter_symbol *kind_symbol = NULL;
|
|
if (Inode::is(kind_node, VAL_IST)) {
|
|
inter_pair val = ValInstruction::value(kind_node);
|
|
if (InterValuePairs::is_symbolic(val))
|
|
kind_symbol = InterValuePairs::to_symbol_at(val, kind_node);
|
|
}
|
|
if (Str::eq(InterSymbol::trans(kind_symbol), I"OBJECT_TY") == FALSE)
|
|
return I6G_CANNOT_PROVE;
|
|
|
|
inter_symbol *prop_symbol = NULL;
|
|
if (Inode::is(prop_node, VAL_IST)) {
|
|
inter_pair val = ValInstruction::value(prop_node);
|
|
if (InterValuePairs::is_symbolic(val))
|
|
prop_symbol = InterValuePairs::to_symbol_at(val, prop_node);
|
|
}
|
|
if ((prop_symbol) && (InterSymbol::get_flag(prop_symbol, ATTRIBUTE_MARK_ISYMF))) {
|
|
return I6G_CAN_PROVE_IS_OBJ_ATTRIBUTE;
|
|
} else if ((prop_symbol) && (Inode::is(prop_symbol->definition, PROPERTY_IST))) {
|
|
return I6G_CAN_PROVE_IS_OBJ_PROPERTY;
|
|
} else {
|
|
return I6G_CANNOT_PROVE;
|
|
}
|
|
}
|
|
|
|
@h The final functions.
|
|
The generator above compiled calls to a handful of functions with names in the
|
|
form |_final_*|; so these functions must clearly be supplied. It might seem that
|
|
they ought to be included in, say, BasicInformKit and not here. But:
|
|
|
|
(1) They are needed only for Inform 6 usage, whereas BasicInformKit contains
|
|
material used whatever the final code-generator;
|
|
(2) They are written in genuine Inform 6 code, not kit code, which looks like
|
|
I6 and is very similar to it but is not quite the same. In kit code, |O.P| means
|
|
"the value of the property P for the object O", but where |P| is the metadata
|
|
array for the property. In genuine Inform 6, |O.P| expects |P| to be the actual
|
|
VM-property. The following functions need the latter interpretation in order to work.
|
|
|
|
=
|
|
void I6TargetCode::end_generation(code_generator *gtr, code_generation *gen) {
|
|
segmentation_pos saved = CodeGen::select(gen, functions_I7CGS);
|
|
text_stream *OUT = CodeGen::current(gen);
|
|
@<Most general implementation of !propertyvalue@>;
|
|
@<Most general implementation of !propertyexists@>;
|
|
@<Most general implementation of !propertyarray@>;
|
|
@<Most general implementation of !propertylength@>;
|
|
@<Most general implementation of writing to a property@>;
|
|
@<Implementation of !messageX@>;
|
|
CodeGen::deselect(gen, saved);
|
|
}
|
|
|
|
@ See //Inform 6 Objects// for the runtime contents of the array of property
|
|
metadata |p|. The following is more or less a safe general-purpose wrapper for
|
|
the Inform 6 operator |.|, used as an rvalue, in cases where we cannot prove
|
|
it would be safe to use |.| directly:
|
|
|
|
@<Most general implementation of !propertyvalue@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_propertyvalue K o p t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) { if (o has p) rtrue; rfalse; }\n");
|
|
WRITE(" if (o provides p) return o.p;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" rfalse;\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" t = value_property_holders-->K;\n");
|
|
WRITE(" return (t.(p-->1))-->(o+COL_HSIZE);\n");
|
|
WRITE(" }\n");
|
|
WRITE("];\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@ Similarly, this is a safe wrapper for |provides|:
|
|
|
|
@<Most general implementation of !propertyexists@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_propertyexists K o p holder;\n");
|
|
WRITE("if (K == OBJECT_TY) {\n");
|
|
WRITE(" if ((o) && (metaclass(o) == Object)) {\n");
|
|
WRITE(" if ((p-->0 == 2) || (o provides p-->1)) {\n");
|
|
WRITE(" rtrue;\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" rfalse;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" rfalse;\n");
|
|
WRITE(" }\n");
|
|
WRITE("} else {\n");
|
|
WRITE(" if ((o >= 1) && (o <= value_ranges-->K)) {\n");
|
|
WRITE(" holder = value_property_holders-->K;\n");
|
|
WRITE(" if ((holder) && (holder provides p-->1)) {\n");
|
|
WRITE(" rtrue;\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" rfalse;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" rfalse;\n");
|
|
WRITE(" }\n");
|
|
WRITE("}\n");
|
|
WRITE("rfalse; ];\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@ And this for |.&|. Note that we always return 0 if the owner is not an object.
|
|
|
|
@<Most general implementation of !propertyarray@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_propertyarray K o p v t;\n");
|
|
WRITE(" if (K ~= OBJECT_TY) return 0;\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) return 0;\n");
|
|
WRITE(" return o.&p;\n");
|
|
WRITE("];\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@ And this for |.#|. Again, we always return 0 if the owner is not an object.
|
|
|
|
@<Most general implementation of !propertylength@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_propertylength K o p v t;\n");
|
|
WRITE(" if (K ~= OBJECT_TY) return 0;\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) return 0;\n");
|
|
WRITE(" return o.#p;\n");
|
|
WRITE("];\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@ And this is a safe way to write to or otherwise alter |O.P|, laboriously
|
|
written out as seven functions. (Speed is more important than conciseness here.)
|
|
|
|
@<Most general implementation of writing to a property@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_store_property K o p v t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (v) give o p; else give o ~p;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" o.p = v;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" ((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE) = v;\n");
|
|
WRITE(" }\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_preinc_property K o p t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (o has p) { give o ~p; rfalse; } give o p; rtrue;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" return ++(o.p);\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" return ++(((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE));\n");
|
|
WRITE(" }\n");
|
|
WRITE(" return 0;\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_predec_property K o p t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (o has p) { give o ~p; rfalse; } give o p; rtrue;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" return --(o.p);\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" return --(((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE));\n");
|
|
WRITE(" }\n");
|
|
WRITE(" return 0;\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_postinc_property K o p t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (o has p) { give o ~p; rtrue; } give o p; rfalse;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" return (o.p)++;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" return (((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE))++;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" return 0;\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_postdec_property K o p t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (o has p) { give o ~p; rtrue; } give o p; rfalse;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" return (o.p)--;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" return (((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE))--;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" return 0;\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_setbit_property K o p v t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (v & 1) give o p;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" o.p = o.p | v;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" ((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE) =\n");
|
|
WRITE(" ((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE) | v;\n");
|
|
WRITE(" }\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_clearbit_property K o p v t;\n");
|
|
WRITE(" if (K == OBJECT_TY) {\n");
|
|
WRITE(" if (metaclass(o) == Object) {\n");
|
|
WRITE(" t = p-->0; p = p-->1;\n");
|
|
WRITE(" if (t == 2) {\n");
|
|
WRITE(" if (v & 1) give o ~p;\n");
|
|
WRITE(" } else if (o provides p) {\n");
|
|
WRITE(" o.p = o.p & ~v;\n");
|
|
WRITE(" }\n");
|
|
WRITE(" }\n");
|
|
WRITE(" } else {\n");
|
|
WRITE(" ((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE) =\n");
|
|
WRITE(" ((value_property_holders-->K).(p-->1))-->(o+COL_HSIZE) & ~v;\n");
|
|
WRITE(" }\n");
|
|
WRITE("];\n");
|
|
WRITE("#endif;\n");
|
|
|
|
@ It's not entirely clear what the result of trying to send a message to an
|
|
either/or property ought to be: nobody should ever do that. We're going to say
|
|
that it's 0 here.
|
|
|
|
@<Implementation of !messageX@> =
|
|
WRITE("#ifdef BASICINFORMKIT;\n");
|
|
WRITE("[ _final_message0 o p q x a rv;\n");
|
|
WRITE(" if (p-->0 == 2) return 0;\n");
|
|
WRITE(" q = p-->1; return o.q();\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_message1 o p v1 q x a rv;\n");
|
|
WRITE(" if (p-->0 == 2) return 0;\n");
|
|
WRITE(" q = p-->1; return o.q(v1);\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_message2 o p v1 v2 q x a rv;\n");
|
|
WRITE(" if (p-->0 == 2) return 0;\n");
|
|
WRITE(" q = p-->1; return o.q(v1, v2);\n");
|
|
WRITE("];\n");
|
|
WRITE("[ _final_message3 o p v1 v2 v3 q x a rv;\n");
|
|
WRITE(" if (p-->0 == 2) return 0;\n");
|
|
WRITE(" q = p-->1; return o.q(v1, v2, v3);\n");
|
|
WRITE("];\n");
|
|
WRITE("#endif;\n");
|