Add more functionalities to the VM.

7 files changed, 277 insertions, 82 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 1a2e80f0..3a792c7f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,33 @@
+2014-09-16  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
+	* rt/vm.cc (VM::Environment::Environment): Define.
+	(VM::Environment::~Environment): Likewise.
+	(VM::Symbol::Symbol): Rework.
+	(VM::BasicContext::make_package): Define.
+	(VM::BasicContext::make_keyword): Likewise.
+	(VM:BasicContext::make_symbol): Remove.
+	(VM::BasicContext::make_operator): Tidy.
+	* include/vm.H (VM::to_bool): New.
+	(VM::to_value): Likewise.
+	(VM::SymbolAttribute): Likewise.
+	(VM::Symbol): Rework.
+	(VM::CmpByName): New helper class.
+	(VM::setf_symbol_function): New helper function.
+	(VM::Environment): Move from Lisp.H.
+	(VM::FunctionBase): Derive from VM::Callable.
+	* include/sexpr.H (Sexpr::SymbolSyntax::Kind): Now bitmask type.
+	(Sexpr::binary_form): New.
+	(Sexpr::Include): Derive from it.
+	(Sexpr::Exclude): Likewise.
+	(Sexpr::Allocator): Adjust.
+	* syntax/sexpr.cc (Sexpr::finish_include): New.
+	(Sexpr::finish_exclude): Likewise.
+	(Sexpr::read_sharp_et_al): Use them.
+	* include/Lisp.H: Adjust.  Move Environment to vm.H.
+	(Lisp::Evaluator): Tidy.
+	* rt/Lisp.cc (define_special_value_constants): New.
+	(Lisp::Evaluator::Evaluator): Call it.
+
 2014-08-26  Raoul B.  <raoulb@bluewin.ch>
 
 	* algebra/combfunc.spad.pamphlet
diff --git a/src/include/Lisp.H b/src/include/Lisp.H
index 724ab54b..119d07f8 100644
--- a/src/include/Lisp.H
+++ b/src/include/Lisp.H
@@ -47,21 +47,21 @@
 
 namespace std {
    template<>
-   struct hash<OpenAxiom::VM::Scope>  {
+   struct hash<OpenAxiom::VM::Package>  {
       hash<OpenAxiom::VM::String>::result_type
-      operator()(const OpenAxiom::VM::Scope& s) const {
-         return h(s.name());
+      operator()(const OpenAxiom::VM::Package& s) const {
+         return h(s.name);
       }
       hash<OpenAxiom::VM::String> h;
    };
 
    template<>
-   struct equal_to<OpenAxiom::VM::Scope> {
-      using arg_type = OpenAxiom::VM::Scope;
+   struct equal_to<OpenAxiom::VM::Package> {
+      using arg_type = OpenAxiom::VM::Package;
       bool operator()(const arg_type& x, const arg_type& y) const {
-         return p(x.name(), y.name());
+         constexpr equal_to<OpenAxiom::VM::String> eq { };
+         return eq(x.name, y.name);
       }
-         equal_to<OpenAxiom::VM::String> p;
    };
 }
 
@@ -79,24 +79,20 @@ namespace OpenAxiom {
          explicit IntegerOverflow(const std::string&);
       };
       
-      // -- Environments.
-      using Environment = std::map<Symbol*, Value>;
-
       // -- Anchor maps
       using AnchorTable = std::map<Ordinal, Value>;
 
       // -- Evaluator --
       struct Evaluator : VM::BasicContext {
          Evaluator();
-         Scope* keyword_namespace() { return &keys; }
-         Scope* active_namespace() { return ns; }
+         Package* core_package() { return core; }
+         Package* current_package() { return ns; }
          Value toplevel_form(const Sexpr::Syntax*);
          Value make_value(const Sexpr::Syntax*);
          Environment* global_environment();
       private:
-         Scope keys;
-         std::unordered_set<Scope> packages;
-         Scope* ns;
+         Package* core;
+         Package* ns;
          std::list<Environment> env_stack;
          AnchorTable anchor_map;
       };
diff --git a/src/include/sexpr.H b/src/include/sexpr.H
index 84513a8b..d3dafcb7 100644
--- a/src/include/sexpr.H
+++ b/src/include/sexpr.H
@@ -139,10 +139,10 @@ namespace OpenAxiom {
       // ------------------
       struct SymbolSyntax : AtomSyntax {
          enum Kind {
-            uninterned,         // uninterned symbol
-            ordinary,           // an interned symbol
-            absolute,           // case-sensitive symbol
-            keyword             // a keyword symbol
+            ordinary   = 0x0,   // an interned symbol
+            uninterned = 0x1,   // uninterned symbol
+            absolute   = 0x2,   // case-sensitive symbol
+            keyword    = 0x4,   // a keyword symbol
          };
          SymbolSyntax(const Lexeme&, Kind);
          Kind kind() const { return sort; }
@@ -188,6 +188,17 @@ namespace OpenAxiom {
          const Syntax* const form;
       };
 
+      template<typename T>
+      struct binary_form : Syntax {
+         const Syntax* first() const { return rep.first; }
+         const Syntax* second() const { return rep.second; }
+         void accept(Visitor&) const;
+      protected:
+         binary_form(const Syntax* f, const Syntax* s) : rep(f, s) { }
+      private:
+         std::pair<const Syntax*, const Syntax*> rep;
+      };
+
       // -----------------
       // -- QuoteSyntax --
       // -----------------
@@ -240,16 +251,16 @@ namespace OpenAxiom {
       // -- Include --
       // -------------
       // Conditional inclusion syntax object
-      struct Include : unary_form<Include> {
-         explicit Include(const Syntax*);
+      struct Include : binary_form<Include> {
+         Include(const Syntax*, const Syntax*);
       };
 
       // -------------
       // -- Exclude --
       // -------------
       // Conditional exclusion syntax object
-      struct Exclude : unary_form<Exclude> {
-         explicit Exclude(const Syntax*);
+      struct Exclude : binary_form<Exclude> {
+         Exclude(const Syntax*, const Syntax*);
       };
 
       // ----------------
@@ -322,6 +333,12 @@ namespace OpenAxiom {
          v.visit(static_cast<const T&>(*this));
       }
 
+      template<typename T>
+      void
+      binary_form<T>::accept(Visitor& v) const {
+         v.visit(static_cast<const T&>(*this));
+      }
+
       // ---------------
       // -- Allocator --
       // ---------------
@@ -342,8 +359,8 @@ namespace OpenAxiom {
          const Eval* make_eval(const Syntax*);
          const Splice* make_splice(const Syntax*);
          const Function* make_function(const Syntax*);
-         const Include* make_include(const Syntax*);
-         const Exclude* make_exclude(const Syntax*);
+         const Include* make_include(const Syntax*, const Syntax*);
+         const Exclude* make_exclude(const Syntax*, const Syntax*);
          const ListSyntax* make_list(const std::vector<const Syntax*>&, bool = false);
          const VectorSyntax* make_vector(const std::vector<const Syntax*>&);
          
diff --git a/src/include/vm.H b/src/include/vm.H
index c66a2e02..9337955b 100644
--- a/src/include/vm.H
+++ b/src/include/vm.H
@@ -41,8 +41,8 @@
 #include <open-axiom/string-pool>
 #include <stdint.h>
 #include <utility>
-#include <map>
 #include <set>
+#include <vector>
 #include <type_traits>
 
 #define internal_type struct alignas(16)
@@ -163,6 +163,14 @@ namespace OpenAxiom {
          t   = 0x10,            // distinguished T value
       };
 
+      constexpr bool to_bool(Value v) {
+         return v != Value::nil;
+      }
+
+      constexpr Value to_value(bool b) {
+         return b ? Value::t : Value::nil;
+      }
+
       template<typename>
       struct ValueTrait {
       };
@@ -208,11 +216,18 @@ namespace OpenAxiom {
          return is<Dynamic>(v) ? to_dynamic(v) : nullptr;
       }
 
-      inline Value from_dynamic(const Dynamic* o) {
+      template<typename T>
+      using IfDynamic = typename
+         std::enable_if<std::is_base_of<Dynamic, T>::value, Value>::type;
+
+      template<typename T>
+      inline IfDynamic<T> to_value(const T* o) {
          return Value(ValueBits(o) | ValueTrait<Dynamic>::tag);
       }
 
-      struct Scope;
+      // -- Callable --
+      struct Callable : Dynamic {
+      };
       
       // -------------
       // -- Fixnum ---
@@ -351,13 +366,27 @@ namespace OpenAxiom {
          const Type* type;
       };
 
+      struct Package;
+
+      enum class SymbolAttribute {
+         None             = 0x0,    // No particular attribute.
+         Constant         = 0x1,    // Symbol defined constant.
+         SpecialBinding   = 0x2,    // Symbol declared special.
+         Keyword          = 0x4,    // A keyword symbol.
+         SpecialConstant  = Constant | SpecialBinding,
+      };
+
       // ------------
       // -- Symbol --
       // ------------
-      struct Symbol : Dynamic, std::pair<String, Scope*> {
-         Symbol(String, Scope*);
-         String name() const { return first; }
-         Scope* scope() const { return second; }
+      struct Symbol : Dynamic {
+         const InternedString name;
+         Value value;
+         const Callable* function;
+         Pair properties;
+         Package* package;
+         SymbolAttribute attributes;
+         explicit Symbol(InternedString);
       };
 
       inline Symbol* to_symbol_if_can(Value v) {
@@ -368,29 +397,53 @@ namespace OpenAxiom {
          return to_symbol_if_can(v) != nullptr;
       }
 
-      inline Value from_symbol(const Symbol* s) {
-         return from_dynamic(s);
+      struct CmpByName {
+         template<typename T>
+         bool operator()(const T& x, const T& y) const {
+            return std::less<String>()(x.name, y.name);
+         }
+      };
+
+      template<typename T>
+      inline const T* setf_symbol_function(Symbol* sym, const T* fun) {
+         sym->function = fun;
+         return fun;
       }
+      
+      // -- Environments.
+      struct Environment {
+         struct Binding {
+            Symbol* symbol;
+            Value value;
+         };
 
-      // -----------
-      // -- Scope --
-      // -----------
-      struct Scope : Dynamic, private std::map<Symbol*, Value> {
-         explicit Scope(InternedString n) : id(n) { }
-         InternedString name() const { return id; }
-         Value* lookup(Symbol*) const;
-         Value* define(Symbol*, Value);
+         Environment();
+         ~Environment();
+
+         void bind(Symbol*, Value);
       private:
-         const InternedString id;
+         std::vector<Binding> lexical;
+         std::vector<Binding> dynamic;
+      };
+
+      // -------------
+      // -- Package --
+      // -------------
+      struct Package : Dynamic {
+         const InternedString name;
+         std::set<Symbol, CmpByName> symbols;
+
+         explicit Package(InternedString);
+         Symbol* make_symbol(InternedString);
       };
 
       // --------------
       // -- Function --
       // --------------
-      struct FunctionBase : Dynamic {
-         const Symbol name;
+      struct FunctionBase : Callable {
+         const Symbol* name;
          Value type;
-         FunctionBase(Symbol n, Value t = Value::nil)
+         FunctionBase(const Symbol* n, Value t = Value::nil)
                : name(n), type(t) { }
       };
 
@@ -407,7 +460,9 @@ namespace OpenAxiom {
       template<typename Code>
       struct BuiltinFunction : FunctionBase {
          Code code;
-         BuiltinFunction(Symbol n, Code c) : FunctionBase(n), code(c) { }
+         BuiltinFunction(const Symbol* n, Code c)
+               : FunctionBase(n), code(c)
+         { }
       };
 
       using NullaryOperator = BuiltinFunction<NullaryCode>;
@@ -423,20 +478,26 @@ namespace OpenAxiom {
          BasicContext();
          ~BasicContext();
 
+         Package* make_package(InternedString);
+         Symbol* make_keyword(InternedString);
          Pair make_pair(Value, Value);
-         const Symbol* make_symbol(String, Scope*);
-         const NullaryOperator* make_operator(Symbol, NullaryCode);
-         const UnaryOperator* make_operator(Symbol, UnaryCode);
-         const BinaryOperator* make_operator(Symbol, BinaryCode);
-         const TernaryOperator* make_operator(Symbol, TernaryCode);
+         const NullaryOperator* make_operator(Symbol*, NullaryCode);
+         const UnaryOperator* make_operator(Symbol*, UnaryCode);
+         const BinaryOperator* make_operator(Symbol*, BinaryCode);
+         const TernaryOperator* make_operator(Symbol*, TernaryCode);
+
+         Package* keyword_package() const { return keywords; }
+         Package* homeless_package() const { return homeless; }
 
       protected:
-         std::set<Symbol> syms;
+         std::set<Package, CmpByName> packages;
          Memory::Factory<ConsCell> conses;
          Memory::Factory<NullaryOperator> nullaries;
          Memory::Factory<UnaryOperator> unaries;
          Memory::Factory<BinaryOperator> binaries;
          Memory::Factory<TernaryOperator> ternaries;
+         Package* keywords;
+         Package* homeless;
       };
    };
 }
diff --git a/src/rt/Lisp.cc b/src/rt/Lisp.cc
index f87db63c..fd1f5289 100644
--- a/src/rt/Lisp.cc
+++ b/src/rt/Lisp.cc
@@ -1,4 +1,4 @@
-// Copyright (C) 2013, Gabriel Dos Reis.
+// Copyright (C) 2013-2014, Gabriel Dos Reis.
 // All rights reserved.
 // Written by Gabriel Dos Reis.
 //
@@ -37,6 +37,30 @@
 
 namespace OpenAxiom {
    namespace Lisp {
+      namespace {
+         template<typename T>
+         struct NamedConstant {
+            const char* const name;
+            const T value;
+         };
+      }
+
+      constexpr NamedConstant<Value> value_constants[] = {
+         { "NIL", Value::nil },
+         { "T", Value::t },
+         { "MOST-NEGATIVE-FIXNUM", from_fixnum(Fixnum::minimum) },
+         { "MOST-POSITIVE-FIXNUM", from_fixnum(Fixnum::maximum) },
+      };
+
+      static void define_special_value_constants(Evaluator* ctx) {
+         auto core = ctx->core_package();
+         for (auto& x : value_constants) {
+            auto sym = core->make_symbol(ctx->intern(x.name));
+            sym->value = x.value;
+            sym->attributes = SymbolAttribute::SpecialConstant;
+         }
+      }
+
       Unimplemented::Unimplemented(const std::string& s)
             : BasicError(s)
       { }
@@ -134,13 +158,13 @@ namespace OpenAxiom {
          auto s = ctx->intern(x.lexeme().begin(), x.lexeme().size());
          switch (x.kind()) {
          case Sexpr::SymbolSyntax::uninterned:
-            return from_symbol(ctx->make_symbol(s, nullptr));
+            return to_value(ctx->homeless_package()->make_symbol(s));
 
          case Sexpr::SymbolSyntax::keyword:
-            return from_symbol(ctx->make_symbol(s, ctx->keyword_namespace()));
+            return to_value(ctx->make_keyword(s));
 
          default:
-            return from_symbol(ctx->make_symbol(s, ctx->active_namespace()));
+            return to_value(ctx->current_package()->make_symbol(s));
          }
       }
 
@@ -199,7 +223,11 @@ namespace OpenAxiom {
          return v;
       }
 
-      Evaluator::Evaluator() : keys(intern("KEYWORD")), ns() {
+      Evaluator::Evaluator()
+            : core(make_package(intern("AxiomCore"))),
+              ns(core)
+      {
+         define_special_value_constants(this);
          env_stack.push_back(Environment{ });
       }
 
@@ -242,7 +270,7 @@ namespace OpenAxiom {
 
       static void format(const Symbol* s, std::ostream& os) {
          // FIXME: Handle escapes.
-         auto n = s->name();
+         auto n = s->name;
          std::copy(n->begin(), n->end(), std::ostream_iterator<char>(os));
       }
       
diff --git a/src/rt/vm.cc b/src/rt/vm.cc
index a0f4f2e3..7f5cd5fc 100644
--- a/src/rt/vm.cc
+++ b/src/rt/vm.cc
@@ -1,4 +1,4 @@
-// Copyright (C) 2011-2013, Gabriel Dos Reis.
+// Copyright (C) 2011-2014, Gabriel Dos Reis.
 // All rights reserved.
 // Written by Gabriel Dos Reis.
 //
@@ -36,12 +36,41 @@
 
 namespace OpenAxiom {
    namespace VM {
+      // -- Environement
+      Environment::Environment() = default;
+
+      Environment::~Environment() {
+         // Restore value of special variables bound in this environment.
+         const auto end = dynamic.rend();
+         for (auto p = dynamic.rbegin(); p != end; ++p)
+            p->symbol->value = p->value;
+      }
+
+      // -- Dynamic
       Dynamic::~Dynamic() { }
 
-      Symbol::Symbol(String n, Scope* s)
-            : std::pair<String, Scope*>(n, s)
+      // -- Symbol
+      Symbol::Symbol(InternedString s)
+            : name(s),
+              value(),
+              function(),
+              properties(),
+              package(),
+              attributes()
       { }
 
+      // -- Package
+      Package::Package(InternedString s)
+            : name(s)
+      { }
+
+      Symbol*
+      Package::make_symbol(InternedString s) {
+         auto sym = const_cast<Symbol*>(&*symbols.insert(Symbol(s)).first);
+         sym->package = this;
+         return sym;
+      }
+
       Fixnum
       count_nodes(Pair p) {
          FixnumBits n = 1;
@@ -51,36 +80,48 @@ namespace OpenAxiom {
       }
 
       // -- BasicContext --
-      Pair BasicContext::make_pair(Value h, Value t) {
-         return conses.make(h, t);
+      Package*
+      BasicContext::make_package(InternedString n) {
+         auto p = &*packages.insert(Package(n)).first;
+         return const_cast<Package*>(p);
+      }
+
+      Symbol*
+      BasicContext::make_keyword(InternedString n) {
+         auto sym = keyword_package()->make_symbol(n);
+         sym->value = to_value(sym);
+         sym->attributes = SymbolAttribute::Keyword;
+         return sym;
       }
 
-      const Symbol*
-      BasicContext::make_symbol(String n, Scope* s) {
-         return &*syms.insert({ n, s }).first;
+      Pair BasicContext::make_pair(Value h, Value t) {
+         return conses.make(h, t);
       }
 
       const NullaryOperator*
-      BasicContext::make_operator(Symbol n, NullaryCode c) {
-         return nullaries.make(n, c);
+      BasicContext::make_operator(Symbol* n, NullaryCode c) {
+         return setf_symbol_function(n, nullaries.make(n, c));
       }
       
       const UnaryOperator*
-      BasicContext::make_operator(Symbol n, UnaryCode c) {
-         return unaries.make(n, c);
+      BasicContext::make_operator(Symbol* n, UnaryCode c) {
+         return setf_symbol_function(n, unaries.make(n, c));
       }
       
       const BinaryOperator*
-      BasicContext::make_operator(Symbol n, BinaryCode c) {
-         return binaries.make(n, c);
+      BasicContext::make_operator(Symbol* n, BinaryCode c) {
+         return setf_symbol_function(n, binaries.make(n, c));
       }
       
       const TernaryOperator*
-      BasicContext::make_operator(Symbol n, TernaryCode c) {
-         return ternaries.make(n, c);
+      BasicContext::make_operator(Symbol* n, TernaryCode c) {
+         return setf_symbol_function(n, ternaries.make(n, c));
       }
       
-      BasicContext::BasicContext() {
+      BasicContext::BasicContext()
+            : keywords(make_package(intern("KEYWORD"))),
+              homeless(make_package(nullptr))
+      {
       }
 
       BasicContext::~BasicContext() {
diff --git a/src/syntax/sexpr.cc b/src/syntax/sexpr.cc
index 6b73d5a0..97413935 100644
--- a/src/syntax/sexpr.cc
+++ b/src/syntax/sexpr.cc
@@ -223,10 +223,14 @@ namespace OpenAxiom {
       Function::Function(const Syntax* s) : unary_form<Function>(s) { }
 
       // -- Include --
-      Include::Include(const Syntax* s) : unary_form<Include>(s) { }
+      Include::Include(const Syntax* c, const Syntax* s)
+            : binary_form<Include>(c, s)
+      { }
 
       // -- Exclude --
-      Exclude::Exclude(const Syntax* s) : unary_form<Exclude>(s) { }
+      Exclude::Exclude(const Syntax* c, const Syntax* s)
+            : binary_form<Exclude>(c, s)
+      { }
 
       // -- ListSyntax --
       ListSyntax::ListSyntax() : dot(false) { }
@@ -325,13 +329,13 @@ namespace OpenAxiom {
       }
 
       const Include*
-      Allocator::make_include(const Syntax* s) {
-         return incs.make(s);
+      Allocator::make_include(const Syntax* c, const Syntax* s) {
+         return incs.make(c, s);
       }
 
       const Exclude*
-      Allocator::make_exclude(const Syntax* s) {
-         return excs.make(s);
+      Allocator::make_exclude(const Syntax* c, const Syntax* s) {
+         return excs.make(c, s);
       }
 
       const ListSyntax*
@@ -553,6 +557,22 @@ namespace OpenAxiom {
       }
 
       static const Syntax*
+      finish_include(Reader::State& s) {
+         ++s.cur;
+         auto cond = read_sexpr(s);
+         auto form = read_sexpr(s);
+         return s.alloc.make_include(cond, form);
+      }
+
+      static const Syntax*
+      finish_exclude(Reader::State& s) {
+         ++s.cur;
+         auto cond = read_sexpr(s);
+         auto form = read_sexpr(s);
+         return s.alloc.make_exclude(cond, form);
+      }
+
+      static const Syntax*
       read_sharp_et_al(Reader::State& s) {
          if (++s.cur >= s.end)
             syntax_error("end-of-input reached after sharp sign");
@@ -562,6 +582,8 @@ namespace OpenAxiom {
          case ':': return finish_uninterned_symbol(s);
          case '.': return finish_readtime_eval(s);
          case '\\': return finish_character(s);
+         case '+': return finish_include(s);
+         case '-': return finish_exclude(s);
 
          default:
             if (isdigit(*s.cur))