(slot-name-lists (pv-table-slot-name-lists pv-table))
(pv-size (pv-table-pv-size pv-table))
(pv-map (make-array pv-size :initial-element nil)))
- (let ((map-index 1)(param-index 0))
+ (let ((map-index 1) (param-index 0))
(dolist (slot-name-list slot-name-lists)
(dolist (slot-name (cdr slot-name-list))
(let ((a (assoc slot-name new-values)))
slots
calls)
(declare (ignore required-parameters env slots calls))
- (or (and (eq (car form) 'make-instance)
- (expand-make-instance-form form))
+ (or ; (optimize-reader ...)?
form))
\f
(defun can-optimize-access (form required-parameters env)
(position (posq parameter-entry slots))
(pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
(unless parameter-entry
- (error "internal error in slot optimization"))
+ (bug "slot optimization bewilderment: O-I-A"))
(unless slot-entry
(setq slot-entry (list slot-name))
(push slot-entry (cdr parameter-entry)))
(position (posq parameter-entry slots))
(pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
(unless parameter-entry
- (error "internal error in slot optimization"))
+ (error "slot optimization bewilderment: O-A-C"))
(unless slot-entry
(setq slot-entry (list name))
(push slot-entry (cdr parameter-entry)))
(standard-class-p class)
(not (eq class *the-class-t*)) ; shouldn't happen, though.
(let ((slotd (find-slot-definition class slot-name)))
- (and slotd (classp (slot-definition-allocation slotd)))))))
+ (and slotd (eq :class (slot-definition-allocation slotd)))))))
(defun skip-fast-slot-access-p (class-form slot-name-form type)
(let ((class (and (constantp class-form) (eval class-form)))
(defmacro instance-read-internal (pv slots pv-offset default &optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-read-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym))
(value index))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (clos-slots-ref ,slots ,index))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(if (eq ,value +slot-unbound+)
`(instance-read-internal .pv. ,(slot-vector-symbol position)
,pv-offset (accessor-slot-value ,parameter ,slot-name)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
(defmacro instance-reader (pv-offset parameter position gf-name class)
(declare (ignore class))
&optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-write-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (setf (clos-slots-ref ,slots ,index)
,new-value))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
,pv-offset ,new-value
(accessor-set-slot-value ,parameter ,slot-name ,new-value)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
(defmacro instance-writer (pv-offset
parameter
&optional type)
(unless (member type '(nil :instance :class :default))
(error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
- (if (eq type ':default)
+ (if (eq type :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type ':instance))
+ ,@(when (or (null type) (eq type :instance))
`((fixnum (not (and ,slots
(eq (clos-slots-ref ,slots ,index)
+slot-unbound+))))))
- ,@(when (or (null type) (eq type ':class))
+ ,@(when (or (null type) (eq type :class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
`(instance-boundp-internal .pv. ,(slot-vector-symbol position)
,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
,(if (generate-fast-class-slot-access-p class slot-name)
- ':class ':instance))))
+ :class :instance))))
;;; This magic function has quite a job to do indeed.
;;;
;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
;; SBCL doesn't have 'em, VALUES should probably be removed from
;; this list.
- '(values %method-name %method-lambda-list
- optimize ftype inline notinline))
-
-(defvar *var-declarations-with-argument*
+ '(values
+ %method-name
+ %method-lambda-list
+ optimize
+ ftype
+ inline
+ notinline))
+
+(defvar *var-declarations-with-arg*
'(%class
type))
-(defvar *var-declarations-without-argument*
+(defvar *var-declarations-without-arg*
'(ignore
ignorable special dynamic-extent
;; FIXME: Possibly this entire list and variable could go away.
(push `(declare ,form) outer-decls)
(let ((arg-p
(member declaration-name
- *var-declarations-with-argument*))
+ *var-declarations-with-arg*))
(non-arg-p
(member declaration-name
- *var-declarations-without-argument*))
+ *var-declarations-without-arg*))
(dname (list (pop form)))
(inners nil) (outers nil))
(unless (or arg-p non-arg-p)
declaration-name 'split-declarations
declaration-name
'*non-var-declarations*
- '*var-declarations-with-argument*
- '*var-declarations-without-argument*)
- (push declaration-name
- *var-declarations-without-argument*))
+ '*var-declarations-with-arg*
+ '*var-declarations-without-arg*)
+ (push declaration-name *var-declarations-without-arg*))
(when arg-p
(setq dname (append dname (list (pop form)))))
(dolist (var form)
(if (member var args)
;; Quietly remove IGNORE declarations on
;; args when a next-method is involved, to
- ;; prevent compiler warns about ignored
+ ;; prevent compiler warnings about ignored
;; args being read.
(unless (and calls-next-method-p
(eq (car dname) 'ignore))
(setq body (cdr body)))
(values outer-decls inner-decls body)))
+;;; Pull a name out of the %METHOD-NAME declaration in the function
+;;; body given, or return NIL if no %METHOD-NAME declaration is found.
+(defun body-method-name (body)
+ (multiple-value-bind (real-body declarations documentation)
+ (parse-body body nil)
+ (declare (ignore documentation real-body))
+ (let ((name-decl (get-declaration '%method-name declarations)))
+ (and name-decl
+ (destructuring-bind (name) name-decl
+ name)))))
+
+;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
+;;; declaration (which is a naming style internal to PCL) into an
+;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
+;;; throughout SBCL, understood by the main compiler); or if there's
+;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
+;;; lambda expression.
+(defun name-method-lambda (method-lambda)
+ (let ((method-name (body-method-name (cddr method-lambda))))
+ (if method-name
+ `(named-lambda ,method-name ,(rest method-lambda))
+ method-lambda)))
+
(defun make-method-initargs-form-internal (method-lambda initargs env)
(declare (ignore env))
- (let (method-lambda-args lmf lmf-params)
+ (let (method-lambda-args
+ lmf ; becomes body of function
+ lmf-params)
(if (not (and (= 3 (length method-lambda))
(= 2 (length (setq method-lambda-args (cadr method-lambda))))
(consp (setq lmf (third method-lambda)))
(cadr (setq lmf-params (cadr lmf))))
(eq (cadr method-lambda-args)
(caddr lmf-params))))
- `(list* :function #',method-lambda
+ `(list* :function ,(name-method-lambda method-lambda)
',initargs)
(let* ((lambda-list (car lmf-params))
- (nreq 0)(restp nil)(args nil))
+ (nreq 0)
+ (restp nil)
+ (args nil))
(dolist (arg lambda-list)
(when (member arg '(&optional &rest &key))
- (setq restp t)(return nil))
- (when (eq arg '&aux) (return nil))
- (incf nreq)(push arg args))
+ (setq restp t)
+ (return nil))
+ (when (eq arg '&aux)
+ (return nil))
+ (incf nreq)
+ (push arg args))
(setq args (nreverse args))
- (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+ (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))
(make-method-initargs-form-internal1
initargs (cddr lmf) args lmf-params restp)))))
(defun make-method-initargs-form-internal1
(initargs body req-args lmf-params restp)
- (multiple-value-bind (outer-decls inner-decls body)
+ (multiple-value-bind (outer-decls inner-decls body-sans-decls)
(split-declarations
body req-args (getf (cdr lmf-params) :call-next-method-p))
(let* ((rest-arg (when restp '.rest-arg.))
(args+rest-arg (if restp
(append req-args (list rest-arg))
req-args)))
- `(list* :fast-function
- (lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
- (declare (ignorable .pv-cell. .next-method-call.))
- ,@outer-decls
- (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
- &rest forms)
- (declare (ignore pv-table-symbol pv-parameters))
- `(let ((,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv)
- ,(make-calls-type-declaration calls))
- ,pv ,calls
- ,@forms)))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body)))
+ `(list*
+ :fast-function
+ (named-lambda
+ ,(or (body-method-name body) '.method.) ; function name
+ (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+ ;; body of the function
+ (declare (ignorable .pv-cell. .next-method-call.))
+ ,@outer-decls
+ (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ (declare (ignore pv-table-symbol
+ pv-parameters))
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body-sans-decls)))
',initargs))))
;;; Use arrays and hash tables and the fngen stuff to make this much
(defun method-function-from-fast-function (fmf)
(declare (type function fmf))
(let* ((method-function nil) (pv-table nil)
- (arg-info (method-function-get fmf ':arg-info))
+ (arg-info (method-function-get fmf :arg-info))
(nreq (car arg-info))
(restp (cdr arg-info)))
(setq 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
+ (when (invalid-wrapper-p w)
(setq w (check-wrapper-validity arg)))
(setf (car w-t) w))
(setq w-t (cdr w-t))
projects / sbcl.git / blobdiff