From f3cf9421cb319e2cb9ffde4ec41cad7fdcafcebc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 15 Nov 2011 23:36:07 +0100 Subject: [PATCH] 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. --- libguile/procprop.c | 37 ++++++ libguile/procprop.h | 2 + module/ice-9/eval.scm | 224 ++++++++++++++++++--------------- test-suite/tests/procprop.test | 19 ++- 4 files changed, 177 insertions(+), 105 deletions(-) diff --git a/libguile/procprop.c b/libguile/procprop.c index c3fb90e37..8e2cd6a5f 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 c8c156a25..919fa4d3a 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 30a373a7a..62e36ed66 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) diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test index 3998a62e1..838f7a427 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 ;;;; -;;;; 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)))) -- 2.20.1