Alex (alex14san) wrote,
Alex
alex14san

Простейший интерпретатор Lisp на C++

Lisp - очень красивый язык, который привлекает меня своей мощью и простотой. Название "Lisp" происходит от "List Processing", "обработки списков". Демонстрацией его простоты является, например, то, что его интерпретатор на C++ (в моем исполнении) занимает менее 20 килобайт :) Вот его текст:

/* ==========================================================================
   Simple Lisp interpreter.

   Coded in Nov-1997 by Alex Yakovlev aka Fantom
     ...as a part of MFV project.

   to do:
     * insert 2 varList -> kill prev; ???
       e.g. (setq a 'b), (setq a 'c) > ((a c) (a b))
     * CADR, CDDR, etc...
     * Binary Load/Save
     * ? What to do with unlimited recurursive calls?
     * ? Apply, Equal, And, Or, Not, Plus1,
       ... can be written in Lisp
     * renumber IDs
     * Local names for Lambda...

   Copyright (c) 1997 by AlexGraf Group.
   ========================================================================= */

#include <fstream.h>

typedef int boolean;
const boolean False = 0;
const boolean True  = 1;

boolean Debug = False;

// Object IDs, 0 to 999 are reserved

const

// Basics - Nil and T

  LNIL      =   0,
  LT        =   1,

// Lists processing - CAR, CDR and CONS

  LCAR      =  10,
  LCDR      =  11,
  LCONS     =  12,

// Basic predicates - Atom, Null and EQ

  LATOM     =  20,
  LNULL     =  21,
  LEQ       =  22,

// Evaluation - Cond, Eval, Quote, ..., Apply

  LCOND     =  30,
  LEVAL     =  31,
  LQUOTE    =  32,
  LSETQ     =  33,
  LDEFUN    =  34,

// Lisp key element - Lambda

  LLAMBDA   =  50,

// Arithmetics...

  LPLUS     = 100,
  LSUB      = 101,
  LMUL      = 102,
  LLT       = 103,
  LGT       = 104,
  LDIV      = 105,
  LMOD      = 106;

// Objects ID counter

int _ID = 1000;

int nextID() {

  return _ID++;
}

// Basic Lisp Objects

class LispObj *theNil;
class LispAtom *theT, *theQuote,
               *theAtom, *theNull, *theSetQ, *theCAR, *theCDR,
               *thePlus, *theEval, *theCons, *theEQ, *theMul,
               *theLambda, *theCond, *theSub, *theDefun, *theLT, *theGT,
               *theDiv,*theMod;

// Abstract object

class LispObj {
public:

  int objID;               // Object ID
  LispObj *car, *cdr;      // we have CAR & CDR for all objs...
                           // it's for fast calculation
  int refs;                // # of references to this object, 0 => kill this!
  int Atom;                // true, if this object is an Atom

// Constructor

  LispObj( int newID, int newAtom, LispObj *ncar, LispObj *ncdr ) {
    objID = newID;
    refs = 0;
    car = ncar; cdr = ncdr;
    Atom = newAtom;
  }

  virtual ~LispObj() { }

// Virtual Output to ostream

  virtual ostream& out( ostream & os ) {
    return os << "[ID = " << objID << "]";
  }

  friend ostream& operator<<(ostream& os, LispObj* LO) {
    return LO->out( os );
  }

// Evaluate object

  virtual LispObj *Eval() { return theNil; }

// Integer value or error - for convenience

  virtual IntVal( int &x ) { x = 0; return False; }

};


// Varlist - all variables list

LispObj *VarList = NULL;

// Delete object, if there's no references to it

inline void Try2Kill( LispObj *A ) {
  if( A->refs == 0 ) {
    delete A;
  }
}

// lisp Atom

class LispAtom *theAtoms = NULL;

class LispAtom : public LispObj {
public:

  char name[60];

  LispAtom *Next;    // We need to have a list of atoms

  LispAtom( int newID, char *aname ) : LispObj( newID, 1, theNil, theNil ) {
    strcpy( name, aname );

    Next = theAtoms; theAtoms = this;
  }

  virtual ~LispAtom() {
    // Clean up...
    for( LispAtom **A = &theAtoms; *A != this; A = &( (*A)->Next ) );
    *A = (*A)->Next;
  }

  virtual ostream& out( ostream & os ) {
    return os << name;
  }

  virtual LispObj *Eval() {

    // T
    if( this == theT ) return this;

    for( LispObj *A = VarList; A->objID; A=A->cdr ) {
      if( A->car->car == this )
        return A->car->cdr->car;
    }

    return theNil;
  }

};

// Nil is a specific object

class LispNil : public LispAtom {
public:

  LispNil() : LispAtom( LNIL, "Nil" ) {
    car = cdr = this;
    Atom = 0; // Nil will be a list
    refs++;
  }

};

// lisp integer numbers

class LispInt *theInts = NULL;

class LispInt : public LispObj {
public:

  int value;

  LispInt *Next;

  LispInt( int newID, int nval ) : LispObj( newID, 1, theNil, theNil ) {
    value = nval;
    Next = theInts; theInts = this;
  }

  virtual ~LispInt() {
    // Clean up...
    for( LispInt **A = &theInts; *A != this; A = &( (*A)->Next ) );
    *A = (*A)->Next;
  }

  virtual ostream& out( ostream & os ) {
    return os << value;
  }

  virtual LispObj *Eval() { return this; }

  virtual IntVal( int &x ) { x = value; return True; }

};

LispInt *FindInt( int v ) {
  for( LispInt *A = theInts; A; A=A->Next )
    if( A->value == v )
      return A;
  return new LispInt( nextID(), v );
}

boolean Apply( LispObj *Fn, LispObj *Arg, LispObj **Val );

// lisp basic element - List

class LispList : public LispObj {
public:

  LispList( int newID, LispObj *ncar, LispObj *ncdr )
  : LispObj( newID, 0, ncar, ncdr ) {

    car->refs++;
    cdr->refs++;

  }

  virtual ~LispList() {
    car->refs--; Try2Kill( car );
    cdr->refs--; Try2Kill( cdr );
  }

  virtual ostream& out( ostream & os ) {

    os << "(" << car;

    for( LispObj *X = this->cdr; X->objID; X = X->cdr ) {
      os << " " << X->car;
    }

    return os << ")";
  }

  virtual LispObj *Eval() {

    LispObj *A,*B;

    if( Apply( car, cdr, &B ) ) {
      if( Debug ) {
        cout << "Apply " << car << " to " << cdr << " gives " << B << endl;
      }
      return B;
    }

    A = car->Eval();
    if( A == theNil ) {
      if( Debug ) {
        cout << "Apply " << car << " to " << cdr << " gives " << theNil << endl;
      }
      return theNil;
    }

    if( ! Apply( A, cdr, &B ) ) {
      Try2Kill( A );
      if( Debug ) {
        cout << "Apply " << car << " to " << cdr << " gives " << theNil << endl;
      }
      return theNil;
    }

   // B->refs++;
    Try2Kill( A );
   // B->refs--;
    if( Debug ) {
      cout << "Apply " << car << " to " << cdr << " gives " << B << endl;
    }
    return B;
  }

};

// Init Lisp kernel

void LispInit() {

  // Nil is a funny object, being all including atom

  theNil    = new LispNil;

  theT      = new LispAtom( LT,      "T" );      theT->refs++;
  theQuote  = new LispAtom( LQUOTE,  "Quote" );  theQuote->refs++;
  theAtom   = new LispAtom( LATOM,   "Atom" );   theAtom->refs++;
  theNull   = new LispAtom( LNULL,   "Null" );   theNull->refs++;
  theSetQ   = new LispAtom( LSETQ,   "SetQ" );   theSetQ->refs++;
  theCAR    = new LispAtom( LCAR,    "CAR" );    theCAR->refs++;
  theCDR    = new LispAtom( LCDR,    "CDR" );    theCDR->refs++;
  theEval   = new LispAtom( LEVAL,   "Eval" );   theEval->refs++;
  theCons   = new LispAtom( LCONS,   "Cons" );   theCons->refs++;
  theEQ     = new LispAtom( LEQ,     "EQ" );     theEQ->refs++;
  theCond   = new LispAtom( LCOND,   "Cond" );   theCond->refs++;
  theLambda = new LispAtom( LLAMBDA, "Lambda" ); theLambda->refs++;
  theDefun  = new LispAtom( LDEFUN,  "Defun" );  theDefun->refs++;

  thePlus   = new LispAtom( LPLUS,   "Plus" );   thePlus->refs++;
  theSub    = new LispAtom( LSUB,    "Minus" );  theSub->refs++;
  theMul    = new LispAtom( LMUL,    "Mul" );    theMul->refs++;
  theGT     = new LispAtom( LGT,     "GT" );     theGT->refs++;
  theLT     = new LispAtom( LLT,     "LT" );     theLT->refs++;
  theDiv    = new LispAtom( LDIV,    "Div" );    theDiv->refs++;
  theMod    = new LispAtom( LMOD,    "Mod" );    theMod->refs++;

  VarList = theNil; VarList->refs++;
}

LispAtom *FindAtom( char *v ) {
  for( LispAtom *A = theAtoms; A; A=A->Next )
    if( strcmpi( A->name, v ) == 0 )
      return A;
  return new LispAtom( nextID(), v );
}

// Parse string to lisp object, recursive

int PStr( char * &s, LispObj * &A ) {

  while( *s == ' ' ) s++;

  if( *s == 0 ) return 2;
  if( *s == ')' ) return 3;

  // Quote?

  if( *s == 39 ) { // ' = Quote

    s++;
    LispObj *D = theNil;

    switch( PStr( s, D ) ) {
      case 0: Try2Kill( A );
              A = new LispList( nextID(), theQuote,
                  new LispList( nextID(), D, theNil ) ); return 0;
      case 2:
      case 3: cout << "Error: quote out of order" << endl;
      default: Try2Kill( A ); A = theNil; return 1;
    }

  }

  // Number?
  if( ( *s == '-' ) || ( *s >= '0' && *s <= '9' ) ) {

    int x=0, sign=0, flag=0;

    if( *s == '-' ) {
      sign = 1; s++;
    }

    for( ; *s != 0 && *s != ' ' && *s != '(' && *s != ')'; s++ ) {
      if( *s >= '0' && *s <= '9' ) {
        x = x*10 + *s - '0';
        flag = 1;
      } else {
        cout << "Error: invalid digit" << endl;
        return 1;
      }
    }

    if( ! flag ) A = FindAtom( "-" ); else
      A = FindInt( sign ? -x : x );
    return 0;
  }

  // List?
  if( *s == '(' ) {
    s++;
    LispObj *B, *D;
    D = theNil;
    switch( PStr( s, D ) ) {
      case 3: s++; return 0;
      case 2: cout << "Error: unmatched '('" << endl;
      case 1: Try2Kill( A ); A = theNil; return 1;
    }
    A = B = new LispList( nextID(), D, theNil );
    while( 1 ) {
      D = theNil;
      switch( PStr( s, D ) ) {
        case 3: s++; return 0;
        case 2: cout << "Error: unmatched '('" << endl;
        case 1: Try2Kill( A ); A = theNil; return 1;
      }
      B->cdr->refs--;
      B->cdr = new LispList( nextID(), D, theNil );
      B->cdr->refs++;
      B = B->cdr;
    }
  }

  // Atom?

  char nb[1024], *v;

  for( v=nb; *s != 0 && *s != 39 && *s != ' '
                     && *s != '(' && *s != ')'; s++ )
    *v++ = *s;
  *v = 0;

  A = FindAtom( nb );
  return 0;
}

// External entry to lisp parser

LispObj *ParseStr( char *s ) {

  LispObj *A = theNil;

  char *v = s;
  int r;

  switch( r = PStr( v, A ) ) {
    case 1:
    case 2:
    case 3: cout << "Parse: error code " << r << " at pos " << (v-s) << endl;
  }

  return A;
}

// ==========================================================================
//   Main calculation - Apply!

boolean Apply( LispObj *Fn, LispObj *Arg, LispObj **Val ) {

  LispObj *A,*B,*C,*D,*E;
  int f;

  if( Fn == theAtom ) {
    A = Arg->car->Eval();
    *Val = A->Atom ? theT : theNil;
    Try2Kill( A );
    return True;
  }
  if( Fn == theNull ) {
    A = Arg->car->Eval();
    *Val = A == theNil ? theT : theNil;
    Try2Kill( A );
    return True;
  }
  if( Fn == theCAR ) {
    A = Arg->car->Eval();
    *Val = A->car;
    (*Val)->refs++;
    Try2Kill( A );
    (*Val)->refs--;
    return True;
  }
  if( Fn == theCDR ) {
    A = Arg->car->Eval();
    *Val = A->cdr;
    (*Val)->refs++;
    Try2Kill( A );
    (*Val)->refs--;
    return True;
  }
  if( Fn == theQuote ) {
    *Val = Arg->car;
    return True;
  }

  if( Fn == theDefun ) {
    if( ! Arg->car->Atom ) { *Val = theNil; return True; }
    VarList->refs--;
    VarList = new LispList( nextID(),
                new LispList( nextID(), Arg->car,
                new LispList( nextID(), // *Val =
                  new LispList( nextID(), theLambda,
                  new LispList( nextID(), Arg->cdr->car,
                  new LispList( nextID(), Arg->cdr->cdr->car, theNil ) ) ),
                theNil ) ),
              VarList );
    VarList->refs++;
    *Val = Arg->car;
    return True;
  }

  if( Fn == theSetQ ) {
    if( ! Arg->car->Atom ) { *Val = theNil; return True; }

    if( Arg->cdr == theNil ) {
      LispObj **X;
      for( X = &VarList; *X != theNil; X = & (*X)->cdr ) {
        if( (*X)->car->car == Arg->car ) {
          A = *X;
          cout << "Del: " << ( (*X)->car->cdr->car ) << endl;
          *X = A->cdr;
          A->refs--;
          (*X)->refs++;
          Try2Kill( A );
        }
      }

      *Val = theNil;
      return True;
    } else {
      A = Arg->cdr->car->Eval();
      VarList->refs--;
      VarList = new LispList( nextID(),
                new LispList( nextID(), Arg->car,
                new LispList( nextID(), A, theNil ) ), VarList );
      VarList->refs++;
      *Val = A;
      return True;
    }
  }

  if( Fn == theEval ) {
    A = Arg->car->Eval();
    *Val = A->Eval();
    (*Val)->refs++;
    Try2Kill( A );
    (*Val)->refs--;
    return True;
  }
  if( Fn == theEQ ) {
    A = Arg->car->Eval();
    B = Arg->cdr->car->Eval();
    *Val = A == B ? theT : theNil;
    Try2Kill( A );
    Try2Kill( B );
    return True;
  }
  if( Fn == theCons ) {
    B = Arg->cdr->car->Eval();
    if( B->Atom ) { Try2Kill( B ); *Val = theNil; return True; }
    A = Arg->car->Eval();
    *Val = new LispList( nextID(), A, B );
    return True;
  }
  if( Fn == theCond ) {
    for( A = Arg; A != theNil; A = A->cdr ) {
      if( A->car->cdr == theNil ) {
        B = A->car->car->Eval();
        if( B != theNil ) { *Val = B; return True; }
        Try2Kill( B );
      } else {
        B = A->car->car->Eval();
        f = B != theNil;
        Try2Kill( B );
        if( f ) {
          *Val = A->car->cdr->car->Eval();
          return True;
        }
      }
    }
    *Val = theNil;
    return True;
  }

  if( Fn == theMul ) {
    int v=1,t;

    if( Arg == theNil ) { *Val = theNil; return True; }

    B = theNil;
    for( A = Arg; A != theNil; A = A->cdr ) {
      C = A->car->Eval();
      f = C->IntVal( t );
      Try2Kill( A );
      if( !f ) { *Val = B; return True; }
      v *= t;
    }
    *Val = FindInt( v );
    return True;
  }
  if( Fn == thePlus ) {
    int v=0,t;

    if( Arg == theNil ) { *Val = theNil; return True; }

    B = theNil;
    for( A = Arg; A != theNil; A = A->cdr ) {
      C = A->car->Eval();
      f = C->IntVal( t );
      Try2Kill( A );
      if( !f ) { *Val = B; return True; }
      v += t;
    }
    *Val = FindInt( v );
    return True;
  }

  if( Fn == theDiv ) {
    int a,b,fa,fb;
    A = Arg->car->Eval();
    B = Arg->cdr->car->Eval();
    fa = A->IntVal( a );
    fb = B->IntVal( b );
    Try2Kill( A );
    Try2Kill( B );
    if( !fa || !fb ) { *Val = theNil; return True; }
    *Val = FindInt( a / b );
    return True;
  }
  if( Fn == theMod ) {
    int a,b,fa,fb;
    A = Arg->car->Eval();
    B = Arg->cdr->car->Eval();
    fa = A->IntVal( a );
    fb = B->IntVal( b );
    Try2Kill( A );
    Try2Kill( B );
    if( !fa || !fb ) { *Val = theNil; return True; }
    *Val = FindInt( a % b );
    return True;
  }

  if( Fn == theGT ) {
    int a,b,fa,fb;
    A = Arg->car->Eval();
    B = Arg->cdr->car->Eval();
    fa = A->IntVal( a );
    fb = B->IntVal( b );
    Try2Kill( A );
    Try2Kill( B );
    if( !fa || !fb ) { *Val = theNil; return True; }
    *Val = a > b ? theT : theNil;
    return True;
  }
  if( Fn == theLT ) {
    int a,b,fa,fb;
    A = Arg->car->Eval();
    B = Arg->cdr->car->Eval();
    fa = A->IntVal( a );
    fb = B->IntVal( b );
    Try2Kill( A );
    Try2Kill( B );
    if( !fa || !fb ) { *Val = theNil; return True; }
    *Val = a < b ? theT : theNil;
    return True;
  }
  if( Fn == theSub ) {
    int v=0,t;

    if( Arg == theNil ) { *Val = theNil; return True; }

    B = theNil;
    for( A = Arg; A != theNil; A = A->cdr ) {
      C = A->car->Eval();
      f = C->IntVal( t );
      Try2Kill( A );
      if( !f ) { *Val = B; return True; }
      v = t - v;
    }
    *Val = FindInt( -v );
    return True;
  }

  if( Fn->car == theLambda ) {
    // Lambda calculation... ( (lambda (x) (plus x 2)) 6 )
    // car->car = 'Lambda'
    // car->(cdr)->car = '(x)'
    // car->cdr->cdr->car = '(plus x 2)'
    // (cdr)->car = '6'

    // Parse arguments first
    if( Debug ) cout << "Push( Arg )" << endl;
    C = D = VarList;
    for( A = Fn->cdr->car, B = Arg;
         A != theNil; A = A->cdr, B = B->cdr ) {
      D = new LispList( nextID(),
          new LispList( nextID(), A->car,
          new LispList( nextID(), B->car->Eval(), theNil ) ), D );
      if( Debug )
        cout << "Arg " << D->car->car << " = " << D->car->cdr->car << endl;
    }
    VarList->refs--;
    VarList = D;
    VarList->refs++;

    // Then - function call
    *Val = Fn->cdr->cdr->car->Eval();

    // Then delete temp arguments
    VarList->refs--;
    A = VarList;
    VarList = C;
    VarList->refs++;
    Try2Kill( A );
    if( Debug ) cout << "Pop( Arg )" << endl;

    // That's all!
    return True;
  }

  return False;
}

void Write( ostream & a, LispObj *V ) {
  if( V == theNil ) return;
  Write( a, V->cdr );
  a << "(SetQ " << V->car->car << " '" << V->car->cdr->car << ")" << endl;
}

void FRead( char *v ) {

  ifstream a( v );
  LispObj *A,*B;
  char s[ 1024 ];

  while( a.good() ) {

    *s = 0;
    a.getline( s, sizeof( s ) );
    if( ! *s ) continue;

    A = ParseStr( s );
    cout << "<< " << A << endl;
    B = A->Eval();
    cout << ">> " << B << endl;

    B->refs++;
    Try2Kill( A );
    B->refs--;
    Try2Kill( B );
  }
}

void FWrite( char *v ) {
  ofstream a( v );
  Write( a, VarList );
}

void WriteAtoms( LispAtom *A ) {
  if( !A ) return;
  if( A->Next ) WriteAtoms( A->Next );
  cout << "Atom: " << A << endl;
}

// ==========================================================================

void main()
{
  cout << "Simple Lisp interpreter by Fantom aka Alex Yakovlev." << endl
       << "Copyright (c) 1997 by AlexGraf Group."
       << endl << endl;

  LispInit();

  LispObj *A, *B;

  boolean quit = False;
  char s[ 1024 ], *v;

  FRead( "Vars.l" );
  cout << endl;

  cout << "Type ! for help"
       << endl << endl;

  do {
    cout << "<- " << flush;
    cin.getline( s, sizeof( s ) );
    v = strchr( s, '\n' );
    if( v ) *v = 0;

    if( strcmpi( s, "!" ) == 0 ) {
      cout << "Simple lisp interpreter help" << endl
           << "  !  - this help" << endl
           << "  !q - quit" << endl
           << "  !a - atoms list" << endl
           << "  !w - write [vars.l]" << endl
           << "  !r - exec [vars.l]" << endl
           << "  !v - vars list" << endl
           << "  !d - debug on/off" << endl;
      continue;
    }

    if( strcmpi( s, "!q" ) == 0 ) {
      FWrite( "Vars.l" );
      quit = True; break;
    }

    if( strcmpi( s, "!v" ) == 0 ) {
      for( A = VarList; A != theNil; A = A->cdr )
        cout << A->car->car << " = " << A->car->cdr->car << endl;
      continue;
    }

    if( strcmpi( s, "!D" ) == 0 ) {
      Debug = !Debug; continue;
    }
    if( strcmpi( s, "!a" ) == 0 ) {
      WriteAtoms( theAtoms );
      continue;
    }

    if( strcmpi( s, "!w" ) == 0 ||
        strnicmp( s, "!w ", 3 ) == 0 ) {
      v = s[2] == ' ' ? s+3 : "vars.l";
      FWrite( v );
      cout << "Vars written to '" << v << "'." << endl;
      continue;
    }

    if( strcmpi( s, "!r" ) == 0 ||
        strnicmp( s, "!r ", 3 ) == 0 ) {
      v = s[2] == ' ' ? s+3 : "vars.l";
      FRead( v );
      cout << "Vars read from '" << v << "'." << endl;
      continue;
    }

    A = ParseStr( s );

    B = A->Eval();
    B->out( cout << "-> " ) << endl;

    B->refs++;
    Try2Kill( A );
    B->refs--;
    Try2Kill( B );

  } while( !quit );

  VarList->refs--; Try2Kill( VarList );
}
Tags: alexgraf, it, lisp
  • Post a new comment

    Error

    default userpic
  • 0 comments