-;;;; Copyright (C) 2000,2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;; 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 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;; Commentary:
;;
;; commentary extraction
;;
-(define default-in-line-re (make-regexp "^;;; Commentary:"))
-(define default-after-line-re (make-regexp "^;;; Code:"))
-(define default-scrub (let ((dirt (make-regexp "^;+")))
- (lambda (line)
- (let ((m (regexp-exec dirt line)))
- (if m (match:suffix m) line)))))
(define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
+
+ ;; These are constants but are not at the top level because the repl in
+ ;; boot-9.scm loads session.scm which in turn loads this file, and we want
+ ;; that to work even even when regexps are not available (ie. make-regexp
+ ;; doesn't exist), as for instance is the case on mingw.
+ ;;
+ (define default-in-line-re (make-regexp "^;;; Commentary:"))
+ (define default-after-line-re (make-regexp "^;;; Code:"))
+ (define default-scrub (let ((dirt (make-regexp "^;+")))
+ (lambda (line)
+ (let ((m (regexp-exec dirt line)))
+ (if m (match:suffix m) line)))))
+
;; fixme: might be cleaner to use optargs here...
(let ((in-line-re (if (> 1 (length cust))
default-in-line-re
default-scrub
(let ((v (caddr cust)))
(cond ((procedure? v) v)
- (else default-scrub)))))
- (port (open-input-file filename)))
- (let loop ((line (read-delimited "\n" port))
- (doc "")
- (parse-state 'before))
- (if (or (eof-object? line) (eq? 'after parse-state))
- doc
- (let ((new-state
- (cond ((regexp-exec in-line-re line) 'in)
- ((regexp-exec after-line-re line) 'after)
- (else parse-state))))
- (if (eq? 'after new-state)
- doc
- (loop (read-delimited "\n" port)
- (if (and (eq? 'in new-state) (eq? 'in parse-state))
- (string-append doc (scrub line) "\n")
- doc)
- new-state)))))))
+ (else default-scrub))))))
+ (call-with-input-file filename
+ (lambda (port)
+ (let loop ((line (read-delimited "\n" port))
+ (doc "")
+ (parse-state 'before))
+ (if (or (eof-object? line) (eq? 'after parse-state))
+ doc
+ (let ((new-state
+ (cond ((regexp-exec in-line-re line) 'in)
+ ((regexp-exec after-line-re line) 'after)
+ (else parse-state))))
+ (if (eq? 'after new-state)
+ doc
+ (loop (read-delimited "\n" port)
+ (if (and (eq? 'in new-state) (eq? 'in parse-state))
+ (string-append doc (scrub line) "\n")
+ doc)
+ new-state)))))))))
\f
(define (find-documentation-in-file name file)
(and (file-exists? file)
- (let ((port (open-input-file file))
- (name (symbol->string name)))
- (let ((len (string-length name)))
- (read-delimited entry-delimiter port) ;skip to first entry
- (let loop ((entry (read-delimited entry-delimiter port)))
- (cond ((eof-object? entry) #f)
- ;; match?
- ((and ;; large enough?
+ (call-with-input-file file
+ (lambda (port)
+ (let ((name (symbol->string name)))
+ (let ((len (string-length name)))
+ (read-delimited entry-delimiter port) ;skip to first entry
+ (let loop ((entry (read-delimited entry-delimiter port)))
+ (cond ((eof-object? entry) #f)
+ ;; match?
+ ((and ;; large enough?
(>= (string-length entry) len)
;; matching name?
(string=? (substring entry 0 len) name)
;; terminated?
(memq (string-ref entry len) '(#\newline)))
- ;; cut away name tag and extra surrounding newlines
- (substring entry (+ len 2) (- (string-length entry) 2)))
- (else (loop (read-delimited entry-delimiter port)))))))))
+ ;; cut away name tag and extra surrounding newlines
+ (substring entry (+ len 2) (- (string-length entry) 2)))
+ (else (loop (read-delimited entry-delimiter port)))))))))))
(define (search-documentation-files name . files)
(or-map (lambda (file)
`documentation' property set."
(or (and (procedure? object)
(proc-doc object))
+ (and (defmacro? object)
+ (proc-doc (defmacro-transformer object)))
(and (macro? object)
(let ((transformer (macro-transformer object)))
(and transformer
HCoop / bpt / guile.git / blobdiff