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.
This commit is contained in:
Andy Wingo
parent
020602791b
commit
f3cf9421cb
4 changed files with 177 additions and 105 deletions
|
|
@ -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"
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;; Ludovic Courtès <ludo@gnu.org>
|
||||
;;;;
|
||||
;;;; 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
|
||||
|
|
@ -52,4 +52,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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue