X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=231ca8d1a711ecaa132c3acaaf1e84458e456a94;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=e6bfa4b28a9288be43a7d5ca5ab7efacb670c449;hpb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index e6bfa4b..231ca8d 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -665,8 +665,21 @@ `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below + ;; (and the analogous spot in + ;; INSTANCE-WRITE-INTERNAL) is there purely + ;; to suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems + ;; to think it could, so we put this here + ;; to shut it up. (see also mail Rudi + ;; Schlatte sbcl-devel 2003-09-21) -- CSR, + ;; 2003-11-30 ,@(when (or (null type) (eq type :instance)) - `((fixnum (clos-slots-ref ,slots ,index)))) + `((fixnum + (and ,slots ; KLUDGE + (clos-slots-ref ,slots ,index))))) ,@(when (or (null type) (eq type :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) @@ -700,8 +713,9 @@ (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index ,@(when (or (null type) (eq type :instance)) - `((fixnum (setf (clos-slots-ref ,slots ,index) - ,new-value)))) + `((fixnum (and ,slots + (setf (clos-slots-ref ,slots ,index) + ,new-value))))) ,@(when (or (null type) (eq type :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -893,7 +907,8 @@ `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) slot-vars pv-parameters)) - ,@body))) + (declare (ignorable ,@(mapcar #'identity slot-vars))) + ,@body))) ;;; This gets used only when the default MAKE-METHOD-LAMBDA is ;;; overridden. @@ -943,7 +958,7 @@ simple-bit-vector simple-string simple-vector single-float standard-char stream string symbol t unsigned-byte vector)) -(defun split-declarations (body args calls-next-method-p) +(defun split-declarations (body args maybe-reads-params-p) (let ((inner-decls nil) (outer-decls nil) decl) @@ -996,7 +1011,7 @@ ;; involved, to prevent compiler ;; warnings about ignored args being ;; read. - (unless (and calls-next-method-p + (unless (and maybe-reads-params-p (eq (car dname) 'ignore)) (push var outers)) (push var inners))) @@ -1029,7 +1044,7 @@ (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)) + `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) @@ -1068,7 +1083,8 @@ (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body-sans-decls) (split-declarations - body req-args (getf (cdr lmf-params) :call-next-method-p)) + body req-args (or (getf (cdr lmf-params) :call-next-method-p) + (getf (cdr lmf-params) :setq-p))) (let* ((rest-arg (when restp '.rest-arg.)) (args+rest-arg (if restp (append req-args (list rest-arg)) @@ -1076,27 +1092,31 @@ `(list* :fast-function (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) - (list (body-method-name body))) ; 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))) + ,@(when (body-method-name body) + ;; function name + (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.)) + ,@outer-decls + (declare (disable-package-locks pv-env)) + (macrolet ((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)) + (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 @@ -1131,13 +1151,7 @@ (apply fmf pv-cell nmc (nconc args (list rest)))) (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) - (name `(,(or (get (car fname) 'method-sym) - (setf (get (car fname) 'method-sym) - (let ((str (symbol-name (car fname)))) - (if (string= "FAST-" str :end2 5) - (intern (subseq str 5) *pcl-package*) - (car fname))))) - ,@(cdr fname)))) + (name (cons 'slow-method (cdr fname)))) (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function))