Logo Search packages:      
Sourcecode: afnix version File versions

Cons.cpp

// ---------------------------------------------------------------------------
// - Cons.cpp                                                                -
// - standard object library - cons cell 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 "Input.hpp"
#include "Stdsid.hxx"
#include "Vector.hpp"
#include "Output.hpp"
#include "Recycle.hpp"
#include "Boolean.hpp"
#include "Integer.hpp"
#include "Runnable.hpp"
#include "QuarkZone.hpp"
#include "Exception.hpp"

namespace afnix {
 
  // -------------------------------------------------------------------------
  // - memory allocation section                                             -
  // -------------------------------------------------------------------------

  // the cons cell recycler
  static Recycle recycler;

  // allocate a new cons cell
  void* Cons::operator new (const t_size size) {
    return recycler.pop (size);
  }

  // delete a cons cell
  void Cons::operator delete (void* handle) {
    recycler.push (handle);
  }

  // -------------------------------------------------------------------------
  // - class section                                                         -
  // -------------------------------------------------------------------------

  // create a new cons cell initialized to nil

00054   Cons::Cons (void) {
    d_type = Cons::NORMAL;
    p_car  = nilp;
    p_cdr  = nilp;
    p_mon  = nilp;
    d_bpt  = false;
  }

  // create a new cons cell with a type

00064   Cons::Cons (t_type type) {
    d_type = type;
    p_car  = nilp;
    p_cdr  = nilp;
    p_mon  = nilp;
    d_bpt  = false;
  }

  // create a new cons cell with a car

00074   Cons::Cons (Object* car) {
    d_type = Cons::NORMAL;
    p_car  = Object::iref (car);
    p_cdr  = nilp;
    p_mon  = nilp;
    d_bpt  = false;
  }

  // create a new cons cell with a type and a car

00084   Cons::Cons (t_type type, Object* car) {
    d_type = type;
    p_car  = Object::iref (car);
    p_cdr  = nilp;
    p_mon  = nilp;
    d_bpt  = false;
  }

  // copy constructor for this cons cell

00094   Cons::Cons (const Cons& that) {
    that.rdlock ();
    d_type  = that.d_type;
    p_car   = Object::iref (that.p_car);
    p_cdr   = that.p_cdr;
    d_bpt   = that.d_bpt;
    Object::iref (that.p_cdr);
    p_mon   = (that.p_mon == nilp) ? nilp : new Monitor;
    that.unlock ();
  }

  // destroy this cons cell

00107   Cons::~Cons (void) {
    delete p_mon;
    Object::dref (p_car);
    Object::dref (p_cdr);
  }

  // return the class name
00114   String Cons::repr (void) const {
    return "Cons";
  }

  // make this cons cell a shared object

00120   void Cons::mksho (void) {
    if (p_shared != nilp) return;
    Object::mksho ();
    if (p_car != nilp) p_car->mksho ();
    if (p_cdr != nilp) p_cdr->mksho ();
  }

  // return the cons cell serial code

00129   t_byte Cons::serialid (void) const {
    return SERIAL_CONS_ID;
  }

  // serialize this cons cell

00135   void Cons::wrstream (Output& os) const {
    rdlock ();
    // write the cons cell type
    switch (d_type) {
    case NORMAL:
      os.write ((char) 0x00);
      break;
    case BLOCK:
      os.write ((char) 0x01);
      break;
    }
    // try to serialize the car
    if (p_car == nilp) {
      Serial::wrnilid (os);
    } else {
      Serial* sobj = dynamic_cast <Serial*> (p_car);
      if (sobj == nilp) {
      unlock ();
      throw Exception ("serial-error", "cannot serialize object", 
                   p_car->repr ());
      }
      sobj->serialize (os);
    }
    // try to serialize the cdr
    if (p_cdr == nilp) {
      Serial::wrnilid (os);
    } else {
      Serial* sobj = dynamic_cast <Serial*> (p_cdr);
      if (sobj == nilp) {
      unlock ();
      throw Exception ("serial-error", "cannot serialize object", 
                   p_car->repr ());
      }
      sobj->serialize (os);
    }
    unlock ();
  }

  // deserialize this cons cell

00175   void Cons::rdstream (Input& is) {
    wrlock ();
    // deserialize the type
    switch (is.read ()) {
    case 0x00:
      d_type = NORMAL;
      break;
    case 0x01:
      d_type = BLOCK;
      break;
    default:
      unlock ();
      throw Exception ("serial-error", "invalid cons cell type found");
      break;
    }
    // deserialize the car
    setcar (Serial::deserialize (is));
    // deserialize the cdr
    Object* obj = Serial::deserialize (is);
    if (obj == nilp) {
      setcdr ((Cons*) nilp);
    } else {
      Cons* cdr = dynamic_cast <Cons*> (obj);
      if (cdr == nilp) {
      unlock ();
      throw Exception ("deserialize-error", "non cons cell to deserialize",
                   obj->repr ());
      }
      setcdr (cdr);
    }
    unlock ();
  }

  // assign a cons cell to this one

00210   Cons& Cons::operator = (const Cons& that) {
    wrlock ();
    that.rdlock ();
    // protect again same assignation
    Object::dref (p_car);
    Object::dref (p_cdr);
    // assign cell
    d_type = that.d_type;
    p_car  = Object::iref (that.p_car);
    p_cdr  = that.p_cdr; Object::iref (p_cdr);
    p_mon  = (that.p_mon == nilp) ? nilp : new Monitor;
    that.unlock ();
    unlock ();
    return *this;
  }

  // append an object to the last cdr of this cons cell

00228   void Cons::append (Object* object) {
    wrlock ();
    try {
      // check for shared
      if ((p_shared != nilp) && (object != nilp)) object->mksho ();
      // create a new cons cell 
      Cons* cons = new Cons (object);
      // find the last cons cell
      Cons* last = this;
      while (last->p_cdr != nilp) last = last->p_cdr;
      // attach this new cons cell
      last->p_cdr = cons;
      Object::iref (cons);
      // unlock the cons cell
      unlock ();
    } catch (...) {
      unlock ();
      throw;
    }
  }

  // set the car if the object is nil or append the object

00251   void Cons::lnkobj (Object* object) {
    wrlock ();
    try {
      // check for shared
      if ((p_shared != nilp) && (object != nilp)) object->mksho ();
      // set the car or append
      if ((p_car == nilp) && (p_cdr == nilp)) {
      setcar (object);
      unlock ();
      return;
      }
      append (object);
      unlock ();
    } catch (...) {
      unlock ();
      throw;
    }
  }

  // set the car of this cons cell

00272   void Cons::setcar (Object* object) {
    wrlock ();
    try {
      // check for shared
      if ((p_shared != nilp) && (object != nilp)) object->mksho ();
      // set the car
      Object::dref (p_car);
      p_car = Object::iref (object);
      // unlock the cons cell
      unlock ();
    } catch (...) {
      unlock ();
      throw;
    }
  }

  // set the cdr of this cons cell

00290   void Cons::setcdr (Cons* cdr) {
    wrlock ();
    try {
      // check for shared
      if ((p_shared != nilp) && (cdr != nilp)) cdr->mksho ();
      // set the cdr
      Object::dref (p_cdr);
      p_cdr = cdr; Object::iref (cdr);
      // unlock the cons cell
      unlock ();
    } catch (...) {
      unlock ();
      throw;
    }
  }

  // return the car of this cons cell

00308   Object* Cons::getcar (void) const {
    rdlock ();
    Object* result = p_car;
    unlock ();
    return result;
  }

  // return the cdr of this cons cell

00317   Cons* Cons::getcdr (void) const {
    rdlock ();
    Cons* result = p_cdr;
    unlock ();
    return result;
  }


  // return the car of the cdr of this cons cell

00327   Object* Cons::getcadr (void) const {
    rdlock ();
    if (p_cdr == nilp) {
      unlock ();
      return nilp;
    }
    Object* result = p_cdr->p_car;
    unlock ();
    return result;
  }

  // return the car of the cdr of the cdr of this cons cell

00340   Object* Cons::getcaddr (void) const {
    rdlock ();
    if (p_cdr == nilp) {
      unlock ();
      return nilp;
    }
    Cons* cdr = p_cdr->p_cdr;
    if (cdr == nilp) {
      unlock ();
      return nilp;
    }
    Object* result = cdr->p_car;
    unlock ();
    return result;
  }

  // return the car of the cdr of the cdr of the cdr of this cons cell

00358   Object* Cons::getcadddr (void) const {
    rdlock ();
    if (p_cdr == nilp) {
      unlock ();
      return nilp;
    }
    Cons* cdr = p_cdr->p_cdr;
    if (cdr == nilp) {
      unlock ();
      return nilp;
    }
    cdr = cdr->p_cdr;
    if (cdr == nilp) {
      unlock ();
      return nilp;
    }
    Object* result = cdr->p_car;
    unlock ();
    return result;
  }

  // return true if the car is nil

00381   bool Cons::isnil (void) const {
    rdlock ();
    bool result = (p_car == nilp);
    unlock ();
    return result;
  }

  // return true if the cons cell is a block cell

00390   bool Cons::isblock (void) const {
    rdlock ();
    bool result = (d_type == BLOCK);
    unlock ();
    return result;
  }
  
  // return the length of this cons cell

00399   long Cons::length (void) const {
    rdlock ();
    long result      = 0;
    const Cons* cons = this;
    do {
      result++;
    } while ((cons = cons->p_cdr) != nilp);
    unlock ();
    return result;
  }

  // return an object by index

00412   Object* Cons::get (const long index) const {
    rdlock ();
    try {
      long count       = 0;
      const Cons* cons = this;
      if (index < 0) throw Exception ("index-error",
                              "invalid negative index in cons get");
      // loop in the cons cell list
      while (cons != nilp) {
      if (count == index) {
        Object* result = cons->p_car;
        unlock ();
        return result;
      }
      count++;
      cons = cons->p_cdr;
      }
      throw Exception ("index-error", "invalid index in cons get method");
    } catch (...) {
      unlock ();
      throw;
    }
  }

  // set the form synchronizer
  
00438   void Cons::mksync (void) {
    wrlock ();
    if (p_mon == nilp) p_mon = new Monitor;
    unlock ();
  }

  // set the form breakpoint

00446   void Cons::setbpt (const bool bpt) {
    wrlock ();
    d_bpt = bpt;
    unlock ();
  }

  // return a cons iterator

00454   Iterator* Cons::makeit (void) {
    return new Consit (this);
  }

  // -------------------------------------------------------------------------
  // - object section                                                        -
  // -------------------------------------------------------------------------

  // the quark zone
  static const long QUARK_ZONE_LENGTH = 13;
  static QuarkZone  zone (QUARK_ZONE_LENGTH);

  // the object supported quarks
  static const long QUARK_GET       = zone.intern ("get");
  static const long QUARK_NILP      = zone.intern ("nil-p");
  static const long QUARK_LINK      = zone.intern ("link");
  static const long QUARK_BLOCKP    = zone.intern ("block-p");
  static const long QUARK_APPEND    = zone.intern ("append");
  static const long QUARK_LENGTH    = zone.intern ("length");
  static const long QUARK_GETCAR    = zone.intern ("get-car");
  static const long QUARK_SETCAR    = zone.intern ("set-car");
  static const long QUARK_GETCDR    = zone.intern ("get-cdr");
  static const long QUARK_SETCDR    = zone.intern ("set-cdr");
  static const long QUARK_GETCADR   = zone.intern ("get-cadr");
  static const long QUARK_GETCADDR  = zone.intern ("get-caddr");
  static const long QUARK_GETCADDDR = zone.intern ("get-cadddr");

  // evaluate each car of a cons cell and return a new form

00483   Cons* Cons::mkcons (Runnable* robj, Nameset* nset, Cons* args) {
    // check for nil and lock
    if (args == nilp) return nilp;
    args->rdlock ();
    // create the result cell and loop
    Cons* cons = args;
    Cons* form = new Cons;
    try {
      while (cons != nilp) {
      Object* car = cons->getcar ();
      Object* obj = (car == nilp) ? nilp : car->eval (robj, nset);
      form->lnkobj (obj);
      cons = cons->getcdr ();
      }
      // unlock and return
      args->unlock ();
      return form;
    } catch (...) {
      delete form;
      args->unlock ();
      throw;
    }
  }

  // evaluate each car of a cons cell - if the object is not a cons cell
  // the object is returned

00510   Object* Cons::mkform (Runnable* robj, Nameset* nset, Object* object) {
    // try to get a cons cell
    Cons* cons = dynamic_cast <Cons*> (object);
    if (cons == nilp) return object;
    // create an evaluated form
    return Cons::mkcons (robj, nset, cons);
  }

  // create a new object in a generic way

00520   Object* Cons::mknew (Vector* argv) {
    long len = 0;
    if ((argv == nilp) || ((len = argv->length ()) == 0)) return nilp;
    // build the cons cell
    Cons* result = nilp;
    for (long i = 0; i < len; i++) {
      if (result == nilp)
      result = new Cons (argv->get (i));
      else
      result->append (argv->get (i));
    }
    return result;
  }

  // return true if the given quark is defined

00536   bool Cons::isquark (const long quark, const bool hflg) const {
    rdlock ();
    if (zone.exists (quark) == true) {
      unlock ();
      return true;
    }
    bool result = hflg ? Iterable::isquark (quark, hflg) : false;
    unlock ();
    return result;
  }

  // set an object to the car of this cons cell

00549   Object* Cons::vdef (Runnable* robj, Nameset* nset, Object* object) {
    setcar (object);
    return object;
  }

  // evaluate this object in the current nameset

00556   Object* Cons::eval (Runnable* robj, Nameset* nset) {
    // check for breakpoint
    if (d_bpt == true) robj->bpt (nset, this);
    // synchronize the form
    if (p_mon != nilp) p_mon->enter ();
    Object* result = nilp;
    try {
      if (d_type == Cons::BLOCK) {
      Cons* cons = this;
      while (cons != nilp) {
        Object::cref (result);
        Object* car = cons->getcar ();
        if (robj->getnext () == true) {
          robj->setnext (false);
          robj->bpt (nset, car);
        }
        result = (car == nilp) ? nilp : car->eval (robj,nset);
        cons   = cons->getcdr ();
      }
      } else {
      if (p_car == nilp) {
        if (p_mon != nilp) p_mon->leave ();
        return nilp;
      }
      Object* func = Object::iref (p_car->eval (robj, nset));
      if (func == nilp) {
        if (p_mon != nilp) p_mon->leave ();
        return nilp;
      }
      try {
        result = func->apply (robj, nset, p_cdr);
        Object::dref (func);
      } catch (...) {
        Object::dref (func);
        throw;
      }
      }
    } catch (...) {
      if (p_mon != nilp) p_mon->leave ();
      throw;
    }
    if (p_mon != nilp) p_mon->leave ();
    return result;
  }

  // apply this object with a set of arguments and a quark

00603   Object* Cons::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_GETCAR)   {
      rdlock ();
      try {
        Object* result = getcar ();
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      }
      if (quark == QUARK_GETCDR) {
      rdlock ();
      try {
        Object* result = getcdr ();
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      }
      if (quark == QUARK_GETCADR) {
      rdlock ();
      try {
        Object* result = getcadr ();
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      } 
      if (quark == QUARK_GETCADDR) {
      rdlock ();
      try {
        Object* result = getcaddr ();
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      }
      if (quark == QUARK_GETCADDDR) {
      rdlock ();
      try {
        Object* result = getcadddr ();
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      }
      if (quark == QUARK_LENGTH) return new Integer (length ());
      if (quark == QUARK_NILP)   return new Boolean (isnil ());
      if (quark == QUARK_BLOCKP) return new Boolean (isblock ());
    }

    // dispatch 1 argument
    if (argc == 1) {
      if (quark == QUARK_SETCAR) {
      Object* result = argv->get (0);
      setcar (result);
      robj->post (result);
      return result;
      }

      if (quark == QUARK_SETCDR) {
      Object* result = argv->get (0);
      if (result == nilp) {
        setcdr ((Cons*) nilp);
        robj->post (result);
        return nilp;
      }
      Cons* cdr = dynamic_cast <Cons*> (result);
      if (cdr == nilp) 
        throw Exception ("type-error", "invalid object with set-cdr method",
                     Object::repr (result));
      
      setcdr (cdr);
      robj->post (cdr);
      return result;
      }

      if (quark == QUARK_APPEND) {
      Object* result = argv->get (0);
      append (result);
      robj->post (result);
      return result;
      }

      if (quark == QUARK_LINK) {
      Object* result = argv->get (0);
      lnkobj (result);
      robj->post (result);
      return result;
      }

      if (quark == QUARK_GET) {
      wrlock ();
      try {
        long val = argv->getint (0);
        Object* result = get (val);
        robj->post (result);
        unlock ();
        return result;
      } catch (...) {
        unlock ();
        throw;
      }
      }
    }
    
    // call the object method
    return Iterable::apply (robj, nset, quark, argv);
  }

  // -------------------------------------------------------------------------
  // - iterator section                                                      -
  // -------------------------------------------------------------------------

  // create a new cons iterator

00740   Consit::Consit (Cons* cons) {
    Object::iref (p_cons = cons);
    Object::iref (p_cell = cons);
    if (p_cell != nilp) p_cell->rdlock ();
  }

  // destroy this cons iterator

00748   Consit::~Consit (void) {
    if (p_cell != nilp) p_cell->unlock ();
    Object::dref (p_cell);
    Object::dref (p_cons);
  }

  // return the class name

00756   String Consit::repr (void) const {
    return "Consit";
  }

  // make this cons cell iterator a shared object

00762   void Consit::mksho (void) {
    if (p_shared != nilp) return;
    Object::mksho ();
    if (p_cell != nilp) p_cell->mksho ();
  }

  // reset the iterator to the begining

00770   void Consit::begin (void) {
    wrlock ();
    if (p_cell != nilp) p_cell->unlock ();
    Object::dref (p_cell);
    Object::iref (p_cell = p_cons);
    if (p_cell != nilp) p_cell->rdlock ();
    unlock ();
  }

  // reset the iterator to the end

00781   void Consit::end (void) {
    throw Exception ("iterator-error", "cannot set a cons iterator to end");
  }

  // go to the next object

00787   void Consit::next (void) {
    wrlock ();
    if (p_cell == nilp) {
      unlock ();
      return;
    }
    Cons* cdr = p_cell->p_cdr;
    if (cdr != nilp) {
      cdr->rdlock ();
      Object::iref (cdr);
    }
    p_cell->unlock ();
    Object::dref (p_cell);
    p_cell = cdr;
    unlock ();
  }

  // go to the previous object
00805   void Consit::prev (void) {
    throw Exception ("iterator-error", "cannot move back a cons iterator");
  }

  // get the object at the current position

00811   Object* Consit::getobj (void) const {
    rdlock ();
    Object* result = (p_cell == nilp) ? nilp : p_cell->getcar ();
    unlock ();
    return result;
  }

  // return true if the iterator is at the end

00820   bool Consit::isend (void) {
    rdlock ();
    bool result =  (p_cell == nilp);
    unlock ();
    return result;
  }
}

Generated by  Doxygen 1.6.0   Back to index