X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=a1e239b9c71891f9bb99c4fd42c5134d39b7c6e7;hb=4e3b57699314dbd3883470d9b196287b178f3e6d;hp=0aeda7eb8ee0cc64d678b9a891cf0b6cc0b7b61d;hpb=675c5a9f9e3028bc2fd922ed6f570f01cf8c41cf;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 0aeda7e..a1e239b 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -27,5 +27,139 @@
   (cons x y))
 (assert (equal (cons 1 2) (newfangled-cons 'right-thing 2 'left-thing 1)))
 
+;;; ANSI specifically says that duplicate keys are OK in lambda lists,
+;;; with no special exception for macro lambda lists. (As reported by
+;;; Pierre Mai on cmucl-imp 2001-03-30, Python didn't think so. The
+;;; rest of the thread had some entertainment value, at least for me
+;;; (WHN). The unbelievers were besmote and now even CMU CL will
+;;; conform to the spec in this regard. Who needs diplomacy when you
+;;; have brimstone?:-)
+(defmacro ayup-duplicate-keys-are-ok-i-see-the-lite (&key k)
+  k)
+(assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 112) 112))
+(assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 'x :k 'y) 'x))
+
+;;; As reported by Alexey Dejneka (sbcl-devel 2002-01-30), in
+;;; sbcl-0.7.1 plus his patch (i.e. essentially sbcl-0.7.1.2), the
+;;; compiler barfed on this, blowing up in FIND-IN-PHYSENV looking for
+;;; the LAMBDA-VAR named NUM. That was fixed in sbcl-0.7.1.3.
+(defun parse-num (index)
+  (let (num x)
+    (flet ((digs ()
+             (setq num index))
+	   (z ()
+	     (let ()
+	       (setq x nil))))
+      (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. (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.)
+
+;;;; 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)