home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part04 / defclass.l < prev    next >
Encoding:
Text File  |  1987-07-30  |  13.1 KB  |  339 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. (in-package 'pcl)
  28.  
  29.  
  30.   ;;   
  31. ;;;;;; New New Minglewood Blues
  32.   ;;   the new "legendary macro itself"
  33. ;;;
  34. (defmacro ndefstruct (name-and-options &rest slot-descriptions)
  35.   ;;
  36.   ;; The defstruct macro does some pre-processing on name-and-options and
  37.   ;; slot-descriptions before it passes them on to expand-defstruct. It
  38.   ;; also pulls out the documentation string (if there is one) and passes
  39.   ;; it to expand defstruct as a separate argument.
  40.   ;;
  41.   ;; The main reason for doing this is that it imposes more uniformity in
  42.   ;; the syntax of defstructs for different metaclasses, and it puts some
  43.   ;; useful error checking for that syntax in one central place.
  44.   ;; 
  45.   (let ((documentation (and (stringp (car slot-descriptions))
  46.                 (pop slot-descriptions))))
  47.     (or (listp name-and-options) (setq name-and-options (list name-and-options)))
  48.     (setq slot-descriptions
  49.           (iterate ((sd in slot-descriptions))
  50.             (collect
  51.               (cond ((not (listp sd)) (list sd nil))
  52.                     (t (unless (evenp (length sd))
  53.                          (error "While parsing the defstruct ~S, the slot-description: ~S~%~
  54.                                  has an odd number of elements."
  55.                                 (car name-and-options) sd))
  56.                        sd)))))
  57.     (keyword-parse ((class 'structure))
  58.                    (cdr name-and-options)
  59.       (let ((class-object (class-named class t)))
  60.         (if class-object
  61.             (expand-defstruct
  62.               (class-prototype class-object) name-and-options documentation slot-descriptions)
  63.             (error "The argument to defstruct's :class option was ~S;~%~
  64.                     but there is no class named ~S."
  65.                    class class))))))
  66.  
  67. (defmacro defclass (name includes slots &rest options)
  68.   (keyword-parse ((metaclass 'class)) options
  69.     (let ((metaclass-object (class-named metaclass t)))
  70.       (or metaclass-object 
  71.       (error "The class option to defclass was ~S,~%~
  72.                   but there is no class with that name."
  73.          metaclass))
  74.       (or (subclassp metaclass-object 'class)
  75.       (error
  76.         "The class specified in the :metaclass option to defclass, ~S,~%~
  77.             is not a subclass of the class class."
  78.         metaclass))
  79.       (expand-defclass metaclass-object name includes slots options))))
  80.  
  81. (defmethod expand-defclass ((metaclass class) name includes slots options)
  82.   (keyword-parse ((accessor-prefix nil accessor-prefix-p)) options
  83.     (when (and accessor-prefix-p
  84.            (not (or (null accessor-prefix)
  85.             (symbolp accessor-prefix))))
  86.       (error "The :accessor-prefix option, when specified must have either~%~
  87.               have an argument which is a symbol, or no argument at all."))
  88.     (setq slots (iterate ((slot in slots))
  89.           (collect
  90.             (cond ((and (listp slot)
  91.                 (cddr slot))
  92.                (let ((initform
  93.                    (if (memq :initform (cdr slot))
  94.                        (cadr (memq :initform (cdr slot)))
  95.                        *slotd-unsupplied*)))
  96.                  (list* (car slot) initform (cdr slot))))
  97.               ((listp slot) slot)
  98.               (t (list slot *slotd-unsupplied*))))))
  99.     `(ndefstruct (,name (:class ,(class-name metaclass))
  100.             (:include ,includes)
  101.             ,@(and accessor-prefix-p
  102.                    `((:conc-name ,accessor-prefix)))
  103.             (:generate-accessors ,(and accessor-prefix-p
  104.                            'method))
  105.             ,@options)
  106.      ,@slots)))
  107.  
  108. (defmeth expand-defstruct ((class basic-class) name-and-options documentation slot-descriptions)
  109.   (ignore documentation)
  110.   (let* ((name (car name-and-options))
  111.          (ds-options (parse-defstruct-options class name (cdr name-and-options)))
  112.          (slotds (parse-slot-descriptions class ds-options slot-descriptions)))
  113.     `(progn
  114.        (eval-when (load eval)     
  115.      (record-definition ',name 'ndefstruct))
  116.        ;; Start by calling add-named-class which will actually define the new
  117.        ;; class, updating the class lattice obsoleting old instances etc.
  118.        (eval-when (compile load eval)
  119.          (add-named-class
  120.        (class-prototype (class-named ',(class-name (class-of class))))
  121.        ',name
  122.        ',(or (ds-options-includes ds-options)
  123.          (class-default-includes class))
  124.        ',slotds
  125.        ',ds-options))
  126.        ,@(expand-defstruct-make-definitions class name ds-options slotds)
  127.        ',name)))
  128.  
  129. (defmeth expand-defstruct-make-definitions ((class basic-class)
  130.                          name ds-options slotds)
  131.   (append (make-accessor-definitions class name ds-options slotds)
  132.           (make-constructor-definitions class name ds-options slotds)
  133.           (make-copier-definitions class name ds-options slotds)
  134.           (make-predicate-definitions class name ds-options slotds)
  135.           (make-print-function-definitions class name ds-options slotds)))
  136.  
  137. (define-function-template iwmc-class-accessor () '(slot-name)
  138.   `(function (lambda (iwmc-class) (get-slot--class iwmc-class slot-name))))
  139.  
  140. (eval-when (load)
  141.   (pre-make-templated-function-constructor iwmc-class-accessor))
  142.  
  143. (define-function-template iwmc-class-accessor-setf (read-only-p) '(slot-name)
  144.   (if read-only-p
  145.       `(function
  146.          (lambda (iwmc-class new-value)
  147.        (error "~S is a read only slot." slot-name)))
  148.       `(function
  149.          (lambda (iwmc-class new-value)
  150.        (put-slot--class iwmc-class slot-name new-value)))))
  151.  
  152.  
  153. (eval-when (load)
  154.   (pre-make-templated-function-constructor iwmc-class-accessor-setf nil)
  155.   (pre-make-templated-function-constructor iwmc-class-accessor-setf t))
  156.  
  157. (defmethod make-iwmc-class-accessor ((ignore class) slotd)
  158.   (funcall (get-templated-function-constructor 'iwmc-class-accessor)
  159.        (slotd-name slotd)))
  160.  
  161. (defmethod make-iwmc-class-accessor-setf ((ignore class) slotd)
  162.   (funcall
  163.     (get-templated-function-constructor 'iwmc-class-accessor-setf
  164.                     (slotd-read-only slotd))
  165.     (slotd-name slotd)))
  166.  
  167. (defun add-named-method-early (discriminator-name
  168.                    arglist
  169.                    argument-specifiers
  170.                    function)
  171.   (if (null *real-methods-exist-p*)
  172.       (unless (memq discriminator-name *protected-early-selectors*)
  173.     (setf (symbol-function discriminator-name) function))
  174.       (add-named-method (class-prototype (class-named 'discriminator))
  175.             (class-prototype (class-named 'method))
  176.             discriminator-name
  177.             arglist
  178.             argument-specifiers
  179.             ()
  180.             function)))
  181.   
  182. (defmeth make-accessor-definitions
  183.      ((class basic-class) name ds-options slotds)
  184.   (ignore class ds-options)
  185.   (cons `(do-accessor-definitions ',name ',slotds)
  186.     (iterate ((slotd in slotds))
  187.       (let ((accessor (slotd-accessor slotd))
  188.         setf-discriminator-name)
  189.         (when accessor
  190.           (setq setf-discriminator-name
  191.             (make-setf-discriminator-name accessor))
  192.           (compile-time-define 'defun accessor)
  193.           (compile-time-define 'defun setf-discriminator-name)
  194.           (compile-time-define 'defsetf accessor setf-discriminator-name)
  195.           (collect `(defsetf ,accessor ,setf-discriminator-name)))))))
  196.  
  197. (defun do-accessor-definitions (name slotds)
  198.   (let ((class (class-named name))
  199.     (accessor nil)
  200.     (setf-discriminator-name nil))
  201.     (dolist (slotd slotds)
  202.       (when (setq accessor (slotd-accessor slotd))
  203.     (setq setf-discriminator-name
  204.           (make-setf-discriminator-name accessor))
  205.     (unless *real-methods-exist-p*
  206.       (record-early-discriminator accessor)
  207.       (record-early-discriminator setf-discriminator-name))
  208.     (add-named-method-early accessor
  209.                 `(,name)
  210.                 `(,class)
  211.                 (or (slotd-get-function slotd)
  212.                     (make-iwmc-class-accessor class slotd)))
  213.     (add-named-method-early setf-discriminator-name
  214.                 `(,name new-value)
  215.                 `(,class)
  216.                 (or (slotd-put-function slotd)
  217.                     (make-iwmc-class-accessor-setf class
  218.                                    slotd)))))
  219.     (unless *real-methods-exist-p*
  220.       (record-early-method-fixup
  221.     `(let ((*real-methods-exist-p* t))
  222.        (do-accessor-definitions ',name ',slotds))))))
  223.  
  224. (defmeth make-constructor-definitions ((class basic-class) name ds-options slotds)
  225.   (ignore class slotds)
  226.   (let ((constructors (ds-options-constructors ds-options)))
  227.     (iterate ((constructor in constructors))
  228.       (when (car constructor)
  229.         (collect
  230.           (if (cdr constructor)
  231.               `(defun ,(car constructor) ,(cadr constructor)
  232.                  (make ',name ,@(iterate ((slot-name in (cadr constructor)))
  233.                                          (unless (memq slot-name
  234.                                                        '(&optional &rest &aux))
  235.                                            (collect `',(make-keyword slot-name))
  236.                                            (collect slot-name)))))
  237.               `(defun ,(car constructor) (&rest init-plist)
  238.                  (apply #'make ',name init-plist))))))))
  239.  
  240. (define-function-template copier--class () ()
  241.   `(function
  242.      (lambda (iwmc-class)
  243.        (let* ((class (class-of iwmc-class))
  244.               (to (make-instance (class-of iwmc-class)))
  245.               (from-static (iwmc-class-static-slots iwmc-class))        
  246.               (to-static (iwmc-class-static-slots to))
  247.               (static-slots (class-instance-slots class)))
  248.          (do ((i 0 (+ i 1))
  249.           (index nil index)         
  250.               (x static-slots (cdr x)))
  251.              ((null x))
  252.        (setq index (%convert-slotd-position-to-slot-index i))
  253.            (setf (%static-slot-storage-get-slot--class to-static index)
  254.                  (%static-slot-storage-get-slot--class from-static index)))
  255.          (setf (iwmc-class-dynamic-slots to)
  256.                (copy-list (iwmc-class-dynamic-slots iwmc-class)))
  257.          to))))
  258.  
  259. (eval-when (load)
  260.   (pre-make-templated-function-constructor copier--class))
  261.  
  262. (defmeth make-copier-definitions ((class basic-class) name ds-options slotds)
  263.   (ignore class slotds)
  264.   (let ((copier (ds-options-copier ds-options)))    
  265.     (when copier
  266.       (compile-time-define 'defun copier)
  267.       `((do-copier-definition ',name ',copier)))))
  268.  
  269. (defun do-copier-definition (class-name copier-name)
  270.   (unless *real-methods-exist-p*
  271.     (record-early-discriminator copier-name)
  272.     (record-early-method-fixup
  273.       `(let ((*real-methods-exist-p* t))
  274.      (do-copier-definition ',class-name ',copier-name))))
  275.   (add-named-method-early copier-name
  276.               `(,class-name)
  277.               `(,(class-named class-name))
  278.               (funcall
  279.                 (get-templated-function-constructor
  280.                   'copier--class))))
  281.  
  282. (define-function-template iwmc-class-predicate () '(class-name)
  283.   `(function (lambda (x)
  284.            (and (iwmc-class-p x)
  285.             (typep--class x class-name)))))
  286.  
  287. (eval-when (load)
  288.   (pre-make-templated-function-constructor iwmc-class-predicate))
  289.  
  290. (defmeth make-predicate-definitions ((class basic-class)
  291.                      name ds-options slotds)
  292.   (ignore class slotds)
  293.   (let ((predicate (or (ds-options-predicate ds-options)
  294.                        (make-symbol (string-append name " Predicate")))))
  295.     (compile-time-define 'defun predicate)
  296.     `((do-predicate-definition ',name ',predicate)
  297.       (deftype ,name () '(satisfies ,predicate)))))
  298.  
  299. (defun do-predicate-definition (class-name predicate-name)
  300.   (setf (symbol-function predicate-name)
  301.     (funcall (get-templated-function-constructor 'iwmc-class-predicate)
  302.          class-name)))
  303.  
  304. (defun make-print-function-definitions
  305.       (class name ds-options slotds)
  306.   (ignore class slotds)
  307.   (let* ((print-function (ds-options-print-function ds-options))
  308.      (arglist ())
  309.      (defun ())
  310.      (defun-name ()))
  311.     (when print-function
  312.       (cond ((symbolp print-function)
  313.          (setq arglist '(object stream depth)))
  314.         ((and (listp print-function) (eq (car print-function) 'lambda))
  315.          (setq arglist (cadr print-function)
  316.            defun-name (intern 
  317.                 (string-append (symbol-name name)
  318.                            " Print Function"))
  319.            defun `(defun ,defun-name ,arglist
  320.                 ,@(cddr print-function))
  321.            print-function defun-name))
  322.         (t
  323.          (error "Internal error, make-print-function-definitions can't~%~
  324.                      understand the contents of the print-function slot of~%~
  325.                      the ds-options.")))
  326.       `(,defun
  327.     (do-print-function-definitions ',name ',arglist ',print-function)))))
  328.  
  329. (defun do-print-function-definitions (name arglist print-function)
  330.   (unless *real-methods-exist-p*
  331.     (record-early-method-fixup
  332.       `(let ((*real-methods-exist-p* t))
  333.      (do-print-function-definitions ',name ',arglist ',print-function))))
  334.   (add-named-method-early 'print-instance
  335.               arglist
  336.               (list (class-named name))
  337.               print-function))
  338.  
  339.