From: Alexey Dejneka <adejneka@comail.ru>
Date: Thu, 5 Jun 2003 17:25:27 +0000 (+0000)
Subject: 0.8.0.36:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=79f9319b412fc6106d65ca435b36548f454b81b9;p=sbcl.git

0.8.0.36:
        Included module SB-CLTL2.
---

diff --git a/NEWS b/NEWS
index 05fc051..b9d65c3 100644
--- a/NEWS
+++ b/NEWS
@@ -1799,6 +1799,8 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0:
     subclass of STANDARD-METHOD no longer causes stack exhaustion.
     (thanks to Gerd Moellmann)
   * increased compilation speed of long MULTIPLE-VALUES-BIND.
+  * a contributed module implementing COMPILER-LET and MACROEXPAND-ALL
+    has been included.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** NIL is now allowed as a structure slot name.
     ** arbitrary numbers, not just reals, are allowed in certain
diff --git a/contrib/sb-cltl2/Makefile b/contrib/sb-cltl2/Makefile
new file mode 100644
index 0000000..9df84ec
--- /dev/null
+++ b/contrib/sb-cltl2/Makefile
@@ -0,0 +1,2 @@
+SYSTEM=sb-cltl2
+include ../asdf-module.mk
diff --git a/contrib/sb-cltl2/compiler-let.lisp b/contrib/sb-cltl2/compiler-let.lisp
new file mode 100644
index 0000000..60600b5
--- /dev/null
+++ b/contrib/sb-cltl2/compiler-let.lisp
@@ -0,0 +1,31 @@
+(in-package :sb-cltl2)
+
+(def-ir1-translator compiler-let ((bindings &rest forms) start cont)
+  (loop for binding in bindings
+     if (atom binding)
+        collect binding into vars
+        and collect nil into values
+       else do (assert (proper-list-of-length-p binding 1 2))
+        and collect (first binding) into vars
+        and collect (eval (second binding)) into values
+     finally (return (progv vars values
+                       (sb-c::ir1-convert-progn-body start cont forms)))))
+
+(defun walk-compiler-let (form context env)
+  (declare (ignore context))
+  (destructuring-bind (bindings &rest body)
+      (cdr form)
+    (loop for binding in bindings
+       if (atom binding)
+          collect binding into vars
+          and collect nil into values
+         else do (assert (proper-list-of-length-p binding 1 2))
+          and collect (first binding) into vars
+          and collect (eval (second binding)) into values
+       finally (return
+                 (progv vars values
+                   (let ((walked-body (sb-walker::walk-repeat-eval body env)))
+                     (sb-walker::relist* form
+                                         'compiler-let bindings walked-body)))))))
+
+(sb-walker::define-walker-template compiler-let walk-compiler-let)
diff --git a/contrib/sb-cltl2/defpackage.lisp b/contrib/sb-cltl2/defpackage.lisp
new file mode 100644
index 0000000..b335da2
--- /dev/null
+++ b/contrib/sb-cltl2/defpackage.lisp
@@ -0,0 +1,4 @@
+(defpackage :sb-cltl2
+  (:use :cl :sb-c :sb-int)
+  (:export #:compiler-let
+           #:macroexpand-all))
diff --git a/contrib/sb-cltl2/macroexpand.lisp b/contrib/sb-cltl2/macroexpand.lisp
new file mode 100644
index 0000000..71f450e
--- /dev/null
+++ b/contrib/sb-cltl2/macroexpand.lisp
@@ -0,0 +1,5 @@
+(in-package :sb-cltl2)
+
+(defun macroexpand-all (form &optional environment)
+  (let ((sb-walker::*walk-form-expand-macros-p* t))
+    (sb-walker:walk-form form environment)))
diff --git a/contrib/sb-cltl2/sb-cltl2.asd b/contrib/sb-cltl2/sb-cltl2.asd
new file mode 100644
index 0000000..470e821
--- /dev/null
+++ b/contrib/sb-cltl2/sb-cltl2.asd
@@ -0,0 +1,23 @@
+(defpackage #:sb-cltl2-system (:use #:asdf #:cl))
+(in-package #:sb-cltl2-system)
+
+(defsystem sb-cltl2
+    :description "Some functionality, mentioned in CLtL2, but not present in ANSI."
+    :components ((:file "defpackage")
+		 (:file "compiler-let" :depends-on ("defpackage"))
+                 (:file "macroexpand" :depends-on ("defpackage"))))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system :sb-cltl2))))
+  (provide 'sb-cltl2))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-cltl2))))
+  (oos 'load-op 'sb-cltl2-tests)
+  (oos 'test-op 'sb-cltl2-tests))
+
+(defsystem sb-cltl2-tests
+    :depends-on (sb-rt)
+    :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-cltl2-tests))))
+  (or (funcall (find-symbol "DO-TESTS" "SB-RT"))
+      (error "test-op failed")))
diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp
new file mode 100644
index 0000000..c649297
--- /dev/null
+++ b/contrib/sb-cltl2/tests.lisp
@@ -0,0 +1,47 @@
+(defpackage :sb-cltl2-tests
+  (:use :sb-cltl2 :cl :sb-rt))
+(in-package :sb-cltl2-tests)
+
+(rem-all-tests)
+
+(defmacro *x*-value ()
+  (declare (special *x*))
+  *x*)
+
+(deftest compiler-let.1
+    (let ((*x* :outer))
+      (compiler-let ((*x* :inner))
+        (list *x* (*x*-value))))
+  (:outer :inner))
+
+(defvar *expansions* nil)
+(defmacro macroexpand-macro (arg)
+  (push arg *expansions*)
+  arg)
+
+(deftest macroexpand-all.1
+    (progn
+      (macroexpand-all '(defmethod foo ((x fixnum)) (1+ x)))
+      t)
+  t)
+
+(deftest macroexpand-all.2
+    (let ((*expansions* nil))
+      (macroexpand-all '(list (macroexpand-macro 1)
+                         (let (macroexpand-macro :no)
+                           (macroexpand-macro 2))))
+      (remove-duplicates (sort *expansions* #'<)))
+  (1 2))
+
+(deftest macroexpand-all.3
+    (let ((*expansions* nil))
+      (compile nil '(lambda ()
+                     (macrolet ((foo (key &environment env)
+                                  (macroexpand-all `(bar ,key) env)))
+                       (foo
+                        (macrolet ((bar (key)
+                                     (push key *expansions*)
+                                     key))
+                          (foo 1))))))
+      (remove-duplicates *expansions*))
+  (1))
diff --git a/version.lisp-expr b/version.lisp-expr
index 6460a54..eb59823 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.35"
+"0.8.0.36"