Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / ice-9 / eval.scm

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index d993db0..d9a4d59 100644 (file)
--- 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, 2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -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) '()))
@@ -238,10 +238,18 @@
       (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)))
+              (begin
+                (set-procedure-property! proc 'arglist
+                                         (list nreq
+                                               nopt
+                                               (if kw (cdr kw) '())
+                                               (and kw (car kw))
+                                               (and rest? '_)))
+                (set-procedure-minimum-arity! proc nreq nopt rest?))
+              (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)
@@ -390,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))
 
         (('seq (head . tail))
          (begin