Merge branch 'bt/elisp'

[bpt/guile.git] / module / language / tree-il / compile-glil.scm

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 81defa1..79f4ff9 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -110,6 +110,7 @@
    ((list? . 1) . list?)
    ((symbol? . 1) . symbol?)
    ((vector? . 1) . vector?)
+   ((nil? . 1) . nil?)
    (list . list)
    (vector . vector)
    ((class-of . 1) . class-of)
@@ -527,6 +528,9 @@
               ((null? ,x)
                (comp-push x)
                (emit-branch src 'br-if-not-null L1))
+              ((nil? ,x)
+               (comp-push x)
+               (emit-branch src 'br-if-not-nil L1))
               ((not ,x)
                (record-case x
                  ((<primcall> name args)
@@ -538,6 +542,9 @@
                     ((null? ,x)
                      (comp-push x)
                      (emit-branch src 'br-if-null L1))
+                    ((nil? ,x)
+                     (comp-push x)
+                     (emit-branch src 'br-if-nil L1))
                     (else
                      (comp-push x)
                      (emit-branch src 'br-if L1))))
@@ -921,7 +928,31 @@
       ;; then proceed with returning or dropping or what-have-you, interacting
       ;; with RA and MVRA. What have you, I say.
       ((<dynwind> src winder pre body post unwinder)
+       (define (thunk? x)
+         (and (lambda? x)
+              (null? (lambda-case-gensyms (lambda-body x)))))
+       (define (make-wrong-type-arg x)
+         (make-primcall src 'scm-error
+                        (list
+                         (make-const #f 'wrong-type-arg)
+                         (make-const #f "dynamic-wind")
+                         (make-const #f "Wrong type (expecting thunk): ~S")
+                         (make-primcall #f 'list (list x))
+                         (make-primcall #f 'list (list x)))))
+       (define (emit-thunk-check x)
+         (comp-drop (make-conditional
+                     src
+                     (make-primcall src 'thunk? (list x))
+                     (make-void #f)
+                     (make-wrong-type-arg x))))
+
+       ;; We know at this point that `winder' and `unwinder' are
+       ;; constant expressions and can be duplicated.
+       (if (not (thunk? winder))
+           (emit-thunk-check winder))
        (comp-push winder)
+       (if (not (thunk? unwinder))
+           (emit-thunk-check unwinder))
        (comp-push unwinder)
        (comp-drop pre)
        (emit-code #f (make-glil-call 'wind 2))