Artifact 22f6cc49440978d63b4ec743f06fb08671c8f45b8b94c7d8fab46de1241e8bb7:

• Executable file r37/lisp/csl/jlisp/Specfn.java — part of check-in [f2fda60abd] at 2011-09-02 18:13:33 on branch master — Some historical releases purely for archival purposes

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 12560) [annotate] [blame] [check-ins using] [more...]

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//



import java.io.*;
import java.math.*;
import java.util.*;
import java.text.*;

// Support for "special functions"

class Specfn
{

    static int        progEvent = 0;
    static LispObject progData  = null;

    static final int NONE   = 0;
    static final int GOTO   = 1;
    static final int RETURN = 2;


    Object [][] specials = 
    {
        {"cond",     new CondSpecial()},
        {"quote",    new QuoteSpecial()},
        {"function", new FunctionSpecial()},
        {"lambda",   new LambdaSpecial()},
        {"defun",    new DefunSpecial()},
        {"de",       new DefunSpecial()},
        {"dm",       new DmSpecial()},
        {"go",       new GoSpecial()},
        {"setq",     new SetqSpecial()},
        {"if",       new IfSpecial()},
        {"when",     new WhenSpecial()},
        {"unless",   new UnlessSpecial()},
        {"block",    new BlockSpecial()},
        {"~let",     new LetSpecial()},
        {"let*",     new LetStarSpecial()},
        {"prog",     new ProgSpecial()},
        {"and",      new AndSpecial()},
        {"or",       new OrSpecial()},
        {"plus",     new PlusSpecial()},
        {"times",    new TimesSpecial()},
        {"list",     new ListSpecial()},
        {"list*",    new ListStarSpecial()},
    };



// (quote xx) evaluates to just xx

class QuoteSpecial extends SpecialFunction
{
    LispObject op(LispObject args)
    {
        if (args.atom) return Jlisp.nil;
        else return args.car;
    }
}

// in an ideal world (function xxx) would create a closure.
// however my Lisp implementation is shallow-bound and so this is
// not a (convenient) option. I therefore make it a synonym for
// quote.

class FunctionSpecial extends SpecialFunction
{
    LispObject op(LispObject args)
    {
        if (args.atom) return Jlisp.nil;
        else return args.car;
    }
}

// (lambda (x) A B C) evaluates to itself, as a minor convenience

class LambdaSpecial extends SpecialFunction
{
    LispObject op(LispObject args)
    {
        return new Cons(Jlisp.lit[Lit.lambda], args);
    }
}

// (cond (p1 e1)        if p1 then e1
//       (p2 e2)        else if p2 then e2
//       (p3 e3) )      else if p3 then e3
//                      else nil

class CondSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {   while (!args.atom)
        {   LispObject a = args;  // ((p1 e1) ...) 
            LispObject x = a.car; // (p1 e1)
            args = a.cdr;
            if (x.atom) continue;
            LispObject predicate = x.car;   // p1
            LispObject consequent = x.cdr;  // (e1)
            predicate = predicate.eval();
            if (progEvent != NONE) return Jlisp.nil;
            if (predicate != Jlisp.nil)
            {   LispObject r = Jlisp.nil;
                while (!consequent.atom)
                {   LispObject cc = consequent;
                    r = cc.car.eval();
                    if (progEvent != NONE) return Jlisp.nil;
                    consequent = cc.cdr;
                }
                return r;
            }
        }
        return Jlisp.nil;
    }
}

class IfSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return Jlisp.nil;
        LispObject c1 = args;     // car is the predicate
        if (c1.cdr.atom)
        {   c1.car.eval();        // degenerate case (IF p)
            return Jlisp.nil;
        }
        LispObject c2 = c1.cdr; // car is the consequent
        c1 = c1.car.eval();
        if (progEvent != NONE) return Jlisp.nil;
        if (c1 != Jlisp.nil) return c2.car.eval();
        args = c2.cdr;
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   c2 = args;
            r = c2.car.eval();
            if (progEvent != NONE) return Jlisp.nil;
            args = c2.cdr;
        }
        return r;
    }
}

class WhenSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return Jlisp.nil;
        LispObject c = args;
        if (c.car.eval() == Jlisp.nil) return Jlisp.nil;
        if (progEvent != NONE) return Jlisp.nil;
        args = c.cdr;
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   c = args;
            r = c.car.eval();
            if (progEvent != NONE) return Jlisp.nil;
            args = c.cdr;
        }
        return r;   
    }
}

class UnlessSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return Jlisp.nil;
        LispObject c = args;
        if (c.car.eval() != Jlisp.nil) return Jlisp.nil;
        if (progEvent != NONE) return Jlisp.nil;
        args = c.cdr;
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   c = args;
            r = c.car.eval();
            if (progEvent != NONE) return Jlisp.nil;
            args = c.cdr;
        }
        return r;   
    }
}

// (defun name (a1 a2 a3) body-of-function(with implied progn))

class DefunSpecial extends SpecialFunction
{
    LispObject op(LispObject a) throws Exception
    {
        if (a.atom) return Jlisp.nil;  // (de) with no args at all!
        Symbol name = (Symbol)(a.car);
        name.fn = new Interpreted(a.cdr);
        if (Jlisp.lit[Lit.starcomp].car/*value*/ != Jlisp.nil &&
            !(((Symbol)Jlisp.lit[Lit.compile]).fn instanceof Undefined))
        {   a = new Cons(name , Jlisp.nil);
            ((Symbol)Jlisp.lit[Lit.compile]).fn.op1(a);
        }
        return name;
    }
}

class DmSpecial extends SpecialFunction
{
    LispObject op(LispObject a) throws Exception
    {
        if (a.atom) return Jlisp.nil;
        Symbol name = (Symbol)a.car;
        name.fn = new Macro(a.cdr);
        if (Jlisp.lit[Lit.starcomp].car/*value*/ != Jlisp.nil &&
            !(((Symbol)Jlisp.lit[Lit.compile]).fn instanceof Undefined))
        {   a = new Cons(name , Jlisp.nil);
            ((Symbol)Jlisp.lit[Lit.compile]).fn.op1(a);
        }
        return name;
    }
}

class SetqSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        LispObject value = Jlisp.nil;
        Symbol name;
        while (!args.atom)
        {   name = (Symbol)args.car;
            args = args.cdr;
            if (!args.atom)
            {   value = args.car.eval();
                if (progEvent != NONE) return Jlisp.nil;
                args = args.cdr;
            }
            else value = Jlisp.nil;
            name.car/*value*/ = value;
        }
        return value;
    }
}

class BlockSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {    return error("BLOCK not implemented yet");
    }
}

class LetSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {    return error("LET not implemented yet");
    }
}

class LetStarSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {    return error("LET* not implemented yet");
    }
}


class GoSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {    
        if (args.atom) 
            return error("go called without an argument");
        progEvent = GOTO;
        progData = args.car;
        return Jlisp.nil;
    }
}

class ProgSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return Jlisp.nil; // (PROG)
        LispObject bvl = args.car;
        args = args.cdr;
        if (args.atom) return Jlisp.nil; // (PROG (v))
        int nvars = 0;
        LispObject bvlsave = bvl;
        while (!bvl.atom)
        {   LispObject w = bvl;
// I really want to check that all the items are symbols here because
// I want the code that saves away values to be guaranteed to succeed
// so that I can be certain not to leave a mess because of things crashing
// part way through
            if (!(w.car instanceof Symbol))
                return error("non-symbol in variable list for prog");
            bvl = w.cdr;
            nvars++;
        }
        LispObject [] save = new LispObject [nvars];
        bvl = bvlsave;
        for (int i=0; i<nvars; i++)
        {   LispObject w = bvl;
            Symbol name = (Symbol)(w.car);
            bvl = w.cdr;
            save[i] = name.car/*value*/;
            name.car/*value*/ = Jlisp.nil;
        }
        try
        {   LispObject pc = args;
            while (!pc.atom)
            {   LispObject s = pc.car;
                pc = pc.cdr;
                if (!s.atom)
                {   
                    s.eval();
                    switch (progEvent)
                    {
                case RETURN:
                        s = progData;
                        progEvent = NONE;
                        progData = Jlisp.nil;
                        return s;
                case GOTO:
                        pc = args;
                        while (!pc.atom)
                        {   if (pc.car == progData) break;
                            pc = pc.cdr;
                        }
                        progEvent = NONE;
                        progData = Jlisp.nil;
                        if (!pc.atom) pc = pc.cdr;
                        else return error("label not found in GO");
                        continue;
                default:
                        continue;
                    }
                }
            }
        }
        finally
        {   bvl = bvlsave;
// Here I restore variables in the same left to right order
// that I saved them. This causes a mess if a name is used
// twice in the list! But working backwards seems unnecessarily
// hard to do (without wasting too much time & space).
            for (int i=0; i<nvars; i++)
            {   LispObject w = bvl;
                Symbol name = (Symbol)(w.car);
                bvl = w.cdr;
                name.car/*value*/ = save[i];
            }
        }
// If the prog block terminates by dropping off the end I
// will give back the result NIL.
        return Jlisp.nil;
    }
}

class AndSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        LispObject r = Jlisp.lispTrue;
        while (!args.atom)
        {   r = args.car.eval();
            if (progEvent != NONE || r == Jlisp.nil) break;
            args = args.cdr;
        }
        return r;
    }
}

class OrSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   r = args.car.eval();
            if (progEvent != NONE || r != Jlisp.nil) break;
            args = args.cdr;
        }
        return r;
    }
}

class PlusSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return LispInteger.valueOf(0);
        LispObject r = args.car.eval();
        args = args.cdr;
        while (!args.atom)
        {   r = r.add(args.car.eval());
            args = args.cdr;
        }
        return r;
    }
}

class TimesSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return LispInteger.valueOf(1);
        LispObject r = args.car.eval();
        args = args.cdr;
        while (!args.atom)
        {   r = r.multiply(args.car.eval());
            args = args.cdr;
        }
        return r;
    }
}

class ListSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   r = new Cons(args.car.eval(), r);
            args = args.cdr;
        }
        args = Jlisp.nil;
        while (!r.atom)
        {   LispObject w = r;
            r = r.cdr;
            w.cdr = args;
            args = w;
        }
        return args;
    }
}

class ListStarSpecial extends SpecialFunction
{
    LispObject op(LispObject args) throws Exception
    {
        if (args.atom) return error("list* with no args");
        LispObject r = Jlisp.nil;
        while (!args.atom)
        {   r = new Cons(args.car.eval(), r);
            args = args.cdr;
        }
        args = r.car;
        r = r.cdr;
        while (!r.atom)
        {   LispObject w = r;
            r = r.cdr;
            w.cdr = args;
            args = w;
        }
        return args;
    }
}

}

// End of Specfn.java