;;;-*-Mode:LISP; Package:(PCL LISP 1000); 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 *early-defclass-forms*
'(
(defclass t () ())
(defclass object (t) ())
(defclass standard-class (object)
((name
:initform nil
:accessor class-name)
(class-precedence-list
:initform ()
:accessor class-precedence-list
:accessor class-class-precedence-list)
(local-supers
:initform ()
:accessor class-local-supers)
(local-slots
:initform ()
:accessor class-local-slots)
(direct-subclasses
:initform ()
:accessor class-direct-subclasses)
(direct-methods
:initform ()
; :accessor class-direct-methods ;This is defined by hand
;during bootstrapping.
)
(forward-referenced-supers
:initform ()
:accessor class-forward-referenced-supers)
(no-of-instance-slots
:initform 0
:accessor class-no-of-instance-slots)
(instance-slots
:initform ())
(non-instance-slots
:initform ()
:accessor class-non-instance-slots)
(wrapper
:initform nil
:accessor class-wrapper)
(direct-generic-functions
:initform ()
:accessor class-direct-generic-functions)
(prototype
:initform nil)
(options
:initform ()
:accessor class-options)
(constructors
:initform ()
:accessor class-constructors)))
(defclass standard-slot-description (object)
((name
:initform nil
; :accessor slotd-name ;This is defined by hand
;during bootstrapping.
)
(keyword
:initform nil
:accessor slotd-keyword)
(initform
:initform *slotd-unsupplied*
:accessor slotd-initform)
(accessors
:initform nil
:accessor slotd-accessors)
(readers
:initform nil
:accessor slotd-readers)
(allocation
:initform nil
:accessor slotd-allocation)
(type
:initform nil
:accessor slotd-type)))
))
(defvar *fsc-defclass-forms*
'((defclass funcallable-standard-class (standard-class)
())))
(defvar *methods-defclass-forms*
'(
(defclass standard-method ()
((function
:initform nil)
(generic-function
:initform nil)
(type-specifiers
:initform ())
(arglist
:initform ())
(options
:initform ())
(documentation
:initform nil))
(:accessor-prefix method-))
(defclass standard-reader/writer-method (standard-method)
((slot-name nil))
;; There is a hand coded reader method for this which appears
;; in the beginning of methods. See the comment there.
;(:reader-prefix reader/writer-method)
)
(defclass standard-reader-method (standard-reader/writer-method) ())
(defclass standard-writer-method (standard-reader/writer-method) ())
(defclass standard-generic-function ()
((name
:initform nil)
(methods
:initform ())
(discriminating-function
:initform ())
(classical-method-table
:initform nil)
(cache
:initform ())
(pretty-arglist
:initform ())
(method-class
:initform (class-named 'standard-method))
(dispatch-order
:initform :default))
(:metaclass funcallable-standard-class)
(:accessor-prefix generic-function-))
; (defclass standard-generic-function (generic-function)
; (
; (method-combination-type
; :initform :daemon
; :accessor method-combination-type)
; (method-combination-parameters
; :initform ()
; :accessor method-combination-parameters)
; (methods-combine-p
; :initform ()
; :accessor methods-combine-p))
; (:metaclass funcallable-standard-class))
))
;;;
;;; make-setf-method-lambda-list is used by any part of PCL that has to
;;; construct the lambda-list of a setf-method from an access lambda list
;;; and a new value lambda list. This function is not (yet) a documented
;;; part of CLOS, but it is a documented part of PCL.
;;;
(defun make-setf-method-lambda-list (access-lambda-list new-value-lambda-list)
(when (or (cdr new-value-lambda-list)
(memq (car new-value-lambda-list) lambda-list-keywords))
(error "The new-value lambda-list is only allowed to contain one~%~
argument, and it must be a required argument.~%~
The new-value lambda-list ~S is illegal."
new-value-lambda-list))
(let* ((setf-ll (list nil))
(setf-tail setf-ll)
(access-tail access-lambda-list))
(loop
(cond ((null access-tail)
(setf (cdr setf-tail) (list (car new-value-lambda-list)))
(return (cdr setf-ll)))
((memq (car access-tail) lambda-list-keywords)
(setf (cdr setf-tail) (cons (car new-value-lambda-list)
(copy-list access-tail)))
(return (cdr setf-ll)))
(t
(setf (cdr setf-tail) (list (pop access-tail))
setf-tail (cdr setf-tail)))))))
;;;
;;; This is like fdefinition on the Lispm. If Common Lisp had something like
;;; function specs I wouldn't need this. On the other hand, I don't like the
;;; way this really works so maybe function specs aren't really right either?
;;;
;;; I also don't understand the real implications of a Lisp-1 on this sort of
;;; thing. Certainly some of the lossage in all of this is because these
;;; SPECs name global definitions.
;;;
;;; Note that this implementation is set up so that an implementation which
;;; has a 'real' function spec mechanism can use that instead and in that way
;;; get rid of setf generic function names.
;;;
(defmacro parse-gspec (spec
(non-setf-var . non-setf-case)
(setf-var . setf-case))
(declare (indentation 1 1))
(once-only (spec)
`(cond ((symbolp ,spec)
(let ((,non-setf-var ,spec)) ,@non-setf-case))
((and (listp ,spec)
(eq (car ,spec) 'setf)
(symbolp (cadr ,spec)))
(let ((,setf-var (cadr ,spec))) ,@setf-case))
(t
(error "Can't understand ~S as a generic function specifier.~%~
It must be either a symbol which can name a function or~%~
a like ~S, where the car is the symbol ~S and the cadr~%~
is a symbol which can name a generic function."
,spec '(setf <foo>) 'setf)))))
;;;
;;; Note that this is just one possible implementation of these functions. In
;;; particular, an implementation that has some 'real' function spec mechanism
;;; is free to redefine these functions not to use these crufty setf generic
;;; function names.
;;;
(defvar *setf-generic-function-names* (make-hash-table :size 100))
(defun get-setf-generic-function-name (name)
(or (gethash name *setf-generic-function-names*)
(setf (gethash name *setf-generic-function-names*)
(intern (string-append "setf " name)
(symbol-package name)))))
(defun gboundp (spec)
(parse-gspec spec
(name (fboundp name))
(name (fboundp (get-setf-generic-function-name name)))))
(defun gmakunbound (spec)
(parse-gspec spec
(name (fmakunbound name))
(name (fmakunbound (get-setf-generic-function-name name)))))
(defun gdefinition (spec)
(parse-gspec spec
(name (or (macro-function name) ;??
(symbol-function name)))
(name (symbol-function (get-setf-generic-function-name name)))))
(defun set-gdefinition (spec new-value)
(parse-gspec spec
(name (setf (symbol-function name)
new-value))
(name (setf (symbol-function (get-setf-generic-function-name name))
new-value))))
(defsetf gdefinition set-gdefinition)
;;;
;;; This is the documented function (in the CLOS spec) for getting at the setf
;;; generic function for a symbol. Of course propagating all these different
;;; namespaces this way is folly, but since we are on a (losing) roll...
;;;
(defun GET-SETF-GENERIC-FUNCTION (name)
(gdefinition `(setf ,name)))
(defsetf get-setf-generic-function (name) (new-value)
`(setf (gdefinition ,name) ,new-value))
;;;
;;; do-defmethod-setf-defsetf is called whenever any part of PCL (typically
;;; load-defmethod-setf) wants to do a 'defsetf' to establish the setf
;;; generic function for a symbol.
;;;
(defun do-defmethod-setf-defsetf (generic-function-name
arglist
&optional (new-value-arglist '(new-value)))
(when (member '&aux arglist)
(setq arglist (reverse arglist))
(loop (when (eq (pop arglist) '&aux)
(return (setq arglist (nreverse arglist))))))
(let* ((setf-name (get-setf-generic-function-name generic-function-name))
(setf-ll (make-setf-method-lambda-list arglist new-value-arglist)))
(do-defsetf generic-function-name
arglist
new-value-arglist
``(,',setf-name
,,@(remove-if #'(lambda (x)
(member x lambda-list-keywords))
setf-ll)))))
(defun do-defsetf (access store-or-args &optional store-vars &rest body)
(let #+Symbolics ((si:inhibit-fdefine-warnings t))
#-Symbolics ()
#+Lispm (setq body (copy-list body))
(if body
(eval `(defsetf ,access ,store-or-args ,store-vars ,@body))
(eval `(defsetf ,access ,store-or-args)))))
(defun do-deftype (name lambda-list &rest body)
(let #+Symbolics ((si:inhibit-fdefine-warnings t))
#-Symbolics ()
#+Lispm (setq body (copy-list body))
(eval `(deftype ,name ,lambda-list ,@body))))
(defun make-type-predicate-name (class-name)
(intern (string-append class-name " predicate")
(symbol-package class-name)))
;;;
;;; Do the defsetfs for accessors defined by defclass's in the bootstrap.
;;; These have to be here because we want to be able to compile setfs of
;;; calls to those accessors before we have actually been able to evaluate
;;; those defclass forms.
;;;
(defun define-early-setfs-and-type-predicates ()
(dolist (forms-var '(*early-defclass-forms*
*fsc-defclass-forms*
*methods-defclass-forms*))
(dolist (defclass (eval forms-var))
(destructuring-bind (ignore name supers slots . options)
defclass
(unless (eq name 't)
(do-deftype name
()
`'(satisfies ,(make-type-predicate-name name))))
(dolist (slot slots)
(let ((slot-options (cdr slot)))
(loop (when (null slot-options) (return t))
(when (eq (car slot-options) ':accessor)
(do-defmethod-setf-defsetf (cadr slot-options)
(list name)))
(setq slot-options (cddr slot-options)))))
(dolist (option options)
(when (and (listp option)
(eq (car option) :accessor-prefix))
(setq option (cadr option))
(dolist (slot slots)
(if (null option)
(do-defmethod-setf-defsetf (car slot) (list name))
(do-defmethod-setf-defsetf
(intern (string-append (symbol-name option)
(symbol-name (car slot))))
(list name))))))))))
(eval-when (load eval)
(define-early-setfs-and-type-predicates))
;;;
;;; Extra little defsetfs which we need now.
;;;
(defsetf class-instance-slots set-class-instance-slots)
(defsetf slotd-name set-slotd-name)
(do-defmethod-setf-defsetf 'class-options '(standard-class))
(defsetf slot-value set-slot-value)
(defsetf slot-value-always (object slot-name &optional default) (new-value)
`(put-slot-always ,object ,slot-name ,new-value))