summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-06-27 11:25:34 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-27 22:02:35 +0200
commit39caffe79b3d159590b5ce1ccf8fe28c3d5cfdc6 (patch)
tree94994ed36aed8426e5287953396350e92db1b5dc /module
parent1773bc7dd5f4c8a1d13c7cf2015f3a04c9299eeb (diff)
downloadguile-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.scm16
-rw-r--r--module/language/tree-il/compile-glil.scm5
-rw-r--r--module/language/tree-il/peval.scm10
-rw-r--r--module/language/tree-il/primitives.scm7
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))