diff options
| author | Mark H Weaver <mhw@netris.org> | 2013-08-22 07:26:50 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2013-08-22 07:26:50 -0400 |
| commit | e41379034b93678f2f051685a5f4dfba2ddcf997 (patch) | |
| tree | 5a255b82f8839516e58f751eac635b1e66e80df6 | |
| parent | 49b2835a1784cde0ac49f43b2273e7a499127e0f (diff) | |
| download | guile-e41379034b93678f2f051685a5f4dfba2ddcf997.tar.gz | |
RTL Compiler: Fix 'case-lambda'.
* module/language/tree-il/compile-cps.scm (compile-cps): Canonicalize
the tree-il before conversion.
* module/language/cps/compile-rtl.scm (emit-fun-entries): Properly adapt
to recent change in 'case-lambda' representation (alternate -> list of
entries).
* test-suite/tests/rtl-compilation.test: Add tests.
| -rw-r--r-- | module/language/cps/compile-rtl.scm | 10 | ||||
| -rw-r--r-- | module/language/tree-il/compile-cps.scm | 3 | ||||
| -rw-r--r-- | test-suite/tests/rtl-compilation.test | 23 |
3 files changed, 30 insertions, 6 deletions
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index 00d6bb1e5..d3db3ba2e 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -337,11 +337,11 @@ (define (emit-fun-entries self entries) (match entries ((entry . entries) - (let ((alternate (match entries - (($cont _ k) k) - (() #f)))) - (emit-fun-entry self entry alternate) - (when alternate + (let ((kalternate (and (not (null? entries)) + (gensym "kalternate")))) + (emit-fun-entry self entry kalternate) + (when kalternate + (emit-label asm kalternate) (emit-fun-entries self entries)))))) (match f diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 304b21182..9a8aa03ee 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -30,6 +30,7 @@ #:use-module (language cps primitives) #:use-module (language tree-il analyze) #:use-module (language tree-il optimize) + #:use-module (language tree-il canonicalize) #:use-module ((language tree-il) #:select (<void> @@ -551,7 +552,7 @@ indicates that the replacement variable is in a box." (optimize x e opts)) (define (compile-cps exp env opts) - (values (cps-convert/thunk (optimize-tree-il exp env opts)) + (values (cps-convert/thunk (canonicalize (optimize-tree-il exp env opts))) env env)) diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test index eadfbc63e..cf00a4f78 100644 --- a/test-suite/tests/rtl-compilation.test +++ b/test-suite/tests/rtl-compilation.test @@ -160,6 +160,29 @@ (even? x))) '(1 2 3))))) +(with-test-prefix "case-lambda" + (pass-if-equal "simple" + '(0 3 9 28) + (let ((proc (run-rtl '(case-lambda + (() 0) + ((x) x) + ((x y) (+ x y)) + ((x y z . rest) (apply + x y z rest)))))) + (map (lambda (args) (apply proc args)) + '(() (3) (2 7) (2 3 5 7 11))))) + + (pass-if-exception "no match" + exception:wrong-num-args + ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y)))) + 1 2 3)) + + (pass-if-exception "zero clauses called with no args" + exception:wrong-num-args + ((run-rtl '(case-lambda)))) + + (pass-if-exception "zero clauses called with args" + exception:wrong-num-args + ((run-rtl '(case-lambda)) 1))) (with-test-prefix "mixed contexts" (pass-if-equal "sequences" '(3 4 5) |