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");
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
#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);
\f
-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"
{
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)));
#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
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;
;;;
;; 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
;; 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)
((<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)))
(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)))
(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))
(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,
(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
(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)
(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)
...))
;; 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
;; 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
(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))
(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 () (_ _ _ _))
bv
(+ offset 4))))
(let ((args (list x y)))
- (@apply
+ (apply
(lambda (bv offset x y)
(bytevector-ieee-single-native-set!
bv
;; 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.
(lambda ()
(let ((args (list 'foo)))
(set-car! args 'bar)
- (@apply
+ (apply
(lambda (z x)
(list z x))
z
((primcall list (const foo)))
(seq
(primcall set-car! (lexical args _) (const bar))
- (primcall @apply
+ (primcall apply
(lambda . _)
(toplevel z)
(lexical args _))))))))
(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
(const 1)
(lambda-case
((() #f args #f () (_))
- (primcall @apply
+ (primcall apply
(lexical handler _)
(lexical args _)))))))
;;;; 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
(pass-if "apply"
(equal? (procedure-minimum-arity apply)
- '(1 0 #t)))
+ '(2 0 #t)))
(pass-if "cons*"
(equal? (procedure-minimum-arity cons*)
;;;; 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
(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"
(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)
(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)
HCoop / bpt / guile.git / commitdiff