[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-10-gee15aa
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-10-gee15aa4 |
|
Date: |
Tue, 15 Nov 2011 23:01:41 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ee15aa46e3fb29e609bd7c431e8f2676f6573d57
The branch, stable-2.0 has been updated
via ee15aa46e3fb29e609bd7c431e8f2676f6573d57 (commit)
via f3cf9421cb319e2cb9ffde4ec41cad7fdcafcebc (commit)
from 020602791b3f929e2d65ffdd8d67977763d6883e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ee15aa46e3fb29e609bd7c431e8f2676f6573d57
Author: Andy Wingo <address@hidden>
Date: Tue Nov 15 23:38:40 2011 +0100
set names of functions defined at the toplevel from `eval'
* module/ice-9/eval.scm (primitive-eval): Set the name of
toplevel-defined functions.
commit f3cf9421cb319e2cb9ffde4ec41cad7fdcafcebc
Author: Andy Wingo <address@hidden>
Date: Tue Nov 15 23:36:07 2011 +0100
better debuggability for interpreted procedures
* libguile/procprop.c (scm_set_procedure_minimum_arity_x): New
function, allows a user to override a function's arity.
(scm_i_procedure_arity): Look up in the overrides table first.
* libguile/procprop.h: Add scm_set_procedure_minimum_arity_x.
* module/ice-9/eval.scm (primitive-eval): Override arity of "general
closures".
* test-suite/tests/procprop.test ("procedure-arity"): Add tests.
Based on a patch from Stefan Israelsson Tampe. Test based on work by
Patrick Bernaud.
-----------------------------------------------------------------------
Summary of changes:
libguile/procprop.c | 37 +++++++
libguile/procprop.h | 2 +
module/ice-9/eval.scm | 229 ++++++++++++++++++++++------------------
test-suite/tests/procprop.test | 26 ++++-
4 files changed, 187 insertions(+), 107 deletions(-)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index c3fb90e..8e2cd6a 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -51,9 +51,25 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM overrides;
static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM arity_overrides;
+
int
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
+ SCM o;
+
+ scm_i_pthread_mutex_lock (&overrides_lock);
+ o = scm_hashq_ref (arity_overrides, proc, SCM_BOOL_F);
+ scm_i_pthread_mutex_unlock (&overrides_lock);
+
+ if (scm_is_true (o))
+ {
+ *req = scm_to_int (scm_car (o));
+ *opt = scm_to_int (scm_cadr (o));
+ *rest = scm_is_true (scm_caddr (o));
+ return 1;
+ }
+
while (!SCM_PROGRAM_P (proc))
{
if (SCM_IMP (proc))
@@ -74,9 +90,29 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
return 0;
}
}
+
return scm_i_program_arity (proc, req, opt, rest);
}
+SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
+ 4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
+ "")
+#define FUNC_NAME s_scm_set_procedure_minimum_arity_x
+{
+ int t SCM_UNUSED;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_INT_COPY (2, req, t);
+ SCM_VALIDATE_INT_COPY (3, opt, t);
+ SCM_VALIDATE_BOOL (4, rest);
+
+ scm_i_pthread_mutex_lock (&overrides_lock);
+ scm_hashq_set_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
+ scm_i_pthread_mutex_unlock (&overrides_lock);
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
(SCM proc),
"Return the \"minimum arity\" of a procedure.\n\n"
@@ -207,6 +243,7 @@ void
scm_init_procprop ()
{
overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ arity_overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index c8c156a..919fa4d 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -36,6 +36,8 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest);
+SCM_API SCM scm_set_procedure_minimum_arity_x (SCM proc, SCM req, SCM opt,
+ SCM rest);
SCM_API SCM scm_procedure_minimum_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 30a373a..c0fa64c 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -235,109 +235,127 @@
(inits (if tail (caddr tail) '()))
(alt (and tail (cadddr tail))))
(make-general-closure env body nreq rest nopt kw inits alt))))
- (lambda %args
- (let lp ((env env)
- (nreq* nreq)
- (args %args))
- (if (> nreq* 0)
- ;; First, bind required arguments.
- (if (null? args)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f))
- (lp (cons (car args) env)
- (1- nreq*)
- (cdr args)))
- ;; Move on to optional arguments.
- (if (not kw)
- ;; Without keywords, bind optionals from arguments.
- (let lp ((env env)
- (nopt nopt)
- (args args)
- (inits inits))
- (if (zero? nopt)
- (if rest?
- (eval body (cons args env))
- (if (null? args)
- (eval body env)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of
arguments"
- '() #f))))
- (if (null? args)
- (lp (cons (eval (car inits) env) env)
- (1- nopt) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt) (cdr args) (cdr inits)))))
- ;; With keywords, we stop binding optionals at the first
- ;; keyword.
- (let lp ((env env)
- (nopt* nopt)
- (args args)
- (inits inits))
- (if (> nopt* 0)
- (if (or (null? args) (keyword? (car args)))
- (lp (cons (eval (car inits) env) env)
- (1- nopt*) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt*) (cdr args) (cdr inits)))
- ;; Finished with optionals.
- (let* ((aok (car kw))
- (kw (cdr kw))
- (kw-base (+ nopt nreq (if rest? 1 0)))
- (imax (let lp ((imax (1- kw-base)) (kw kw))
- (if (null? kw)
- imax
- (lp (max (cdar kw) imax)
- (cdr kw)))))
- ;; Fill in kwargs with "undefined" vals.
- (env (let lp ((i kw-base)
- ;; Also, here we bind the rest
- ;; arg, if any.
- (env (if rest? (cons args env)
env)))
- (if (<= i imax)
- (lp (1+ i) (cons unbound-arg env))
- env))))
- ;; Now scan args for keywords.
- (let lp ((args args))
- (if (and (pair? args) (pair? (cdr args))
- (keyword? (car args)))
- (let ((kw-pair (assq (car args) kw))
- (v (cadr args)))
- (if kw-pair
- ;; Found a known keyword; set its value.
- (list-set! env (- imax (cdr kw-pair)) v)
- ;; Unknown keyword.
- (if (not aok)
- (scm-error 'keyword-argument-error
- "eval" "Unrecognized
keyword"
- '() #f)))
- (lp (cddr args)))
- (if (pair? args)
- (if rest?
- ;; Be lenient parsing rest args.
- (lp (cdr args))
- (scm-error 'keyword-argument-error
- "eval" "Invalid keyword"
- '() #f))
- ;; Finished parsing keywords. Fill in
- ;; uninitialized kwargs by evalling init
- ;; expressions in their appropriate
- ;; environment.
- (let lp ((i (- imax kw-base))
- (inits inits))
- (if (pair? inits)
- (let ((tail (list-tail env i)))
- (if (eq? (car tail) unbound-arg)
- (set-car! tail
- (eval (car inits)
- (cdr tail))))
- (lp (1- i) (cdr inits)))
- ;; Finally, eval the body.
- (eval body env))))))))))))))
+ (define (set-procedure-arity! proc)
+ (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
+ (if (not alt)
+ (set-procedure-minimum-arity! proc nreq nopt rest?)
+ (let* ((nreq* (cadr alt))
+ (rest?* (if (null? (cddr alt)) #f (caddr alt)))
+ (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
+ (nopt* (if tail (car tail) 0))
+ (alt* (and tail (cadddr tail))))
+ (if (or (< nreq* nreq)
+ (and (= nreq* nreq)
+ (if rest?
+ (and rest?* (> nopt* nopt))
+ (or rest?* (> nopt* nopt)))))
+ (lp alt* nreq* nopt* rest?*)
+ (lp alt* nreq nopt rest?)))))
+ proc)
+ (set-procedure-arity!
+ (lambda %args
+ (let lp ((env env)
+ (nreq* nreq)
+ (args %args))
+ (if (> nreq* 0)
+ ;; First, bind required arguments.
+ (if (null? args)
+ (if alt
+ (apply alt-proc %args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (lp (cons (car args) env)
+ (1- nreq*)
+ (cdr args)))
+ ;; Move on to optional arguments.
+ (if (not kw)
+ ;; Without keywords, bind optionals from arguments.
+ (let lp ((env env)
+ (nopt nopt)
+ (args args)
+ (inits inits))
+ (if (zero? nopt)
+ (if rest?
+ (eval body (cons args env))
+ (if (null? args)
+ (eval body env)
+ (if alt
+ (apply alt-proc %args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of
arguments"
+ '() #f))))
+ (if (null? args)
+ (lp (cons (eval (car inits) env) env)
+ (1- nopt) args (cdr inits))
+ (lp (cons (car args) env)
+ (1- nopt) (cdr args) (cdr inits)))))
+ ;; With keywords, we stop binding optionals at the first
+ ;; keyword.
+ (let lp ((env env)
+ (nopt* nopt)
+ (args args)
+ (inits inits))
+ (if (> nopt* 0)
+ (if (or (null? args) (keyword? (car args)))
+ (lp (cons (eval (car inits) env) env)
+ (1- nopt*) args (cdr inits))
+ (lp (cons (car args) env)
+ (1- nopt*) (cdr args) (cdr inits)))
+ ;; Finished with optionals.
+ (let* ((aok (car kw))
+ (kw (cdr kw))
+ (kw-base (+ nopt nreq (if rest? 1 0)))
+ (imax (let lp ((imax (1- kw-base)) (kw kw))
+ (if (null? kw)
+ imax
+ (lp (max (cdar kw) imax)
+ (cdr kw)))))
+ ;; Fill in kwargs with "undefined" vals.
+ (env (let lp ((i kw-base)
+ ;; Also, here we bind the rest
+ ;; arg, if any.
+ (env (if rest? (cons args env)
env)))
+ (if (<= i imax)
+ (lp (1+ i) (cons unbound-arg env))
+ env))))
+ ;; Now scan args for keywords.
+ (let lp ((args args))
+ (if (and (pair? args) (pair? (cdr args))
+ (keyword? (car args)))
+ (let ((kw-pair (assq (car args) kw))
+ (v (cadr args)))
+ (if kw-pair
+ ;; Found a known keyword; set its value.
+ (list-set! env (- imax (cdr kw-pair)) v)
+ ;; Unknown keyword.
+ (if (not aok)
+ (scm-error 'keyword-argument-error
+ "eval" "Unrecognized
keyword"
+ '() #f)))
+ (lp (cddr args)))
+ (if (pair? args)
+ (if rest?
+ ;; Be lenient parsing rest args.
+ (lp (cdr args))
+ (scm-error 'keyword-argument-error
+ "eval" "Invalid keyword"
+ '() #f))
+ ;; Finished parsing keywords. Fill in
+ ;; uninitialized kwargs by evalling init
+ ;; expressions in their appropriate
+ ;; environment.
+ (let lp ((i (- imax kw-base))
+ (inits inits))
+ (if (pair? inits)
+ (let ((tail (list-tail env i)))
+ (if (eq? (car tail) unbound-arg)
+ (set-car! tail
+ (eval (car inits)
+ (cdr tail))))
+ (lp (1- i) (cdr inits)))
+ ;; Finally, eval the body.
+ (eval body env)))))))))))))))
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
@@ -407,7 +425,10 @@
(memoize-variable-access! exp #f))))
(('define (name . x))
- (define! name (eval x env)))
+ (let ((x (eval x env)))
+ (if (and (procedure? x) (not (procedure-property x 'name)))
+ (set-procedure-property! x 'name name))
+ (define! name x)))
(('toplevel-set! (var-or-sym . x))
(variable-set!
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 3998a62..25dd4c2 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 <address@hidden>
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011 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
@@ -26,7 +26,12 @@
(eq? 'display (procedure-name display)))
(pass-if "gsubr"
- (eq? 'hashq-ref (procedure-name hashq-ref))))
+ (eq? 'hashq-ref (procedure-name hashq-ref)))
+
+ (pass-if "from eval"
+ (eq? 'foobar (procedure-name
+ (eval '(begin (define (foobar) #t) foobar)
+ (current-module))))))
(with-test-prefix "procedure-arity"
@@ -52,4 +57,19 @@
(pass-if "list"
(equal? (procedure-minimum-arity list)
- '(0 0 #t))))
+ '(0 0 #t)))
+
+ (pass-if "fixed, eval"
+ (equal? (procedure-minimum-arity (eval '(lambda (a b) #t)
+ (current-module)))
+ '(2 0 #f)))
+
+ (pass-if "rest, eval"
+ (equal? (procedure-minimum-arity (eval '(lambda (a b . c) #t)
+ (current-module)))
+ '(2 0 #t)))
+
+ (pass-if "opt, eval"
+ (equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
+ (current-module)))
+ '(2 1 #f))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-10-gee15aa4,
Andy Wingo <=