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.4 1998/01/29 16:16:49 per Exp $"; + constant cvs_version = "$Id: lisp.pike,v 1.5 1998/01/29 17:25:28 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) + { +  if(environs[f]) return environs[f]; +  environs[f] = E(); +  init_for( environs[f] ); +  return environs[f]; + }      string tag_lisp(string t, mapping m, string c,    object id, object f, mapping defines)   { -  object e; -  mixed f = m->context||id->not_query; -  if(environs[f]) -  { -  e = environs[f]; -  f = 0; -  } else { -  e = environs[f] = E(); -  init_for( e ); -  f = 1; -  } -  if(m->once && !f) return ""; // only once... -  +     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 = this_object()->NilSymbol(symbol_table); -  object True = this_object()->ConstantSymbol("t", 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)
Roxen.git/server/modules/tags/lisp.pike:126:       object mapcar(string|function fun, mixed ...extra)    {    object new_car, new_cdr;    new_car = stringp(fun)? car[fun](@extra) : fun(car, @extra);    if (!new_car)    {    error("No car");    }    -  object new_cdr = (!cdr->is_nil) ? cdr->mapcar(fun, @extra) : cdr; +  object new_cdr = (!cdr->is_nil) ? cdr->mapcar(fun, @extra) +  : cdr;    if (cdr)    return object_program(this_object())(new_car, new_cdr);    else    {    error("No cdr");    }    }       object map(string|function fun, mixed ...extra)    {
Roxen.git/server/modules/tags/lisp.pike:215:    if(globals->eval_limit==0)    {    globals->eval_limit=1;    error("Maximum eval-depth reached.");    }    }    object binding = env->query_binding(this_object())    || globals->query_binding(this_object());    if (!binding)    { -  error("No binding for this symbol ["+this_object()->print()+"].\n"); +  error("No binding for this symbol ["+name+"].\n");    }    return binding->query();    }       // int __hash() { return hash(name); }       string print()    {    return name;    }
Roxen.git/server/modules/tags/lisp.pike:371:    object res = env->copy();    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 arglist->map("eval", env, globals); +  return list->map("eval", env, globals);    error("Nothing to apply with.");    }    }       class Lexical    {    inherit Lambda : l;    object env;       void create(object e, object formals_list, object expressions)
Roxen.git/server/modules/tags/lisp.pike:552:    }    return Cons(item , read_list());    }    }   }            inherit lisp_types;    +    /* Special forms */   object s_quote(object arglist, object env, object globals)   {    return arglist->car;   }    -  +  +    object s_setq(object arglist, object env, object globals)   {   // werror(sprintf("set!, arglist: %s\n", arglist->print() + "\n"));    object value = arglist->cdr->car->eval(env, globals);    object binding = env->query_binding(arglist->car)    || globals->query_binding(arglist->car);    if (binding)    {    binding->set(value);    return value;
Roxen.git/server/modules/tags/lisp.pike:608:   }      object s_if(object arglist, object env, object globals)   {    if (!arglist->car->eval(env, globals)->is_nil)    return arglist->cdr->car->eval(env, globals);    object e = arglist->cdr->cdr;    return e ? e->car->eval(env, globals) : Nil;   }    - object s_or(object arglist, object env, object globals) + object s_and(object arglist, object env, object globals)   {    object res;    while(!arglist->cdr->is_nil)    {    res = arglist->car->eval(env, globals); -  if (!res || !res->is_nil) +  if (!res || res->is_nil)    return res;    arglist = arglist->cdr;    }    return arglist->car->eval(env, globals);   }    -  - object s_and(object arglist, object env, object globals) + object s_or(object arglist, object env, object globals)   {    object res;    while(!arglist->cdr->is_nil)    {    res = arglist->car->eval(env, globals); -  if (!res || res->is_nil) +  if (!res || !res->is_nil)    return res;    arglist = arglist->cdr;    }    return arglist->car->eval(env, globals);   }      object s_progn(object arglist, object env, object globals)   {    return arglist->map("eval", env, globals);   }
Roxen.git/server/modules/tags/lisp.pike:656:    * fatal.    *    * The catch special form catches errors, returning nil    * if an error occured. */   object s_catch(object arglist, object env, object globals)   {    return s_progn(arglist, env, globals) || Nil;   }       -  +    object s_while(object arglist, object env, object globals)   { -  object expr = arglist->car; +  object expr = arglist->car, res;    object to_eval = arglist->cdr; -  -  while(!expr->eval(env,globals)->is_nil) -  { -  object f = to_eval; -  while( f->car && !f->car->is_nil ) -  { -  if(!f->car->eval(env,globals)) return 0; -  f = f->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;   } -  } - } +       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("define"), Special(s_define)); +     environment->extend(make_symbol("while"), Special(s_while)); -  +  environment->extend(make_symbol("define"), Special(s_define));    environment->extend(make_symbol("defmacro"), Special(s_defmacro));    environment->extend(make_symbol("lambda"), Special(s_lambda));    environment->extend(make_symbol("if"), Special(s_if)); -  environment->extend(make_symbol("or"), Special(s_or)); -  environment->extend(make_symbol("while"), Special(s_while)); +     environment->extend(make_symbol("and"), Special(s_and)); -  +  environment->extend(make_symbol("or"), Special(s_or));    environment->extend(make_symbol("progn"), Special(s_progn));    environment->extend(make_symbol("catch"), Special(s_catch));   }       -  + object f_get_id_int(object arglist, object env, object globals) + { +  return Number( (int)globals->id[arglist->car->value] ); + } +  +  + 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; + } +    object f_car(object arglist, object env, object globals)   {    return arglist->car->car;   }      object f_cdr(object arglist, object env, object globals)   {    return arglist->car->cdr;   }   
Roxen.git/server/modules/tags/lisp.pike:817:      object f_get(object arglist, object env, object globals)   {    if(globals->id->variables[arglist->car->value])    return String( globals->id->variables[arglist->car->value] );    if(globals->id->misc->defines[arglist->car->value])    return String( globals->id->misc->defines[arglist->car->value] );    return Nil;   }    - object f_get_id_int(object arglist, object env, object globals) - { -  return Number( (int)globals->id[arglist->car->value] ); - } -  -  - 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; - } -  +    object f_getint(object arglist, object env, object globals)   {    if(globals->id->variables[arglist->car->value])    return Number( (int)globals->id->variables[arglist->car->value] );    if(globals->id->misc->defines[arglist->car->value])    return Number( (int)globals->id->misc->defines[arglist->car->value] );    return Nil;   }      object f_output(object arglist, object env, object globals)   {    int foo = strlen( globals->id->misc->lisp_result ); -  do +  do {    globals->id->misc->lisp_result += (string)arglist->car->value; -  while( !(arglist = arglist->cdr)->is_nil); +  } while( !(arglist = arglist->cdr)->is_nil);    return Number( strlen(globals->id->misc->lisp_result) - foo );   }      object f_concat(object arglist, object env, object globals)   {    string res="";    do {    res += arglist->car->value;    } while( !(arglist = arglist->cdr)->is_nil);    return String( res );
Roxen.git/server/modules/tags/lisp.pike:895:    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..];    }    return String( res );   }      object boot_code; -  +    void init_functions(object environment)   {    environment->extend(make_symbol("+"), Builtin(f_add));    environment->extend(make_symbol("*"), Builtin(f_mult));    environment->extend(make_symbol("-"), Builtin(f_subtract));    environment->extend(make_symbol("="), Builtin(f_equal));    environment->extend(make_symbol("<"), Builtin(f_lt));    environment->extend(make_symbol(">"), Builtin(f_gt));       environment->extend(make_symbol("concat"), Builtin(f_concat));    environment->extend(make_symbol("format"), Builtin(f_format));       environment->extend(make_symbol("variable"), Builtin(f_get));    environment->extend(make_symbol("variable-number"), Builtin(f_getint)); -  -  environment->extend(make_symbol("id"), Builtin(f_get_id)); -  environment->extend(make_symbol("id-number"), Builtin(f_get_id_int)); +  environment->extend(make_symbol("id"), Builtin(f_get)); +  environment->extend(make_symbol("id-number"), Builtin(f_getint));    environment->extend(make_symbol("output"), Builtin(f_output));    -  +  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)); -  -  environment->extend(make_symbol("line-break"), Builtin(f_line_break)); +    }         void init_for(object e)   {    init_specials(e);    init_functions(e);    boot_code->eval(e,e);   }