Roxen.git / server / modules / tags / lisp.pike

version» Context lines:

Roxen.git/server/modules/tags/lisp.pike:1:   #define error(X) throw( ({ (X), backtrace() }) ) - constant cvs_version = "$Id: lisp.pike,v 1.5 1998/01/29 17:25:28 per Exp $"; + constant cvs_version = "$Id: lisp.pike,v 1.6 1998/02/03 22:47:53 per Exp $";      #include <module.h>   inherit "module";      constant thread_safe=1;      array register_module()   {    return ({ MODULE_PARSER, "Lisp tag module",    "This module defines a new tag, "
Roxen.git/server/modules/tags/lisp.pike:51:      void start()   {    boot_code = parse( query("bootcode") );   }      void init_for(object e);      mapping environs = ([]);   program E = this_object()->Environment; - object find_environment(string f) + object find_environment(string f, mapping m, object id)   { -  if(environs[f]) return environs[f]; +  if(environs[f]) +  { +  environs[f]->id = id; +  return environs[f]; +  } +  +  m_delete(m, "once");    environs[f] = E(); -  +  environs[f]->id = id;    init_for( environs[f] );    return environs[f];   }      string tag_lisp(string t, mapping m, string c,    object id, object f, mapping defines)   { -  +  object e = find_environment(m->context||id->not_query, m, id); +  if(m->once) return "";    object lisp = parse( "(progn\n"+c+")" ); -  object e = find_environment(m->context||id->not_query); +     id->misc->lisp_result=""; -  e->id = id; +     e->eval_limit = query("max-eval-time");    lisp->eval( e, e );    return (id->misc->lisp_result);   }      mapping query_container_callers()   {    return ([ "lisp":tag_lisp, ]);   }       -  -  +    class lisp_types   {    /* Data shared between all Lisp objects */    mapping symbol_table = ([ ]);    object Nil = NilSymbol(symbol_table);    object True = ConstantSymbol("t", symbol_table);    -  +     class LObject    {    }       class SelfEvaluating    {    inherit LObject;    object eval(object env, object globals)    {    return this_object();
Roxen.git/server/modules/tags/lisp.pike:144:    if (!cdr || cdr->is_nil)    {    if (stringp(fun))    return car[fun](@extra);    else    return fun(car, @extra);    }    if (stringp(fun) ? car[fun](@extra) : fun(car, @extra))    return cdr->map(fun, @extra);    else -  error("Unknown function"); +  error("Function ["+(stringp(fun)?fun:sprintf("%O", fun))+ +  "]\nin "+car->print()+" returned error\n");       }       string print()    {    string s = "(";    object p = this_object();    while (!p->is_nil)    {    if (!p->car)
Roxen.git/server/modules/tags/lisp.pike:321:    }       object copy() { return object_program(this_object())(copy_value(env)); };       object extend(object symbol, object value)    {    // werror(sprintf("Binding '%s'\n", symbol->print()));    env[symbol] = Binding(value);    }    -  string print() { return sprintf("<Environment: %O>\n", -  Array.map(indices(env), "print")); } +  string print() +  { +  string res=""; +  foreach(indices(env), object s) +  { +  if(env[s]->value != this_object()) +  res += s->print()+": "+env[s]->value->print()+"\n"; +  else +  res += "global-environment: ...\n";    } -  +  return res; +  } +  }       class Lambda    {    inherit LObject;       object formals; /* May be a dotted list */    object list; /* expressions */       void create(object formals_list, object expressions)    {    formals = formals_list;    list = expressions;    }    -  string print() { return "<lambda>"; } +  string print() { return "lambda "+list->print(); }       int build_env1(object env, object symbols, object arglist)    {    if (symbols->is_nil)    return arglist->is_nil;    if (!symbols->car)    {    /* An atom */    env->extend(symbols, arglist);    return 1;
Roxen.git/server/modules/tags/lisp.pike:368:    return build_env1(res, formals, arglist) ? res : 0;    }       object new_env(object env, object arglist);       object apply(object arglist, object env, object globals)    {    env = new_env(env, arglist);    if (env)    return list->map("eval", env, globals); -  error("Nothing to apply with."); +  error("Nothing to apply with.\n");    }    }       class Lexical    {    inherit Lambda : l;    object env;       void create(object e, object formals_list, object expressions)    {
Roxen.git/server/modules/tags/lisp.pike:423:       function apply;       void create(function f)    {    apply = f;    }       string print()    { -  return "<Builtin>"; +  return sprintf("Builtin (%O)", apply);    }    }       class Special    {    inherit Builtin;    constant is_special = 1;    string print()    { -  return "<Special>"; +  return sprintf("Special (%O)", apply);    }    }    -  +  +  class APIObject +  { +  inherit LObject; +  function fun; +  +  string print() { return sprintf("APIfunction %O", fun); } +  +  object apply(object arglist, object env, object globals) +  { +  array args = ({ globals->id }); +  while(arglist->car && !arglist->car->is_nil) +  { +  mixed v = arglist->car->print(); +  if((int)v || v=="0") v=(int)v; +  args += ({ v }); +  arglist = arglist->cdr; +  } +  mixed val = fun( @ args ); +  +  if(stringp(val)) +  return String( val ); +  +  if(intp(val) && !zero_type(val)) +  return Number( val ); +  +  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; +  } +  +  void create(array f) +  { +  fun = f[0]; // f[1] is list of types for arguments.. +  } +  }    /* Parser */       class Parser    {    object number_re = Regexp("^(-|)([0-9]+)");    object symbol_re = Regexp("^([^0-9 \t\n(.)\"]+)");    object space_re = Regexp("^([ \t\n]+)");    object comment_re = Regexp("^(;[^\n]*\n)");    object string_re = Regexp("^(\"[^\"]*\")");   
Roxen.git/server/modules/tags/lisp.pike:660:    return s_progn(arglist, env, globals) || Nil;   }         object s_while(object arglist, object env, object globals)   {    object expr = arglist->car, res;    object to_eval = arglist->cdr;    werror( to_eval->print() );    while (!expr->eval(env,globals)->is_nil) -  res=to_eval->map("eval", env, globals); //f_eval (to_eval,env,globals); -  return res; +  to_eval->map("eval", env, globals);//f_eval (to_eval,env,globals); +  return Nil;   }      void init_specials(object environment)   {    environment->extend(make_symbol("quote"), Special(s_quote));    environment->extend(make_symbol("set!"), Special(s_setq));    environment->extend(make_symbol("setq"), Special(s_setq));    environment->extend(make_symbol("while"), Special(s_while));    environment->extend(make_symbol("define"), Special(s_define));    environment->extend(make_symbol("defmacro"), Special(s_defmacro));
Roxen.git/server/modules/tags/lisp.pike:885:    args+=({(int)arglist->car->value});    else    args+=({arglist->car->value});    }    if(!stringp(f)) {    return 0;    }    return String( sprintf(f, @args) );   }    -  -  +    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..];    }
Roxen.git/server/modules/tags/lisp.pike:932:    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 = environment->id->conf->api_functions(); +  foreach(indices(m), string f) +  environment->extend(make_symbol(replace(f, "_", "-")), APIObject( m[f] ));   }         void init_for(object e)   {    init_specials(e);    init_functions(e); -  +     boot_code->eval(e,e);   }