Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / language / scheme / decompile-tree-il.scm

diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index f5bb699..99edee4 100644 (file)
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -261,20 +261,22 @@
          (build-define name (recurse exp)))
 
         ((<lambda> meta body)
-         (let ((body (recurse body))
-               (doc (assq-ref meta 'documentation)))
-           (if (not doc)
-               body
-               (match body
-                 (('lambda formals body ...)
-                  `(lambda ,formals ,doc ,@body))
-                 (('lambda* formals body ...)
-                  `(lambda* ,formals ,doc ,@body))
-                 (('case-lambda (formals body ...) clauses ...)
-                  `(case-lambda (,formals ,doc ,@body) ,@clauses))
-                 (('case-lambda* (formals body ...) clauses ...)
-                  `(case-lambda* (,formals ,doc ,@body) ,@clauses))
-                 (e e)))))
+         (if body
+             (let ((body (recurse body))
+                   (doc (assq-ref meta 'documentation)))
+               (if (not doc)
+                   body
+                   (match body
+                     (('lambda formals body ...)
+                      `(lambda ,formals ,doc ,@body))
+                     (('lambda* formals body ...)
+                      `(lambda* ,formals ,doc ,@body))
+                     (('case-lambda (formals body ...) clauses ...)
+                      `(case-lambda (,formals ,doc ,@body) ,@clauses))
+                     (('case-lambda* (formals body ...) clauses ...)
+                      `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+                     (e e))))
+             '(case-lambda)))
 
         ((<lambda-case> req opt rest kw inits gensyms body alternate)
          (let ((names (map output-name gensyms)))
@@ -430,27 +432,12 @@
          `(call-with-values (lambda () ,@(recurse-body exp))
             ,(recurse (make-lambda #f '() body))))
 
-        ((<dynwind> body winder unwinder)
-         `(dynamic-wind ,(recurse winder)
-                        (lambda () ,@(recurse-body body))
-                        ,(recurse unwinder)))
-
-        ((<dynlet> fluids vals body)
-         `(with-fluids ,(map list
-                             (map recurse fluids)
-                             (map recurse vals))
-            ,@(recurse-body body)))
-
-        ((<dynref> fluid)
-         `(fluid-ref ,(recurse fluid)))
-
-        ((<dynset> fluid exp)
-         `(fluid-set! ,(recurse fluid) ,(recurse exp)))
-
-        ((<prompt> tag body handler)
+        ((<prompt> escape-only? tag body handler)
          `(call-with-prompt
            ,(recurse tag)
-           (lambda () ,@(recurse-body body))
+           ,(if escape-only?
+                `(lambda () ,(recurse body))
+                (recurse body))
            ,(recurse handler)))
 
 
@@ -702,7 +689,8 @@
             ((<seq> head tail)
              (primitive 'begin) (recurse head) (recurse tail))
 
-            ((<lambda> body) (recurse body))
+            ((<lambda> body)
+             (if body (recurse body) (primitive 'case-lambda)))
 
             ((<lambda-case> req opt rest kw inits gensyms body alternate)
              (primitive 'lambda)
@@ -758,23 +746,8 @@
              (primitive 'call-with-values)
              (recurse exp) (recurse body))
 
-            ((<dynwind> winder body unwinder)
-             (primitive 'dynamic-wind)
-             (recurse winder) (recurse body) (recurse unwinder))
-
-            ((<dynlet> fluids vals body)
-             (primitive 'with-fluids)
-             (for-each recurse fluids)
-             (for-each recurse vals)
-             (recurse body))
-
-            ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
-            ((<dynset> fluid exp)
-             (primitive 'fluid-set!) (recurse fluid) (recurse exp))
-
             ((<prompt> tag body handler)
              (primitive 'call-with-prompt)
-             (primitive 'lambda)
              (recurse tag) (recurse body) (recurse handler))
 
             ((<abort> tag args tail)