object: change to a stateful table

1 files changed, 57 insertions, 40 deletions

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)))