[Sbcl-commits] CVS: sbcl/contrib/sb-cltl2 Makefile,NONE,1.1 compiler-let.lisp,NONE,1.1 defpackage.lisp,NONE,1.1 macroexpand.lisp,NONE,1.1 sb-cltl2.asd,NONE,1.1 tests.lisp,NONE,1.1

[Alexey D. <ade...@us...>]

Update of /cvsroot/sbcl/sbcl/contrib/sb-cltl2
In directory sc8-pr-cvs1:/tmp/cvs-serv30426/contrib/sb-cltl2

Added Files:
	Makefile compiler-let.lisp defpackage.lisp macroexpand.lisp 
	sb-cltl2.asd tests.lisp 
Log Message:
0.8.0.36:
        Included module SB-CLTL2.


--- NEW FILE: Makefile ---
SYSTEM=sb-cltl2
include ../asdf-module.mk

--- NEW FILE: compiler-let.lisp ---
(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)

--- NEW FILE: defpackage.lisp ---
(defpackage :sb-cltl2
  (:use :cl :sb-c :sb-int)
  (:export #:compiler-let
           #:macroexpand-all))

--- NEW FILE: macroexpand.lisp ---
(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)))

--- NEW FILE: sb-cltl2.asd ---
(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")))

--- NEW FILE: tests.lisp ---
(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))