Remove with-fluids; replaced by with-fluid* and inlined push-fluid primops

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

diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 2536a71..9b0c0c8 100644 (file)
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -1,6 +1,6 @@
 ;;; Tree-il canonicalizer
 
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 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
@@ -22,18 +22,16 @@
   #:use-module (language tree-il)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:export (canonicalize!))
+  #:export (canonicalize))
 
 (define (tree-il-any proc exp)
   (tree-il-fold (lambda (exp res)
                   (or res (proc exp)))
-                (lambda (exp res)
-                  (or res (proc exp)))
                 (lambda (exp res) res)
                 #f exp))
 
-(define (canonicalize! x)
-  (post-order!
+(define (canonicalize x)
+  (post-order
    (lambda (x)
      (match x
        (($ <let> src () () () body)
@@ -42,8 +40,21 @@
         body)
        (($ <fix> src () () () body)
         body)
-       (($ <dynlet> src () () body)
-        body)
+       (($ <lambda> src meta #f)
+        ;; Give a body to case-lambda with no clauses.
+        (make-lambda
+         src meta
+         (make-lambda-case
+          #f '() #f #f #f '() '()
+          (make-primcall
+           #f
+           'throw
+           (list (make-const #f 'wrong-number-of-args)
+                 (make-const #f #f)
+                 (make-const #f "Wrong number of arguments")
+                 (make-const #f '())
+                 (make-const #f #f)))
+          #f)))
        (($ <prompt> src tag body handler)
         (define (escape-only? handler)
           (match handler
@@ -70,7 +81,7 @@
         ;; thunk.  Sad but true.
         (if (or (escape-only? handler)
                 (thunk-application? body))
-            #f
+            x
             (make-prompt src tag (make-thunk-application body) handler)))
-       (_ #f)))
+       (_ x)))
    x))