(defun pv-cache-limit-fn (nlines)
(default-limit-fn nlines))
-(defstruct (pv-table
- (:predicate pv-tablep)
- (:constructor make-pv-table-internal
- (slot-name-lists call-list)))
+(defstruct (pv-table (:predicate pv-tablep)
+ (:constructor make-pv-table-internal
+ (slot-name-lists call-list))
+ (:copier nil))
(cache nil :type (or cache null))
(pv-size 0 :type fixnum)
(slot-name-lists nil :type list)
;; against 'THE scattered through the PCL code.
(setq var (caddr var)))
(when (symbolp var)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- var
- env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
(parameter-or-nil (car (memq (or rebound? var)
required-parameters))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration '%class
- parameter-or-nil
- env)))
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
(class (find-class class-name nil)))
(when (or (not (eq *boot-state* 'complete))
(and class (not (class-finalized-p class))))
(setq class nil))
- (when (and class-name (not (eq class-name 't)))
+ (when (and class-name (not (eq class-name t)))
(when (or (null type)
(not (and class
(memq *the-class-structure-object*
,parameter)
,new-value))
(:boundp
- 'T)))
+ t)))
(let* ((parameter-entry (assq parameter slots))
(slot-entry (assq slot-name (cdr parameter-entry)))
(position (posq parameter-entry slots))
(eq (car form) 'the))
(setq form (caddr form)))
(or (and (symbolp form)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- form env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding
+ form
+ env)))
(parameter-or-nil (car (assq (or rebound? form) slots))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration
- 'class parameter-or-nil env))))
- (when (and class-name (not (eq class-name 't)))
+ (let* ((class-name (caddr (var-declaration 'class
+ parameter-or-nil
+ env))))
+ (when (and class-name (not (eq class-name t)))
(position parameter-or-nil slots :key #'car))))))
(if (constantp form)
(let ((form (eval form)))
`(instance-write-internal .pv. ,(slot-vector-symbol position)
,pv-offset ,new-value
(,(if (consp gf-name)
- (get-setf-function-name gf-name)
+ (get-setf-fun-name gf-name)
gf-name)
(instance-accessor-parameter ,parameter)
,new-value)
slot-vars pv-parameters))
,@body)))
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; overridden.
(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
&rest forms)
`(let* ((.pv-table. ,pv-table-symbol)
,pv ,calls
,@forms))
-(defvar *non-variable-declarations*
+(defvar *non-var-declarations*
;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
;; SBCL doesn't have 'em, VALUES should probably be removed from
'(values %method-name %method-lambda-list
optimize ftype inline notinline))
-(defvar *variable-declarations-with-argument*
+(defvar *var-declarations-with-argument*
'(%class
type))
-(defvar *variable-declarations-without-argument*
+(defvar *var-declarations-without-argument*
'(ignore
ignorable special dynamic-extent
;; FIXME: Possibly this entire list and variable could go away.
(dolist (form (cdr decl))
(when (consp form)
(let ((declaration-name (car form)))
- (if (member declaration-name *non-variable-declarations*)
+ (if (member declaration-name *non-var-declarations*)
(push `(declare ,form) outer-decls)
(let ((arg-p
(member declaration-name
- *variable-declarations-with-argument*))
+ *var-declarations-with-argument*))
(non-arg-p
(member declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(dname (list (pop form)))
(inners nil) (outers nil))
(unless (or arg-p non-arg-p)
;; FIXME: This warning, and perhaps the
- ;; various *VARIABLE-DECLARATIONS-FOO* and/or
- ;; *NON-VARIABLE-DECLARATIONS* variables,
+ ;; various *VAR-DECLARATIONS-FOO* and/or
+ ;; *NON-VAR-DECLARATIONS* variables,
;; could probably go away now that we're not
;; trying to be portable between different
;; CLTL1 hosts the way PCL was. (Note that to
(Assuming it is a variable declaration without argument)."
declaration-name 'split-declarations
declaration-name
- '*non-variable-declarations*
- '*variable-declarations-with-argument*
- '*variable-declarations-without-argument*)
+ '*non-var-declarations*
+ '*var-declarations-with-argument*
+ '*var-declarations-without-argument*)
(push declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(when arg-p
(setq dname (append dname (list (pop form)))))
(dolist (var form)
(nm (car next-methods))
(nms (cdr next-methods))
(nmc (when nm
- (make-method-call :function (if (std-instance-p nm)
- (method-function nm)
- nm)
- :call-method-args (list nms)))))
+ (make-method-call
+ :function (if (std-instance-p nm)
+ (method-function nm)
+ nm)
+ :call-method-args (list nms)))))
(if restp
(let* ((rest (nthcdr nreq method-args))
(args (ldiff method-args rest)))
(intern (subseq str 5) *pcl-package*)
(car fname)))))
,@(cdr fname))))
- (set-function-name method-function name))
+ (set-fun-name method-function name))
(setf (method-function-get method-function :fast-function) fmf)
method-function))
(w-t pv-wrappers))
(dolist (arg args)
(setq w (wrapper-of arg))
- (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+ (unless (eq t (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
(setq w (check-wrapper-validity arg)))
(setf (car w-t) w))
(setq w-t (cdr w-t))
projects / sbcl.git / blobdiff