;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
;;;
;;; *************************************************************************
;;; 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)
(eval-when (compile load eval)
(fix-early-generic-functions))
;;
;;;;;; Pending defmeths which I couldn't do before.
;;
(eval-when (load eval)
(setf (symbol-function 'print-instance)
(symbol-function 'print-object)))
(eval-when (load)
(define-meta-class essential-class (lambda (x) (%instance-ref x 0)))
(defmethod class-slots ((class essential-class))
(declare (ignore class))
())
(defmethod allocate-instance ((class essential-class))
(let ((primitive-instance
(%allocate-instance (class-named 'essential-class)
(1+ (length (class-slots class))))))
(setf (%instance-ref primitive-instance 0) class)
primitive-instance))
(defmethod slot-value-using-class ((class essential-class) object slot-name)
(let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
(if pos
(%instance-ref object (1+ pos))
(slot-missing ;class
object slot-name))))
(defmethod put-slot-using-class ((class essential-class)
object
slot-name
new-value)
(let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
(if pos
(setf (%instance-ref object (1+ pos)) new-value)
(slot-missing ;class
object slot-name))))
(defmethod optimize-slot-value (class form) ;This lossage ha to go away
(declare (ignore class)) ;now that we know that
form) ;standard class is it.
(defmethod optimize-setf-of-slot-value (class form)
(declare (ignore class))
form)
(defmethod make-slotd ((class essential-class) &rest keywords-and-options)
(declare (ignore class))
(apply #'make-slotd--essential-class keywords-and-options))
;(defmethod add-named-class ((proto-class essential-class) name
; local-supers
; local-slot-slotds
; extra)
; ;; First find out if there is already a class with this name.
; ;; If there is, call class-for-redefinition to get the class
; ;; object to use for the new definition. If there is no exisiting
; ;; class we just make a new instance.
; (let* ((existing (class-named name t))
; (class (if existing
; (class-for-redefinition existing proto-class name
; local-supers local-slot-slotds
; extra)
; (make-instance (class-of proto-class)))))
;
; (setq local-supers
; (mapcar
; #'(lambda (ls)
; (or (class-named ls t)
; (error "~S was specified as the name of a local-super~%~
; for the class named ~S. But there is no class~%~
; class named ~S." ls name ls)))
; local-supers))
;
; (setf (class-name class) name)
;; (setf (class-ds-options class) extra) ;This is NOT part of the
;; ;standard protocol.
;
; (add-class class local-supers local-slot-slotds extra)
;
; (setf (class-named name) class)
; name))
(defmethod supers-changed ((class essential-class)
old-local-supers
old-local-slots
extra
top-p)
(declare (ignore old-local-supers old-local-slots top-p))
(let ((cpl (compute-class-precedence-list class)))
(setf (class-class-precedence-list class) cpl)
; (update-slots--class class cpl) ;This is NOT part of
; ;the essential-class
; ;protocol.
(dolist (sub-class (class-direct-subclasses class))
(supers-changed sub-class
(class-local-supers sub-class)
(class-local-slots sub-class)
extra
nil))
; (when top-p ;This is NOT part of
; (update-method-inheritance class old-local-supers));the essential-class
; ;protocol.
))
(defmethod slots-changed ((class essential-class)
old-local-slots
extra
top-p)
(declare (ignore top-p old-local-slots))
;; When this is called, class should have its local-supers and
;; local-slots slots filled in properly.
; (update-slots--class class (class-class-precedence-list class))
(dolist (sub-class (class-direct-subclasses class))
(slots-changed sub-class (class-local-slots sub-class) extra nil)))
;(defmethod method-equal (method argument-specifiers options)
; (declare (ignore options))
; (equal argument-specifiers (method-type-specifiers method)))
(defmethod methods-combine-p ((d generic-function))
(declare (ignore d))
nil)
)
;;
;;;;;;
;;
(define-method-body-macro call-next-method ()
:global :error
:method (expand-call-next-method
(macroexpand-time-method macroexpand-time-environment)
nil
macroexpand-time-environment))
(defmethod expand-call-next-method ((mex-method method) args mti)
(declare (ignore args))
(let* ((arglist (method-arglist mex-method))
(uid (macroexpand-time-method-uid mti))
(applyp nil))
(multiple-value-setq (arglist applyp) (make-call-arguments arglist))
(cond ((null (method-type-specifiers mex-method))
(warn "Using call-next-method in a default method.~%~
At run time this will generate an error.")
`(error "Using call-next-method in a default method."))
(applyp
`(apply #'call-next-method-internal ,uid . ,arglist))
(t
`(call-next-method-internal ,uid . ,arglist)))))
(defun call-next-method-internal (current-method &rest args)
(let* ((generic-function (method-generic-function current-method))
(type-specifiers (method-type-specifiers current-method))
(most-specific nil)
(most-specific-type-specifiers ())
(dispatch-order (slot-value--funcallable-standard-class
(class-of generic-function)
generic-function
'dispatch-order
nil
nil)))
(iterate ((method in (generic-function-methods generic-function)))
(let ((method-type-specifiers (method-type-specifiers method))
(temp ()))
(and (every #'(lambda (arg type-spec)
(or (eq type-spec 't)
(memq type-spec
(slot-value--class
(class-of arg) 'class-precedence-list))))
args method-type-specifiers)
(eql 1 (setq temp (compare-type-specifier-lists
type-specifiers
method-type-specifiers
()
args
()
dispatch-order)))
(or (null most-specific)
(eql 1 (setq temp (compare-type-specifier-lists
method-type-specifiers
most-specific-type-specifiers
()
args
()
dispatch-order))))
(setq most-specific method
most-specific-type-specifiers method-type-specifiers))))
(if (or most-specific
(setq most-specific (generic-function-default-method
generic-function)))
(apply (method-function most-specific) args)
(error "no super method found"))))
;;;
;;; This is kind of bozoid because it always copies the lambda-list even
;;; when it doesn't need to. It also doesn't remember things it could
;;; remember, causing it to call memq more than it should. Fix this one
;;; day when there is nothing else to do.
;;;
(defun make-call-arguments (lambda-list &aux applyp)
(setq lambda-list (reverse lambda-list))
(when (memq '&aux lambda-list)
(setq lambda-list (cdr (memq '&aux lambda-list))))
(setq lambda-list (nreverse lambda-list))
(let ((optional (memq '&optional lambda-list)))
(when optional
;; The &optional keyword appears in the lambda list.
;; Get rid of it, by moving the rest of the lambda list
;; up, then go through the optional arguments, replacing
;; them with the real symbol.
(setf (car optional) (cadr optional)
(cdr optional) (cddr optional))
(iterate ((loc on optional))
(when (memq (car loc) lambda-list-keywords)
(unless (memq (car loc) '(&rest &key &allow-other-keys))
(error
"The non-standard lambda list keyword ~S appeared in the~%~
lambda list of a method in which CALL-NEXT-METHOD is used.~%~
PCL can only deal with standard lambda list keywords."))
(when (listp (car loc)) (setf (car loc) (caar loc)))))))
(let ((rest (memq '&rest lambda-list)))
(cond ((not (null rest))
;; &rest appears in the lambda list. This means we
;; have to do an apply. We ignore the rest of the
;; lambda list, just grab the &rest var and set applyp.
(setf (car rest) (if (listp (cadr rest))
(caadr rest)
(cadr rest))
(cdr rest) ())
(setq applyp t))
(t
(let ((key (memq '&key lambda-list)))
(when key
;; &key appears in the lambda list. Remove &key from the
;; lambda list then replace all the keywords with pairs of
;; the actual keyword followed by the value variable.
;; Have to parse the hairy triple case of &key.
(let ((key-args
(iterate ((arg in (cdr key)))
(until (eq arg '&allow-other-keys))
(cond ((symbolp arg)
(collect (make-keyword arg))
(collect arg))
((cddr arg)
(collect (caddr arg))
(collect (car arg)))
(t
(collect (make-keyword (car arg)))
(collect (car arg)))))))
(if key-args
(setf (car key) (car key-args)
(cdr key) (cdr key-args))
(setf (cdr key) nil
lambda-list (remove '&key lambda-list)))))))))
(values lambda-list applyp))