inform7/inter/bytecode-module/Chapter 4/The Primitive Construct.w

[PrimitiveInstruction::] The Primitive Construct.

Defining the primitive construct.

@h Definition.
For what this does and why it is used, see //inter: Textual Inter//.

=
void PrimitiveInstruction::define_construct(void) {
	inter_construct *IC = InterInstruction::create_construct(PRIMITIVE_IST, I"primitive");
	InterInstruction::defines_symbol_in_fields(IC, DEFN_PRIM_IFLD, -1);
	InterInstruction::specify_syntax(IC, I"primitive !IDENTIFIER TOKENS -> TOKEN");
	InterInstruction::data_extent_at_least(IC, 3);
	InterInstruction::permit(IC, OUTSIDE_OF_PACKAGES_ICUP);
	METHOD_ADD(IC, CONSTRUCT_READ_MTID, PrimitiveInstruction::read);
	METHOD_ADD(IC, CONSTRUCT_VERIFY_MTID, PrimitiveInstruction::verify);
	METHOD_ADD(IC, CONSTRUCT_WRITE_MTID, PrimitiveInstruction::write);
}

@h Instructions.
In bytecode, the frame of a |primitive| instruction is laid out with the
compulsory words -- see //Inter Nodes// -- followed by a variable number of
words depending on the length of the signature.

Note that |cat1 cat2 ... catN -> result| takes N+1 words, one for each primitive
category: but that |void -> result| takes only 1. (Thus the not-really-a-category
|void| is not stored when it is an argument, though it is stored -- as 0 -- when
it is the result: the result is always stored.) It follows that the shortest
possible signature, say |void -> void|, occupies 1 word, so the minimum extent of
a |primitive| instruction is 4.

@d DEFN_PRIM_IFLD      (DATA_IFLD + 0)
@d BIP_PRIM_IFLD       (DATA_IFLD + 1)
@d SIGNATURE_PRIM_IFLD (DATA_IFLD + 2)

=
inter_error_message *PrimitiveInstruction::new(inter_bookmark *IBM, inter_symbol *prim_name, 
	text_stream *from, text_stream *to, inter_ti level, inter_error_location *eloc) {

	inter_tree_node *F = Inode::new_with_2_data_fields(IBM, PRIMITIVE_IST,
		/* DEFN_PRIM_IFLD: */ InterSymbolsTable::id_at_bookmark(IBM, prim_name),
		/* BIP_PRIM_IFLD: */ 0,
		eloc, level);

	inter_error_message *E = NULL;
	text_stream *in = from;
	match_results mr = Regexp::create_mr();
	while (Regexp::match(&mr, in, L" *(%i+) *(%c*)")) {
		inter_ti lcat = PrimitiveInstruction::read_category(eloc, mr.exp[0], &E);
		if (E) break;
		if (lcat == 0) break;
		Inode::extend_instruction_by(F, 1);
		F->W.instruction[F->W.extent - 1] = lcat;
		Str::copy(in, mr.exp[1]);
	}
	Regexp::dispose_of(&mr);
	if (E) return E;

	inter_ti rcat = PrimitiveInstruction::read_category(eloc, to, &E);
	if (E) return E;
	Inode::extend_instruction_by(F, 1);
	F->W.instruction[F->W.extent - 1] = rcat;

	E = VerifyingInter::instruction(InterBookmark::package(IBM), F);
	if (E) return E;
	NodePlacement::move_to_moving_bookmark(F, IBM);

	return NULL;
}

@ Verification consists only of sanity checks.

=
void PrimitiveInstruction::verify(inter_construct *IC, inter_tree_node *P,
	inter_package *owner, inter_error_message **E) {
	if (P->W.instruction[BIP_PRIM_IFLD] >= MAX_BIPS) {
		*E = Inode::error(P, I"primitive with impossible BIP code", NULL);
		return;
	}
	inter_symbol *prim_name = PrimitiveInstruction::primitive(P);
	if ((prim_name == NULL) ||
		(Str::get_first_char(InterSymbol::identifier(prim_name)) != '!')) {
		*E = Inode::error(P, I"primitive name not beginning with '!'", NULL);
		return;
	}
	int voids = 0, args = 0;
	for (int i=SIGNATURE_PRIM_IFLD; i<P->W.extent-1; i++) {
		inter_ti prim_cat = P->W.instruction[i];
		if (PrimitiveInstruction::category_is_valid(prim_cat) == FALSE) {
			*E = Inode::error(P, I"unknown primitive category", NULL);
			return;
		}
		if (prim_cat == 0) voids++;
		args++;
	}
	if ((voids > 1) || ((voids == 1) && (args > 1))) {
		*E = Inode::error(P, I"if used on the left, 'void' must be the only argument", NULL);
		return;
	}
}

@h Creating from textual Inter syntax.

=
void PrimitiveInstruction::read(inter_construct *IC, inter_bookmark *IBM,
	inter_line_parse *ilp, inter_error_location *eloc, inter_error_message **E) {
	inter_symbol *prim_name =
		TextualInter::new_symbol(eloc, InterBookmark::scope(IBM), ilp->mr.exp[0], E);
	if (*E) return;
	*E = PrimitiveInstruction::new(IBM, prim_name, ilp->mr.exp[1], ilp->mr.exp[2],
		(inter_ti) ilp->indent_level, eloc);
}

@h Writing to textual Inter syntax.

=
void PrimitiveInstruction::write(inter_construct *IC, OUTPUT_STREAM, inter_tree_node *P) {
	inter_symbol *prim_name = InterSymbolsTable::symbol_from_ID_at_node(P, DEFN_PRIM_IFLD);
	WRITE("primitive %S", InterSymbol::identifier(prim_name));
	for (int i=SIGNATURE_PRIM_IFLD; i<P->W.extent-1; i++) {
		WRITE(" ");
		PrimitiveInstruction::write_category(OUT, P->W.instruction[i]);
	}
	if (SIGNATURE_PRIM_IFLD == P->W.extent-1) WRITE(" void");
	WRITE(" -> ");
	PrimitiveInstruction::write_category(OUT, P->W.instruction[P->W.extent-1]);
}

@h The BIP.
The BIP code is a quick index code to identify which primitive is used from the
standard Inform set (if, indeed, the primitive is from that set: it will be 0
otherwise).

=
inter_ti PrimitiveInstruction::get_BIP(inter_symbol *prim) {
	if (prim == NULL) return 0;
	inter_tree_node *D = InterSymbol::definition(prim);
	if (D == NULL) return 0;
	return D->W.instruction[BIP_PRIM_IFLD];
}

void PrimitiveInstruction::set_BIP(inter_symbol *prim, inter_ti BIP) {
	if (prim == NULL) internal_error("no primitive for BIP");
	inter_tree_node *D = InterSymbol::definition(prim);
	if (D == NULL) internal_error("undefined primitive for BIP");
	D->W.instruction[BIP_PRIM_IFLD] = BIP;
}

@h Primitive categories.

@d VAL_PRIM_CAT 1
@d REF_PRIM_CAT 2
@d LAB_PRIM_CAT 3
@d CODE_PRIM_CAT 4

=
inter_ti PrimitiveInstruction::read_category(inter_error_location *eloc, text_stream *T,
	inter_error_message **E) {
	*E = NULL;
	if (Str::eq(T, I"void")) return 0;
	if (Str::eq(T, I"val")) return VAL_PRIM_CAT;
	if (Str::eq(T, I"ref")) return REF_PRIM_CAT;
	if (Str::eq(T, I"lab")) return LAB_PRIM_CAT;
	if (Str::eq(T, I"code")) return CODE_PRIM_CAT;
	*E = InterErrors::quoted(I"no such category", T, eloc);
	return VAL_PRIM_CAT;
}

void PrimitiveInstruction::write_category(OUTPUT_STREAM, inter_ti cat) {
	WRITE("%s", PrimitiveInstruction::cat_name(cat));
}

char *PrimitiveInstruction::cat_name(inter_ti cat) {
	switch (cat) {
		case REF_PRIM_CAT: return "ref";
		case VAL_PRIM_CAT: return "val";
		case LAB_PRIM_CAT: return "lab";
		case CODE_PRIM_CAT: return "code";
		case 0: return "void";
	}
	return "<unknown>";
}

int PrimitiveInstruction::category_is_valid(inter_ti cat) {
	switch (cat) {
		case VAL_PRIM_CAT: return TRUE;
		case REF_PRIM_CAT: return TRUE;
		case LAB_PRIM_CAT: return TRUE;
		case CODE_PRIM_CAT: return TRUE;
		case 0: return TRUE;
	}
	return FALSE;
}

@h Signature of a primitive.

=
int PrimitiveInstruction::arity(inter_symbol *prim) {
	if (prim == NULL) return 0;
	inter_tree_node *D = InterSymbol::definition(prim);
	if (D == NULL) return 0;
	return D->W.extent - SIGNATURE_PRIM_IFLD - 1;
}

inter_ti PrimitiveInstruction::operand_category(inter_symbol *prim, int i) {
	if (prim == NULL) return 0;
	inter_tree_node *D = InterSymbol::definition(prim);
	if (D == NULL) return 0;
	return D->W.instruction[SIGNATURE_PRIM_IFLD + i];
}

inter_ti PrimitiveInstruction::result_category(inter_symbol *prim) {
	if (prim == NULL) return 0;
	inter_tree_node *D = InterSymbol::definition(prim);
	if (D == NULL) return 0;
	return D->W.instruction[D->W.extent - 1];
}

inter_symbol *PrimitiveInstruction::primitive(inter_tree_node *P) {
	if (P == NULL) return NULL;
	if (Inode::isnt(P, PRIMITIVE_IST)) return NULL;
	return InterSymbolsTable::symbol_from_ID_at_node(P, DEFN_PRIM_IFLD);
}