Procedure


1   package scm;
2   
3                                   // This is the (usual) compound procedure
4                                   // object
5   /**
6    * This is a container class that is overidden
7    * by primitives. It can be generated through
8    * @see jas.Lambda procedures.
9    */
10  
11  class Procedure implements Obj
12  {
13    Cell body;                    // the seq of expressions constituting
14                                  // the body of the procedure
15    Cell formals;                 // the arglist expected by the procedure
16    Env procenv;                  // env in which the proc was created
17  
18  
19    Env extendargs(Cell args, Env f)
20      throws Exception  
21    {
22      Cell params = null;
23      Cell tail = null;
24      while (args != null)
25        {
26          Obj now = args.car;
27          if (now != null) 
28            { now = now.eval(f); } // eval args in context of old expression
29          if (tail != null)
30            {
31              tail.cdr = new Cell(now, null);
32              tail = tail.cdr;
33            }
34          else
35            {
36              params = new Cell(now, params);
37              tail = params;
38            }
39          args = args.cdr;
40        }
41                                  // make new frame, with appropriate
42                                  // bindings. The enclosing frame
43                                  // is the env in which the procedure
44                                  // was created.
45      return (procenv.extendenv(formals, params));
46    }
47  
48    Obj apply(Cell args, Env f)
49      throws Exception  
50    {
51      Env newEnv = extendargs(args, f);
52      Cell expr = body;
53      Obj ret = null;
54                                  // eval body with new bindings
55      while (expr != null)
56        {
57          ret = expr.car;
58          if (ret != null)
59            { ret = ret.eval(newEnv); }
60          expr =  expr.cdr;
61        }
62      return (ret);
63    }
64    public Obj eval(Env e)
65    { throw new SchemeError("Cant eval procedures directly"); }
66  
67    public String   toString()
68    {
69      return ("<lambda generated> " + body);
70    }
71  }
72  
73                                  // do a few primitives here
74  /**
75   * Add two integers
76   * <code> (+ int1 int2) </code>
77   */
78  
79  class Plus extends Procedure implements Obj
80  {
81    Obj apply(Cell args, Env f)
82      throws Exception  
83    {
84      Obj l1 = args.car.eval(f);
85      Obj l2 = args.cdr.car.eval(f);
86  
87      return (new Selfrep(((Selfrep)l1).num + ((Selfrep)l2).num));
88    }
89    public String   toString()
90    {
91      return ("<#plus#>");
92    }
93  }
94  /**
95   * Subtract integers
96   * <code>(- int1 int2)
97   */
98  
99  class Minus extends Procedure implements Obj
100 {
101   Obj apply(Cell args, Env f)
102     throws Exception  
103   {
104     Obj l1 = args.car.eval(f);
105     Obj l2 = args.cdr.car.eval(f);
106 
107     return (new Selfrep(((Selfrep)l1).num - ((Selfrep)l2).num));
108   }
109   public String   toString()
110   {
111     return ("<#minus#>");
112   }
113 }
114 /**
115  * Multiply integers
116  * <code> (* int1 int2) </code>
117  */
118 
119 class Mult extends Procedure implements Obj
120 {
121   Obj apply(Cell args, Env f)
122     throws Exception  
123   {
124     Obj l1 = args.car.eval(f);
125     Obj l2 = args.cdr.car.eval(f);
126 
127     return (new Selfrep(((Selfrep)l1).num * ((Selfrep)l2).num));
128   }
129   public String   toString()
130   {
131     return ("<#mult#>");
132   }
133 }
134 
135 /**
136  * divide integers
137  * <code> (/ int1 int2) </code>
138  */
139 
140 class Div extends Procedure implements Obj
141 {
142   Obj apply(Cell args, Env f)
143     throws Exception  
144   {
145     Obj l1 = args.car.eval(f);
146     Obj l2 = args.cdr.car.eval(f);
147 
148     return (new Selfrep(((Selfrep)l1).num / ((Selfrep)l2).num));
149   }
150   public String   toString()
151   {
152     return ("<#div#>");
153   }
154 }
155 /**
156  * Bitwise or of integers
157  * <code> (| int1 int2) </code>
158  */
159 
160 class Or extends Procedure implements Obj
161 {
162   Obj apply(Cell args, Env f)
163     throws Exception  
164   {
165     Obj l1 = args.car.eval(f);
166     Obj l2 = args.cdr.car.eval(f);
167 
168     return (new Selfrep
169             ((int)(Math.round(((Selfrep)l1).num)) |
170              (int)(Math.round(((Selfrep)l2).num))));
171   }
172   public String   toString()
173   {
174     return ("<#or#>");
175   }
176 }
177 
178 /**
179  * Yup. just as it says.
180  * <code> (car (quote (a b)))
181  * => a
182  * </code>
183  */
184 
185 class Car extends Procedure implements Obj
186 {
187   Obj apply(Cell args, Env f)
188     throws Exception  
189   {
190     Cell tmp = (Cell) args.car.eval(f);
191     return (tmp.car);
192   }
193   public String   toString()
194   { return ("<#car#>"); }
195 }
196 
197 /**
198  * More lispisms.
199  * <code> (cdr (quote (a b)))
200  * => (b)
201  * </code>
202  */
203 
204 class Cdr extends Procedure implements Obj
205 {
206   Obj apply(Cell args, Env f)
207     throws Exception  
208   {
209     Cell tmp = (Cell) args.car.eval(f);
210     return (tmp.cdr);
211   }
212   public String   toString()
213   { return ("<#cdr#>"); }
214 }
215 
216 /**
217  * Generate new list
218  * <code> (cons (quote a) (quote (b c))) => (a b c) </code>
219  */
220 
221  
222 class Cons extends Procedure implements Obj
223 {
224   Obj apply(Cell args, Env f)
225     throws Exception  
226   {
227     Obj ncar = args.car.eval(f);
228     Obj ncdr = args.cdr.car.eval(f);
229     return (new Cell(ncar, (Cell) ncdr));
230   }
231   public String   toString()
232   { return ("<#cons#>"); }
233 }
234 
235 /**
236  * Prevent from evaluation.
237  * <code> (quote a) => a </code>
238  */
239 
240 class Quote extends Procedure implements Obj
241 {
242   Obj apply(Cell args, Env f)
243     throws Exception  
244   {
245     if (args == null)
246       { throw new SchemeError("null args to Quote"); }
247     return args.car;
248   }
249   public String   toString()
250   { return ("<#Quote#>"); }
251 }
252 
253 /**
254  * bind a value to a symbol.<p>
255  *
256  * <code> (define some-new-symbol "some thing") => "some thing"</code><br>
257  * <code> some-new-symbol => "some thing" </code>
258  */
259 
260 class Define extends Procedure implements Obj
261 {
262   Obj apply(Cell args, Env f)
263     throws Exception  
264   {
265     Symbol v;                   // (symbol value)
266     if (args == null)
267       { throw new SchemeError("null args to define"); }
268     if (args.car instanceof Symbol)
269       { v = (Symbol) args.car; }
270     else
271       { throw new SchemeError("bad argtype to define" + args.car); }
272 
273     if (v == null)
274       { throw new SchemeError("null symbol value"); }
275 
276     Cell val =  args.cdr;
277     if (val == null)
278       { throw new SchemeError("not enough args to define"); }
279     Obj ret = val.car;
280     if (ret != null) 
281       { ret = ret.eval(f); }
282     f.definevar(v, ret);
283     return ret;
284   }
285   public String   toString()
286   { return ("<#define#>"); }
287 }
288 /**
289  * reset a value to a symbol.<p>
290  *
291  * <code> (set! some-old-symbol "xyz")
292  */
293 
294 class Setvar extends Procedure implements Obj
295 {
296   Obj apply(Cell args, Env f)
297     throws Exception  
298   {
299     Symbol v;                   // (symbol value)
300     if (args == null)
301       { throw new SchemeError("null args to define"); }
302     if (args.car instanceof Symbol)
303       { v = (Symbol) args.car; }
304     else
305       { throw new SchemeError("bad argtype to set!" + args.car); }
306 
307     if (v == null)
308       { throw new SchemeError("null symbol value"); }
309 
310     Cell val =  args.cdr;
311     if (val == null)
312       { throw new SchemeError("not enough args to set!"); }
313     Obj ret = val.car;
314     if (ret != null) 
315       { ret = ret.eval(f); }
316     f.setvar(v, ret);
317     return ret;
318   }
319   public String   toString()
320   { return ("<#set!#>"); }
321 }
322 
323 /**
324  * (cond (condition body) (condition body)...)
325  */
326 
327 class Cond extends Procedure implements Obj
328 {
329   Obj apply(Cell args, Env f)
330     throws Exception  
331   {
332     Cell t = args;
333 
334     while (t != null)
335       {
336                                 // examine condition part
337         if (t.car == null)
338           { throw new SchemeError("null clause for cond"); }
339         Obj clause = t.car;
340         if (!(clause instanceof Cell))
341           { throw new SchemeError("need a condition body for cond clause"); }
342         Obj result = (((Cell)clause).car);
343         if (result != null) { result = result.eval(f); }
344         if (result == null)
345           { t = t.cdr; continue; }
346                                 // Got a non nill, so do body and
347                                 // return.
348         Obj body = (((Cell)clause).cdr).car;
349         return (body.eval(f));
350       }
351     return null;
352   }
353   public String   toString()
354   { return ("<#cond#>"); }
355 }
356 
357 /**
358  * (num? thing)
359  */
360 
361 class NumP extends Procedure implements Obj
362 {
363   Obj apply(Cell args, Env f)
364     throws Exception  
365   {
366     if (args == null) return null;
367 
368     Obj target = args.car;
369     if (target != null) target = target.eval(f);
370     if (target == null) return null;
371     if ((target instanceof Selfrep) &&
372         (((Selfrep)target).val == null))
373       return target;
374     return null;
375   }
376   public String   toString()
377   { return ("<#num?#>"); }
378 }
379 /**
380  * <
381  */
382 
383 class LessP extends Procedure implements Obj
384 {
385   Obj apply(Cell args, Env f)
386     throws Exception  
387   {
388     if (args == null)
389       { throw new SchemeError("< expects a pair of arguments"); }
390 
391     Obj target1 = args.car;
392     if (target1 != null) target1 = target1.eval(f);
393     args = args.cdr;
394     Obj target2 = args.car;
395     if (target2 != null) target2 = target2.eval(f);
396 
397     if ((target1 == null) ||
398         (target2 == null))
399       { throw new SchemeError("< expects a pair of arguments"); }
400     if (!(target1 instanceof Selfrep) ||
401         !(target2 instanceof Selfrep))
402       { throw new SchemeError("< expects a pair of numbers as args"); }
403     if ((((Selfrep)target1).num) < (((Selfrep)target2).num))
404       { return target1; }
405     return null;
406   }
407   public String   toString()
408   { return ("<#<#>"); }
409 }
410 /**
411  * >
412  */
413 
414 class MoreP extends Procedure implements Obj
415 {
416   Obj apply(Cell args, Env f)
417     throws Exception  
418   {
419     if (args == null)
420       { throw new SchemeError("> expects a pair of arguments"); }
421 
422     Obj target1 = args.car;
423     if (target1 != null) target1 = target1.eval(f);
424     args = args.cdr;
425     Obj target2 = args.car;
426     if (target2 != null) target2 = target2.eval(f);
427 
428     if ((target1 == null) ||
429         (target2 == null))
430       { throw new SchemeError("> expects a pair of arguments"); }
431     if (!(target1 instanceof Selfrep) ||
432         !(target2 instanceof Selfrep))
433       { throw new SchemeError("> expects a pair of numbers as args"); }
434     if ((((Selfrep)target1).num) > (((Selfrep)target2).num))
435       { return target1; }
436     return null;
437   }
438   public String   toString()
439   { return ("<#>#>"); }
440 }
441 /**
442  * (eq? obj1 obj2)
443  */
444 
445 class EqP extends Procedure implements Obj
446 {
447   Obj apply(Cell args, Env f)
448     throws Exception  
449   {
450     if (args == null) return null;
451 
452     Obj target1 = args.car;
453     if (target1 != null) target1 = target1.eval(f);
454     args = args.cdr;
455     Obj target2 = args.car;
456     if (target2 != null) target2 = target2.eval(f);
457 
458     if ((target1 == null) &&
459         (target2 == null)) return (new Selfrep(1));
460     if ((target1 == null) ||
461         (target2 == null))
462       { return null; }
463     
464     if (target1 == target2)
465       {
466         return (target1);
467       }
468         
469     if ((target1 instanceof Selfrep) &&
470         (target2 instanceof Selfrep))
471       {
472         if ((((Selfrep)target1).val) == null)
473           {
474             if ((((Selfrep)target1).num) == (((Selfrep)target2).num))
475               { return new Selfrep(1); }
476           }
477         else
478           {
479             if ((((Selfrep)target1).val).equals((((Selfrep)target2).val)))
480               { return new Selfrep(1); }
481           }            
482       }
483     return null;
484   }
485   public String   toString()
486   { return ("<#eq?#>"); }
487 }
488 
489 /**
490  * (string? thing)
491  */
492 
493 class StringP extends Procedure implements Obj
494 {
495   Obj apply(Cell args, Env f)
496     throws Exception  
497   {
498     if (args == null) return null;
499 
500     Obj target = args.car;
501     if (target != null) target = target.eval(f);
502     if (target == null) return null;
503     if ((target instanceof Selfrep) &&
504         (((Selfrep)target).val != null))
505       return target;
506     return null;
507   }
508   public String   toString()
509   { return ("<#string?#>"); }
510 }
511 
512 /**
513  * (progn body1 body2 ...)
514  */
515 
516 class Progn extends Procedure implements Obj
517 {
518   Obj apply(Cell args, Env f)
519     throws Exception  
520   {
521     Cell t = args;
522     Obj result = null;
523     while (t != null)
524       {
525         if (t.car == null)
526           {
527             result = null;
528           }
529         else
530           {
531             result = t.car.eval(f);
532           }
533         t = t.cdr;
534       }
535     return result;
536   }
537   public String   toString()
538   { return ("<#progn#>"); }
539 }
540 
541 /**
542  * (mapcar function (args1 args2 ...))
543  */
544 
545 class Mapcar extends Procedure implements Obj
546 {
547   Obj apply(Cell args, Env f)
548     throws Exception  
549   {
550     Obj ftmp = args.car;
551     if (ftmp != null) ftmp = ftmp.eval(f);
552     if (ftmp == null)
553       { throw new SchemeError("null function for mapcar"); }
554     if (!(ftmp instanceof Procedure))
555       { throw new SchemeError("expected a procedure for mapcar"); }
556     Procedure fn = (Procedure) ftmp;
557 
558     Cell t = (Cell)((args.cdr.car).eval(f));
559     Cell res = null;
560     Cell tail = null;
561     while (t != null)
562       {
563         if (tail == null)
564           { 
565             res =
566               new Cell
567               (fn.apply
568                (new Cell((t.car), null), f),
569               null);
570             tail = res;
571           }
572         else
573           {
574             tail.cdr =
575               new Cell
576               (fn.apply
577                (new Cell((t.car), null), f),
578                null);
579           }
580         t = t.cdr;
581       }
582     return res;
583   }
584 }
585
A to Z: JavaDoc & Examples Daily Java News & Articles Open Source Projects Open Source Codes Free Computer Books Remove Frame
Popular Tags