X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fvector.lisp;h=292e76333763fa1c20192c7d72af304f9359e545;hb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;hp=7008ec1bb13c0c0dbc256a8f5831171adae23bed;hpb=f6a2be77637d025bfded9430f02863c28f74f77a;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7008ec1..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))) @@ -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,15 +1040,20 @@ (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)) (make-method-initargs-form-internal1 @@ -1028,31 +1061,36 @@ (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 @@ -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))