#-sb-fluid (declaim (sb-ext:freeze-type pv-table))
-(defvar *initial-pv-table* (make-pv-table-internal nil nil))
-
-; help new slot-value-using-class methods affect fast iv access
-(defvar *all-pv-table-list* nil)
+;;; FIXME: The comment below seem to indicate that this was intended
+;;; to be actually used, however, it isn't anymore, and was commented
+;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
+;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
+;;;
+;;; help new slot-value-using-class methods affect fast iv access
+;;;
+;;; (defvar *all-pv-table-list* nil)
+(declaim (inline make-pv-table))
(defun make-pv-table (&key slot-name-lists call-list)
- (let ((pv-table (make-pv-table-internal slot-name-lists call-list)))
- (push pv-table *all-pv-table-list*)
- pv-table))
+ (make-pv-table-internal slot-name-lists call-list))
(defun make-pv-table-type-declaration (var)
`(type pv-table ,var))
(setq new-p t)
(make-pv-table :slot-name-lists snl
:call-list cl))))))
- (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists)))))
- (when new-p
- (let ((pv-index 1))
- (dolist (slot-name-list slot-name-lists)
- (dolist (slot-name (cdr slot-name-list))
- (note-pv-table-reference slot-name pv-index pv-table)
- (incf pv-index)))
- (dolist (gf-call call-list)
- (note-pv-table-reference gf-call pv-index pv-table)
- (incf pv-index))
- (setf (pv-table-pv-size pv-table) pv-index)))
- pv-table))))
+ (let ((pv-table
+ (outer (mapcar #'inner (cons call-list slot-name-lists)))))
+ (when new-p
+ (let ((pv-index 1))
+ (dolist (slot-name-list slot-name-lists)
+ (dolist (slot-name (cdr slot-name-list))
+ (note-pv-table-reference slot-name pv-index pv-table)
+ (incf pv-index)))
+ (dolist (gf-call call-list)
+ (note-pv-table-reference gf-call pv-index pv-table)
+ (incf pv-index))
+ (setf (pv-table-pv-size pv-table) pv-index)))
+ pv-table))))
(defun note-pv-table-reference (ref pv-offset pv-table)
(let ((entry (gethash ref *pv-key-to-pv-table-table*)))
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
-(defvar *empty-pv* #())
-
(defmacro pvref (pv index)
`(svref ,pv ,index))
(declare (ignorable ,@(mapcar #'identity slot-vars)))
,@body)))
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
;;; overridden.
-(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
+(define-symbol-macro pv-env-environment overridden)
+
+(defmacro pv-env (&environment env
+ (pv calls pv-table-symbol pv-parameters)
&rest forms)
- `(let* ((.pv-table. ,pv-table-symbol)
- (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
- (,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv))
- (declare ,(make-calls-type-declaration calls))
- ,@(when (symbolp pv-table-symbol)
- `((declare (special ,pv-table-symbol))))
- ,pv ,calls
- ,@forms))
+ ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
+ ;; symbol-macrolet.
+ (if (eq (macroexpand 'pv-env-environment env) 'default)
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)
+ `(let* ((.pv-table. ,pv-table-symbol)
+ (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
+ (,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv))
+ (declare ,(make-calls-type-declaration calls))
+ ,@(when (symbolp pv-table-symbol)
+ `((declare (special ,pv-table-symbol))))
+ ,pv ,calls
+ ,@forms)))
(defvar *non-var-declarations*
;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
(list (cons 'fast-method (body-method-name body))))
(.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
;; body of the function
- (declare (ignorable .pv-cell. .next-method-call.))
+ (declare (ignorable .pv-cell. .next-method-call.)
+ (disable-package-locks pv-env-environment))
,@outer-decls
- (declare (disable-package-locks pv-env))
- (macrolet (;; If :PV-TABLE-SYMBOL isn't in the plist, the PV-ENV
- ;; macro defined here will never get expanded. To
- ;; speed up compilation of CLOS code, don't emit it
- ;; in the first place.
- ,@(when (getf (cdr lmf-params) :pv-env-p)
- `((pv-env
- ((pv calls pv-table-symbol pv-parameters)
- &rest forms)
- (declare (ignore pv-table-symbol
- pv-parameters))
- (declare (enable-package-locks pv-env))
- `(let ((,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv)
- ,(make-calls-type-declaration calls))
- ,pv ,calls
- ,@forms)))))
- (declare (enable-package-locks pv-env))
+ (symbol-macrolet ((pv-env-environment default))
(fast-lexical-method-functions
(,(car lmf-params) .next-method-call. ,req-args ,rest-arg
,@(cdddr lmf-params))
projects / sbcl.git / blobdiff