2901b1 | 1998-01-29 | Per Hedbor | | #define error(X) throw( ({ (X), backtrace() }) )
|
0dae34 | 1998-02-11 | Niels Möller | | constant cvs_version = "$Id: lisp.pike,v 1.7 1998/02/11 01:31:30 nisse Exp $";
|
2901b1 | 1998-01-29 | Per Hedbor | |
#include <module.h>
inherit "module";
constant thread_safe=1;
array register_module()
{
return ({ MODULE_PARSER, "Lisp tag module",
"This module defines a new tag, "
"<lisp [context=foo]></lisp>", 0, ({}) });
}
void create()
{
defvar("max-eval-time", 10000, "Max eval time", TYPE_INT);
|
0dae34 | 1998-02-11 | Niels Möller | | defvar("bootcode", "(begin)",
"Lisp code executed to initialize the top-level environments.",
|
2901b1 | 1998-01-29 | Per Hedbor | | TYPE_TEXT);
|
0dae34 | 1998-02-11 | Niels Möller | | defvar("enable_context", 1, "Enable the context attribute.",
TYPE_FLAG);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | import Languages.PLIS;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | class RoxenEnv
|
1756d3 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | import Languages.PLIS;
|
85f91a | 1998-02-03 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | inherit Environment;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | int once_done;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | |
class RoxenId
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | import Languages.PLIS;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object lisp_env;
int limit;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object roxen_id;
mapping defines;
string lisp_result;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | int limit_apply()
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if (!limit)
|
2901b1 | 1998-01-29 | Per Hedbor | | return 1;
|
0dae34 | 1998-02-11 | Niels Möller | | limit--;
return 0;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object query_binding(object symbol) { return lisp_env->query_binding(symbol); }
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object copy() { return lisp_env->copy(); }
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object extend(object symbol, object value)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | return lisp_env->extend(symbol, value);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | string print(int display)
{ return lisp_env->print(display); }
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | void create(object env, object id, mapping defs)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | lisp_env = env;
roxen_id = id;
defines = defs;
lisp_result = "";
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | }
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | class API_Function
{
import Languages.PLIS;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | inherit LObject;
function fun;
array types;
string print(int display) { return sprintf("API_Function %O", fun); }
|
85f91a | 1998-02-03 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object to_lisp(mixed o)
|
85f91a | 1998-02-03 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if(stringp(o))
return String( o );
|
85f91a | 1998-02-03 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | if(intp(o) && !zero_type(o))
return Number(o);
|
85f91a | 1998-02-03 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | if(arrayp(o) || multisetp(o))
|
85f91a | 1998-02-03 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | object res = Lempty;
int m = 0;
if(multisetp(o)) { m = 1; o = indices( o ); }
for(int i=sizeof(o)-1; i>=0; i--)
|
85f91a | 1998-02-03 | Per Hedbor | | {
object t;
|
0dae34 | 1998-02-11 | Niels Möller | | if(m && stringp(o[i]))
t = make_symbol( o[i] );
|
85f91a | 1998-02-03 | Per Hedbor | | else
|
0dae34 | 1998-02-11 | Niels Möller | | t = to_lisp(o[i]);
|
85f91a | 1998-02-03 | Per Hedbor | | res = Cons( t , res );
}
return res;
}
|
0dae34 | 1998-02-11 | Niels Möller | | return Lfalse;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object apply(object arglist, object env, object globals)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | object id;
if (!globals->roxen_id)
|
2901b1 | 1998-01-29 | Per Hedbor | | return 0;
|
0dae34 | 1998-02-11 | Niels Möller | |
array args = ({ });
int i = 0;
int optional;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | while(arglist != Lempty)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if (i == sizeof(types))
{
if (!optional)
return 0;
else
break;
}
switch(types[i])
{
case 0:
optional = 1;
i++;
break;
case "string":
if (!arglist->car->is_string)
return 0;
args += ({ arglist->car->value });
arglist = arglist->cdr;
break;
case "int":
if (!arglist->car->is_number)
return 0;
args += ({ (int) arglist->car->value });
arglist = arglist->cdr;
break;
default:
error(sprintf("API_Function: Unexpected type '%s'\n", types[i]));
}
i++;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | return to_lisp(fun(globals->roxen_id, @args));
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | void create(array a)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | [ fun, types ] = a;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
}
|
0dae34 | 1998-02-11 | Niels Möller | | mapping environments;
mapping(string:object) lisp_code;
object boot_code;
|
1756d3 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | void start()
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | werror("Lisp: starting...\n");
boot_code = Parser( query("bootcode") )->read();
werror(sprintf("Read boot_code: %s\n",
boot_code ? boot_code->print(1) : "<error>"));
environments = ([]);
lisp_code = ([]);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | void init_environment(object e, object conf)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | init_specials(e);
init_functions(e);
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | init_roxen_functions(e, conf);
default_boot_code->eval(e, e);
boot_code->eval(e,e);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object find_environment(string f, object conf)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if(environments[f])
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | return environments[f];
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | environments[f] = RoxenEnv();
init_environment( environments[f], conf );
return environments[f];
|
1963e6 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object lisp_compile(string s)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | object o = lisp_code[s];
if (o)
return o;
o = Parser("(begin\n" + s + " )")->read();
lisp_code[s] = o;
return o;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | string tag_lisp(string t, mapping m, string c,
object id, object f, mapping defines)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | string context = (query("enable_context") && m->context)
|| id->not_query;
object e = find_environment(context, id->conf);
if(m->once && e->once_done) return "";
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | object lisp = lisp_compile(c);
if (!lisp)
return "<!-- syntax error in lisp code -->\n";
object globals = RoxenId(e, id, defines);
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | globals->limit = query("max-eval-time");
lisp->eval( e, globals );
|
1963e6 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | if (m->once)
e->once_done = 1;
return globals->lisp_result;
|
1963e6 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | mapping query_container_callers()
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | return ([ "lisp":tag_lisp, ]);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | #if 0
|
1756d3 | 1998-01-29 | Per Hedbor | | object f_get_id_int(object arglist, object env, object globals)
{
|
0dae34 | 1998-02-11 | Niels Möller | | object id = globals->roxen_id;
if (id && arglist->car->is_string)
return Number( (int)globals->id[arglist->car->value] );
else
return 0;
|
1756d3 | 1998-01-29 | Per Hedbor | | }
object f_get_id(object arglist, object env, object globals)
{
mixed val = globals->id[arglist->car->value];
if(stringp(val))
return String( globals->id->variables[arglist->car->value] );
if(intp(val) && !zero_type(val))
return Number( globals->id->variables[arglist->car->value] );
if(arrayp(val) || multisetp(val))
{
object res = Nil;
int m;
if(multisetp(val)) { m = 1; val = indices( val ); }
for(int i=sizeof(val)-1; i>=0; i--)
{
object t;
if(m)
t = make_symbol( (string)val[i] );
else
t = stringp(val[i])?String(val[i]):Number((int)val[i]);
res = Cons( t , res );
}
return res;
}
return Nil;
}
|
0dae34 | 1998-02-11 | Niels Möller | | #endif
|
1756d3 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | |
object f_display(object arglist, object env, object globals)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if (!globals->lisp_result)
return 0;
return String(arglist->car->print(1) + "\n");
return Lfalse;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object f_get(object arglist, object env, object globals)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | object id = globals->roxen_id;
werror(sprintf("lisp.pike->f_get %s\n", arglist->print(1)));
if (!id)
return 0;
werror("lisp.pike->f_get: id ok\n");
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | if (!arglist->car->to_string)
|
2901b1 | 1998-01-29 | Per Hedbor | | return 0;
|
0dae34 | 1998-02-11 | Niels Möller | | string name = arglist->car->to_string();
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | if (!name)
return 0;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | werror(sprintf("lisp.pike->f_get: name '%s'\n", name));
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | string res = id->variables[name];
if (res)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | werror(sprintf("lisp.pike->f_get: variable = '%s'\n", res));
return String(res);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | res = id->misc->defines[name];
if (res)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | werror(sprintf("lisp.pike->f_get: define = '%s'\n", res));
return String(res);
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | return Lfalse;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
object f_getint(object arglist, object env, object globals)
{
|
0dae34 | 1998-02-11 | Niels Möller | | object id = globals->roxen_id;
if (!id)
return 0;
if(id->variables[arglist->car->value])
return Number( (int)id->variables[arglist->car->value] );
if(id->misc->defines[arglist->car->value])
return Number( (int)id->misc->defines[arglist->car->value] );
return Lfalse;
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | object f_write(object arglist, object env, object globals)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | | if (!globals->lisp_result)
return 0;
int len = 0;
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | while(arglist != Lempty)
{
string s = arglist->car->print(0);
len += strlen(s);
globals->lisp_result += s;
arglist = arglist->cdr;
}
return Number( len );
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|
0dae34 | 1998-02-11 | Niels Möller | | #if 0
|
2901b1 | 1998-01-29 | Per Hedbor | | object f_format(object arglist, object env, object globals)
{
string f = arglist->car->value;
array args=({});
while( !(arglist = arglist->cdr)->is_nil)
{
if(objectp(arglist->car->value))
args+=({(int)arglist->car->value});
else
args+=({arglist->car->value});
}
if(!stringp(f)) {
return 0;
}
return String( sprintf(f, @args) );
}
|
0dae34 | 1998-02-11 | Niels Möller | |
|
1963e6 | 1998-01-29 | Per Hedbor | | object f_line_break(object arglist, object env, object globals)
{
string f = arglist->car->print();
int n = (arglist->cdr && (int)arglist->cdr->car->value) || 75;
string res = "";
while(strlen(f))
{
res += f[..n-1]+"\n";
f = f[n..];
}
return String( res );
}
|
0dae34 | 1998-02-11 | Niels Möller | | #endif
|
2901b1 | 1998-01-29 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | | void init_roxen_functions(object environment, object conf)
|
2901b1 | 1998-01-29 | Per Hedbor | | {
|
0dae34 | 1998-02-11 | Niels Möller | |
environment->extend(make_symbol("r-get-string"), Builtin(f_get));
environment->extend(make_symbol("r-get-int"), Builtin(f_getint));
environment->extend(make_symbol("write"), Builtin(f_write));
environment->extend(make_symbol("display"), Builtin(f_display));
|
85f91a | 1998-02-03 | Per Hedbor | |
|
0dae34 | 1998-02-11 | Niels Möller | |
mapping m = conf->api_functions();
|
85f91a | 1998-02-03 | Per Hedbor | | foreach(indices(m), string f)
|
0dae34 | 1998-02-11 | Niels Möller | | environment->extend(make_symbol("r-" + replace(f, "_", "-")),
API_Function( m[f] ));
|
2901b1 | 1998-01-29 | Per Hedbor | | }
|