object: change to a stateful table

4 files changed, 95 insertions, 42 deletions

diff --git a/linked-list.scm b/linked-list.scm
index c9dff5b..67e32ab 100644
--- a/linked-list.scm
+++ b/linked-list.scm
@@ -27,7 +27,7 @@
         ((head '())
          (tail '())
          (this
-          (object/procedures
+          (object/immutable-attributes
            'push!
            (lambda (val)
              (set! head (cons val head))
diff --git a/object.scm b/object.scm
index c03d599..d30574d 100644
--- a/object.scm
+++ b/object.scm
@@ -11,47 +11,64 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 ;;; 
-;;; 
-;;; 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))))))
+;;; 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))))
 
-;;; Convert a list of 'SYMBOL PROCEDURE ... into a table.
-(define object:list->table
-  (lambda pairs
-    (object:append-table '() 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))))))))
 
+;;; (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)))))
 
-(define object/procedures
-  (lambda procedures
-    (object/table (apply object:list->table procedures))))
\ No newline at end of file
+;;; 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)))
diff --git a/read.scm b/read.scm
index 07d708c..75d22e0 100644
--- a/read.scm
+++ b/read.scm
@@ -77,7 +77,7 @@
              (datum-labels '())
              (fold-case? #f)
              (this
-              (object/procedures
+              (object/immutable-attributes
                'process
                (lambda (ch)
                  (this 'update-position! ch)
diff --git a/set.scm b/set.scm
index 52d10b6..6aa661d 100644
--- a/set.scm
+++ b/set.scm
@@ -467,6 +467,42 @@
           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
 ;;; ;;;;;