Revert "object: change to a stateful table"

This reverts commit 3c34c4a5a7253df4417420bf276a78f8e9e1969b.

4 files changed, 42 insertions, 95 deletions

diff --git a/linked-list.scm b/linked-list.scm
index 67e32ab..c9dff5b 100644
--- a/linked-list.scm
+++ b/linked-list.scm
@@ -27,7 +27,7 @@
         ((head '())
          (tail '())
          (this
-          (object/immutable-attributes
+          (object/procedures
            'push!
            (lambda (val)
              (set! head (cons val head))
diff --git a/object.scm b/object.scm
index d30574d..c03d599 100644
--- a/object.scm
+++ b/object.scm
@@ -11,64 +11,47 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 ;;; 
-
-;;; Create a new object.
-;;; 
-;;; Messages:
-;;; (SET! KEY VAL): Set KEY in the table to VAL.
-;;; (GET KEY): Get value of KEY in table.
-;;; (ADD-TYPE TYPE): Add TYPE to the list of types of the object.
-;;; (OF-TYPE? TYPE): Check if object has TYPE in the type list.
 ;;; 
-;;; Attributes:
-;;; TYPES: List of types associated with the object.
-(define object
-  (lambda ()
-    (let ((table (symbol-table)))
-      (table 'set! 'set! (lambda (key val) (table 'set! key val)))
-      (table 'set! 'get (lambda (key) (table 'get key)))
-      (table 'set! 'delete! (lambda (key) (table 'delete! key)))
-      (table 'set! 'types '(object))
-      (table 'set! 'add-type (lambda (type)
-                               (table 'set! 'type
-                                      (cons type (table 'get 'types)))))
-      (table 'set! 'of-type? (lambda (type)
-                               (memq type (table 'get 'types))))
+;;; Handles messages passed to objects. The state of each object is
+;;; expected to be in the table or in the environment. Each message
+;;; invokes a procedure whose name is the first argument to the object,
+;;; and the arguments to that procedure are the rest of the arguments to
+;;; the object.
+
+;;; Lookup NAME-AS-SYMBOL in TABLE and returns the handler, or the default
+;;; handler if not available.
+(define object:lookup
+  (lambda (table name-as-symbol)
+    (let ((node (smap:search table (symbol->string name-as-symbol))))
+      (if (null? node)
+          (set! node (smap:search table "default")))
+      (if (null? node)
+          (error "object:lookup" "no handler found for" name-as-symbol)
+          (map:val node)))))
+
+;;; Create an object with TABLE as its procedure table.
+(define object/table
+  (lambda (table)
+    (lambda (op . args)
+      (apply (object:lookup table op) args))))
+
+;;; Append procedures to a table.
+(define object:append-table
+  (lambda (table next-pairs)
+    (if (null? next-pairs)
+        table
+        (let ((key (symbol->string (car next-pairs)))
+              (proc (cadr next-pairs)))
+          (object:append-table
+           (car (smap:insert table key proc))
+           (cddr next-pairs))))))
 
-      (let ((must-execute-default
-             (lambda (op args)
-               (let ((proc (table 'get 'default)))
-                 (if (not proc)
-                     (error 'object 'invalid-op op args)
-                     (apply proc args))))))
-        (lambda (op . args)
-          (let ((proc (table 'get op)))
-            (if (not proc)
-                (must-execute-default op args)
-                (apply proc args))))))))
+;;; Convert a list of 'SYMBOL PROCEDURE ... into a table.
+(define object:list->table
+  (lambda pairs
+    (object:append-table '() pairs)))
 
-;;; (OBJECT/ATTRIBUTES NAME1 VAL1 NAME2 VAL2 ...)
-;;; creates a new object with NAME1 bound to VAL1, NAME2 bound to VAL2,
-;;; etc.
-(define object/attributes
-  (lambda args
-    (let ((obj (object)))
-      (letrec ((process-args
-                (lambda (name val . rest)
-                  (obj 'set! name val)
-                  (apply check-args rest)))
-               (check-args
-                (lambda args
-                  (if (null? args)
-                      obj
-                      (apply process-args args)))))
-        (apply check-args args)))))
 
-;;; Like OBJECT/ATTRIBUTES, but with SET!, GET, and DELETE! removed.
-(define object/immutable-attributes
-  (lambda args
-    (let ((obj (apply object/attributes args)))
-      (obj 'delete! 'set!)
-      (obj 'delete! 'get)
-      (obj 'delete! 'delete!)
-      obj)))
+(define object/procedures
+  (lambda procedures
+    (object/table (apply object:list->table procedures))))
\ No newline at end of file
diff --git a/read.scm b/read.scm
index 75d22e0..07d708c 100644
--- a/read.scm
+++ b/read.scm
@@ -77,7 +77,7 @@
              (datum-labels '())
              (fold-case? #f)
              (this
-              (object/immutable-attributes
+              (object/procedures
                'process
                (lambda (ch)
                  (this 'update-position! ch)
diff --git a/set.scm b/set.scm
index 6aa661d..52d10b6 100644
--- a/set.scm
+++ b/set.scm
@@ -467,42 +467,6 @@
           smap
           pairs)))
 
-;;; SYMBOL-TABLE:
-;;; 
-;;; A stateful map from symbols to values.
-;;; 
-;;; (SET! KEY VAL)
-;;; (DELETE! KEY)
-;;; (GET KEY)
-;;; (TYPE)
-(define symbol-table
-  (lambda ()
-    (let ((table '()))
-      (letrec ((insert!
-                (lambda (key val)
-                  (let ((ret (smap:insert table
-                                          (symbol->string key)
-                                          val)))
-                    (set! table (car ret))
-                    (cdr ret))))
-               (delete! (lambda (key) (smap:delete table (symbol->string
-                                                          key))))
-               (search
-                (lambda (key . default)
-                  (let ((ret (smap:search table (symbol->string key))))
-                    (if (null? ret)
-                        (if (null? default)
-                            #f
-                            (car default))
-                        (map:val ret))))))
-        (lambda (op . args)
-          (cond
-            ((eq? op 'set!) (apply insert! args))
-            ((eq? op 'delete!) (apply delete! args))
-            ((eq? op 'get) (apply search args))
-            ((eq? op 'type) 'symbol-table)
-            (else (error 'symbol-table 'unknown op args))))))))
-
 ;;; ;;;;;
 ;;; Tests
 ;;; ;;;;;