// Strict binary operators.
static value_t *e_binary_op(env_t *env, expr_t *expr)
{
value_t *result;
value_t *l;
value_t *r;
l = e_expr(env, binary_left(expr));
r = e_expr(env, binary_right(expr));
result = alloc_value(v_unused);
switch (expr->type) {
case p_add:
result->type = v_num;
num_val(result) = num_val(l) + num_val(r);
break;
case p_div:
result->type = v_num;
num_val(result) = num_val(l) / num_val(r);
break;
case p_ge:
result->type = v_bool;
bool_val(result) = num_val(l) >= num_val(r);
break;
case p_gt:
result->type = v_bool;
bool_val(result) = num_val(l) > num_val(r);
break;
case p_le:
result->type = v_bool;
bool_val(result) = num_val(l) <= num_val(r);
break;
case p_lt:
result->type = v_bool;
bool_val(result) = num_val(l) < num_val(r);
break;
case p_mod:
result->type = v_num;
num_val(result) = (long)num_val(l) % (long)num_val(r);
break;
case p_mul:
result->type = v_num;
num_val(result) = num_val(l) * num_val(r);
break;
case p_sub:
result->type = v_num;
num_val(result) = num_val(l) - num_val(r);
break;
default:
error("Not a strict binary operator.");
return NULL; // gcc dataflow
}
return result;
}
static value_t *e_equals(env_t *env, expr_t *l, expr_t *r)
{
value_t *result;
result = alloc_value(v_bool);
bool_val(result) = equality_test(e_expr(env, l), e_expr(env, r));
return result;
}
static value_t *e_ite(env_t *env, expr_t *expr)
{
value_t *cond;
cond = e_expr(env, ite_cond(expr));
return bool_val(cond)
? e_expr(env, ite_then(expr))
: e_expr(env, ite_else(expr));
}
static int equality_test(value_t *l, value_t *r)
{
int result;
switch (l->type) {
default:
case v_unused:
if (*(int *)NULL) {
printf("should crash.\n");
}
break;
case v_bool:
result = bool_val(l) == bool_val(r);
break;
case v_char:
result = char_val(l) == char_val(r);
break;
case v_datacons:
if (strcmp(datacons_tag(l), datacons_tag(r)) == 0) {
result = 1;
list_zip_with(datacons_params(l),
datacons_params(r),
equality_test_i, &result);
} else {
result = 0;
}
break;
case v_num:
result = num_val(l) == num_val(r);
break;
case v_tuple:
result = 1;
list_zip_with(tuple_val(l),
tuple_val(r),
equality_test_i, &result);
break;
}
return result;
}
static value_t *e_expr(env_t *env, expr_t *expr)
{
value_t *result;
switch (expr->type) {
default: // This is to handle invalid tags.
case p_unused:
if (*(int *)NULL) {
printf("should crash.\n");
}
return NULL;
case p_and:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = e_expr(env, binary_right(expr));
} else {
result = l;
}
}
break;
case p_or:
{
value_t *l = e_expr(env, binary_left(expr));
if (bool_val(l)) {
result = l;
} else {
result = e_expr(env, binary_right(expr));
}
}
break;
case p_add:
case p_div:
case p_ge:
case p_gt:
case p_le:
case p_lt:
case p_mod:
case p_mul:
case p_sub:
result = e_binary_op(env, expr);
break;
case p_bconst:
result = alloc_value(v_bool);
bool_val(result) = bool_val(expr);
break;
case p_cconst:
result = alloc_value(v_char);
char_val(result) = char_val(expr);
break;
case p_datacons:
result = e_datacons(env, expr);
break;
case p_eqop:
result = e_equals(env, binary_left(expr), binary_right(expr));
break;
case p_fncall:
result = e_fncall(env, fncall_fn(expr), fncall_args(expr));
break;
case p_nconst:
result = alloc_value(v_num);
num_val(result) = num_val(expr);
break;
case p_ite:
result = e_ite(env, expr);
break;
case p_let:
result = e_let(env, expr);
break;
case p_listcons:
result = e_listcons(env, expr);
break;
case p_listlit:
result = e_listlit(env, expr);
break;
case p_listempty:
result = e_listempty();
break;
case p_match:
result = e_match(env, expr);
break;
case p_ne:
result = e_equals(env, binary_left(expr), binary_right(expr));
bool_val(result) = !bool_val(result);
break;
case p_negate:
result = e_expr(env, unary_expr(expr));
bool_val(result) = !bool_val(result);
break;
case p_tuple:
result = e_tuple(env, expr);
break;
case p_var:
result = env_lookup(env, var_name(expr));
if (result == NULL) {
error("e_expr: variable '%s' not in scope on line %d.\n", var_name(expr), expr->line_num);
}
result = thunk_force(result);
break;
}
return result;
}
// Mapped over the clauses in a "match" expression.
static int e_match_pat_i(void *data, void *info)
{
pm_closure_t *pmc = (pm_closure_t *)info;
clause_t *c = (clause_t *)data;
// The style of pattern matching depends on the type of the pattern:
// - constants match literally
// - variables match anything (and extend the environment)
// - tuples always match (and extend the environment)
// - data constructors are more complex.
///
switch (c->pattern->type) {
// Constants: match literally, no binding.
case p_bconst:
if (bool_val(c->pattern) == bool_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_cconst:
if (char_val(c->pattern) == char_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_nconst:
if (num_val(c->pattern) == num_val(pmc->val)) {
pmc->match_body = c->body;
}
break;
case p_listempty:
if (pmc->val->type == v_datacons && strcmp(datacons_tag(pmc->val), listEmptyTag) == 0) {
pmc->match_body = c->body;
}
break;
case p_var:
// Matches anything. Bind it.
env_add_binding(pmc->env, var_name(c->pattern), pmc->val);
pmc->match_body = c->body;
break;
case p_listcons:
// Check the list contains at least one element, then bind variables.
if (pmc->val->type == v_datacons && strcmp(datacons_tag(pmc->val), listConsTag) == 0) {
value_t *head;
value_t *tail;
head = list_nth(datacons_params(pmc->val), 0);
tail = list_nth(datacons_params(pmc->val), 1);
env_add_binding(pmc->env, listcons_hvar(c->pattern), head);
env_add_binding(pmc->env, listcons_tvar(c->pattern), tail);
pmc->match_body = c->body;
}
break;
case p_datacons:
// Check the tag matches, then bind the arguments (if any).
if (strcmp(datacons_tag(c->pattern), datacons_tag(pmc->val)) == 0) {
list_zip_with(datacons_params(c->pattern),
datacons_params(pmc->val),
e_bind_params_i, pmc->env);
pmc->match_body = c->body;
}
break;
case p_tuple:
// Always matches (assuming the program type checks). Bind the variables.
list_zip_with(tuple_val(c->pattern),
tuple_val(pmc->val),
e_bind_params_i, pmc->env);
pmc->match_body = c->body;
break;
default:
error("INTERNAL pattern match: invalid pattern.\n");
}
return pmc->match_body == NULL;
}
CCompoundID CCompoundIDDumpParser::ParseID()
{
SkipSpace();
x_SaveErrPos();
if (x_EOF() || !isalpha(*m_Ch)) {
CID_PARSER_EXCEPTION("missing compound ID class name");
}
const char* token_begin = m_Ch;
do
++m_Ch;
while (!x_EOF() && isalpha(*m_Ch));
CTempString new_id_class_name(token_begin, m_Ch - token_begin);
ECompoundIDClass new_id_class = eCIC_NumberOfClasses;
switch (*token_begin) {
case 'C':
if (new_id_class_name == CIC_GENERICID_CLASS_NAME)
new_id_class = eCIC_GenericID;
break;
case 'N':
if (new_id_class_name == CIC_NETCACHEBLOBKEY_CLASS_NAME)
new_id_class = eCIC_NetCacheBlobKey;
else if (new_id_class_name == CIC_NETSCHEDULEJOBKEY_CLASS_NAME)
new_id_class = eCIC_NetScheduleJobKey;
else if (new_id_class_name == CIC_NETSTORAGEOBJECTLOC_CLASS_NAME)
new_id_class = eCIC_NetStorageObjectLoc;
else if (new_id_class_name == CIC_NETSTORAGEOBJECTLOC_CLASS_NAME_V1)
new_id_class = eCIC_NetStorageObjectLocV1;
}
if (new_id_class == eCIC_NumberOfClasses) {
CID_PARSER_EXCEPTION("unknown compound ID class '" <<
new_id_class_name << '\'');
}
SkipSpace();
if (x_EOF() || *m_Ch != '{') {
x_SaveErrPos();
CID_PARSER_EXCEPTION("missing '{'");
}
++m_Ch;
SkipSpaceToNextToken();
CCompoundID result(m_Pool.NewID(new_id_class));
if (*m_Ch != '}')
for (;;) {
token_begin = m_Ch;
x_SaveErrPos();
do
++m_Ch;
while (isalnum(*m_Ch) || *m_Ch == '_');
CTempString field_type_name(token_begin, m_Ch - token_begin);
ECompoundIDFieldType field_type = eCIT_NumberOfTypes;
switch (*token_begin) {
case '}':
CID_PARSER_EXCEPTION("a field type name is required");
case 'b':
if (field_type_name == CIT_BOOLEAN_TYPE_NAME)
field_type = eCIT_Boolean;
break;
case 'd':
if (field_type_name == CIT_DATABASE_NAME_TYPE_NAME)
field_type = eCIT_DatabaseName;
break;
case 'f':
if (field_type_name == CIT_FLAGS_TYPE_NAME)
field_type = eCIT_Flags;
break;
case 'h':
if (field_type_name == CIT_HOST_TYPE_NAME)
field_type = eCIT_Host;
break;
case 'i':
if (field_type_name == CIT_ID_TYPE_NAME)
field_type = eCIT_ID;
else if (field_type_name == CIT_INTEGER_TYPE_NAME)
field_type = eCIT_Integer;
else if (field_type_name == CIT_IPV4_ADDRESS_TYPE_NAME)
field_type = eCIT_IPv4Address;
else if (field_type_name == CIT_IPV4_SOCK_ADDR_TYPE_NAME)
field_type = eCIT_IPv4SockAddr;
break;
case 'n':
if (field_type_name == CIT_NESTED_CID_TYPE_NAME)
field_type = eCIT_NestedCID;
else if (field_type_name == CIT_CUE_TYPE_NAME)
field_type = eCIT_Cue;
break;
case 'p':
if (field_type_name == CIT_OBJECTREF_TYPE_NAME)
field_type = eCIT_ObjectRef;
else if (field_type_name == CIT_PORT_TYPE_NAME)
field_type = eCIT_Port;
break;
case 'r':
if (field_type_name == CIT_RANDOM_TYPE_NAME)
field_type = eCIT_Random;
break;
case 's':
if (field_type_name == CIT_SEQ_ID_TYPE_NAME)
field_type = eCIT_SeqID;
else if (field_type_name == CIT_SERVICE_NAME_TYPE_NAME)
field_type = eCIT_ServiceName;
else if (field_type_name == CIT_STRING_TYPE_NAME)
field_type = eCIT_String;
break;
case 't':
if (field_type_name == CIT_LABEL_TYPE_NAME)
field_type = eCIT_Label;
else if (field_type_name == CIT_TAX_ID_TYPE_NAME)
field_type = eCIT_TaxID;
else if (field_type_name == CIT_TIMESTAMP_TYPE_NAME)
field_type = eCIT_Timestamp;
}
if (field_type == eCIT_NumberOfTypes) {
CID_PARSER_EXCEPTION("unknown field type '" <<
field_type_name << '\'');
}
SkipSpaceToNextToken();
switch (field_type) {
case eCIT_ID:
result.AppendID(x_ReadUint8());
break;
case eCIT_Integer:
result.AppendInteger(x_ReadInt8());
break;
case eCIT_ServiceName:
result.AppendServiceName(x_ReadString());
break;
case eCIT_DatabaseName:
result.AppendDatabaseName(x_ReadString());
break;
case eCIT_Timestamp:
result.AppendTimestamp(x_ReadInt8());
break;
case eCIT_Random:
{
x_SaveErrPos();
Uint8 random_number = x_ReadUint8();
if (random_number >= ((Uint8) 1) << 8 * sizeof(Uint4)) {
CID_PARSER_EXCEPTION(
"random number exceeds maximum allowed value");
}
result.AppendRandom((Uint4) random_number);
}
break;
case eCIT_IPv4Address:
result.AppendIPv4Address(x_ReadIPv4Address());
break;
case eCIT_Host:
result.AppendHost(x_ReadString());
break;
case eCIT_Port:
result.AppendPort(x_ReadPortNumber());
break;
case eCIT_IPv4SockAddr:
{
Uint4 ipv4_address = x_ReadIPv4Address();
if (x_EOF() || *m_Ch != ':') {
x_SaveErrPos();
CID_PARSER_EXCEPTION("missing ':'");
}
++m_Ch;
result.AppendIPv4SockAddr(ipv4_address, x_ReadPortNumber());
}
break;
case eCIT_ObjectRef:
result.AppendObjectRef(x_ReadString());
break;
case eCIT_String:
result.AppendString(x_ReadString());
break;
case eCIT_Boolean:
{
token_begin = m_Ch;
x_SaveErrPos();
while (!x_EOF() && isalpha(*m_Ch))
++m_Ch;
CTempString bool_val(token_begin, m_Ch - token_begin);
if (bool_val == "false")
result.AppendBoolean(false);
else if (bool_val == "true")
result.AppendBoolean(true);
else {
CID_PARSER_EXCEPTION("invalid boolean value \"" <<
bool_val << '\"');
}
}
break;
case eCIT_Flags:
result.AppendFlags(x_ReadUint8());
break;
case eCIT_Label:
result.AppendLabel(x_ReadString());
break;
case eCIT_Cue:
result.AppendCue(x_ReadUint8());
break;
case eCIT_SeqID:
result.AppendSeqID(x_ReadString());
break;
case eCIT_TaxID:
result.AppendTaxID(x_ReadUint8());
break;
case eCIT_NestedCID:
result.AppendNestedCID(ParseID());
break;
case eCIT_NumberOfTypes:
break;
}
SkipSpaceToNextToken();
if (*m_Ch == ',')
++m_Ch;
else if (*m_Ch == '}')
break;
else {
x_SaveErrPos();
CID_PARSER_EXCEPTION("either ',' or '}' expected");
}
SkipSpaceToNextToken();
}
++m_Ch;
return result;
}