diff options
author | Andy Wingo <wingo@pobox.com> | 2013-06-27 11:25:34 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-27 22:02:35 +0200 |
commit | 39caffe79b3d159590b5ce1ccf8fe28c3d5cfdc6 (patch) | |
tree | 94994ed36aed8426e5287953396350e92db1b5dc /module | |
parent | 1773bc7dd5f4c8a1d13c7cf2015f3a04c9299eeb (diff) | |
download | guile-39caffe79b3d159590b5ce1ccf8fe28c3d5cfdc6.tar.gz |
remove @apply memoizer
* libguile/memoize.c (memoize): Recognize a primcall to 'apply as
SCM_M_APPLY.
(@apply): Remove @apply memoizer.
(unmemoize): Unmemoize using "apply", not "@apply".
* libguile/memoize.h:
* libguile/expand.c (scm_sym_atapply): Remove.
* module/ice-9/boot-9.scm (apply): Re-implement using apply primcall.
Use case-lambda, so as to give an appropriate minimum arity.
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
Compile a primcall of "apply" specially, not "@apply".
* module/language/tree-il/peval.scm (peval): Match primcalls to "apply",
not "@apply". Residualize "apply" primcalls.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*multiply-valued-primitives*): Remove @apply, and apply primitive
expander.
* test-suite/tests/peval.test:
* test-suite/tests/tree-il.test: Update tests to expect residualized
"apply".
* test-suite/tests/procprop.test ("procedure-arity"): Update test for
better apply arity.
* test-suite/tests/strings.test ("string"): Update expected error.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 16 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 5 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 10 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 7 |
4 files changed, 23 insertions, 15 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 4a884d871..7760a2c38 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -192,7 +192,7 @@ If there is no handler at all, Guile prints an error and then exits." ;;; ;; These are are the procedural wrappers around the primitives of -;; Guile's language: @apply, @call-with-current-continuation, etc. +;; Guile's language: apply, call-with-current-continuation, etc. ;; ;; Usually, a call to a primitive is compiled specially. The compiler ;; knows about all these kinds of expressions. But the primitives may @@ -200,8 +200,18 @@ If there is no handler at all, Guile prints an error and then exits." ;; stub procedures are the "values" of apply, dynamic-wind, and other ;; such primitives. ;; -(define (apply fun . args) - (@apply fun (apply:nconc2last args))) +(define apply + (case-lambda + ((fun args) + ((@@ primitive apply) fun args)) + ((fun arg1 . args) + (letrec ((append* (lambda (tail) + (let ((tail (car tail)) + (tail* (cdr tail))) + (if (null? tail*) + tail + (cons tail (append* tail*))))))) + (apply fun (cons arg1 (append* args))))))) (define (call-with-current-continuation proc) (@call-with-current-continuation proc)) (define (call-with-values producer consumer) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index c06a1f6da..c211f37e7 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -372,7 +372,7 @@ ((<primcall> src name args) (pmatch (cons name args) - ((@apply ,proc . ,args) + ((apply ,proc . ,args) (cond ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) (not (eq? context 'push)) (not (eq? context 'vals))) @@ -398,7 +398,8 @@ (emit-code src (make-glil-call 'apply (1+ (length args)))) (maybe-emit-return)) (else - (comp-tail (make-primcall src 'apply (cons proc args)))))))) + (comp-tail (make-call src (make-primitive-ref #f 'apply) + (cons proc args)))))))) ((values . _) ;; tail: (lambda () (values '(1 2))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 27da46068..a7504fdf8 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -861,7 +861,7 @@ top-level bindings from ENV and return the resulting expression." (names ... rest) (gensyms ... rest-sym) (vals ... ($ <primcall> _ 'list rest-args)) - ($ <primcall> asrc (or 'apply '@apply) + ($ <primcall> asrc 'apply (proc args ... ($ <lexical-ref> _ (? (cut eq? <> rest)) @@ -1192,7 +1192,7 @@ top-level bindings from ENV and return the resulting expression." (for-tail (list->seq src (append (cdr vals) (list (car vals))))) (make-primcall src 'values vals)))))) - (($ <primcall> src (or 'apply '@apply) (proc args ... tail)) + (($ <primcall> src 'apply (proc args ... tail)) (let lp ((tail* (find-definition tail 1)) (speculative? #t)) (define (copyable? x) ;; Inlining a result from find-definition effectively copies it, @@ -1205,7 +1205,7 @@ top-level bindings from ENV and return the resulting expression." (for-tail (make-call src proc (append args args*))))) (($ <primcall> _ 'cons ((and head (? copyable?)) (and tail (? copyable?)))) - (for-tail (make-primcall src '@apply + (for-tail (make-primcall src 'apply (cons proc (append args (list head tail)))))) (($ <primcall> _ 'list @@ -1215,7 +1215,7 @@ top-level bindings from ENV and return the resulting expression." (if speculative? (lp (for-value tail) #f) (let ((args (append (map for-value args) (list tail*)))) - (make-primcall src '@apply + (make-primcall src 'apply (cons (for-value proc) args)))))))) (($ <primcall> src (? constructor-primitive? name) args) @@ -1461,7 +1461,7 @@ top-level bindings from ENV and return the resulting expression." (define (lift-applied-lambda body gensyms) (and (not opt) rest (not kw) (match body - (($ <primcall> _ '@apply + (($ <primcall> _ 'apply (($ <lambda> _ _ (and lcase ($ <lambda-case>))) ($ <lexical-ref> _ _ sym) ...)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index fb300822b..db80d8a89 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -36,7 +36,7 @@ ;; When adding to this, be sure to update *multiply-valued-primitives* ;; if appropriate. (define *interesting-primitive-names* - '(apply @apply + '(apply call-with-values @call-with-values call-with-current-continuation @call-with-current-continuation call/cc @@ -180,7 +180,7 @@ ;; Primitives that don't always return one value. (define *multiply-valued-primitives* - '(apply @apply + '(apply call-with-values @call-with-values call-with-current-continuation @call-with-current-continuation call/cc @@ -448,9 +448,6 @@ (define-primitive-expander acons (x y z) (cons (cons x y) z)) -(define-primitive-expander apply (f a0 . args) - (@apply f a0 . args)) - (define-primitive-expander call-with-values (producer consumer) (@call-with-values producer consumer)) |