2901b11998-01-29Per Hedbor #define error(X) throw( ({ (X), backtrace() }) )
0dae341998-02-11Niels Möller constant cvs_version = "$Id: lisp.pike,v 1.7 1998/02/11 01:31:30 nisse Exp $";
2901b11998-01-29Per 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, " "&lt;lisp [context=foo]&gt;&lt;/lisp&gt;", 0, ({}) }); } void create() { defvar("max-eval-time", 10000, "Max eval time", TYPE_INT);
0dae341998-02-11Niels Möller  defvar("bootcode", "(begin)", "Lisp code executed to initialize the top-level environments.",
2901b11998-01-29Per Hedbor  TYPE_TEXT);
0dae341998-02-11Niels Möller  defvar("enable_context", 1, "Enable the context attribute.", TYPE_FLAG);
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller import Languages.PLIS;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller class RoxenEnv
1756d31998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  import Languages.PLIS;
85f91a1998-02-03Per Hedbor 
0dae341998-02-11Niels Möller  inherit Environment;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  int once_done;
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller /* This contains request specific data */ class RoxenId
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  import Languages.PLIS;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  object lisp_env; int limit;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  object roxen_id; mapping defines; string lisp_result;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  int limit_apply()
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  if (!limit)
2901b11998-01-29Per Hedbor  return 1;
0dae341998-02-11Niels Möller  limit--; return 0;
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  object query_binding(object symbol) { return lisp_env->query_binding(symbol); }
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  object copy() { return lisp_env->copy(); }
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  object extend(object symbol, object value)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  return lisp_env->extend(symbol, value);
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  string print(int display) // { return "Global roxen environment"; } { return lisp_env->print(display); }
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  void create(object env, object id, mapping defs)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  lisp_env = env; roxen_id = id; defines = defs; lisp_result = "";
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller }
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller class API_Function { import Languages.PLIS;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  inherit LObject; function fun; array types; string print(int display) { return sprintf("API_Function %O", fun); }
85f91a1998-02-03Per Hedbor 
0dae341998-02-11Niels Möller  object to_lisp(mixed o)
85f91a1998-02-03Per Hedbor  {
0dae341998-02-11Niels Möller  if(stringp(o)) return String( o );
85f91a1998-02-03Per Hedbor 
0dae341998-02-11Niels Möller  if(intp(o) && !zero_type(o)) return Number(o);
85f91a1998-02-03Per Hedbor 
0dae341998-02-11Niels Möller  if(arrayp(o) || multisetp(o))
85f91a1998-02-03Per Hedbor  {
0dae341998-02-11Niels 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--)
85f91a1998-02-03Per Hedbor  { object t;
0dae341998-02-11Niels Möller  if(m && stringp(o[i])) t = make_symbol( o[i] );
85f91a1998-02-03Per Hedbor  else
0dae341998-02-11Niels Möller  t = to_lisp(o[i]);
85f91a1998-02-03Per Hedbor  res = Cons( t , res ); } return res; }
0dae341998-02-11Niels Möller  return Lfalse;
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  object apply(object arglist, object env, object globals)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  object id; if (!globals->roxen_id)
2901b11998-01-29Per Hedbor  return 0;
0dae341998-02-11Niels Möller  array args = ({ }); int i = 0; int optional;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  while(arglist != Lempty)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  if (i == sizeof(types)) { if (!optional) return 0; else break; } switch(types[i]) { case 0: /* Any arguments left are optional */ 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++;
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  return to_lisp(fun(globals->roxen_id, @args));
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  void create(array a)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  [ fun, types ] = a;
2901b11998-01-29Per Hedbor  } }
0dae341998-02-11Niels Möller mapping environments; mapping(string:object) lisp_code; object boot_code;
1756d31998-01-29Per Hedbor 
0dae341998-02-11Niels Möller void start()
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels 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 = ([]);
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller void init_environment(object e, object conf)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  init_specials(e); init_functions(e);
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  init_roxen_functions(e, conf); default_boot_code->eval(e, e); boot_code->eval(e,e);
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller object find_environment(string f, object conf)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  if(environments[f])
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  return environments[f];
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  environments[f] = RoxenEnv(); init_environment( environments[f], conf ); return environments[f];
1963e61998-01-29Per Hedbor }
0dae341998-02-11Niels Möller object lisp_compile(string s)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  object o = lisp_code[s]; if (o) return o; o = Parser("(begin\n" + s + " )")->read(); lisp_code[s] = o; return o;
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller string tag_lisp(string t, mapping m, string c, object id, object f, mapping defines)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  string context = (query("enable_context") && m->context) || id->not_query; object e = find_environment(context, id->conf); // werror(sprintf("Environment: %s\n", e->print(1))); if(m->once && e->once_done) return "";
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  object lisp = lisp_compile(c); if (!lisp) return "<!-- syntax error in lisp code -->\n"; object globals = RoxenId(e, id, defines);
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  globals->limit = query("max-eval-time"); lisp->eval( e, globals );
1963e61998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  if (m->once) e->once_done = 1; return globals->lisp_result;
1963e61998-01-29Per Hedbor }
0dae341998-02-11Niels Möller mapping query_container_callers()
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  return ([ "lisp":tag_lisp, ]);
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller #if 0
1756d31998-01-29Per Hedbor object f_get_id_int(object arglist, object env, object globals) {
0dae341998-02-11Niels Möller  object id = globals->roxen_id; if (id && arglist->car->is_string) return Number( (int)globals->id[arglist->car->value] ); else return 0;
1756d31998-01-29Per 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; }
0dae341998-02-11Niels Möller #endif
1756d31998-01-29Per Hedbor 
0dae341998-02-11Niels Möller /* Returns a string, instead of outputting it directly. * Usually, you want to html-quote it before output. */ object f_display(object arglist, object env, object globals)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  if (!globals->lisp_result) return 0; return String(arglist->car->print(1) + "\n"); return Lfalse;
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller object f_get(object arglist, object env, object globals)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels 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");
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  if (!arglist->car->to_string)
2901b11998-01-29Per Hedbor  return 0;
0dae341998-02-11Niels Möller  string name = arglist->car->to_string();
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  if (!name) return 0;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  werror(sprintf("lisp.pike->f_get: name '%s'\n", name));
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  string res = id->variables[name]; if (res)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  werror(sprintf("lisp.pike->f_get: variable = '%s'\n", res)); return String(res);
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  res = id->misc->defines[name]; if (res)
2901b11998-01-29Per Hedbor  {
0dae341998-02-11Niels Möller  werror(sprintf("lisp.pike->f_get: define = '%s'\n", res)); return String(res);
2901b11998-01-29Per Hedbor  }
0dae341998-02-11Niels Möller  return Lfalse;
2901b11998-01-29Per Hedbor } object f_getint(object arglist, object env, object globals) {
0dae341998-02-11Niels 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;
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller object f_write(object arglist, object env, object globals)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  if (!globals->lisp_result) return 0; int len = 0;
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller  while(arglist != Lempty) { string s = arglist->car->print(0); len += strlen(s); globals->lisp_result += s; arglist = arglist->cdr; } return Number( len );
2901b11998-01-29Per Hedbor }
0dae341998-02-11Niels Möller #if 0
2901b11998-01-29Per 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) ); }
0dae341998-02-11Niels Möller 
1963e61998-01-29Per 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 ); }
0dae341998-02-11Niels Möller #endif
2901b11998-01-29Per Hedbor 
0dae341998-02-11Niels Möller void init_roxen_functions(object environment, object conf)
2901b11998-01-29Per Hedbor {
0dae341998-02-11Niels Möller  // environment->extend(make_symbol("format"), Builtin(f_format)); 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));
85f91a1998-02-03Per Hedbor 
0dae341998-02-11Niels Möller  // environment->extend(make_symbol("line-break"), Builtin(f_line_break)); // environment->extend(make_symbol("read"), Builtin(f_read)); // environment->extend(make_symbol("print"), Builtin(f_print)); // environment->extend(make_symbol("princ"), Builtin(f_print)); // environment->extend(make_symbol("eval"), Builtin(f_eval)); // environment->extend(make_symbol("apply"), Builtin(f_apply)); // environment->extend(make_symbol("global-environment"), environment); // environment->extend(make_symbol("car"), Builtin(f_car)); // environment->extend(make_symbol("cdr"), Builtin(f_cdr)); // environment->extend(make_symbol("setcar!"), Builtin(f_setcar)); // environment->extend(make_symbol("setcdr!"), Builtin(f_setcdr)); // environment->extend(make_symbol("cons"), Builtin(f_cons)); // environment->extend(make_symbol("list"), Builtin(f_list)); mapping m = conf->api_functions();
85f91a1998-02-03Per Hedbor  foreach(indices(m), string f)
0dae341998-02-11Niels Möller  environment->extend(make_symbol("r-" + replace(f, "_", "-")), API_Function( m[f] ));
2901b11998-01-29Per Hedbor }