------------------------------------------------------------------------------
MC logo
Callable Objects
[^] Tom's Lisp Code
------------------------------------------------------------------------------
[Classes for Lisp Atoms] [Functions for Lisp Built-Ins] [Classes for Closures] [Context] [Base For Evaluable Objects] [Callable Objects] [Interrupt Utility] [Main Program] [Pairs] [Code Reader] [Reference Counting]
func.h [Download]
//*****************************************************************************
//***  Applyable objects.
//*** 
//***    These are objects which can be functions: they have an apply method,
//***    which evaluates them with a parameter list in some context.  The base
//***    class Applyable is here, and derived classes Builtin and Error.  The
//***    closures are also Applyable, but they have their own file.
//*****************************************************************************

#include <iostream>
#include <string>

using namespace std;

#include "refct.h"
#include "context.h"
#include "evaluable.h"
#include "atoms.h"

#ifndef _func_h_
#define _func_h_

/* These are objects which apply (with a parameter list and context) work. */
class Applyable: public Evaluable {
public:
        virtual bool applyable() { return true; }
        virtual Ptr<Evaluable> apply(Ptr<Evaluable>, Ptr<Context>) = 0;

        // Evaluates to itself.
        Ptr<Evaluable> eval(Ptr<Context> c) { 
                return newref();
        }
};

/* Evaluate the members of list and return the new list.  If anything in the
   list fails, it return the error generated by the first such. */
Ptr<Evaluable> evalall(Ptr<Evaluable> lst, Ptr<Context> c);

// This denotes a builtin functions.  It has no string representation 
// which is recognized on input, though all the ones we create are bound
// to names in the base context.
class Builtin: public Applyable {
protected:
        // This is a C++ function which actually performs the operation.
        // The declaration denotes a pointer to a function which returns a 
        // Ptr<Evaluable> and takes a Ptr<Evaluable> and a Ptr<Context>.
        // The first is an argument list, and the second is the context
        // in which the function is to be evaluated.
        Ptr<Evaluable> (*func)(Ptr<Evaluable>, Ptr<Context>);

        // The name is here only to make nice messages.  The inerpreter 
        // itself doesn't care.
        string _name;

        // Tell it should evaluate parameters first (normal function behavior),
        // or not (macro behavior).
        bool preval;

        // Signature for type check on apply.
        const char * signature;

        // Construction.  Takes the name of the C++ implementation function
        // the name, a string denoting the correct signature (see sigchk),
        // and the evaluate-arguments boolean.  These are stored.
        Builtin(Ptr<Evaluable> (*r)(Ptr<Evaluable>, Ptr<Context>),
                string n, const char * sig, bool p): 
                func(r), _name(n), preval(p), signature(sig) { }

        // Check an argument list against a signature specification, sig.
        // Return nil or an error.  See function itself in .cpp file for notes
        // on the interpretation of sig.
        Ptr<Evaluable> sigchk(Ptr<Evaluable> list, const char *sig, 
                              const char **term = 0);
        Ptr<Evaluable> sigchk(Ptr<Evaluable> list, const char **term = 0) { 
                return sigchk(list, signature, term);
        }
public:
        // Allocator.  Looks complicated, but it just takes all the parms
        // and sends them to the constructor, which just stores them
        // in the object.
        static Ptr<Builtin> alloc(Ptr<Evaluable> 
                                  (*r)(Ptr<Evaluable>,Ptr<Context>), 
                                  string n, const char * sig, bool p = true){
                return RefCtObj::newRefPtr(new Builtin(r, n, sig, p));
        }

        // Apply the args to the function.
        Ptr<Evaluable> apply(Ptr<Evaluable> p, Ptr<Context> c);

        // Tell if the parms are evaluated before running.
        bool function_like() { return preval; }
        bool macro_like() { return !preval; }

        // These are needed, but they don't  do much.
        virtual void print(ostream &s) { s << _name; }
        virtual string name() { return string("Builtin ") + _name; }

        // This seems pointless too, but needed for completeness.
        virtual bool equal_same(RefCtObj& other) { 
                return _name == ((Builtin*)&other)->_name && 
                        func == ((Builtin*)&other)->func;
        }
};

/* The catch function requires special behavior because it actually 
   consumes an error argument.  Otherwise, it acts like a Builtin with
   bi_begin loaded as the operator function. */
class Catch: public Builtin {
        // Construction.  We're not generalized, so we don't take much
        // from the client.
        Catch();
public:
        // Again, how we allocate.
        static Ptr<Catch> alloc() {
                return RefCtObj::newRefPtr(new Catch());
        }

        // Apply for catch.  Uses the base class to do an ordinary evalution
        // using begin semantics.  If that returns a non-error, we return
        // (#t . the-non-error-value).  If it goes boom, we build our
        // return value as (nil . ( error-code . error-message))
        Ptr<Evaluable> apply(Ptr<Evaluable> p, Ptr<Context> c);
};

#endif
func.cpp [Download]
#include "pair.h"
#include "interrupt.h"
#include "func.h"
#include "builtin.h"

/* Evaluate the members of list and return the new list.  If anything in the
   list fails, it return the error generated by the first such. */
Ptr<Evaluable> evalall(Ptr<Evaluable> lst, Ptr<Context> c) 
{
        // Test for empty.
        if(lst.points_to(typeid(Pair))) {
                // Not empty.

                // Evaluate the head of the list.  If bad, bug out.
                Ptr<Evaluable> ceval = lst->car()->eval(c);
                if(ceval.points_to(typeid(Error))) return ceval;

                // Recursively evaluate the tail of the list.  Pass up
                // an error if one occurs.
                Ptr<Context> recur = evalall(lst->cdr(), c);
                if(recur.points_to(typeid(Error))) return recur;

                // Construct the list of the evaluated head and tail.
                return Pair::alloc(ceval, recur);
        } else
                // Empty.

                // Evaluate the last thing, which is most likely Nil and
                // evaluates to itself.
                return lst->eval(c);
}

// Apply the function to the argument list in the indicated context.
Ptr<Evaluable> Builtin::apply(Ptr<Evaluable> p, Ptr<Context> c)
{ 
        // Check for an interrupt.
        if(zapped()) return Error::alloc(INTER, "Interrupted.", p);

        // Perform argument evaluation if required.
        if(function_like()) {
                // Evaluate the arg list, pass up an error if one
                // appears.  Add the list of parms to the history of 
                // the error.
                Ptr<Evaluable> ep = evalall(p, c);
                if(ep.points_to(typeid(Error))) 
                        return Ptr<Error>(ep)->hist(p);
                p = ep;
        }

        // Check that it was called correctly.
        Ptr<Evaluable> e = sigchk(p);
        if(e.points_to(typeid(Error)))
                return Ptr<Error>(e)->hist(p);

        // Okay.  NOW we can run the function.
        Ptr<Evaluable> ret = func(p, c); 
        if(ret.points_to(typeid(Error)))
                Ptr<Error>(ret)->hist(p);
        return ret;
}

Catch::Catch(): Builtin(bi_begin, "catch", "+", false) { }

// Apply for catch.  Uses the base class to do an ordinary evalution
// using begin semantics.  If that returns a non-error, we return
// (#t . the-non-error-value).  If it goes boom, we build our
// return value as (nil . ( error-code . error-message))
Ptr<Evaluable> Catch::apply(Ptr<Evaluable> p, Ptr<Context> c) 
{
        // Perform an ordinary begin evaluation.
        Ptr<Evaluable> res = Builtin::apply(p, c);

        // Boom?
        if(res.points_to(typeid(Error)))
                // If it went boom, return a description of the
                // error.
                return Pair::alloc
                        (the_nil, 
                         Pair::alloc(Int::alloc(Ptr<Error>(res)->code()),
                                     Str::alloc(Ptr<Error>(res)->msg())));
        else
                // If completed w/o error, return a pair to indicate
                // that, and the value produced.
                return Pair::alloc(the_true, res);
}


// Argument signature checker.  Check the argument list against a signature
// specification and return nil or an error.  Signature expressions use single
// letters for types:
//    .   No restriction
//    l   List:  Pair or Nil
//    p   Pair
//    i   Int
//    s   Str
//    n   Id (name)
//    F   Mean a lambda or macro parameter argument.  Either a 
//        single identifier, or a list of identifiers.
//    +   Means zero or more.  + followed by one of the above means
//        all of them must have that type.
//    ()  Parenthesised subexpressions match lists with the form of
//        their contents.
// The signature which is checked defaults to the one for this
// object, but can be sent.  The term parameter is used to return
// the scan location after recursive calls, which are made to 
// process sublist specs in ()s.  It may be sent at NULL (the
// default) if this return is not desired, and valid data is
// returned only when the main return value is not an Error.  Since
// format strings are not input data, their form is not checked
// carefully.
//
// The term, if specified, returns the location in the sig at the
// end of the check, if the caller wishes that reported.  The
// sig is sent when the stored one is not desired, and it is used
// only for sigchk's own recursive calls.
Ptr<Evaluable> Builtin::sigchk(Ptr<Evaluable> e, const char *sig, 
                               const char **term)
{
        // Scan the list.
        while(1) {
                // End of list.  Either we're done, or the list was short.
                if(e.points_to(typeid(Nil)))
                        if(*sig == '\0' || *sig == ')' || *sig == '+')
                                break;
                        else
                                return Error::alloc(SHORTARG, _name + 
                                                    ": Missing argument.");

                // Not end of list, rest must be properly formed.
                if(!e.points_to(typeid(Pair)))
                        return Error::alloc(BADARG, _name + ": Bad arg list.");

                // Since we're not out of parms, the spec must allow it.
                if(*sig == '\0' || *sig ==')')
                        return Error::alloc(LONGARG, 
                                            _name + ": Too many arguments.");

                // Get the character which specifies the check for this arg,
                // and advance the sig scanner.
                char curspec;
                if(*sig == '+')
                        if(sig[1])
                                curspec = sig[1];
                        else
                                curspec = '.';
                else
                        curspec = *sig++;

                // Isolate first arg and move the list pointer down.
                Ptr<Evaluable> arg = e->car();
                e = e->cdr();

                // If the parameter is an error, that is the result of
                // the operation.
                if(arg.points_to(typeid(Error))) return arg;

                // Check type as appropriate.
                switch(curspec)
                {
                case '.':
                        // No restriction.
                        break;
                case 'l':
                        // A pair or nil (list).
                        if(!arg.points_to(typeid(Pair)) &&
                           !arg.points_to(typeid(Nil)))
                                return Error::alloc(BADTYPE,
                                                    _name + ": Bad arg type.");
                        break;
                case 'p':
                        // A pair strictly.
                        if(!arg.points_to(typeid(Pair)))
                                return Error::alloc(BADTYPE, 
                                                    _name + ": Bad arg type.");
                        break;
                case 'i':
                        // Must be integer.
                        if(!arg.points_to(typeid(Int)))
                                return Error::alloc(BADTYPE, 
                                                    _name + ": Bad arg type.");
                        break;
                case 's':
                        // Must be string.
                        if(!arg.points_to(typeid(Str)))
                                return Error::alloc(BADTYPE, 
                                                    _name + ": Bad arg type.");
                        break;
                case 'n':
                        // Must be id (name).
                        if(!arg.points_to(typeid(Id)))
                                return Error::alloc(BADTYPE, 
                                                    _name + ": Bad arg type.");
                        break;
                case 'F':
                        // Either a single id or a lists of id's.  Needed 
                        // for lambda and macro.
                        if(!arg.points_to(typeid(Nil)) && 
                           !arg.points_to(typeid(Id))) {
                                // If it's not a single ID or an empty list,
                                // then it must be a non-empty list...
                                if(!arg.points_to(typeid(Pair)))
                                        return Error::alloc(BADTYPE, _name + 
                                                            ": Bad arg type.");

                                // ... and must consist only of names.
                                Ptr<Evaluable> ilist = sigchk(arg, "+n");
                                if(ilist.points_to(typeid(Error)))
                                        return ilist;
                        }
                        break;
                case '(':
                        // Sublist.
                        Ptr<Evaluable> slc = sigchk(arg, sig, &sig);
                        if(slc.points_to(typeid(Error))) return slc;
                        break;
                otherwise:
                        cerr << "Internal error: Illegal signature " <<
                                "string character." << endl;
                        exit(3);
                }
        }

        // Normal return.
        if(term) {
                // Need to clear to proper place.
                while(*sig && *sig != ')') ++sig;
                if(*sig) ++ sig;
                *term = sig;
        }
        return the_nil;
}

// Pair printing function.
void Pair::print(ostream &s, bool listmode)
{
        if(!listmode) s << '(';
        if(car().isnull()) s << "[null]";
        else car()->print(s);
        if(cdr().isnull()) s << " . [null]";
        else {
                // Print the cdr in some form.
                if(cdr().points_to(typeid(Pair))) {
                        s << " ";
                        (Ptr<Pair>(cdr()))->print(s, true);
                }
                else if(!cdr().points_to(typeid(Nil))) {
                        s << " . ";
                        cdr()->print(s);
                }

        }
        if(!listmode) s << ')';
}