contrib/sb-cltl2/compiler-let.lisp

   1 (in-package :sb-cltl2)
   2
   3 (def-ir1-translator compiler-let ((bindings &rest forms) start next result)
   4   (loop for binding in bindings
   5      if (atom binding)
   6         collect binding into vars
   7         and collect nil into values
   8        else do (assert (proper-list-of-length-p binding 1 2))
   9         and collect (first binding) into vars
  10         and collect (eval (second binding)) into values
  11      finally (return (progv vars values
  12                        (sb-c::ir1-convert-progn-body start next result forms)))))
  13
  14 (defun walk-compiler-let (form context env)
  15   (declare (ignore context))
  16   (destructuring-bind (bindings &rest body)
  17       (cdr form)
  18     (loop for binding in bindings
  19        if (atom binding)
  20           collect binding into vars
  21           and collect nil into values
  22          else do (assert (proper-list-of-length-p binding 1 2))
  23           and collect (first binding) into vars
  24           and collect (eval (second binding)) into values
  25        finally (return
  26                  (progv vars values
  27                    (let ((walked-body (sb-walker::walk-repeat-eval body env)))
  28                      (sb-walker::relist* form
  29                                          'compiler-let bindings walked-body)))))))
  30
  31 (sb-walker::define-walker-template compiler-let walk-compiler-let)
  32
  33 #+sb-eval
  34 (setf (getf sb-eval::*eval-dispatch-functions* 'compiler-let)
  35       (lambda (form env)
  36         (destructuring-bind (bindings &body body) (cdr form)
  37           (loop for binding in bindings
  38                 if (atom binding)
  39                 collect binding into vars
  40                 and collect nil into values
  41                 else do (assert (proper-list-of-length-p binding 1 2))
  42                 and collect (first binding) into vars
  43                 and collect (eval (second binding)) into values
  44                 finally (return
  45                           (let ((new-env (sb-eval::make-env
  46                                           :parent env
  47                                           :vars (sb-eval::special-bindings vars))))
  48                             (progv vars values
  49                               (sb-eval::eval-progn body new-env))))))))