// ---------------------------------------------------------------------------
// - Closure.hpp -
// - afnix engine - closure class implementation -
// ---------------------------------------------------------------------------
// - This program is free software; you can redistribute it and/or modify -
// - it provided that this copyright notice is kept intact. -
// - -
// - This program is distributed in the hope that it will be useful, but -
// - without any warranty; without even the implied warranty of -
// - merchantability or fitness for a particular purpose. In no event shall -
// - the copyright holder be liable for any direct, indirect, incidental or -
// - special damages arising in any way out of the use of this software. -
// ---------------------------------------------------------------------------
// - copyright (c) 1999-2007 amaury darsch -
// ---------------------------------------------------------------------------
#include "Cons.hpp"
#include "Stack.hpp"
#include "Vector.hpp"
#include "Return.hpp"
#include "Boolean.hpp"
#include "Lexical.hpp"
#include "Closure.hpp"
#include "Runnable.hpp"
#include "Reserved.hpp"
#include "Argument.hpp"
#include "QuarkZone.hpp"
#include "Exception.hpp"
namespace afnix {
// -------------------------------------------------------------------------
// - private section -
// -------------------------------------------------------------------------
// the quark zone
static const long QUARK_ZONE_LENGTH = 1;
static QuarkZone zone (QUARK_ZONE_LENGTH);
// the object supported quarks
static const long QUARK_SELF = zone.intern ("self");
// -------------------------------------------------------------------------
// - class section -
// -------------------------------------------------------------------------
// the object eval quarks
static const long QUARK_ARGS = String::intern ("args");
static const long QUARK_CONST = String::intern ("const");
// create a default closure
Closure::Closure (void) {
d_lflag = true;
d_argc = 0;
d_args = false;
p_form = nilp;
Object::iref (p_lset = new Localset);
// add the self closure
addarg (QUARK_SELF, true);
}
// create a default closure with a type
Closure::Closure (const bool type) {
d_lflag = type;
d_argc = 0;
d_args = false;
p_form = nilp;
Object::iref (p_lset = new Localset);
// add the self closure
addarg (QUARK_SELF, true);
}
// create a new closure
Closure::Closure (const bool type, Cons* argl, Object* form) {
// save the arguments
d_lflag = type;
d_argc = 0;
d_args = false;
Object::iref (p_form = form);
Object::iref (p_lset = new Localset);
// add the self closure
addarg (QUARK_SELF, true);
// add the arguments
try {
while (argl != nilp) {
addarg (argl->getcar ());
argl = argl->getcdr ();
}
} catch (...) {
Object::dref (p_lset);
throw;
}
}
// destroy this closure
Closure::~Closure (void) {
// reset before removal
if (p_lset != nilp) p_lset->reset ();
// destroy object
Object::dref (p_form);
Object::dref (p_lset);
}
// return the class name
String Closure::repr (void) const {
return "Closure";
}
// make this closure a shared object
void Closure::mksho (void) {
if (p_shared != nilp) return;
Object::mksho ();
if (p_lset != nilp) p_lset->mksho ();
if (p_form != nilp) p_form->mksho ();
}
// add an argument by name to this closure
void Closure::addarg (const long quark, const bool flag) {
wrlock ();
try {
// check if the argument already exists
if (p_lset->exists (quark) == true) {
throw Exception ("argument-error", "duplicate argument name",
String::qmap (quark));
}
// check if the args flag is set
if (d_args == true) {
throw Exception ("argument-error", "cannot add arguments after args");
}
// check if we set the args flag
if (quark == QUARK_ARGS) {
if (d_args == true) {
throw Exception ("argument-error", "cannot add multiple args",
String::qmap (quark));
}
d_args = true;
}
// create a new argument and bind it
Argument* arg = new Argument (quark, d_argc++);
arg->setconst (flag);
p_lset->bind (quark, arg);
unlock ();
} catch (...) {
unlock ();
throw;
}
}
// add an argument by object - we can either add a lexical name, a
// form with a const flag or a string
void Closure::addarg (Object* object) {
wrlock ();
try {
String* sobj = dynamic_cast <String*> (object);
if (sobj != nilp) {
addarg (sobj->toquark (), false);
unlock ();
return;
}
Lexical* lex = dynamic_cast <Lexical*> (object);
if (lex != nilp) {
addarg (lex->toquark (), false);
unlock ();
return;
}
Cons* form = dynamic_cast <Cons*> (object);
if (form != nilp) {
if (form->length () != 2) {
throw Exception ("argument-error", "invalid argument list form");
}
Reserved* crsv = dynamic_cast <Reserved*> (form->getcar ());
Lexical* alex = dynamic_cast <Lexical*> (form->getcadr ());
if ((crsv == nilp) || (alex == nilp)) {
throw Exception ("argument-error", "invalid argument list form");
}
if (crsv->toquark () != QUARK_CONST) {
throw Exception ("argument-error", "invalid argument list form");
}
addarg (alex->toquark (), true);
unlock ();
return;
}
throw Exception ("argument-error", "invalid argument list form");
} catch (...) {
unlock ();
throw;
}
}
// add a closed variable to this closure
void Closure::addclv (const long quark, Object* object) {
wrlock ();
try {
// check if the argument already exists
if (p_lset->exists (quark) == true) {
throw Exception ("argument-error", "duplicate argument name",
String::qmap (quark));
}
p_lset->bind (quark, object);
unlock ();
} catch (...) {
unlock ();
throw;
}
}
// set this closure form
void Closure::setform (Object* form) {
wrlock ();
Object::iref (form);
Object::dref (p_form);
p_form = form;
unlock ();
}
// return true if the closure is a lambda expression
bool Closure::islambda (void) const {
rdlock ();
bool result = d_lflag;
unlock ();
return result;
}
// -------------------------------------------------------------------------
// - object section -
// -------------------------------------------------------------------------
// the object supported quarks
static const long QUARK_ADDARG = zone.intern ("add-argument");
static const long QUARK_GAMMAP = zone.intern ("gamma-p");
static const long QUARK_LAMBDAP = zone.intern ("lambda-p");
static const long QUARK_SETFORM = zone.intern ("set-form");
static const long QUARK_GETFORM = zone.intern ("get-form");
// create a ew object in a generic way
Object* Closure::mknew (Vector* argv) {
// get the number of arguments
long argc = (argv == nilp) ? 0 : argv->length ();
// check for 0 argument
if (argc == 0) return new Closure;
// check for 1 argument
if (argc == 1) {
bool type = argv->getbool (0);
return new Closure (type);
}
// illegal arguments
throw Exception ("argument-error", "too many arguments with closure");
}
// return true if the given quark is defined
bool Closure::isquark (const long quark, const bool hflg) const {
rdlock ();
if (zone.exists (quark) == true) {
unlock ();
return true;
}
bool result = hflg ? Object::isquark (quark, hflg) : false;
unlock ();
return result;
}
// set this object as a const object
Object* Closure::cdef (Runnable* robj, Nameset* nset, const long quark,
Object* object) {
wrlock ();
try {
Object* result = p_lset->cdef (robj, nset, quark, object);
robj->post (result);
unlock ();
return result;
} catch (...) {
unlock ();
throw;
}
}
// set this object closed object
Object* Closure::vdef (Runnable* robj, Nameset* nset, const long quark,
Object* object) {
wrlock ();
try {
Object* result = p_lset->vdef (robj, nset, quark, object);
robj->post (result);
unlock ();
return result;
} catch (...) {
unlock ();
throw;
}
}
// evaluate a closed object
Object* Closure::eval (Runnable* robj, Nameset* nset, const long quark) {
rdlock ();
// define constant
try {
Object* result = nilp;
if (p_lset->exists (quark) == true) {
result = p_lset->eval (robj, nset, quark);
} else {
result = Object::eval (robj, nset, quark);
}
robj->post (result);
unlock ();
return result;
} catch (...) {
unlock ();
throw;
}
}
// apply this object with a set of arguments
Object* Closure::apply (Runnable* robj, Nameset* nset, Cons* args) {
rdlock ();
// get the stack context
Stack* stk = robj->getstk ();
Object** sp = stk->getsp ();
Object** fp = stk->getfp ();
try {
// push this closure on the stack
stk->push (this);
// evaluate the arguments on the stack
long argc = 1;
long maxa = d_args ? d_argc - 1 : d_argc;
while (args != nilp) {
if (argc++ == maxa) break;
Object* car = args->getcar ();
stk->push ((car == nilp) ? nilp : car->eval (robj, nset));
args = args->getcdr ();
}
// check for the remaining arguments
if (args != nilp) {
// check is the args flag is set
if (d_args == false) {
throw Exception ("argument-error", "too many arguments at call");
}
Cons* larg = nilp;
try {
while (args != nilp) {
Object* car = args->getcar ();
Object* arg = (car == nilp) ? nilp : car->eval (robj, nset);
if (larg == nilp) {
larg = new Cons (arg);
} else {
larg->append (arg);
}
args = args->getcdr ();
}
} catch (...) {
delete larg;
throw;
}
stk->push (larg);
} else {
if (d_args == true) stk->push ((Object*) nilp);
}
} catch (...) {
stk->unwind (sp, fp);
unlock ();
throw;
}
// set the parent nameset
Nameset* lset = new Localset (p_lset);
if (d_lflag == true)
lset->setparent (nset);
else
lset->setparent (robj->getgset ());
// execute this closure - catch any exception so we unlink and destroy
// the local set. The stack is unwind after the execution. Note how the
// stack frame is created and restored. If you have a better idea - well
// let me know.
Object* result = nilp;
try {
stk->setfp (sp);
result = Object::iref (p_form->eval (robj,lset));
stk->unwind (sp, fp);
lset->reset ();
delete lset;
} catch (const Return& r) {
result = Object::iref (r.getobj ());
stk->unwind (sp, fp);
lset->reset ();
delete lset;
} catch (...) {
stk->unwind (sp, fp);
lset->reset ();
delete lset;
unlock ();
throw;
}
robj->post (result);
Object::tref (result);
unlock ();
return result;
}
// apply this object with a set of arguments and a quarkO
Object* Closure::apply (Runnable* robj, Nameset* nset, const long quark,
Vector* argv) {
// get the number of arguments
long argc = (argv == nilp) ? 0 : argv->length ();
// dispatch 0 argument
if (argc == 0) {
if (quark == QUARK_GAMMAP) return new Boolean (!islambda ());
if (quark == QUARK_LAMBDAP) return new Boolean ( islambda ());
if (quark == QUARK_GETFORM) {
rdlock ();
Object* result = p_form;
robj->post (result);
unlock ();
return result;
}
}
// dispatch 1 argument
if (argc == 1) {
if (quark == QUARK_SETFORM) {
Object* form = argv->get (0);
setform (form);
return nilp;
}
if (quark == QUARK_ADDARG) {
Object* arg = argv->get (0);
addarg (arg);
return nilp;
}
}
// call the object method
return Object::apply (robj, nset, quark, argv);
}
}
syntax highlighted by Code2HTML, v. 0.9.1