void xl_enter_block(Context *context, text name, native_fn fn, Tree *rtype,
text open, text type, text close,
text doc)
// ----------------------------------------------------------------------------
// Enter a block into the context (called from .tbl files)
// ----------------------------------------------------------------------------
{
Tree *parms = xl_parameter("c", type);
Block *from = new Block(parms, open, close);
Name *to = new Name(open + close);
from = new Block(from, open, close); // Extra block removed by Define
Rewrite *rw = context->Define(from, to);
rw->native = (native_fn) fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterRewrite(from, to);
rw2->type = rtype;
to->code = fn;
to->SetSymbols(s);
xl_enter_builtin(MAIN, name, to, rw2->parameters, fn);
xl_set_documentation(from, doc);
}
void xl_enter_prefix(Context *context, text name, native_fn fn, Tree *rtype,
TreeList ¶meters, text symbol, text doc)
// ----------------------------------------------------------------------------
// Enter a prefix into the context (called from .tbl files)
// ----------------------------------------------------------------------------
{
if (parameters.size())
{
Tree *parmtree = xl_parameters_tree(parameters);
Prefix *from = new Prefix(new Name(symbol), parmtree);
Name *to = new Name(symbol);
Rewrite *rw = context->Define(from, to);
rw->native = fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterRewrite(from, to);
rw2->type = rtype;
to->code = fn;
to->SetSymbols(s);
xl_enter_builtin(MAIN, name, to, rw2->parameters, fn);
xl_set_documentation(from, doc);
}
else
{
Name *n = new Name(symbol);
n->SetInfo<PrefixDefinitionsInfo>(new PrefixDefinitionsInfo());
Rewrite *rw = context->Define(n, n);
rw->native = fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterName(symbol, n, Rewrite::GLOBAL);
rw2->type = rtype;
n->code = fn;
n->SetSymbols(s);
TreeList noparms;
xl_enter_builtin(MAIN, name, n, noparms, fn);
xl_set_documentation(n, doc);
}
}
void xl_enter_form(Context *context, text name, native_fn fn,
Tree *rtype, text form, TreeList ¶meters,
text doc)
// ----------------------------------------------------------------------------
// Enter an arbitrary form in the symbol table
// ----------------------------------------------------------------------------
{
Tree *from = xl_parse_text(form);
Name *to = new Name(name);
Rewrite *rw = context->Define(from, to);
rw->native = fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterRewrite(from, to);
rw2->type = rtype;
to->code = fn;
to->SetSymbols(s);
xl_enter_builtin(MAIN, name, to, rw2->parameters, fn);
ulong sz = parameters.size();
if (sz != rw2->parameters.size())
{
std::cerr << "WARNING: Internal error on parameter count for "
<< name << "\n"
<< " " << form << "\n";
ulong sz2 = rw2->parameters.size();
for (ulong i = 0; i < sz || i < sz2; i++)
{
std::cerr << " #" << i << ": ";
if (i < sz)
std::cerr << "spec(" << parameters[i] << ") ";
if (i < sz2)
std::cerr << "form(" << rw2->parameters[i] << ") ";
std::cerr << "\n";
}
}
xl_set_documentation(from, doc);
}
void xl_enter_type(Symbols *symbols, Name *name,
text castfnname, typecheck_fn tc)
// ----------------------------------------------------------------------------
// Enter a type function into the symbol table
// ----------------------------------------------------------------------------
{
/* Enter the type name itself */
name->code = xl_identity;
symbols->EnterName(name->value, name, Rewrite::TYPE);
name->SetSymbols(symbols);
/* Type as infix : evaluates to type check, e.g. 0 : integer */
text nv = name->value;
Infix *from = new Infix(":", new Name("V"), new Name(nv));
Name *to = new Name(nv);
Rewrite *rw = symbols->EnterRewrite(from, to);
eval_fn typeTestFn = (eval_fn) (void *) tc;
to->code = typeTestFn;
to->SetSymbols(symbols);
xl_enter_builtin(MAIN, castfnname, to,rw->parameters,typeTestFn);
}
void xl_enter_postfix(Context *context, text name, native_fn fn, Tree *rtype,
TreeList ¶meters, text symbol, text doc)
// ----------------------------------------------------------------------------
// Enter a postfdix into the context (called from .tbl files)
// ----------------------------------------------------------------------------
{
Tree *parmtree = xl_parameters_tree(parameters);
Postfix *from = new Postfix(parmtree, new Name(symbol));
Name *to = new Name(symbol);
Rewrite *rw = context->Define(from, to);
rw->native = (native_fn) fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterRewrite(from, to);
rw2->type = rtype;
to->code = fn;
to->SetSymbols(s);
xl_enter_builtin(MAIN, name, to, rw2->parameters, fn);
xl_set_documentation(from, doc);
}
void xl_enter_infix(Context *context, text name, native_fn fn, Tree *rtype,
text t1, text symbol, text t2, text doc)
// ----------------------------------------------------------------------------
// Enter an infix into the context (called from .tbl files)
// ----------------------------------------------------------------------------
{
Tree *ldecl = xl_parameter("l", t1);
Tree *rdecl = xl_parameter("r", t2);
Infix *from = new Infix(symbol, ldecl, rdecl);
Name *to = new Name(symbol);
Rewrite *rw = context->Define(from, to);
rw->native = fn;
rw->type = rtype;
Symbols *s = MAIN->globals;
Rewrite *rw2 = s->EnterRewrite(from, to);
rw2->type = rtype;
to->code = fn;
to->SetSymbols(s);
xl_enter_builtin(MAIN, name, to, rw2->parameters, fn);
xl_set_documentation(from, doc);
}
