From: William Harold Newman Date: Wed, 23 Jan 2002 23:13:14 +0000 (+0000) Subject: 0.7.0.6: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;p=sbcl.git 0.7.0.6: APD bug 111 patch sbcl-devel 2001-12-30 APD PCL INHIBIT-WARNINGS patch ("Re: [sbcl-devel] sbcl style" sbcl-devel 2002-01-23) nibbling away at bug 137: making functions defined by DEFMETHOD have debug names not e.g. "#'(LAMBDA (SB-PCL::.PV-CELL. SB-PCL::.NEXT-METHOD-CALL. COMMON-LISP-USER::X) (DECLARE #) ...)" but instead (:METHOD FOO (INTEGER))... ...added NAME-METHOD-LAMBDA and BODY-METHOD-NAME, and used 'em ...tweaked %METHOD-NAME declared values to look more like modern CLOS syntax ...made NAMED-LAMBDA treat not-legal-as-source-name names as debug names, so it barfeth not when fed method names ...tweaked BACKTRACE printing so that it won't truncate the shiny new method names into e.g. (:METHOD FOO #) deleted unused WALK-NAMED-LAMBDA --- diff --git a/BUGS b/BUGS index 748c907..14bfd66 100644 --- a/BUGS +++ b/BUGS @@ -255,21 +255,24 @@ WORKAROUND: 45: a slew of floating-point-related errors reported by Peter Van Eynde on July 25, 2000: - a: (fixed in sbcl-0.6.11.25) b: SBCL's value for LEAST-POSITIVE-SHORT-FLOAT is bogus, and should probably be 1.4012985e-45. In SBCL, (/ LEAST-POSITIVE-SHORT-FLOAT 2) returns a number smaller than LEAST-POSITIVE-SHORT-FLOAT. Similar problems exist for LEAST-NEGATIVE-SHORT-FLOAT, LEAST-POSITIVE-LONG-FLOAT, and LEAST-NEGATIVE-LONG-FLOAT. - c: Many expressions generate floating infinity: + c: Many expressions generate floating infinity on x86/Linux: (/ 1 0.0) (/ 1 0.0d0) (EXPT 10.0 1000) (EXPT 10.0d0 1000) - PVE's regression tests want them to raise errors. SBCL - generates the infinities instead, which may or may not be - conforming behavior. + PVE's regression tests want them to raise errors. sbcl-0.7.0.5 + on x86/Linux generates the infinities instead. That might or + might not be conforming behavior, but it's also inconsistent, + which is almost certainly wrong. (Inconsistency: (/ 1 0.0) + should give the same result as (/ 1.0 0.0), but instead (/ 1 0.0) + generates SINGLE-FLOAT-POSITIVE-INFINITY and (/ 1.0 0.0) + signals an error. d: (in section12.erg) various forms a la (FLOAT 1 DOUBLE-FLOAT-EPSILON) don't give the right behavior. @@ -331,7 +334,7 @@ WORKAROUND: d: In general, the system doesn't like '(INTEGER (0) (0)) -- it blows up at the level of SPECIFIER-TYPE with "Lower bound (0) is greater than upper bound (0)." Probably - SPECIFIER-TYPE should return NIL instead. + SPECIFIER-TYPE should return the NIL type instead. g: The type system isn't all that smart about relationships between hairy types, as shown in the type.erg test results, e.g. (SUBTYPEP 'CONS '(NOT ATOM)) => NIL, NIL. @@ -802,20 +805,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: type declarations are supposed to be treated as assertions unless SAFETY 0, so we should be getting a TYPE-ERROR. -111: - reported by Martin Atzmueller 2001-06-25; originally from CMU CL bugs - collection: - (in-package :cl-user) - ;;; Produces an assertion failures when compiled. - (defun foo (z) - (declare (type (or (function (t) t) null) z)) - (let ((z (or z #'identity))) - (declare (type (function (t) t) z)) - (funcall z 1))) - The error in sbcl-0.6.12.42 is - internal error, failed AVER: - "(COMMON-LISP:NOT (COMMON-LISP:EQ SB!C::CHECK COMMON-LISP:T))" - 112: reported by Martin Atzmueller 2001-06-25; taken from CMU CL bugs collection; apparently originally reported by Bruno Haible diff --git a/NEWS b/NEWS index 59a1d3c..2cef80c 100644 --- a/NEWS +++ b/NEWS @@ -980,12 +980,20 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: * The fasl file version number changed again, for dozens of reasons, some of which are apparent above. -changes in sbcl-0.7.0 relative to sbcl-0.6.13: -* various bug fixes, notably: - ** DEFGENERIC is now choosier about the methods it redefines, so - reLOADing a previously-LOADed file containing DEFGENERICs does - the right thing now, so now the Lispy edit/reLOAD-a-little/test - cycle works as it should. (thanks to APD) +changes in sbcl-0.7.1 relative to sbcl-0.7.0: +* SB-ALIEN:LOAD-FOREIGN and SB-ALIEN:LOAD-1-FOREIGN are set + up properly again. (There was a packaging bug in 0.7.0 which + left their definitions in SB-SYS::LOAD-FOREIGN and + SB-SYS::LOAD-1-FOREIGN.) +* DEFGENERIC is now choosier about the methods it redefines, so that + reLOADing a previously-LOADed file containing DEFGENERICs does + the right thing now. Thus, the Lispy edit/reLOAD-a-little/test + cycle now works as it should. (thanks to Alexey Dejneka) +* Bug 106 (types (COMPLEX FOO) where FOO is an obscure type) was + fixed by Christophe Rhodes. (He actually submitted this patch + months ago, and I delayed until after 0.7.0.) +* Bug 111 (internal compiler confusion about runtime checks on + FUNCTION types) was fixed by Alexey Dejneka. planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/TODO b/TODO index 05eb79d..4ca9685 100644 --- a/TODO +++ b/TODO @@ -1,8 +1,5 @@ for early 0.7.x: -* patches postponed until after 0.7.0: - ** CSR "rough patch to fix bug 106" 2001-10-28 - ** Alexey Dejneka "bug 111" 2001-12-30 * building with CLISP (or explaining why not). This will likely involve a rearrangement of the build system so that it never renames the output from COMPILE-FILE, because CLISP's COMPILE-FILE @@ -11,7 +8,7 @@ for early 0.7.x: besides CLISPiosyncrasies, I'm reasonably motivated to do it. * urgent EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup: ** made inlining DEFUN inside MACROLET work again - ** (also, while working on INLINE anyway, it should be easy + ** (also, while working on INLINE anyway, it might be easy to flush the old MAYBE-INLINE cruft entirely, including e.g. on the man page) ** fixed bug 137 (more) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 937decf..fc9c8b2 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -491,37 +491,51 @@ Function and macro commands: ;;; lambda-list variables since any other arguments will be in the ;;; &REST arg's list of values. (defun print-frame-call-1 (frame) - (let* ((d-fun (sb!di:frame-debug-fun frame)) - (loc (sb!di:frame-code-location frame)) - (results (list (sb!di:debug-fun-name d-fun)))) + (let ((debug-fun (sb!di:frame-debug-fun frame)) + (loc (sb!di:frame-code-location frame)) + (reversed-args nil)) + + ;; Construct function arguments in REVERSED-ARGS. (handler-case - (dolist (ele (sb!di:debug-fun-lambda-list d-fun)) + (dolist (ele (sb!di:debug-fun-lambda-list debug-fun)) (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) results)) - :optional ((push (frame-call-arg (second ele) loc frame) results)) - :keyword ((push (second ele) results) - (push (frame-call-arg (third ele) loc frame) results)) - :deleted ((push (frame-call-arg ele loc frame) results)) + :required ((push (frame-call-arg ele loc frame) reversed-args)) + :optional ((push (frame-call-arg (second ele) loc frame) + reversed-args)) + :keyword ((push (second ele) reversed-args) + (push (frame-call-arg (third ele) loc frame) + reversed-args)) + :deleted ((push (frame-call-arg ele loc frame) reversed-args)) :rest ((lambda-var-dispatch (second ele) loc nil (progn - (setf results + (setf reversed-args (append (reverse (sb!di:debug-var-value (second ele) frame)) - results)) + reversed-args)) (return)) (push (make-unprintable-object "unavailable &REST argument") - results))))) + reversed-args))))) (sb!di:lambda-list-unavailable () - (push (make-unprintable-object "lambda list unavailable") results))) - (pprint-logical-block (*standard-output* nil) - (let ((x (nreverse (mapcar #'ensure-printable-object results)))) - (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x)))) - (when (sb!di:debug-fun-kind d-fun) + (push (make-unprintable-object "lambda list unavailable") + reversed-args))) + + (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") + (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args)))) + ;; Since we go to some trouble to make nice informative function + ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure + ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*. + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun)))) + ;; For the function arguments, we can just print normally. + (format t "~{ ~_~S~}" args))) + + (when (sb!di:debug-fun-kind debug-fun) (write-char #\[) - (prin1 (sb!di:debug-fun-kind d-fun)) + (prin1 (sb!di:debug-fun-kind debug-fun)) (write-char #\])))) (defun ensure-printable-object (object) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index f1fc71b..e809bb3 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -441,29 +441,32 @@ ;;; except that the value of NAME is passed to the compiler for use in ;;; creation of debug information for the resulting function. ;;; -;;; Eventually we might use this for NAME values other than legal -;;; function names, e.g. +;;; NAME can be a legal function name or some arbitrary other thing. +;;; +;;; If NAME is a legal function name, then the caller should be +;;; planning to set (FDEFINITION NAME) to the created function. +;;; (Otherwise the debug names will be inconsistent and thus +;;; unnecessarily confusing.) +;;; +;;; Arbitrary other things are appropriate for naming things which are +;;; not the FDEFINITION of NAME. E.g. ;;; NAME = (:FLET FOO BAR) ;;; for the FLET function in ;;; (DEFUN BAR (X) ;;; (FLET ((FOO (Y) (+ X Y))) ;;; FOO)) ;;; or -;;; NAME = (:METHOD PRINT-OBJECT (STARSHIP T)) +;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T)) ;;; for the function used to implement -;;; (DEFMETHOD PRINT-OBJECT ((SS STARSHIP) STREAM) ...). -;;; However, as of this writing (while defining/implementing it in -;;; sbcl-0.pre7.108) NAME is always a legal function name. -;;; -;;; If NAME is a legal function name, then the caller should be -;;; planning to set (FDEFINITION NAME) to the created function. -;;; (Otherwise the debug names will be inconsistent and thus -;;; unnecessarily confusing.) +;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...). (def-ir1-translator named-lambda ((name &rest rest) start cont) (reference-leaf start cont - (ir1-convert-lambda `(lambda ,@rest) - :source-name name))) + (if (legal-fun-name-p name) + (ir1-convert-lambda `(lambda ,@rest) + :source-name name) + (ir1-convert-lambda `(lambda ,@rest) + :debug-name name)))) ;;;; FUNCALL diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 777bf75..07598c4 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -56,9 +56,9 @@ (node-derived-type (continuation-use cont))))) ;;; Our best guess for the type of this continuation's value. Note -;;; that this may be Values or Function type, which cannot be passed +;;; that this may be VALUES or FUNCTION type, which cannot be passed ;;; as an argument to the normal type operations. See -;;; Continuation-Type. This may be called on deleted continuations, +;;; CONTINUATION-TYPE. This may be called on deleted continuations, ;;; always returning *. ;;; ;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the @@ -84,6 +84,18 @@ (cond ((values-subtypep proven asserted) (setf (continuation-%type-check cont) nil) (setf (continuation-%derived-type cont) proven)) + ((and (values-subtypep proven (specifier-type 'function)) + (values-subtypep asserted (specifier-type 'function))) + ;; It's physically impossible for a runtime type check to + ;; distinguish between the various subtypes of FUNCTION, so + ;; it'd be pointless to do more type checks here. + (setf (continuation-%type-check cont) nil) + (setf (continuation-%derived-type cont) + ;; FIXME: This should depend on optimization + ;; policy. This is for SPEED > SAFETY: + #+nil (values-type-intersection asserted proven) + ;; and this is for SAFETY >= SPEED: + #-nil proven)) (t (unless (or (continuation-%type-check cont) (not (continuation-dest cont)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index bacdd39..f8df4fd 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -404,7 +404,8 @@ bootstrapping. ,,(cadr specializer)) `',specializer)) specializers)) - unspecialized-lambda-list method-class-name + unspecialized-lambda-list + method-class-name initargs-form pv-table-symbol)))) @@ -446,7 +447,24 @@ bootstrapping. (extract-declarations body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) - (declare (%method-name ,(list name qualifiers specializers))) + ;; (Old PCL code used a somewhat different style of + ;; list for %METHOD-NAME values. Our names use + ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the + ;; method names look more like what you see in a + ;; DEFMETHOD form.) + ;; + ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at + ;; least the code to set up named BLOCKs around the + ;; bodies of methods, depends on the function's base + ;; name being the first element of the %METHOD-NAME + ;; list. It would be good to remove this dependency, + ;; perhaps by building the BLOCK here, or by using + ;; another declaration (e.g. %BLOCK-NAME), so that + ;; our method debug names are free to have any format, + ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). + (declare (%method-name (,name + ,@qualifiers + ,specializers))) (declare (%method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) @@ -455,7 +473,8 @@ bootstrapping. (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) - (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) + (unless (and (consp method-lambda) + (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ is not a lambda form." method-lambda)) @@ -946,31 +965,38 @@ bootstrapping. (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) `(macrolet ((call-next-method-bind (&body body) - `(let () ,@body)) + `(let () ,@body)) (call-next-method-body (cnm-args) - `(if ,',next-method-call - ,(if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - ,',next-method-call nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - ,',next-method-call - ,',(not (null rest-arg)) - ,@',args - ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) - ,cnm-args) - ,call) - ,call))) - (error "no next method"))) + `(if ,',next-method-call + ,(locally + ;; This declaration suppresses a "deleting + ;; unreachable code" note for the following IF when + ;; REST-ARG is NIL. It is not nice for debugging + ;; SBCL itself, but at least it keeps us from + ;; annoying users. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(invoke-effective-method-function + ,',next-method-call nil + ,@(cdr cnm-args)) + (let ((call `(invoke-effective-method-function + ,',next-method-call + ,',(not (null rest-arg)) + ,@',args + ,@',(when rest-arg `(,rest-arg))))) + `(if ,cnm-args + (bind-args ((,@',args + ,@',(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call)))) + (error "no next method"))) (next-method-p-body () - `(not (null ,',next-method-call)))) - ,@body)) + `(not (null ,',next-method-call)))) + ,@body)) (defmacro bind-lexical-method-functions ((&key call-next-method-p next-method-p-p closurep applyp) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 275b0ac..cb3371b 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -1353,8 +1353,9 @@ ;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do ;;; we need it both here and there? Why? -- WHN 19991203 (eval-when (:load-toplevel) - (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) - (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) + (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65) + (2 64) (7 33) (16 32) (16 17) (32 16) + (64 9) (64 8) (6 5) (128 4) (35 2))) (let ((n (car n-size)) (size (cadr n-size))) (mapcar #'free-cache-vector diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index fbd507d..b5cb581 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -43,7 +43,7 @@ (defun expand-make-instance-form (form) (let ((class (cadr form)) (initargs (cddr form)) - (keys nil)(allow-other-keys-p nil) key value) + (keys nil) (allow-other-keys-p nil) key value) (when (and (constant-symbol-p class) (let ((initargs-tail initargs)) (loop (when (null initargs-tail) (return t)) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 9d4bbd8..ef82f3c 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,11 +29,14 @@ (/show "starting pcl/macros.lisp") (declaim (declaration - ;; These three nonstandard declarations seem to be used - ;; privately within PCL itself to pass information around, - ;; so we can't just delete them. - %class + ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration + ;; to propagate information needed to set up nice debug + ;; names (as seen e.g. in BACKTRACE) for method functions. %method-name + ;; These nonstandard declarations seem to be used privately + ;; within PCL itself to pass information around, so we can't + ;; just delete them. + %class %method-lambda-list ;; This declaration may also be used within PCL to pass ;; information around, I'm not sure. -- WHN 2000-12-30 diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index ef53775..a33b891 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))) @@ -917,8 +917,13 @@ ;; 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)) + '(values + %method-name + %method-lambda-list + optimize + ftype + inline + notinline)) (defvar *var-declarations-with-arg* '(%class @@ -987,7 +992,7 @@ (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)) @@ -1000,9 +1005,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 (documentation declarations real-body) + (extract-declarations 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))) @@ -1011,15 +1041,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 @@ -1027,31 +1062,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 diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 0589bd1..6078fb6 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -811,20 +811,6 @@ walked-arglist walked-body)))) -(defun walk-named-lambda (form context old-env) - (walker-environment-bind (new-env old-env) - (let* ((name (cadr form)) - (arglist (caddr form)) - (body (cdddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* form - (car form) - name - walked-arglist - walked-body)))) - (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) diff --git a/tests/clocc-ansi-test-known-bugs.lisp b/tests/clocc-ansi-test-known-bugs.lisp index 2fbb446..4756aa2 100644 --- a/tests/clocc-ansi-test-known-bugs.lisp +++ b/tests/clocc-ansi-test-known-bugs.lisp @@ -36,6 +36,17 @@ :ALLTEST-LEGACY-1613 :ALLTEST-LEGACY-1715 :ALLTEST-LEGACY-1723 + + ;; bug 45c + #+(and linux x86) :ALLTEST-LEGACY-1814 + #+(and linux x86) :ALLTEST-LEGACY-1818 + #+(and linux x86) :ALLTEST-LEGACY-1822 + #+(and linux x86) :ALLTEST-LEGACY-1826 + #+(and linux x86) :ALLTEST-LEGACY-1830 + #+(and linux x86) :ALLTEST-LEGACY-1834 + #+(and linux x86) :ALLTEST-LEGACY-1838 + #+(and linux x86) :ALLTEST-LEGACY-1842 + :ALLTEST-LEGACY-2204 :CLOS-LEGACY-170 :CMUCL-BUGS-LEGACY-292 diff --git a/version.lisp-expr b/version.lisp-expr index 64f1d56..167616b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.0.5" +"0.7.0.6"