2005/5/9

     
 

LispObject.cpp

artefaktur
// -*- mode:C++; tab-width:2; c-basic-offset:2; indent-tabs-mode:nil -*- 
//
// Copyright (C) 2000-2005 by Roger Rene Kommer / artefaktur, Kassel, Germany.
// 
// This library is free software; you can redistribute it and/or
// modify it under the terms of the GNU Library General Public License (LGPL).
// 
// 
// This library 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.	 See the 
// License ACDK-FreeLicense document enclosed in the distribution
// for more for more details.
// This file is part of the Artefaktur Component Development Kit:
//                         ACDK
// 
// Please refer to
// - http://www.acdk.de
// - http://www.artefaktur.com
// - http://acdk.sourceforge.net
// for more information.
// 



#include "LispObject.h"
#include "LispException.h"
#include "LispEnvironment.h"
#include <acdk/lang/ParamsMismatchException.h>

namespace acdk {
namespace lisp {

//static
RLispList LispObject::_definition;

//virtual
RLispList
LispObject::getDefinition() 
{ 
  if (_definition != Nil)
    return _definition;
  _definition =  LispEnvironment::lenv()->parseToList("(self methodname &rest args)"); 
  return _definition;
}

RLispVar acdk2lisp(const ScriptVar& sv)
{
  if (sv.isObjectType() == true)
  {
    acdk::lang::Object obj = sv.getObjectVar();
    if (instanceof(obj, RLispVar) == true)
      return RLispVar(obj);
  }
  return new LispAtom(sv);
}


void 
LispObject::initObject(IN(RString) classname, IN(NamedArgs) args)
{
  RLispEnvironment env = LispEnvironment::lenv();
  RLispVar lvar = env->lookupVar(classname);

  if (lvar == Nil && instanceof(lvar, LispClass) == true)
    THROW1(ClassNotFoundException, "Cannot find LispClass: " + classname);
  _class = RLispClass(lvar);

  initObject(env, _class);

  for (int i = 0; i < args.size(); ++i)
  {
    if (setSlotByInitArg(env, args[i].name(), acdk2lisp(args[i].value())) == false)
      THROW1(ParamsMismatchException, "Cannot not initialize Class " + classname + " with argument " + args[i].name());
  }
}

LispObject::LispObject(IN(RString) classname, IN(NamedArgs) args)
: _slots(new ::acdk::util::HashMap())
{
  initObject(classname, args);
}

  
//foreign virtual 
RString 
LispObject::toString() 
{ 
  return "LispObject"; 
}

//foreign virtual 
RString 
LispObject::toCode() 
{ 
  StringBuffer sb("'(");
  ::acdk::util::RIterator it = _slots->keySet()->iterator();
  while (it->hasNext() == true)
  {
    acdk::lang::Object obj = it->next();
    sb << "('" << obj->toString() 
       << " ";
    acdk::lang::Object vobj = _slots->get(obj);
    if (vobj == Nil)
      sb << "Nil";
    else
      sb << RLispVar(vobj)->toCode();
    sb << ")";
  }
  sb << ")";
  return sb.toString();
}

void 
LispObject::initObject(IN(RLispEnvironment) env, IN(RLispClass) cls)
{
  int i;
  for (i = 0; i < cls->supers()->length(); ++i)
  {
    initObject(env, cls->supers()[i]);
  }

  RLispSlotArray slots = cls->slots();
  for (i = 0; i < slots->length(); ++i)
  {
    RLispSlot slot = slots[i];
    if (slot->isStatic == true)
      continue;
    RLispVar nval = slot->initform;
    _slots->put(&slot->name, &nval);
  }
}

bool 
LispObject::setSlotByInitArg(IN(RLispEnvironment) env, IN(RLispClass) cls, IN(RString) initarg, IN(RLispVar) val)
{
  int i;
  RLispSlotArray slots = cls->slots();
  for (i = 0; i < slots->length(); ++i)
  {
    RLispSlot slot = slots[i];
    if (slot->isStatic == true)
      continue;

    if (slot->initarg != Nil && slot->initarg->equals(initarg) == true)
    {
      RLispVar nval = val;
      _slots->put(&slot->name, &nval);
      return true;
    }
  }
  for (i = 0; i < cls->supers()->length(); ++i)
  {
    if (setSlotByInitArg(env, cls->supers()[i], initarg, val) == true)
      return true;
  }
  return false;
} 

// (self (qoute member) args)
//virtual 
RLispVar 
LispObject::eval(IN(RLispEnvironment) env, IN(RLispList) args)
{
  if (args->length() < 2)
    THROW2(LispException, env, "LispObject member invocation/access needs at least 1 argument: " + args->toCode());
  
  RLispList targs = args;
  
  RLispVar self = targs->car();
  targs = targs->cdr();
  //RString tstr = targs->toCode();
  RString membern = env->eval(targs->car())->toString();

  targs = targs->cdr();
  RLispVar member = getSlot(membern);
  if (instanceof(member, Function) == true)
  {
    RLispList nargs = new LispList(self, targs);
    RLispList nm = new LispList(member, nargs);

    return env->_eval(nm);
  } 
  if (targs == Nil || targs->length() == 0)  // getter
  {
    return member;
  } 
  else if (targs->length() == 1) // setter
  {
    setSlot(membern, env->eval(targs->car()));
    return targs->car();
  }
  THROW2(LispException, env, "LispObject member access needs 1 (getter) or 2 (setter) arguments" + args->toCode());
  return Nil;
}

RLispVar 
lisp_make_instance(IN(RLispEnvironment) env, IN(RLispList) args)
{
  if (args->length() < 2)
    THROW2(LispException, env, "make-instance needs at least 1 argument: " + args->toCode());
  
  RLispList targs = args->cdr();
  
  RLispVar tclvar = env->eval(targs->car());
  if (instanceof(tclvar, LispClass) == false)
    tclvar = env->lookupVar(tclvar->toString());
  if (tclvar == Nil || instanceof(tclvar, LispClass) == false)
    THROW2(LispException, env, "Cannot find LispClass with name: " + tclvar->toCode());
  RLispClass lclass = RLispClass(tclvar);
  RLispObject lobj = new LispObject(env, lclass);
  targs = targs->cdr();
  while (targs != Nil && targs->car() != Nil)
  {
    RString n = targs->car()->toString();
    targs = targs->cdr();
    RLispVar val = targs->car();
    if (lobj->setSlotByInitArg(env, n, val) == false)
      THROW2(LispException, env, "Cannot not initialize Class " + tclvar->toCode() + " with argument " + n);
    targs = targs->cdr();
  }
  return &lobj;
}



RLispList 
toLispArgs(::acdk::lang::dmi::ScriptVarArray& args, 
                                                          ::acdk::lang::dmi::DmiClient& dc,
                                                          IN(::acdk::lang::RStringArray) namedArgs)
{
  int nonnamedargsnum = args.size();
  if (namedArgs != Nil)
    nonnamedargsnum =- namedArgs->length();
  
  RLispList first;
  RLispList ll;
  int i;
  for (i = 0; i < nonnamedargsnum; ++i)
  {

    RLispList tl = new LispList(acdk2lisp(args[i]));
    if (first == Nil)
      first = tl;
    if (ll != Nil)
      ll->setCdr(tl);
    ll = tl;
  }
  for (; i < args.size(); ++i)
  {
    RLispList tl = new LispList(new LispSymbol(namedArgs[i - nonnamedargsnum]));
    if (first == Nil)
      first = tl;
    if (ll != Nil)
      ll->setCdr(tl);
    ll = tl;
    tl = new LispList(acdk2lisp(args[i]));
    ll->setCdr(tl);
    ll = tl;
  }
  return first;
}


//static 
const ::acdk::lang::dmi::ClazzMethodInfo* 
LispObject::dynamic_dispatch(::acdk::lang::Object* This_, 
                                                         IN(RString) fname, 
                                                         ::acdk::lang::dmi::ScriptVar& ret, 
                                                         ::acdk::lang::dmi::ScriptVarArray& args, 
                                                         ::acdk::lang::dmi::DmiClient& dc,
                                                         IN(::acdk::lang::RStringArray) namedArgs,
                                                         int flags,
                                                         const ::acdk::lang::dmi::ClazzInfo* clazzinfo,
                                                         const ::acdk::lang::dmi::ClazzMethodInfo* methinf)
{
  RLispEnvironment env = LispEnvironment::lenv();
  RLispObject This = dynamic_cast<LispObject*>(This_);
  //RLispVar slot = getSlot(fname);
  //if (slot == Nil)
//    THROW1(MethodNotFoundException, "Member cannot be found: " + getLispClass()->getName());
  RLispList largs = toLispArgs(args, dc, namedArgs);
  RLispList func = new LispList(new LispSymbol("quote"), new LispList(new LispSymbol(&fname)));
  RLispList fn = new LispList(&This, new LispList(&func, largs));
  //RString tstr = fn->toCode();
  RLispVar erg = This->eval(env, fn);
  if (instanceof(erg, LispAtom) == true)
    ret = RLispAtom(erg)->val();
  else
    ret = &erg;
  return (const ::acdk::lang::dmi::ClazzMethodInfo* )1;
}


// static
const ::acdk::lang::dmi::ClazzMethodInfo* 
LispObject::static_dispatch(IN(RString) fname, 
                                                         ::acdk::lang::dmi::ScriptVar& ret, 
                                                         ::acdk::lang::dmi::ScriptVarArray& args, 
                                                         ::acdk::lang::dmi::DmiClient& dc,
                                                         IN(::acdk::lang::RStringArray) namedArgs,
                                                         int flags,
                                                         const ::acdk::lang::dmi::ClazzInfo* clazzinfo,
                                                         const ::acdk::lang::dmi::ClazzMethodInfo* methinf)
{
  return 0;
}

/*
//virtual 
::acdk::lang::dmi::ScriptVar 
LispObject::getMember(const char* fieldname, ::acdk::lang::dmi::DmiClient& dc, int flags, const ::acdk::lang::dmi::ClazzInfo* type_requested )
{
  return ScriptVar();
}
  
//virtual 
void 
LispObject::setMember(const char* fieldname, const ::acdk::lang::dmi::ScriptVar& newval, ::acdk::lang::dmi::DmiClient& dc, int flags)
{

}
*/

} // namespace lisp
} // namespace acdk