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.

11 files changed, 46 insertions, 79 deletions

diff --git a/libguile/expand.c b/libguile/expand.c
index 396df3b07..28636a462 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -181,7 +181,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
 SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
 SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
 SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
 SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
 SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
diff --git a/libguile/memoize.c b/libguile/memoize.c
index f4a4c9ef7..12e670ae1 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -279,6 +279,9 @@ memoize (SCM exp, SCM env)
           return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
                                            CADR (args),
                                            CADDR (args));
+        else if (nargs == 2
+                 && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
+          return MAKMEMO_APPLY (CAR (args), CADR (args));
         else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
           return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
         else
@@ -524,18 +527,10 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
 #define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N)                           \
 SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
 
-#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N)                        \
-  (scm_cell (scm_tc16_memoizer,                                         \
-             SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
-#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N)                      \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest);
 static SCM m_call_cc (SCM proc);
 static SCM m_call_values (SCM prod, SCM cons);
 static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
 
-SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
 SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
 SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
 SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
@@ -543,41 +538,6 @@ SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
 
 
 
-static SCM m_apply (SCM proc, SCM arg, SCM rest)
-#define FUNC_NAME "@apply"
-{
-  long len;
-  
-  SCM_VALIDATE_MEMOIZED (1, proc);
-  SCM_VALIDATE_MEMOIZED (2, arg);
-  len = scm_ilength (rest);
-  if (len < 0)
-    abort ();
-  else if (len == 0)
-    return MAKMEMO_APPLY (proc, arg);
-  else
-    {
-      SCM tail;
-
-      rest = scm_reverse (rest);
-      tail = scm_car (rest);
-      rest = scm_cdr (rest);
-      len--;
-      
-      while (scm_is_pair (rest))
-        {
-          tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
-                                                scm_from_latin1_symbol ("cons"),
-                                                SCM_BOOL_F),
-                               2,
-                               scm_list_2 (scm_car (rest), tail));
-          rest = scm_cdr (rest);
-        }
-      return MAKMEMO_APPLY (proc, tail);
-    }
-}
-#undef FUNC_NAME
-
 static SCM m_call_cc (SCM proc)
 #define FUNC_NAME "@call-with-current-continuation"
 {
@@ -666,7 +626,8 @@ unmemoize (const SCM expr)
   switch (SCM_MEMOIZED_TAG (expr))
     {
     case SCM_M_APPLY:
-      return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
+      return scm_cons (scm_from_latin1_symbol ("apply"),
+                       unmemoize_exprs (args));
     case SCM_M_SEQ:
       return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
                          unmemoize (CDR (args)));
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 764aa42cc..3bd37ebbd 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -3,7 +3,7 @@
 #ifndef SCM_MEMOIZE_H
 #define SCM_MEMOIZE_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2013
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -48,7 +48,6 @@ SCM_API SCM scm_sym_with_fluids;
 
 SCM_API SCM scm_sym_at;
 SCM_API SCM scm_sym_atat;
-SCM_API SCM scm_sym_atapply;
 SCM_API SCM scm_sym_atcall_cc;
 SCM_API SCM scm_sym_at_call_with_values;
 SCM_API SCM scm_sym_delay;
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))
 
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7322d6120..0beeb75bd 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -874,7 +874,7 @@
     (let (args) (_) ((primcall list (const 2) (const 3)))
          (seq
           (call (toplevel foo!) (lexical args _))
-          (primcall @apply
+          (primcall apply
                     (lambda ()
                       (lambda-case
                        (((x y z w) #f #f #f () (_ _ _ _))
@@ -898,7 +898,7 @@
                 bv
                 (+ offset 4))))
         (let ((args (list x y)))
-          (@apply
+          (apply
            (lambda (bv offset x y)
              (bytevector-ieee-single-native-set!
               bv
@@ -938,7 +938,7 @@
     ;; Here we ensure that non-constant expressions are not copied.
     (lambda ()
       (let ((args (list (foo!))))
-        (@apply
+        (apply
          (lambda (z x)
            (list z x))
          ;; This toplevel ref might raise an unbound variable exception.
@@ -959,7 +959,7 @@
     (lambda ()
       (let ((args (list 'foo)))
         (set-car! args 'bar)
-        (@apply
+        (apply
          (lambda (z x)
            (list z x))
          z
@@ -971,7 +971,7 @@
              ((primcall list (const foo)))
              (seq
               (primcall set-car! (lexical args _) (const bar))
-              (primcall @apply
+              (primcall apply
                         (lambda . _)
                         (toplevel z)
                         (lexical args _))))))))
@@ -1106,7 +1106,7 @@
           (lambda-case
            ((() #f vals #f () (_))
             (seq (toplevel baz)
-                 (primcall @apply (primitive values) (lexical vals _))))))))
+                 (primcall apply (primitive values) (lexical vals _))))))))
   
   (pass-if-peval
    ;; Prompt is removed if tag is unreferenced
@@ -1145,7 +1145,7 @@
                 (const 1)
                 (lambda-case
                  ((() #f args #f () (_))
-                  (primcall @apply
+                  (primcall apply
                             (lexical handler _)
                             (lexical args _)))))))
 
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 9407791f7..eee54e61e 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -1,7 +1,7 @@
 ;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
 ;;;; Ludovic Courtès <ludo@gnu.org>
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 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
@@ -49,7 +49,7 @@
 
   (pass-if "apply"
     (equal? (procedure-minimum-arity apply)
-            '(1 0 #t)))
+            '(2 0 #t)))
 
   (pass-if "cons*"
     (equal? (procedure-minimum-arity cons*)
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index 679e17326..56c898c8b 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -2,7 +2,7 @@
 ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
 ;;;;
 ;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
-;;;;   2011 Free Software Foundation, Inc.
+;;;;   2011, 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
@@ -546,10 +546,10 @@
 (with-test-prefix "string"
 
   (pass-if-exception "convert circular list to string"
-     exception:wrong-type-arg
-     (let ((foo (list #\a #\b #\c)))
-       (set-cdr! (cddr foo) (cdr foo))
-       (apply string foo))))
+    '(wrong-type-arg . "Apply to non-list")
+    (let ((foo (list #\a #\b #\c)))
+      (set-cdr! (cddr foo) (cdr foo))
+      (apply string foo))))
  
 (with-test-prefix "string-split"
 
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 50847fd21..059cb8261 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -653,10 +653,10 @@
 
 (with-test-prefix "apply"
   (assert-tree-il->glil
-   (primcall @apply (toplevel foo) (toplevel bar))
+   (primcall apply (toplevel foo) (toplevel bar))
    (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
   (assert-tree-il->glil
-   (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
+   (begin (primcall apply (toplevel foo) (toplevel bar)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -664,7 +664,7 @@
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
-   (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
+   (call (toplevel foo) (call (toplevel apply) (toplevel bar) (toplevel baz)))
    (program () (std-prelude 0 0 #f) (label _)
             (toplevel ref foo)
             (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)