mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

eval: Store docstrings for lambdas.

Browse source 
Fixes <http://bugs.gnu.org/12173>.
Reported by Ian Price <ianprice90@googlemail.com>.

* 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.
This commit is contained in:
Ludovic Courtès 2012-11-28 16:42:49 +01:00
parent fc32c44995
commit c438cd7175
6 changed files with 130 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

10
libguile/eval.c
View file

@ -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; \

101
libguile/memoize.c
View file

@ -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)),

9
libguile/procs.c
View file

@ -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

5
libguile/procs.h
View file

@ -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 */
/*

43
module/ice-9/eval.scm
View file

@ -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))

30
test-suite/tests/eval.test
View file

@ -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
;;;