Haciendo un intérprete de LISP (XIV)

En esta parte de la serie sobre el intérprete LISP vamos a poner el código de algunas funciones nativas que pueden ser útiles.

Operaciones de lista

Tendríamos por ejemplo

Cell& FOL_Cons(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || !args.GetTail().GetTail().IsEmpty())
  throw std::runtime_error("Cons needs two arguments");

 Cell& head=heap.Evaluate(args.GetHead(), envir);
 Cell& tail=heap.Evaluate(args.GetTail().GetHead(), envir);

 if(!tail.IsList())
  throw std::runtime_error("Cons needs a list as second argument");

 return heap.CreatePair(head, tail);
}

Cell& FOL_Car(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Car requires one arguments");

 Cell& head=heap.Evaluate(args.GetHead(), envir);
 return head.GetHead();
}

Cell& FOL_Cdr(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Cdr requires one arguments");

 Cell& head=heap.Evaluate(args.GetHead(), envir);
 return head.GetTail();
}

Cell& FOL_Second(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Second requires one arguments");

 Cell& head=heap.Evaluate(args.GetHead(), envir);
 return head.GetTail().GetHead();
}

Cell& FOL_Third(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Third requires one arguments");

 Cell& head=heap.Evaluate(args.GetHead(), envir);
 return head.GetTail().GetTail().GetHead();
}

Cell& FOL_Nth(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || !args.GetTail().GetTail().IsEmpty())
  throw std::runtime_error("Nth requires two arguments");

 INTEGER at=heap.Evaluate(args.GetHead(), envir).GetInteger();
 Cell& list=heap.Evaluate(args.GetTail().GetHead(), envir);
 return list.ListIdx(at);
}

Cell& FOL_Length(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Length requires one arguments");

 Cell& list=heap.Evaluate(args.GetHead(), envir);
 return heap.CreateInteger(list.ListLength());
}

Cell& FOL_List(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty())
  return heap.CreateEmpty();

 return heap.CreatePair(  heap.Evaluate(args.GetHead(), envir)
  , FOL_List(heap, args.GetTail(), envir)  );
}

Cell& R_Append(Heap& heap, Cell& list1, Cell& list2)
{
 if(list1.IsEmpty())
  return list2;

 return heap.CreatePair( list1.GetHead(), R_Append(heap, list1.GetTail(), list2) );
}

Cell& FOL_Append(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || !args.GetTail().GetTail().IsEmpty())
  throw std::runtime_error("Append requires two arguments");

 Cell& list1=heap.Evaluate(args.GetHead(), envir);
 Cell& list2=heap.Evaluate(args.GetTail().GetHead(), envir);

 return R_Append(heap, list1, list2);
}

Cell& FOL_Reverse(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Reverse requires one arguments");

 Cell* r=&heap.CreateEmpty();
 for(Cell* p=&heap.Evaluate(args.GetHead(), envir); p->IsPair(); p=&p->GetTail())
  r=&heap.CreatePair( p->GetHead(), *r );

 return *r;
}

Formas especiales

Algunas posibles son

Cell& FOL_Lambda(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("Lambda needs two arguments at least");

 Cell* params=&args.GetHead();
 Cell* p;
 for(p=params; p->IsPair(); p=&p->GetTail())
  if(!p->GetHead().IsName())
   throw std::runtime_error("Binding a non-name");

 if(!p->IsEmpty())
  throw std::runtime_error("Lambda needs a list as first argument");

 return heap.CreateLambda(*new Lambda(*params, args.GetTail(), envir));
}


Cell& FOL_Defun(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("Defun needs three arguments at least");

 Cell& lambda=FOL_Lambda(heap, args.GetTail(), envir);
 envir.GetEnvironment().Bind(heap, *args.GetHead().GetName(), lambda);
 return lambda;
}

Cell& FOL_Quote(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Quote needs one single argument");

 return args.GetHead();
}


Cell& FOL_SetQ(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("SetQ needs two arguments at least");

 if(!args.GetHead().IsName())
  throw std::runtime_error("SetQ requires a name as fist argument");

 Cell& r=heap.EvaluateInSequence(args.GetTail(), envir);
 envir.GetEnvironment().ChangeBond(heap, heap.GetStringFromPool(*args.GetHead().GetName()), r);
 return r;
}

Cell& FOL_Define(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("Define needs two arguments at least");

 if(!args.GetHead().IsName())
  throw std::runtime_error("Define requires a name as fist argument");

 Cell& r=heap.EvaluateInSequence(args.GetTail(), envir);
 envir.GetEnvironment().Bind(heap, *args.GetHead().GetName(), r);
 return r;
}

Cell& FOL_Let(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("Let needs two arguments at least");

 Cell& envcell=heap.CreateEnvironment(&envir);
 Environment& newenv=envcell.GetEnvironment();

 //Bind to environment
 for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
 {
  Cell& binding=qb->GetHead();
  if(binding.IsEmpty() || binding.GetTail().IsEmpty())
   throw std::runtime_error("Bindings must have two elements at least");
  
  newenv.Bind(heap, *binding.GetHead().GetName(), heap.EvaluateInSequence(binding.GetTail()
   , envir)); // HERE!
 }

 //Evaluate in new environment
 return heap.EvaluateInSequence(args.GetTail(), envcell);
}

Cell& FOL_LetInSeq(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty())
  throw std::runtime_error("Let* needs two arguments at least");

 Cell& envcell=heap.CreateEnvironment(&envir);
 Environment& newenv=envcell.GetEnvironment();

 //Bind to environment
 for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
 {
  Cell& binding=qb->GetHead();
  if(binding.IsEmpty() || binding.GetTail().IsEmpty())
   throw std::runtime_error("Bindings must have two elements at least");
  
  newenv.Bind(heap, *binding.GetHead().GetName(), heap.EvaluateInSequence(binding.GetTail()
   , envcell)); // HERE!
 }

 //Evaluate in new environment
 return heap.EvaluateInSequence(args.GetTail(), envcell);
}

Cell& FOL_Do(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || args.GetTail().GetTail().IsEmpty())
  throw std::runtime_error("Do needs three arguments at least");

 Cell& envcell=heap.CreateEnvironment(&envir);
 Environment& newenv=envcell.GetEnvironment();

 //Initial bind to environment
 for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
 {
  Cell& binding=qb->GetHead();
  if(binding.IsEmpty() || binding.GetTail().IsEmpty())
   throw std::runtime_error("Bindings must have two elements at least");
  
  newenv.Bind(heap, *binding.GetHead().GetName(), heap.Evaluate(binding.GetTail().GetHead()
   , envir)); // HERE!
 }

 //Loop
 Cell* r=NULL;
 while(heap.Evaluate(args.GetTail().GetHead(), envcell).GetBoolean())
 {
  r=&heap.EvaluateInSequence(args.GetTail().GetTail(), envcell);

  //Update
  for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
  {
   Cell& binding=qb->GetHead();
   heap.EvaluateInSequence(binding.GetTail().GetTail(), envcell);
  }
 }

 return r==NULL ? heap.CreateEmpty() : *r;
}

Cell& FOL_DoInSeq(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || args.GetTail().GetTail().IsEmpty())
  throw std::runtime_error("Do* needs three arguments at least");

 Cell& envcell=heap.CreateEnvironment(&envir);
 Environment& newenv=envcell.GetEnvironment();

 //Initial bind to environment
 for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
 {
  Cell& binding=qb->GetHead();
  if(binding.IsEmpty() || binding.GetTail().IsEmpty())
   throw std::runtime_error("Bindings must have two elements at least");
  
  newenv.Bind(heap, *binding.GetHead().GetName(), heap.Evaluate(binding.GetTail().GetHead()
   , envcell)); // HERE!
 }

 //Loop
 Cell* r=NULL;
 while(heap.Evaluate(args.GetTail().GetHead(), envcell).GetBoolean())
 {
  r=&heap.EvaluateInSequence(args.GetTail().GetTail(), envcell);

  //Update
  for(Cell* qb=&args.GetHead(); qb->IsPair(); qb=&qb->GetTail())
  {
   Cell& binding=qb->GetHead();
   heap.EvaluateInSequence(binding.GetTail().GetTail(), envcell);
  }
 }

 return r==NULL ? heap.CreateEmpty() : *r;
}

Cell& FOL_DoList(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty())
  throw std::runtime_error("DoList needs one arguments at least");

 Cell& envcell=heap.CreateEnvironment(&envir);
 Environment& newenv=envcell.GetEnvironment();

 //Check the binding
 Cell& binding=args.GetHead();
 if(binding.IsEmpty() || binding.GetTail().IsEmpty())
  throw std::runtime_error("Bindings must have two elements at least");

 //Loop
 Cell* r=NULL;
 for(Cell* list= &heap.EvaluateInSequence(binding.GetTail(), envir); list->IsPair(); list=&list->GetTail())
 {
  newenv.Bind(heap, binding.GetHead().GetName(), list->GetHead());
  r=&heap.EvaluateInSequence(args.GetTail(), envcell);
 }

 return r==NULL ? heap.CreateEmpty() : *r;
}

Operaciones y formas especiales con booleanos

Cell& FOL_Boolean_And(Heap& heap, Cell& args, Cell& envir)
{
 for(Cell* qa=&args; qa->IsPair(); qa=&qa->GetTail())
  if(!heap.Evaluate(qa->GetHead(), envir).GetBoolean())
   return heap.CreateBoolean(false);

 return heap.CreateBoolean(true);
}

Cell& FOL_Boolean_Or(Heap& heap, Cell& args, Cell& envir)
{
 for(Cell* qa=&args; qa->IsPair(); qa=&qa->GetTail())
  if(heap.Evaluate(qa->GetHead(), envir).GetBoolean())
   return heap.CreateBoolean(true);

 return heap.CreateBoolean(false);
}

Cell& FOL_Boolean_Not(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || !args.GetTail().IsEmpty())
  throw std::runtime_error("Boolean not needs one single argument");

 return heap.CreateBoolean(!heap.Evaluate(args.GetHead(), envir).GetBoolean());
}

Cell& FOL_Boolean_If(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty() || args.GetTail().IsEmpty() || args.ListLength()>3)
  throw std::runtime_error("Lambda needs two or three arguments");

 if(heap.Evaluate(args.GetHead(), envir).GetBoolean())
  return heap.Evaluate(args.GetTail().GetHead(), envir);

 return args.GetTail().GetTail().IsEmpty() ? heap.CreateEmpty()
  : heap.Evaluate(args.GetTail().GetTail().GetHead(), envir);
}

Otras funciones

Cell& FOL_ProgN(Heap& heap, Cell& args, Cell& envir)
{
 Cell* r=&args;
 for(Cell* qa=&args; qa->IsPair(); qa=&qa->GetTail())
  r=&heap.Evaluate(qa->GetHead(), envir);
 return *r;
}

Cell& FOL_Prog1(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty())
  return args;

 Cell& r=heap.Evaluate(args.GetHead(), envir);
 for(Cell* qa=&args.GetTail(); qa->IsPair(); qa=&qa->GetTail())
  heap.Evaluate(qa->GetHead(), envir);

 return r;
}

Cell& FOL_Eval(Heap& heap, Cell& args, Cell& envir)
{
 if(args.IsEmpty())
  throw std::runtime_error("The evaluator needs one argument at least");

 return heap.Evaluate(heap.Evaluate(args.GetHead(), envir), envir);
}

Cell& FOL_Print(Heap& heap, Cell& args, Cell& envir)
{
 if(heap.GetPrintOutput()!=NULL)
  for(Cell* qa=&args; qa->IsPair(); qa=&qa->GetTail())
   heap.Evaluate(qa->GetHead(), envir).Print(*heap.GetPrintOutput());

 return heap.CreateEmpty();
}

Realmente podríamos seguir así creando bibliotecas y bibliotecas de funciones.