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 . ;;; + +;;; Create a new object. ;;; -;;; 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. +;;; 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)))) -;;; 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))))) + (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)))))))) -;;; Create an object with TABLE as its procedure table. -(define object/table - (lambda (table) - (lambda (op . args) - (apply (object:lookup table op) 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))))) -;;; 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 +;;; 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 ;;; ;;;;;