LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032821. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "DEFCLASS" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388078. :AUTHOR "REL3" :LENGTH-IN-BYTES 12211. :LENGTH-IN-BLOCKS 12. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-;;;;;; *************************************************************************;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.;;;;;; Use and copying of this software and preparation of derivative works;;; based upon this software are permitted.  Any distribution of this;;; software or derivative works must comply with all applicable United;;; States export control laws.;;; ;;; This software is made available AS IS, and Xerox Corporation makes no;;; warranty about the software, its performance or its conformity to any;;; specification.;;; ;;; Any person obtaining a copy of this software is requested to send their;;; name and post office or electronic mail address to:;;;   CommonLoops Coordinator;;;   Xerox Artifical Intelligence Systems;;;   2400 Hanover St.;;;   Palo Alto, CA 94303;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa);;;;;; Suggestions, comments and requests for improvements are also welcome.;;; *************************************************************************;;;(in-package 'pcl)(defvar *slotd-unsupplied* (list nil));;;; ;;;(defmacro defclass (name includes slots &rest options)  (declare (indentation 2 4 3 1))  (unless (legal-class-name-p name)    (error "The name argument to defclass was ~S.%~            It should have been a non-keyword symbol other than NIL."   name))  (unless (and (listp includes)       (every #'legal-class-name-p includes))    (error "The super-classes argument to defclass was ~S.%~            It should have been a list of legal class names."   includes))  (let ((metaclass 'class)(class-prototype nil))    ;; OK, hold your breath. We are now going to go through the list of    ;; options three times.  The reason we do it three times is that its    ;; conceptually simpler that way, and the list of options can hardly    ;; be expected to be very long.    ;;    ;; First copy the options because later they may be side-effected since    ;; they are used to communicate info from the parsing code to the class    ;; itself.  While we are at it convert any atomic options to a list of    ;; that atom.  This implements the questionable abbreviation that :foo    ;; is the same as (:foo).    (setq options (mapcar #'(lambda (o) (if (listp o) o (list o))) options))        ;; Now go see if there is a :metaclass option.  We need that before we    ;; can do anything else.  If there is a :metaclass option, we remove it    ;; from the options -- it isn't needed anymore since the class-protype    ;; communicates the same information.    (dolist (option options)      (when (eq (car option) ':metaclass)(unless (legal-class-name-p (cadr option))  (error "The value of the :metaclass option (~S) is not a~%~                   legal class name." (cadr option)))(unless (class-named (cadr option) t)  (error "The value of the :metaclass option (~S) does not~%~                  name a currently defined class.  The metaclass must be~%~                  defined at the time the defclass form is compiled or~%~                  evaluated." (cadr option)))(setq metaclass (cadr option)      options (delete option options))))    (setq class-prototype (class-prototype (class-named metaclass)))        ;; Now that we have the class-prototype, we can validate the    ;; rest of the options.    (dolist (option options)      (unless (legal-defclass-option-p class-prototype option)(error "~S is an illegal defclass option." option)))    (let ((prototype-class (class-prototype (class-named metaclass))))      (expand-defclass prototype-class name includes slots options       (list* 'defclass name includes slots options)))))(defun legal-class-name-p (x)  (and (symbolp x)       (not (keywordp x))       (not (null x))))(defmethod legal-defclass-option-p ((proto class) option)  (declare (ignore proto))  (memq (car option)'(:constructor :reader-prefix :accessor-prefix :documentation)))(defmethod expand-defclass ((proto class) name includes slots options whole)    (let* ((parsed-options   (parse-defclass-options proto options whole)) (parsed-slots   (parse-defclass-slots proto slots parsed-options whole)))        `(progn       (eval-when (load eval)  (record-definition ',name 'ndefstruct))       ;; Having to dump the unparsed options and whole in the file is a       ;; tragedy of Common Lisp.  If Common Lisp let me tell the dumper       ;; how to dump slotds this wouldn't happen.       (eval-when (load eval) (load-defclass   (class-prototype (class-named ',(class-name (class-of proto))))   ',name   ',(or includes (class-default-includes proto))   ',slots   ',parsed-options   ',whole))       ,(defclass-epilogue proto name parsed-options parsed-slots)       ',name)))(defmethod load-defclass ((proto class) name includes slots parsed-options w)  (setq parsed-options (copy-list parsed-options)) ;Have to copy it because   ;CL is allowed to share   ;lists in the fasl file.  (let* ((parsed-slots   (parse-defclass-slots proto slots parsed-options w)) (class   (add-named-class proto name includes parsed-slots parsed-options)))    (do-type-predicate-definition class name)    (do-accessor-definitions class name parsed-slots)))(defmethod parse-defclass-options ((proto class) options whole)  (declare (ignore proto whole))  (dolist (option options)    (when (listp option)      (case (car option)(:metaclass ())(:constructor ())(:reader-prefix ())(:accessor-prefix ())(:documentation ())(otherwise ()))))  options)(defmethod parse-defclass-slots ((proto class) slots parsed-options whole)  (let ((slotds   (mapcar #'(lambda (slot)      (parse-defclass-slot proto slot parsed-options whole))  slots)))    ;; Now go off and check to be sure that this defclass doesn't have    ;; incompatible accessors and readers, that it doesn't define the    ;; "same method" with different behavior.    (let ((entries ())  (losers ()))      (labels ((entry (gfun) (alist-entry entries gfun (lambda (x) (list x nil nil))))       (check (gfun slot type) (let ((entry (entry gfun)))        (ecase type     (:accessor       (when (and (cadr entry)  (not (memq slot (cadr entry)))) (pushnew entry losers))       (push slot (cadr entry)))          (:reader       (when (and (caddr entry)  (not (memq slot (caddr entry)))) (pushnew entry losers))       (push slot (caddr entry)))))))(dolist (slotd slotds)  (let ((slot-name (slotd-name slotd)))    (dolist (accessor (slotd-accessors slotd))      (check accessor slot-name ':accessor))    (dolist (reader (slotd-readers slotd))      (check reader slot-name ':reader))))(when losers  (complain-about-multiple-definitions losers))))        slotds))(defun complain-about-multiple-definitions (losers)  (setq losers (apply #'append losers))  (flet ((pretty-type (type)   (if (eq type :accessor) "an :accessor" "a :reader")))    (error      "This defclass defines incompatible accessor or reader methods.~       ~{~%For the generic-function ~S:~%~       accessors for the slot(s): ~:S, and readers for the slots(s): ~:S.~}"      losers)))(defmethod parse-defclass-slot ((proto class) slot parsed-options whole)  (declare (ignore whole))  (let ((name nil)(initform *slotd-unsupplied*)(accessors ())(readers ())(allocation ':instance)(type 't))    (cond ((symbolp slot)   (setq name slot))  ((null (cdr slot));Is this really legal??   (setq name (car slot)))  ((null (cddr slot))   (setq name (car slot) initform (cadr slot)))  (t   (setq name (car slot))   (let ((slot-options (cdr slot)))     (loop (when (null slot-options) (return t))   (case (car slot-options)     (:initform   (setq initform (cadr slot-options)))     (:accessor   (push (cadr slot-options) accessors))     (:reader     (push (cadr slot-options) readers))     (:allocation (setq allocation (cadr slot-options)))     (:type       (setq type (cadr slot-options))))   (setq slot-options (cddr slot-options))))))     (dolist (option parsed-options)      (when (listp option)(case (car option)  (:accessor-prefix    (push (intern (string-append (cadr option) name)) accessors))  (:reader-prefix    (push (intern (string-append (cadr option) name)) readers)))))    (make-slotd proto:name name:keyword (make-keyword name):initform initform:accessors accessors:readers readers:allocation allocation:type type)))(defmethod make-slotd ((class class) &rest keywords-and-options)  (declare (ignore class))  (apply #'make 'standard-slotd keywords-and-options))(defmethod defclass-epilogue ((proto class) name parsed-options parsed-slots)  `(progn      (deftype ,name () '(satisfies ,(type-predicate-name name)))     ,(make-constructor-definitions proto name parsed-options)     ,@(mapcar #'(lambda (slot) (defclass-slot-epilouge proto slot name))       parsed-slots)))(defmethod defclass-slot-epilouge ((proto class) slot name)  (declare (ignore proto))  (cons 'progn(mapcar #'(lambda (accessor)    `(defsetf ,accessor (,name) (new-value)       `(,',(make-setf-generic-function-name accessor) ,new-value ,,name)))(slotd-accessors slot))))(defun do-accessor-definitions (class name slotds)  (dolist (slotd slotds)    (do-accessor-definitions-internal      class name slotd (slotd-accessors slotd) (slotd-readers slotd))))(defun do-accessor-definitions-internal (class name slotd accessors readers)    (flet ((do-get-definition (accessor slotd)   (add-named-method accessor     `(,name)     `(,name)     (make-get-function class slotd))) (do-set-definition (accessor slotd)   (add-named-method (make-setf-generic-function-name accessor)     `(new-value ,name)     `(T ,name)     (make-set-function class slotd))))    (dolist (accessor accessors)      (do-get-definition accessor slotd)      (do-set-definition accessor slotd))    (dolist (reader readers slotd)      (do-get-definition reader slotd))))    (defmethod make-get-function ((class class) slotd)  (declare (ignore class))  (funcall (get-templated-function-constructor 'get-function--std-class)   (slotd-name slotd)))(defmethod make-set-function ((class class) slotd)  (declare (ignore class))  (funcall (get-templated-function-constructor 'set-function--std-class)   (slotd-name slotd)))(define-function-template get-function--std-class () '(slot-name)  `(function     (lambda (instance--std-class)       (get-slot--class instance--std-class slot-name))))(define-function-template set-function--std-class () '(slot-name)  `(function     (lambda (new-value instance--std-class)       (put-slot--class instance--std-class slot-name new-value))))(eval-when (load)  (pre-make-templated-function-constructor get-function--std-class)  (pre-make-templated-function-constructor set-function--std-class))(defmethod make-constructor-definitions ((proto class) name parsed-options)  (declare (ignore proto))  (cons 'progn(mapcar #'(lambda (option)    (when (and (listp option)       (eq (car option) ':constructor))      (setq option (cdr option))      (if (cdr option)  `(defun ,(car option) ,(cadr option)     (make ',name      ,@(iterate ((slot-name in (cadr option)))  (unless (memq slot-name'(&optional &rest &aux))    (collect `',(make-keyword slot-name))    (collect slot-name)))))  `(defun ,(car option) (&rest init-plist)     (apply #'make ',name init-plist)))))parsed-options)))(defmethod do-type-predicate-definition ((class class) name)  (setf (symbol-function (type-predicate-name name))(funcall  (get-templated-function-constructor 'type-predicate--std-class)  name)))(define-function-template type-predicate--std-class () '(class-name)  '(function (lambda (x)       (and (iwmc-class-p x)    (typep--class x class-name)))))(eval-when (load)  (pre-make-templated-function-constructor type-predicate--std-class))s macro does not prevent concurrent event processing;  ; see with-event-queu