From ba26544bec78e491c7836da4f7438739ce0a8935 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Fri, 27 Sep 2024 11:16:22 -0400 Subject: [PATCH] Revert "object: change to a stateful table" This reverts commit 3c34c4a5a7253df4417420bf276a78f8e9e1969b. --- linked-list.scm | 2 +- object.scm | 97 ++++++++++++++++++++----------------------------- read.scm | 2 +- set.scm | 36 ------------------ 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 . ;;; - -;;; 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. - (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)))))))) +;;; 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))))) -;;; (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))))) +;;; Create an object with TABLE as its procedure table. +(define object/table + (lambda (table) + (lambda (op . args) + (apply (object:lookup table op) 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))) +;;; 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)))))) + +;;; Convert a list of 'SYMBOL PROCEDURE ... into a table. +(define object:list->table + (lambda pairs + (object:append-table '() pairs))) + + +(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 ;;; ;;;;;