home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 01 / levelki / lisp.inc < prev    next >
Encoding:
Text File  |  1988-09-29  |  14.4 KB  |  419 lines
  1. (*******************************************************)
  2. (*                      LISP.INC                       *)
  3. (*         Include-Modul des LittleLisp-Systems        *)
  4. (*          (C) 1988 Reinhard Häring & TOOLBOX         *)
  5. (*******************************************************)
  6.  
  7. function self_evalp(x:objp):boolean;
  8.   function del_obj(x:objp):boolean;
  9.     begin
  10.       del_obj:=false;
  11.       if x^.typ=3 then
  12.         del_obj:=equal(car(x),p_delayed_obj);
  13.     end;
  14.   var t:integer; n:string20;
  15.   begin
  16.     t:=x^.typ;
  17.     if t=2 then n:=x^.a^;
  18.     self_evalp:= (t=0) or (t=1)
  19.     or ((t=2) and (n='t'))
  20.     or ((t=2) and (n='true'))
  21.     or (t=-1) or del_obj(x);
  22.   end;
  23.  
  24. function variable(x:objp):boolean;
  25.   begin
  26.     variable:=2=x^.typ;
  27.   end;
  28.  
  29. function definition_variable(exp:objp):objp;
  30.   begin
  31.     if variable(car(cdr(exp))) then
  32.       definition_variable:=car(cdr(exp))
  33.     else
  34.       definition_variable:=car(car(cdr(exp)));
  35.   end;
  36.  
  37. function definition_value(exp:objp):objp;
  38.   begin
  39.     if variable(car(cdr(exp))) then
  40.       definition_value:=car(cdr(cdr(exp)))
  41.     else
  42.       definition_value:=cons(p_lambda,
  43.                                   cons(cdr(car(cdr(exp))),
  44.                                        cdr(cdr(exp))));
  45.   end;
  46.  
  47. function eval_definition(exp,env:objp):objp;
  48.   begin
  49.     dummy:=define_variable(definition_variable(exp),
  50.                            eval(definition_value(exp),env),
  51.                            env);
  52.     eval_definition:=definition_variable(exp);
  53.   end;
  54.  
  55. function eval_assignment(exp,env:objp):objp;
  56.   var new_value:objp;
  57.   begin
  58.     new_value:=eval(car(cdr(cdr(exp))),env);
  59.     dummy:=set_variable_value(car(cdr(exp)),
  60.                               new_value,env);
  61.     eval_assignment:=new_value;
  62.   end;
  63.  
  64.  
  65. function make_procedure(typ,exp,env:objp):objp;
  66.   begin
  67.     make_procedure:=cons(typ,cons(exp,cons(env,null)));
  68.   end;
  69.  
  70. function mproc(p:objp):boolean;
  71.   begin
  72.     mproc:=false;
  73.     if (3=p^.typ) then if equal(car(p),p_mprocedure)
  74.       then mproc:=true;
  75.   end;
  76.  
  77. function dproc(p:objp):boolean;
  78.   begin
  79.     dproc:=false;
  80.     if (3=p^.typ) then if equal(car(p),p_dprocedure)
  81.       then dproc:=true;
  82.   end;
  83.  
  84. function dellist(l:objp):objp;
  85.   function delay_item(x:objp):objp;
  86.     begin
  87.       delay_item:=cons(p_delay,cons(x,null));
  88.     end;
  89.   begin
  90.     if nullp(l) then dellist:=null else
  91.     dellist:=cons(delay_item(car(l)),dellist(cdr(l)));
  92.   end;
  93.  
  94. function else_clause(x:objp):boolean;
  95.   begin
  96.     else_clause:= (3=x^.typ) and equal(car(x),p_else)
  97.   end;
  98.  
  99. function eval_sequence(exps,env:objp):objp;
  100.   begin
  101.     if nullp(cdr(exps)) then
  102.       eval_sequence:=eval(car(exps),env) else
  103.     begin
  104.       dummy:=eval(car(exps),env);
  105.       eval_sequence:=eval_sequence(cdr(exps),env);
  106.     end;
  107.   end;
  108.  
  109. function map(proc,list,env:objp):objp;
  110.   begin
  111.     if nullp(list) then map:=null else
  112.     if 3<>list^.typ then
  113.       error('no list for map: '+outlist(list))
  114.     else
  115.       map:=cons(apply(proc,cons(car(list),null),env),
  116.                 map(proc,cdr(list),env));
  117.     end;
  118.  
  119. function eval_cond(clist,env:objp):objp;
  120.   begin
  121.     if nullp(clist) then eval_cond:=null else
  122.     if else_clause(car(clist))
  123.        then eval_cond:=eval_sequence(cdr(car(clist)),env)
  124.     else if not nullp(eval(car(car(clist)),env))
  125.        then eval_cond:=eval_sequence(cdr(car(clist)),env)
  126.     else eval_cond:=eval_cond(cdr(clist),env);
  127.   end;
  128.  
  129. function list_of_values(exps,env:objp):objp;
  130.   begin
  131.     if nullp(exps) then list_of_values:=null else
  132.     list_of_values:=cons(eval(car(exps),env),
  133.                          list_of_values(cdr(exps),env));
  134.   end;
  135.  
  136. function getprop(atom,key:objp):objp;
  137.   var alist,p:objp;
  138.   begin
  139.     alist:=assoc(atom,property);
  140.     if nullp(alist) then getprop:=null
  141.       else begin p:=assoc(key,cdr(alist));
  142.         if nullp(p) then getprop:=null
  143.           else getprop:=cdr(p);
  144.        end;
  145.   end;
  146.  
  147. function proplist(atom:objp):objp;
  148.   var plist:objp;
  149.   begin
  150.     plist:=assoc(atom,property);
  151.     if nullp(plist) then proplist:=null
  152.       else proplist:=cdr(plist);
  153.   end;
  154.  
  155. function replace(alist,atom,new_entry:objp):objp;
  156.   { ersetzt in alist alle Einträge für atom durch new_entry}
  157.   begin
  158.     if nullp(alist) then replace:=cons(new_entry,null) else
  159.     if equal(car(car(alist)),atom) then
  160.       if nullp(new_entry) then
  161.         replace:=cdr(alist)
  162.       else
  163.         replace:=cons(new_entry,cdr(alist))
  164.     else
  165.       replace:=cons(car(alist),replace(cdr(alist),
  166.                     atom,new_entry));
  167.   end;
  168.  
  169. function putprop(atom,key,value:objp):objp;
  170.   var old_alist,new_alist:objp;
  171.   begin
  172.     putprop:=value;
  173.     old_alist:=assoc(atom,property);
  174.     if nullp(old_alist) then
  175.        new_alist:=cons(atom,cons(cons(key,value),null))
  176.       else new_alist:=cons(atom,cons(cons(key,value),
  177.                            cdr(old_alist)));
  178.     property:=replace(property,atom,new_alist);
  179.   end;
  180.  
  181. function remprop(atom,key:objp):objp;
  182.   var new_alist,old_alist:objp;
  183.   begin
  184.     remprop:=key;
  185.     old_alist:=assoc(atom,property);
  186.     if not nullp(old_alist) then  begin
  187.       new_alist:=cons(atom,replace(cdr(old_alist),
  188.                       key,null));
  189.       property:=replace(property,atom,new_alist);
  190.     end;
  191.  end;
  192.  
  193. function primitive(proc,args,env:objp):objp;
  194.   var a,b,c,d,h:objp;
  195.       p:string[20];
  196.       st:lstring;
  197.       ai,bi:integer;
  198.   function ll(x:boolean):objp;
  199.     begin
  200.       if x then ll:=p_t else ll:=null;
  201.     end;
  202.   begin
  203.     p:=proc^.a^;
  204.     if nullp(args) then  { Funktionen mit 0 Argumenten }
  205.         if p='property' then primitive:=property else
  206.         if p='the-env' then primitive:=env else
  207.         if p='dynamic' then begin
  208.           dynamic:=true; primitive:=null;
  209.         end else if p='lexical' then begin
  210.           dynamic:=false; primitive:=null;
  211.         end else if p='dynamic?' then primitive:=ll(dynamic)
  212.         else if p='newline'then begin
  213.           writeln; primitive:=null;
  214.         end
  215.         else if p='read' then begin
  216.           readln(st); primitive:=inlist(st);
  217.         end
  218.         else
  219.           error('0 Arguments to '+outlist(proc))
  220.         else begin
  221.           a:=car(args); b:=cdr(args);
  222.           if nullp(b) then  { Funktionen mit 1 Argument }
  223.           if p='delayed?' then primitive:=ll(eq(car(a),p_delayed_obj))
  224.           else if p='proplist' then primitive:=proplist(a)
  225.           else if p='length' then primitive:=make_number(llen(a))
  226.           else if p='-' then primitive:=make_number(-a^.i)
  227.           else if p='+' then primitive:=a
  228.           else if p='strlen' then primitive:=make_number(length(a^.s^))
  229.           else if p='eval' then primitive:=eval(a,env)
  230.           else if p='proc-env' then primitive:=car(cdr(cdr(a)))
  231.           else if p='proc-def' then primitive:=car(cdr(a))
  232.           else if p='null?' then  primitive:=ll(nullp(a))
  233.           else if p='atom?' then
  234.             primitive:=ll((2=a^.typ) or (-1=a^.typ) or (0=a^.typ))
  235.           else if p='integer?' then primitive:=ll(0=a^.typ)
  236.           else if p='symbol?' then primitive:=ll(2=a^.typ)
  237.           else if p='number?' then primitive:=ll(0=a^.typ)
  238.           else if p='string?' then primitive:=ll(1=a^.typ)
  239.           else if p='pair?' then primitive:=ll(3=a^.typ)
  240.           else if p='car' then primitive:=car(a)
  241.           else if p='cdr' then primitive:=cdr(a)
  242.           else if p='cdar' then primitive:=cdr(car(a))
  243.           else if p='cddr' then primitive:=cdr(cdr(a))
  244.           else if p='caar' then primitive:=car(car(a))
  245.           else if p='cadr' then primitive:=car(cdr(a))
  246.           else if p='list' then primitive:=cons(a,null) else
  247.        if p='not' then primitive:=ll(nullp(a)) else
  248.        if p='inlist' then primitive:=inlist(a^.s^) else
  249.        if p='outlist' then begin new(h); h^.typ:=1; new(h^.s);
  250.                              h^.s^:=outlist(a); primitive:=h; end else
  251.        if p='print' then begin primitive:=a; write(outlist(a)); end else
  252.        if p='read-file' then begin read_file(a); primitive:=a; end else
  253.         error('1 Argument to '+outlist(proc))  else begin
  254.       c:=cdr(b); b:=car(b);
  255.     if nullp(c) then { Funktionen mit 2 Argumenten }
  256.        if p='get' then primitive:=getprop(a,b) else
  257.        if p='rem' then primitive:=remprop(a,b) else
  258.        if p='apply' then primitive:=apply(a,b,env) else
  259.        if p='setcar!' then primitive:=setcar(a,b) else
  260.        if p='setcdr!' then primitive:=setcdr(a,b) else
  261.        if p='eval' then primitive:=eval(a,b) else
  262.        if p='cons' then primitive:=cons(a,b) else
  263.        if p='append' then primitive:=append(a,b) else
  264.        if p='member' then primitive:=ll(member(a,b)) else
  265.        if p='list' then primitive:=cons(a,cons(b,null)) else
  266.        if p='equal' then primitive:=ll(equal(a,b)) else
  267.        if p='eq' then primitive:=ll(eq(a,b)) else
  268.        if p='equal?' then primitive:=ll(equal(a,b)) else
  269.        if p='eq?' then primitive:=ll(eq(a,b)) else
  270.        if p='assoc' then primitive:=assoc(a,b) else
  271.        if p='concat' then begin new(h); h^.typ:=1; new(h^.s);
  272.                           h^.s^:=a^.s^+b^.s^; primitive:=h; end else
  273.        if p='+' then primitive:=make_number(a^.i+b^.i) else
  274.        if p='-' then primitive:=make_number(a^.i-b^.i) else
  275.        if p='*' then primitive:=make_number(a^.i*b^.i) else
  276.        if p='/' then primitive:=make_number(a^.i div b^.i) else
  277.        if p='>' then primitive:=ll(a^.i>b^.i) else
  278.        if p='<' then primitive:=ll(a^.i<b^.i) else
  279.        if p='>=' then primitive:=ll(a^.i>=b^.i) else
  280.        if p='<>' then primitive:=ll(a^.i<>b^.i) else
  281.        if p='<=' then primitive:=ll(a^.i<=b^.i) else
  282.        if p='=' then primitive:=ll(a^.i=b^.i) else
  283.        if p='access' then primitive:=lookup_variable_value(a,b) else
  284.        if p='bound-in-frame?' then
  285.                primitive:=ll(not(nullp(assoc(a,car(b))))) else
  286.        if p='bound?' then
  287.                primitive:=ll(not(nullp(binding_in_env(a,b)))) else
  288.        if p='map' then primitive:=map(a,b,env) else
  289.         error('2 Arguments to '+outlist(proc)) else begin
  290.       d:=cdr(c); c:=car(c);  { Funktionen mit 3 Argumenten }
  291.       if p='put' then primitive:=putprop(a,b,c) else
  292.       if p='apply' then primitive:=apply(a,b,c) else
  293.       if p='list' then primitive:=cons(a,cons(b,cons(c,null))) else
  294.       if p='+' then primitive:=make_number(a^.i+b^.i+c^.i) else
  295.       if p='*' then primitive:=make_number(a^.i*b^.i*c^.i) else
  296.       if p='set' then primitive:=set_variable_value(a,b,c) else
  297.       if p='def' then primitive:=define_variable(a,b,c) else
  298.       if p='strcopy' then begin new(h); h^.typ:=1; new(h^.s);
  299.                 h^.s^:=copy(a^.s^,b^.i,c^.i); primitive:=h; end else
  300.       if p='extend-env' then primitive:=extend_environment(a,b,c) else
  301.       error('Unknown Function '+outlist(proc));
  302.     end; end; end;
  303.   end;
  304.  
  305. function apply;
  306.   var ext_env:objp;
  307.   begin
  308.     if 3=proc^.typ then
  309.      if dynamic then
  310.       apply:=eval_sequence(cdr(cdr(car(cdr(proc)))),
  311.                            extend_environment(car(cdr(car(cdr(proc)))),
  312.                                               args,env))
  313.      else  begin
  314.        ext_env:= extend_environment(car(cdr(car(cdr(proc)))),
  315.                                     args,
  316.                                     car(cdr(cdr(proc))));
  317.        apply:=eval_sequence(cdr(cdr(car(cdr(proc)))),ext_env);
  318.        end else
  319.      apply:=primitive(proc,args,env);
  320.   end;
  321.  
  322. function eval_op(op,env:objp):objp;
  323.   begin
  324.     if not nullp(binding_in_env(op,env)) then
  325.       eval_op:=eval(op,env) else
  326.       eval_op:=op;
  327.   end;
  328.  
  329. function eval_and(l,env:objp):objp;
  330.   begin
  331.     if nullp(l) then eval_and:=p_t else
  332.     if nullp(eval(car(l),env)) then eval_and:=null else
  333.     eval_and:=eval_and(cdr(l),env);
  334.   end;
  335.  
  336. function eval_or(l,env:objp):objp;
  337.   begin
  338.     if nullp(l) then eval_or:=null else
  339.     if not nullp(eval(car(l),env)) then eval_or:=p_t else
  340.     eval_or:=eval_or(cdr(l),env);
  341.   end;
  342.  
  343.  
  344. function eval_iff(exp,env:objp):objp;
  345.   begin
  346.     if not  nullp(eval(car(exp),env))
  347.       then eval_iff:=eval(car(cdr(exp)),env)
  348.       else if not nullp(cdr(cdr(exp))) then
  349.         eval_iff:=eval(car(cdr(cdr(exp))),env)
  350.        else eval_iff:=null
  351.   end;
  352.  
  353. function eval_let(exp,env:objp):objp;
  354.   var eenv,vars,vals:objp;
  355.   function carlist(x:objp):objp;
  356.     begin
  357.       if nullp(x) then carlist:=null else
  358.       carlist:=cons(car(car(x)),carlist(cdr(x)));
  359.     end;
  360.   function cadrlist(x:objp):objp;
  361.     begin
  362.       if nullp(x) then cadrlist:=null else
  363.       cadrlist:=cons(car(cdr(car(x))),cadrlist(cdr(x)));
  364.     end;
  365.   begin
  366.     vars:=carlist(car(exp));
  367.     vals:=list_of_values(cadrlist(car(exp)),env);
  368.     eenv:=extend_environment(vars,vals,env);
  369.     eval_let:=eval_sequence(cdr(exp),eenv);
  370.   end;
  371.  
  372. function make_delay(ex,env:objp):objp;
  373.   function delay:objp;
  374.     var l:objp;
  375.     begin
  376.       l:=cons(p_lambda,cons(null,cons(ex,null)));
  377.       delay:=eval(cons(p_memo_proc,cons(l,null)),env);
  378.     end;
  379.   begin
  380.     make_delay:=cons(p_delayed_obj,cons(delay,null));
  381.   end;
  382.  
  383. function careq(l,x:objp):boolean;
  384.   begin
  385.     if l^.typ=3 then careq:=equal(x,car(l)) else careq:=false;
  386.   end;
  387.  
  388. function eval;
  389.   var op:objp;
  390.   begin
  391.     if self_evalp(exp) then eval:=exp else
  392.     if careq(exp,p_quote) then eval:=car(cdr(exp)) else
  393.     if variable(exp) then eval:=lookup_variable_value(exp,env) else
  394.     if careq(exp,p_define) then eval:=eval_definition(exp,env) else
  395.     if careq(exp,p_set) then eval:=eval_assignment(exp,env) else
  396.     if careq(exp,p_begin) then eval:=eval_sequence(cdr(exp),env) else
  397.     if careq(exp,p_let) then eval:=eval_let(cdr(exp),env) else
  398.     if careq(exp,p_if) then eval:=eval_iff(cdr(exp),env) else
  399.     if careq(exp,p_or) then eval:=eval_or(cdr(exp),env) else
  400.     if careq(exp,p_and) then eval:=eval_and(cdr(exp),env) else
  401.     if careq(exp,p_delay) then eval:=make_delay(car(cdr(exp)),env) else
  402.     if careq(exp,p_lambda) then
  403.           eval:=make_procedure(p_procedure,exp,env) else
  404.     if careq(exp,p_mlambda) then
  405.           eval:=make_procedure(p_mprocedure,exp,env) else
  406.     if careq(exp,p_dlambda) then
  407.           eval:=make_procedure(p_dprocedure,exp,env) else
  408.     if careq(exp,p_cond) then eval:=eval_cond(cdr(exp),env) else
  409.     if exp^.typ=3 then begin
  410.       op:=eval(car(exp),env);
  411.       if mproc(op) then
  412.         eval:=apply(op,cdr(exp),env)
  413.       else if dproc(op) then
  414.            eval:=apply(op,list_of_values(dellist(cdr(exp)),env),env)
  415.       else eval:=apply(op,list_of_values(cdr(exp),env),env)
  416.      end else
  417.     error('Unknown Typ of expression -- EVAL');
  418.   end;
  419.