From c438cd7175540536c3965b4ffea28ae6df7e59e0 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 28 Nov 2012 16:42:49 +0100 Subject: [PATCH] eval: Store docstrings for lambdas. Fixes . Reported by Ian Price . * libguile/memoize.c (MAKMEMO_LAMBDA): New `docstring' parameter. Add it as the second argument of `SCM_M_LAMBDA'. Update caller. (memoize)[SCM_M_LAMBDA]: Extract docstring from EXP; when `memoize' returns, add the docstring to the lambda's arguments. (unmemoize)[SCM_M_LAMBDA]: Adjust to new argument layout of `SCM_M_LAMBDA'. * libguile/eval.c (BOOT_CLOSURE_NUM_REQUIRED_ARGS, BOOT_CLOSURE_HAS_REST_ARGS, BOOT_CLOSURE_IS_REST, BOOT_CLOSURE_PARSE_FULL): Adjust to new argument layout of `SCM_M_LAMBDA'. * module/ice-9/eval.scm (primitive-eval)[make-general-closure]: Likewise. [eval]: When EXP is a lambda, match its docstring; when the docstring is not #f, add it to the closures procedure properties. * test-suite/tests/eval.test ("docstrings"): New test prefix. * libguile/procs.c (sym_documentation): Rename to... (scm_sym_documentation): ... this. Make it global. * libguile/procs.h (scm_sym_documentation): New declaration. --- libguile/eval.c | 10 ++-- libguile/memoize.c | 101 ++++++++++++++++++++++--------------- libguile/procs.c | 9 ++-- libguile/procs.h | 5 +- module/ice-9/eval.scm | 43 +++++++++------- test-suite/tests/eval.test | 30 +++++++++++ 6 files changed, 130 insertions(+), 68 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index e52fa48e4..c5b458009 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -109,16 +109,16 @@ static scm_t_bits scm_tc16_boot_closure; #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x) #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x) #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x)) -#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CADR (BOOT_CLOSURE_CODE (x))) -#define BOOT_CLOSURE_IS_FIXED(x) scm_is_null (CDDR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x)))) +#define BOOT_CLOSURE_IS_FIXED(x) (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))) /* NB: One may only call the following accessors if the closure is not FIXED. */ -#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (BOOT_CLOSURE_CODE (x))) -#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x)))) +#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x)))) /* NB: One may only call the following accessors if the closure is not REST. */ #define BOOT_CLOSURE_IS_FULL(x) (1) #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \ do { SCM fu = fu_; \ - body = CAR (fu); fu = CDR (fu); \ + body = CAR (fu); fu = CDDR (fu); \ \ rest = kw = alt = SCM_BOOL_F; \ inits = SCM_EOL; \ diff --git a/libguile/memoize.c b/libguile/memoize.c index 911d97294..0f4837a92 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -1,6 +1,7 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 - * Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 + * 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 License * as published by the Free Software Foundation; either version 3 of @@ -78,8 +79,9 @@ scm_t_bits scm_tc16_memoized; #define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \ alt, SCM_UNDEFINED) -#define MAKMEMO_LAMBDA(body, arity) \ - MAKMEMO (SCM_M_LAMBDA, (scm_cons (body, arity))) +#define MAKMEMO_LAMBDA(body, arity, docstring) \ + MAKMEMO (SCM_M_LAMBDA, \ + scm_cons (body, scm_cons (docstring, arity))) #define MAKMEMO_LET(inits, body) \ MAKMEMO (SCM_M_LET, scm_cons (inits, body)) #define MAKMEMO_QUOTE(exp) \ @@ -268,7 +270,21 @@ memoize (SCM exp, SCM env) case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case. */ - return memoize (REF (exp, LAMBDA, BODY), env); + { + SCM meta, docstring, proc; + + meta = REF (exp, LAMBDA, META); + docstring = scm_assoc_ref (meta, scm_sym_documentation); + + proc = memoize (REF (exp, LAMBDA, BODY), env); + if (scm_is_string (docstring)) + { + SCM args = SCM_MEMOIZED_ARGS (proc); + SCM_SETCAR (SCM_CDR (args), docstring); + } + + return proc; + } case SCM_EXPANDED_LAMBDA_CASE: { @@ -350,7 +366,8 @@ memoize (SCM exp, SCM env) else arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); - return MAKMEMO_LAMBDA (memoize (body, new_env), arity); + return MAKMEMO_LAMBDA (memoize (body, new_env), arity, + SCM_BOOL_F /* docstring */); } case SCM_EXPANDED_LET: @@ -640,39 +657,43 @@ unmemoize (const SCM expr) return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)), unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args))); case SCM_M_LAMBDA: - if (scm_is_null (CDDR (args))) - return scm_list_3 (scm_sym_lambda, - scm_make_list (CADR (args), sym_placeholder), - unmemoize (CAR (args))); - else if (scm_is_null (CDDDR (args))) - { - SCM formals = scm_make_list (CADR (args), sym_placeholder); - return scm_list_3 (scm_sym_lambda, - scm_is_true (CADDR (args)) - ? scm_cons_star (sym_placeholder, formals) - : formals, - unmemoize (CAR (args))); - } - else - { - SCM body = CAR (args), spec = CDR (args), alt, tail; - - alt = CADDR (CDDDR (spec)); - if (scm_is_true (alt)) - tail = CDR (unmemoize (alt)); - else - tail = SCM_EOL; - - return scm_cons - (sym_case_lambda_star, - scm_cons (scm_list_2 (scm_list_5 (CAR (spec), - CADR (spec), - CADDR (spec), - CADDDR (spec), - unmemoize_exprs (CADR (CDDDR (spec)))), - unmemoize (body)), - tail)); - } + { + SCM body = CAR (args), spec = CDDR (args); + + if (scm_is_null (CDR (spec))) + return scm_list_3 (scm_sym_lambda, + scm_make_list (CAR (spec), sym_placeholder), + unmemoize (CAR (args))); + else if (scm_is_null (SCM_CDDR (spec))) + { + SCM formals = scm_make_list (CAR (spec), sym_placeholder); + return scm_list_3 (scm_sym_lambda, + scm_is_true (CADR (spec)) + ? scm_cons_star (sym_placeholder, formals) + : formals, + unmemoize (CAR (args))); + } + else + { + SCM alt, tail; + + alt = CADDR (CDDDR (spec)); + if (scm_is_true (alt)) + tail = CDR (unmemoize (alt)); + else + tail = SCM_EOL; + + return scm_cons + (sym_case_lambda_star, + scm_cons (scm_list_2 (scm_list_5 (CAR (spec), + CADR (spec), + CADDR (spec), + CADDDR (spec), + unmemoize_exprs (CADR (CDDDR (spec)))), + unmemoize (body)), + tail)); + } + } case SCM_M_LET: return scm_list_3 (scm_sym_let, unmemoize_bindings (CAR (args)), diff --git a/libguile/procs.c b/libguile/procs.c index a096591df..59caed1b4 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009, + * 2010, 2011, 2012 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 License * as published by the Free Software Foundation; either version 3 of @@ -75,7 +76,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, } #undef FUNC_NAME -SCM_SYMBOL (sym_documentation, "documentation"); +SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation"); SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, (SCM proc), @@ -86,7 +87,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, #define FUNC_NAME s_scm_procedure_documentation { SCM_VALIDATE_PROC (SCM_ARG1, proc); - return scm_procedure_property (proc, sym_documentation); + return scm_procedure_property (proc, scm_sym_documentation); } #undef FUNC_NAME diff --git a/libguile/procs.h b/libguile/procs.h index a4dfaff3c..a35872e3d 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -3,7 +3,8 @@ #ifndef SCM_PROCS_H #define SCM_PROCS_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009, + * 2012 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 License @@ -36,6 +37,8 @@ SCM_API SCM scm_procedure (SCM proc); SCM_API SCM scm_setter (SCM proc); SCM_INTERNAL void scm_init_procs (void); +SCM_INTERNAL SCM scm_sym_documentation; + #endif /* SCM_PROCS_H */ /* diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 81b9538f9..4054bd853 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -1,7 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- -;;;; Copyright (C) 2009, 2010 -;;;; Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2012 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 @@ -65,7 +64,7 @@ (define (make-formals n) (map (lambda (i) (datum->syntax - x + x (string->symbol (string (integer->char (+ (char->integer #\a) i)))))) (iota n))) @@ -225,11 +224,12 @@ ;; multiple arities, as with case-lambda. (define (make-general-closure env body nreq rest? nopt kw inits alt) (define alt-proc - (and alt + (and alt ; (body docstring nreq ...) (let* ((body (car alt)) - (nreq (cadr alt)) - (rest (if (null? (cddr alt)) #f (caddr alt))) - (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt))) + (spec (cddr alt)) + (nreq (car spec)) + (rest (if (null? (cdr spec)) #f (cadr spec))) + (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt (if tail (car tail) 0)) (kw (and tail (cadr tail))) (inits (if tail (caddr tail) '())) @@ -246,9 +246,10 @@ (and kw (car kw)) (and rest? '_))) (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))) + (let* ((spec (cddr alt)) + (nreq* (car spec)) + (rest?* (if (null? (cdr spec)) #f (cadr spec))) + (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec))) (nopt* (if tail (car tail) 0)) (alt* (and tail (cadddr tail)))) (if (or (< nreq* nreq) @@ -397,14 +398,20 @@ (eval body new-env) (lp (cdr inits) (cons (eval (car inits) env) new-env))))) - - (('lambda (body nreq . tail)) - (if (null? tail) - (make-fixed-closure eval nreq body (capture-env env)) - (if (null? (cdr tail)) - (make-general-closure (capture-env env) body nreq (car tail) - 0 #f '() #f) - (apply make-general-closure (capture-env env) body nreq tail)))) + + (('lambda (body docstring nreq . tail)) + (let ((proc + (if (null? tail) + (make-fixed-closure eval nreq body (capture-env env)) + (if (null? (cdr tail)) + (make-general-closure (capture-env env) body + nreq (car tail) + 0 #f '() #f) + (apply make-general-closure (capture-env env) + body nreq tail))))) + (when docstring + (set-procedure-property! proc 'documentation docstring)) + proc)) (('begin (first . rest)) (let lp ((first first) (rest rest)) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a5fbfece2..6ab3b8ac8 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -427,6 +427,36 @@ (thunk (let loop () (cons 's (loop))))) (call-with-vm vm thunk)))) +;;; +;;; docstrings +;;; + +(with-test-prefix "docstrings" + + (pass-if-equal "fixed closure" + '("hello" "world") + (map procedure-documentation + (list (eval '(lambda (a b) "hello" (+ a b)) + (current-module)) + (eval '(lambda (a b) "world" (- a b)) + (current-module))))) + + (pass-if-equal "fixed closure with many args" + "So many args." + (procedure-documentation + (eval '(lambda (a b c d e f g h i j k) + "So many args." + (+ a b)) + (current-module)))) + + (pass-if-equal "general closure" + "How general." + (procedure-documentation + (eval '(lambda* (a b #:key k #:rest r) + "How general." + (+ a b)) + (current-module))))) + ;;; ;;; local-eval ;;; -- 2.20.1