X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fpcl%2Fvector.lisp;h=292e76333763fa1c20192c7d72af304f9359e545;hb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;hp=7dda26aa50730c93521389894917553477c1f608;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7dda26a..292e763 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -290,7 +290,7 @@ (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))) @@ -388,8 +388,7 @@ 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)) (defun can-optimize-access (form required-parameters env) @@ -529,7 +528,7 @@ (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))) @@ -557,7 +556,7 @@ (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))) @@ -638,7 +637,7 @@ (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))) @@ -660,16 +659,16 @@ (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+) @@ -682,7 +681,7 @@ `(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)) @@ -695,16 +694,16 @@ &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))))))) @@ -720,7 +719,7 @@ ,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 @@ -742,17 +741,17 @@ &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))))))) @@ -762,7 +761,7 @@ `(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. ;;; @@ -917,14 +916,19 @@ ;; 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. @@ -956,10 +960,10 @@ (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) @@ -978,17 +982,16 @@ 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)) @@ -1001,9 +1004,34 @@ (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))) @@ -1012,47 +1040,57 @@ (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 @@ -1063,7 +1101,7 @@ (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 @@ -1117,7 +1155,7 @@ (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))