UNSLISP/object.scm

;;; Copyright (C) Peter McGoron 2024
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, version 3 of the License.
;;; 
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; 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))))

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

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