Confirm that a couple screw cases in closure analysis work.

Once upon a time the Y combinator and U combinator would crash the
compiler.  It's been fixed now but let's at least immortalize the
code I had lying around that crashed it so it doesn't happen again.

diff --git a/tests/check.scm b/tests/check.scm
index 05bfb54d3dffe10043a72f2e01030f8c57976d84..4eb7aa03a47e9eecb74fba9b101be90c697f13bc 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -42,6 +42,7 @@ USA.
   '(
     "compiler/test-fgopt-conect"
     "compiler/test-varname"
+    "compiler/test-y"
     "microcode/test-chacha"
     ;++ Kludge to run the flonum cast tests interpreted and compiled --
     ;++ the compiler has a bug with negative zero.

diff --git a/tests/compiler/test-y.scm b/tests/compiler/test-y.scm
new file mode 100644 (file)
index 0000000..4db7d7e
--- /dev/null
+++ b/tests/compiler/test-y.scm
@@ -0,0 +1,72 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests for the Y combinator
+
+(declare (usual-integrations))
+\f
+(define test-env
+  (make-top-level-environment))
+
+;;; XXX This should really confirm that we don't cons closures.
+
+(define-test 'Y
+  (lambda ()
+    (define factorial-sexp
+      '(let ()
+         (define (Y f)
+           (f (lambda (x) ((Y f) x))))
+         (Y (named-lambda (Yf f)
+              (named-lambda (factorial n)
+                (if (< n 2)
+                    1
+                    (* n (f (- n 1)))))))))
+    (define factorial-scode
+      (syntax&integrate factorial-sexp '((usual-integrations)) test-env))
+    (define factorial-compiled
+      (compile-scode factorial-scode))
+    (define factorial
+      (eval factorial-compiled test-env))
+    (assert-= (factorial 5) 120)))
+
+(define-test 'U
+  (lambda ()
+    (define factorial-sexp
+      '(let ()
+         (define (U f)
+           (f f))
+         (U (named-lambda (Uf f)
+              (named-lambda (factorial n)
+                (if (< n 2)
+                    1
+                    (* n ((U f) (- n 1)))))))))
+    (define factorial-scode
+      (syntax&integrate factorial-sexp '((usual-integrations)) test-env))
+    (define factorial-compiled
+      (compile-scode factorial-scode))
+    (define factorial
+      (eval factorial-compiled test-env))
+    (assert-= (factorial 5) 120)))
\ No newline at end of file