mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 00:30:21 +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

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