X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=9a8458c203d1867f9fa25356b6312db331005300;hb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;hp=44943e2eb7480d0acb912614c22722b1e55945b8;hpb=a0a198faba322eccaf947862b59946aed99b2347;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 44943e2..9a8458c 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -53,11 +53,654 @@ (when (and (digs) (digs)) x)))) ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH -;;; tags. This was fixed by Alexey Dejneka in sbcl-0.7.1.14. (They're -;;; still a bad idea because tags are compared with EQ, but now it's a +;;; tags. This was fixed by Alexey Dejneka in sbcl-0.7.1.14. (INTEGER +;;; catch tags are still a bad idea because EQ is used to compare +;;; tags, and EQ comparison on INTEGERs is unportable; but now it's a ;;; compiler warning instead of a failure to compile.) (defun foo () (catch 0 (print 1331))) +;;; Bug 150: In sbcl-0.7.1.15, compiling this code caused a failure in +;;; SB-C::ADD-TEST-CONSTRAINTS: +;;; The value NIL is not of type SB-C::CONTINUATION. +;;; This bug was fixed by APD in sbcl-0.7.1.30. +(defun bug150-test1 () + (let* () + (flet ((wufn () (glorp table1 4.9))) + (gleep *uustk* #'wufn "#1" (list))) + (if (eql (lo foomax 3.2)) + (values) + (error "not ~S" '(eql (lo foomax 3.2)))) + (values))) +;;; A simpler test case for bug 150: The compiler died with the +;;; same type error when trying to compile this. +(defun bug150-test2 () + (let () + (<))) + +;;; bug 147, fixed by APD 2002-04-28 +;;; +;;; This test case used to crash the compiler, e.g. with +;;; failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)" +(defun bug147 (string ind) + (flet ((digs () + (let (old-index) + (if (and (< ind ind) + (typep (char string ind) '(member #\1))) + nil)))))) + +;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13 +(defmacro foo-2002-05-13 () ''x) +(eval '(foo-2002-05-13)) +(compile 'foo-2002-05-13) +(foo-2002-05-13) ; (The bug caused UNDEFINED-FUNCTION to be signalled here.) + +;;; floating point pain on the PPC. +;;; +;;; This test case used to fail to compile on most powerpcs prior to +;;; sbcl-0.7.4.2x, as floating point traps were being incorrectly +;;; masked. +(defun floating-point-pain (x) + (declare (single-float x)) + (log x)) + +;;; bug found and fixed ca. sbcl-0.7.5.12: The INTERSECTION-TYPE +;;; here satisfies "is a subtype of ARRAY-TYPE", but can't be +;;; accessed with ARRAY-TYPE accessors like +;;; ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE, so ARRAY-related +;;; DEFTRANSFORMs died with TYPE-ERROR at compile time when +;;; compiling the DEFUN here. +(defun stupid-input-to-smart-array-deftransforms-0-7-5-12 (v) + (declare (type (and simple-vector fwd-type-ref) v)) + (aref v 0)) + +;;; Ca. sbcl-0.7.5.15 the compiler would fail an internal consistency +;;; check on this code because it expected all calls to %INSTANCE-REF +;;; to be transformed away, but its expectations were dashed by perverse +;;; code containing app programmer errors like this. +(defstruct something-known-to-be-a-struct x y) +(multiple-value-bind (fun warnings-p failure-p) + (compile nil + '(lambda () + (labels ((a1 (a2 a3) + (cond (t (a4 a2 a3)))) + (a4 (a2 a3 a5 a6) + (declare (type (or simple-vector null) a5 a6)) + (something-known-to-be-a-struct-x a5)) + (a8 (a2 a3) + (a9 #'a1 a10 a2 a3)) + (a11 (a2 a3) + (cond ((and (funcall a12 a2) + (funcall a12 a3)) + (funcall a13 a2 a3)) + (t + (when a14 + (let ((a15 (a1 a2 a3))) + )) + a16)))) + (values #'a17 #'a11)))) + ;; Python sees the structure accessor on the known-not-to-be-a-struct + ;; A5 value and is very, very disappointed in you. (But it doesn't + ;; signal BUG any more.) + (assert failure-p)) + +;;; On the SPARC, there was an erroneous definition of some VOPs used +;;; to compile LOGANDs, which would lead to compilation of the +;;; following function giving rise to a compile-time error (bug +;;; spotted and fixed by Raymond Toy for CMUCL) +(defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + (declare (type (unsigned-byte 32) a0) + (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + ;; to ensure that the call is a candidate for + ;; transformation + (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) + (values + ;; the call that fails compilation + (logand a0 a10) + ;; a call to prevent the other arguments from being optimized away + (logand a1 a2 a3 a4 a5 a6 a7 a8 a9))) + +;;; bug 192, reported by Einar Floystad Dorum sbcl-devel 2002-08-14, +;;; fixed in sbcl-0.7.6.26: Compiling this function in 0.7.6 caused +;;; the compiler to try to constant-fold DATA-VECTOR-REF, which is OK, +;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so +;;; it would fail. +(defun bug192 () + (funcall + (LAMBDA (TEXT I L ) + (LABELS ((G908 (I) + (LET ((INDEX + (OR + (IF (= I L) + NIL + (LET ((S TEXT) + (E (ELT TEXT I))) + (DECLARE (IGNORABLE S E)) + (WHEN (EQL #\a E) + (G909 (1+ I)))))))) + INDEX)) + (G909 (I) + (OR + (IF (= I L) + NIL + (LET ((S TEXT) + (E (ELT TEXT I))) + (DECLARE (IGNORABLE S E)) + (WHEN (EQL #\b E) (G910 (1+ I))))))) + (G910 (I) + (LET ((INDEX + (OR + (IF NIL + NIL + (LET ((S TEXT)) + (DECLARE (IGNORABLE S)) + (WHEN T I)))))) + INDEX))) + (G908 I))) "abcdefg" 0 (length "abcdefg"))) + +;;; bugs #65, #70, and #109, closed by APD's patch sbcl-devel 2002-08-17 +;;; +;;; This was "YA code deletion bug" whose symptom was the failure of +;;; the assertion +;;; (EQ (C::LAMBDA-TAIL-SET C::CALLER) +;;; (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE))) +;;; at compile time. +(defun bug65-1 (termx termy) ; from Carl Witty on submit bugs list, debian.org + (labels + ((alpha-equal-bound-term-lists (listx listy) + (or (and (null listx) (null listy)) + (and listx listy + (let ((bindings-x (bindings-of-bound-term (car listx))) + (bindings-y (bindings-of-bound-term (car listy)))) + (if (and (null bindings-x) (null bindings-y)) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (and (= (length bindings-x) (length bindings-y)) + (prog2 + (enter-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (exit-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))))))) + (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) + + (alpha-equal-terms (termx termy) + (if (and (variable-p termx) + (variable-p termy)) + (equal-bindings (id-of-variable-term termx) + (id-of-variable-term termy)) + (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) + (alpha-equal-bound-term-lists (bound-terms-of-term termx) + (bound-terms-of-term termy)))))) + + (or (eq termx termy) + (and termx termy + (with-variable-invocation (alpha-equal-terms termx termy)))))) +(defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28 + ;; Given an FSSP alignment file named by the argument . . . + (labels ((get-fssp-char () + (get-fssp-char)) + (read-fssp-char () + (get-fssp-char))) + ;; Stub body, enough to tickle the bug. + (list (read-fssp-char) + (read-fssp-char)))) +(defun bug70 ; from David Young cmucl-help 30 Nov 2000 + (item sequence &key (test #'eql)) + (labels ((find-item (obj seq test &optional (val nil)) + (let ((item (first seq))) + (cond ((null seq) + (values nil nil)) + ((funcall test obj item) + (values val seq)) + (t + (find-item obj + (rest seq) + test + (nconc val `(,item)))))))) + (find-item item sequence test))) +(defun bug109 () ; originally from CMU CL bugs collection, reported as + ; SBCL bug by MNA 2001-06-25 + (labels + ((eff (&key trouble) + (eff) + ;; nil + ;; Uncomment and it works + )) + (eff))) + +;;; bug 192a, fixed by APD "more strict type checking" patch +;;; (sbcl-devel 2002-08-07) +(defun bug192a (x) + (declare (optimize (speed 0) (safety 3))) + ;; Even with bug 192a, this declaration was checked as an assertion. + (declare (real x)) + (+ x + (locally + ;; Because of bug 192a, this declaration was trusted without checking. + (declare (single-float x)) + (sin x)))) +(assert (null (ignore-errors (bug192a nil)))) +(multiple-value-bind (result error) (ignore-errors (bug192a 100)) + (assert (null result)) + (assert (equal (type-error-expected-type error) 'single-float))) + +;;; bug 194, fixed in part by APD "more strict type checking" patch +;;; (sbcl-devel 2002-08-07) +(progn + #+nil ; FIXME: still broken in 0.7.7.19 (after patch) + (multiple-value-bind (result error) + (ignore-errors (multiple-value-prog1 (progn (the real '(1 2 3))))) + (assert (null result)) + (assert (typep error 'type-error))) + #+nil ; FIXME: still broken in 0.7.7.19 (after patch) + (multiple-value-bind (result error) + (ignore-errors (the real '(1 2 3))) + (assert (null result)) + (assert (typep error 'type-error)))) + +;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden +;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. +(multiple-value-bind (function warnings-p failure-p) + (compile nil '(lambda () (symbol-macrolet ((t nil)) t))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +(multiple-value-bind (function warnings-p failure-p) + (compile nil + '(lambda () + (symbol-macrolet ((*standard-input* nil)) + *standard-input*))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +#|| +BUG 48c, not yet fixed: +(multiple-value-bind (function warnings-p failure-p) + (compile nil '(lambda () (symbol-macrolet ((s nil)) (declare (special s)) s))) + (assert failure-p) + (assert (raises-error? (funcall function) program-error))) +||# + +;;; bug 120a: Turned out to be constraining code looking like (if foo +;;; ) where was optimized by the compiler to be the exact +;;; same block in both cases, but not turned into (PROGN FOO ). +;;; Fixed by APD in sbcl-0.7.7.2, who provided this test: +(declaim (inline dont-constrain-if-too-much)) +(defun dont-constrain-if-too-much (frame up-frame) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (if (or (not frame) t) + frame + "bar")) +(defun dont-constrain-if-too-much-aux (x y) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (if x t (if y t (dont-constrain-if-too-much x y)))) + +(assert (null (dont-constrain-if-too-much-aux nil nil))) + +;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by +;;; APD sbcl-devel 2002-09-14 +(defun exercise-0-7-7-24-bug (x) + (declare (integer x)) + (let (y) + (setf y (the single-float (if (> x 0) x 3f0))) + (list y y))) +(multiple-value-bind (v e) (ignore-errors (exercise-0-7-7-24-bug 4)) + (assert (null v)) + (assert (typep e 'type-error))) +(assert (equal (exercise-0-7-7-24-bug -4) '(3f0 3f0))) + +;;; non-intersecting type declarations were DWIMing in a confusing +;;; fashion until sbcl-0.7.7.28, when APD reported and fixed the +;;; problem. +(defun non-intersecting-the (x) + (let (y) + (setf y (the single-float (the integer x))) + (list y y))) + +(raises-error? (foo 3) type-error) +(raises-error? (foo 3f0) type-error) + +;;; until 0.8.2 SBCL did not check THEs in arguments +(defun the-in-arguments-aux (x) + x) +(defun the-in-arguments-1 (x) + (list x (the-in-arguments-aux (the (single-float 0s0) x)))) +(defun the-in-arguments-2 (x) + (list x (the-in-arguments-aux (the single-float x)))) + +(multiple-value-bind (result condition) + (ignore-errors (the-in-arguments-1 1)) + (assert (null result)) + (assert (typep condition 'type-error))) +(multiple-value-bind (result condition) + (ignore-errors (the-in-arguments-2 1)) + (assert (null result)) + (assert (typep condition 'type-error))) + +;;; bug 153: a hole in a structure slot type checking +(declaim (optimize safety)) +(defstruct foo153 + (bla 0 :type fixnum)) +(defun bug153-1 () + (let ((foo (make-foo153))) + (setf (foo153-bla foo) '(1 . 1)) + (format t "Is ~a of type ~a a cons? => ~a~%" + (foo153-bla foo) + (type-of (foo153-bla foo)) + (consp (foo153-bla foo))))) +(defun bug153-2 (x) + (let ((foo (make-foo153))) + (setf (foo153-bla foo) x) + (format t "Is ~a of type ~a a cons? => ~a~%" + (foo153-bla foo) + (type-of (foo153-bla foo)) + (consp (foo153-bla foo))))) + +(multiple-value-bind (result condition) + (ignore-errors (bug153-1)) + (declare (ignore result)) + (assert (typep condition 'type-error))) +(multiple-value-bind (result condition) + (ignore-errors (bug153-2 '(1 . 1))) + (declare (ignore result)) + (assert (typep condition 'type-error))) + +;;; bug 110: the compiler flushed the argument type test and the default +;;; case in the cond. + +(defun bug110 (x) + (declare (optimize (safety 2) (speed 3))) + (declare (type (or string stream) x)) + (cond ((typep x 'string) 'string) + ((typep x 'stream) 'stream) + (t + 'none))) + +(multiple-value-bind (result condition) + (ignore-errors (bug110 0)) + (declare (ignore result)) + (assert (typep condition 'type-error))) + +;;; bug 202: the compiler failed to compile a function, which derived +;;; type contradicted declared. +(declaim (ftype (function () null) bug202)) +(defun bug202 () + t) + +;;; bugs 178, 199: compiler failed to compile a call of a function +;;; with a hairy type +(defun bug178 (x) + (funcall (the function (the standard-object x)))) + +(defun bug199-aux (f) + (eq nil (funcall f))) + +(defun bug199 (f x) + (declare (type (and function (satisfies bug199-aux)) f)) + (funcall f x)) + +;;; check non-toplevel DEFMACRO +(defvar *defmacro-test-status* nil) + +(defun defmacro-test () + (fmakunbound 'defmacro-test-aux) + (let* ((src "defmacro-test.lisp") + (obj (compile-file-pathname src))) + (unwind-protect + (progn + (compile-file src) + (assert (equal *defmacro-test-status* '(function a))) + (setq *defmacro-test-status* nil) + (load obj) + (assert (equal *defmacro-test-status* nil)) + (macroexpand '(defmacro-test-aux 'a)) + (assert (equal *defmacro-test-status* '(macro 'a z-value))) + (eval '(defmacro-test-aux 'a)) + (assert (equal *defmacro-test-status* '(expanded 'a z-value)))) + (ignore-errors (delete-file obj))))) + +(defmacro-test) + +;;; bug 204: EVAL-WHEN inside a local environment +(defvar *bug204-test-status*) + +(defun bug204-test () + (let* ((src "bug204-test.lisp") + (obj (compile-file-pathname src))) + (unwind-protect + (progn + (setq *bug204-test-status* nil) + (compile-file src) + (assert (equal *bug204-test-status* '((:expanded :load-toplevel) + (:called :compile-toplevel) + (:expanded :compile-toplevel)))) + (setq *bug204-test-status* nil) + (load obj) + (assert (equal *bug204-test-status* '((:called :load-toplevel))))) + (ignore-errors (delete-file obj))))) + +(bug204-test) + +;;; toplevel SYMBOL-MACROLET +(defvar *symbol-macrolet-test-status*) + +(defun symbol-macrolet-test () + (let* ((src "symbol-macrolet-test.lisp") + (obj (compile-file-pathname src))) + (unwind-protect + (progn + (setq *symbol-macrolet-test-status* nil) + (compile-file src) + (assert (equal *symbol-macrolet-test-status* + '(2 1))) + (setq *symbol-macrolet-test-status* nil) + (load obj) + (assert (equal *symbol-macrolet-test-status* '(2)))) + (ignore-errors (delete-file obj))))) + +(symbol-macrolet-test) + +;;; On the x86, this code failed to compile until sbcl-0.7.8.37: +(defun x86-assembler-failure (x) + (declare (optimize (speed 3) (safety 0))) + (eq (setf (car x) 'a) nil)) + +;;; bug 211: :ALLOW-OTHER-KEYS +(defun bug211d (&key (x :x x-p) ((:allow-other-keys y) :y y-p)) + (list x x-p y y-p)) + +(assert (equal (bug211d) '(:x nil :y nil))) +(assert (equal (bug211d :x 1) '(1 t :y nil))) +(assert (raises-error? (bug211d :y 2) program-error)) +(assert (equal (bug211d :y 2 :allow-other-keys t :allow-other-keys nil) + '(:x nil t t))) +(assert (raises-error? (bug211d :y 2 :allow-other-keys nil) program-error)) + +(let ((failure-p + (nth-value + 3 + (compile 'bug211b + '(lambda () + (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p)) + (list x x-p y y-p))) + (assert (equal (test) '(:x nil :y nil))) + (assert (equal (test :x 1) '(1 t :y nil))) + (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil) + '(:x nil 11 t))))))))) + (assert (not failure-p)) + (bug211b)) + +(let ((failure-p + (nth-value + 3 + (compile 'bug211c + '(lambda () + (flet ((test (&key (x :x x-p)) + (list x x-p))) + (assert (equal (test) '(:x nil))) + (assert (equal (test :x 1) '(1 t))) + (assert (equal (test :y 2 :allow-other-keys 11 :allow-other-keys nil) + '(:x nil))))))))) + (assert (not failure-p)) + (bug211c)) + +(dolist (form '((test :y 2) + (test :y 2 :allow-other-keys nil) + (test :y 2 :allow-other-keys nil :allow-other-keys t))) + (multiple-value-bind (result warnings-p failure-p) + (compile nil `(lambda () + (flet ((test (&key (x :x x-p) ((:allow-other-keys y) :y y-p)) + (list x x-p y y-p))) + ,form))) + (assert failure-p) + (assert (raises-error? (funcall result) program-error)))) + +;;; bug 217: wrong type inference +(defun bug217-1 (x s) + (let ((f (etypecase x + (character #'write-char) + (integer #'write-byte)))) + (funcall f x s) + (etypecase x + (character (write-char x s)) + (integer (write-byte x s))))) +(bug217-1 #\1 *standard-output*) + + +;;; bug 221: tried and died on CSUBTYPEP (not VALUES-SUBTYPEP) of the +;;; function return types when inferring the type of the IF expression +(declaim (ftype (function (fixnum) (values package boolean)) bug221f1)) +(declaim (ftype (function (t) (values package boolean)) bug221f2)) +(defun bug221 (b x) + (funcall (if b #'bug221f1 #'bug221f2) x)) + +;;; bug 172: macro lambda lists were too permissive until 0.7.9.28 +;;; (fix provided by Matthew Danish) on sbcl-devel +(assert (null (ignore-errors + (defmacro bug172 (&rest rest foo) `(list ,rest ,foo))))) + +;;; embedded THEs +(defun check-embedded-thes (policy1 policy2 x y) + (handler-case + (funcall (compile nil + `(lambda (f) + (declare (optimize (speed 2) (safety ,policy1))) + (multiple-value-list + (the (values (integer 2 3) t) + (locally (declare (optimize (safety ,policy2))) + (the (values t (single-float 2f0 3f0)) + (funcall f))))))) + (lambda () (values x y))) + (type-error (error) + error))) + +(assert (equal (check-embedded-thes 0 0 :a :b) '(:a :b))) + +(assert (equal (check-embedded-thes 0 3 :a 2.5f0) '(:a 2.5f0))) +(assert (typep (check-embedded-thes 0 3 2 3.5f0) 'type-error)) + +(assert (equal (check-embedded-thes 0 1 :a 3.5f0) '(:a 3.5f0))) +(assert (typep (check-embedded-thes 0 1 2 2.5d0) 'type-error)) + +#+nil +(assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a))) +(assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error)) + +(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b))) +(assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error)) + + +(assert (equal (check-embedded-thes 3 3 2 2.5f0) '(2 2.5f0))) +(assert (typep (check-embedded-thes 3 3 0 2.5f0) 'type-error)) +(assert (typep (check-embedded-thes 3 3 2 3.5f0) 'type-error)) + + +;;; INLINE inside MACROLET +(declaim (inline to-be-inlined)) +(macrolet ((def (x) `(defun ,x (y) (+ y 1)))) + (def to-be-inlined)) +(defun call-inlined (z) + (to-be-inlined z)) +(assert (= (call-inlined 3) 4)) +(macrolet ((frob (x) `(+ ,x 3))) + (defun to-be-inlined (y) + (frob y))) +(assert (= (call-inlined 3) + ;; we should have inlined the previous definition, so the + ;; new one won't show up yet. + 4)) +(defun call-inlined (z) + (to-be-inlined z)) +(assert (= (call-inlined 3) 6)) +(defun to-be-inlined (y) + (+ y 5)) +(assert (= (call-inlined 3) 6)) + +;;;; tests not in the problem domain, but of the consistency of the +;;;; compiler machinery itself + +(in-package "SB-C") + +;;; Hunt for wrong-looking things in fundamental compiler definitions, +;;; and gripe about them. +;;; +;;; FIXME: It should be possible to (1) repair the things that this +;;; code gripes about, and then (2) make the code signal errors +;;; instead of just printing complaints to standard output, in order +;;; to prevent the code from later falling back into disrepair. +(defun grovel-results (function) + (dolist (template (fun-info-templates (info :function :info function))) + (when (template-more-results-type template) + (format t "~&Template ~A has :MORE results, and translates ~A.~%" + (template-name template) + function) + (return nil)) + (when (eq (template-result-types template) :conditional) + ;; dunno. + (return t)) + (let ((types (template-result-types template)) + (result-type (fun-type-returns (info :function :type function)))) + (cond + ((values-type-p result-type) + (do ((ltypes (append (args-type-required result-type) + (args-type-optional result-type)) + (rest ltypes)) + (types types (rest types))) + ((null ltypes) + (unless (null types) + (format t "~&More types than ltypes in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))) + (when (null types) + (unless (null ltypes) + (format t "~&More ltypes than types in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))))) + ((eq result-type (specifier-type nil)) + (unless (null types) + (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%" + (template-name template) + function) + (return nil))) + ((/= (length types) 1) + (format t "~&Template ~A isn't returning 1 value for ~A.~%" + (template-name template) + function) + (return nil)) + (t t))))) +(defun identify-suspect-vops (&optional (env (first + (last *info-environment*)))) + (do-info (env :class class :type type :name name :value value) + (when (and (eq class :function) (eq type :type)) + ;; OK, so we have an entry in the INFO database. Now, if ... + (let* ((info (info :function :info name)) + (templates (and info (fun-info-templates info)))) + (when templates + ;; ... it has translators + (grovel-results name)))))) +(identify-suspect-vops) + ;;; success (quit :unix-status 104)