Gecko [ lostrivercommunitycenter.com ]

Name	Size	Permission	Date
and-let-star.scm	2.53 KB	-rw-r--r--	2019-10-13 01:10
binary-ports.scm	1.88 KB	-rw-r--r--	2019-10-13 01:10
boot-9.scm	151.09 KB	-rw-r--r--	2019-10-13 01:10
buffered-input.scm	4.82 KB	-rw-r--r--	2019-10-13 01:10
calling.scm	10.54 KB	-rw-r--r--	2019-10-13 01:10
channel.scm	5.19 KB	-rw-r--r--	2019-10-13 01:10
command-line.scm	18.22 KB	-rw-r--r--	2019-10-13 01:10
common-list.scm	8.95 KB	-rw-r--r--	2019-10-13 01:10
control.scm	3.94 KB	-rw-r--r--	2019-10-13 01:10
curried-definitions.scm	1.79 KB	-rw-r--r--	2019-10-13 01:10
debug.scm	1.09 KB	-rw-r--r--	2019-10-13 01:10
deprecated.scm	31.24 KB	-rw-r--r--	2019-10-13 01:10
documentation.scm	7.26 KB	-rw-r--r--	2019-10-13 01:10
eval-string.scm	2.93 KB	-rw-r--r--	2019-10-13 01:10
eval.scm	20.85 KB	-rw-r--r--	2019-10-13 01:10
expect.scm	5.5 KB	-rw-r--r--	2019-10-13 01:10
format.scm	74.5 KB	-rw-r--r--	2019-10-13 01:10
ftw.scm	24.17 KB	-rw-r--r--	2019-10-13 01:10
futures.scm	10.92 KB	-rw-r--r--	2019-10-13 01:10
gap-buffer.scm	10.14 KB	-rw-r--r--	2019-10-13 01:10
getopt-long.scm	16.49 KB	-rw-r--r--	2019-10-13 01:10
hash-table.scm	1.77 KB	-rw-r--r--	2019-10-13 01:10
hcons.scm	2.55 KB	-rw-r--r--	2019-10-13 01:10
history.scm	2.29 KB	-rw-r--r--	2019-10-13 01:10
i18n.scm	17.36 KB	-rw-r--r--	2019-10-13 01:10
iconv.scm	3.65 KB	-rw-r--r--	2019-10-13 01:10
lineio.scm	3.85 KB	-rw-r--r--	2019-10-13 01:10
list.scm	1.29 KB	-rw-r--r--	2019-10-13 01:10
local-eval.scm	9.71 KB	-rw-r--r--	2019-10-13 01:10
ls.scm	3.2 KB	-rw-r--r--	2019-10-13 01:10
mapping.scm	4.84 KB	-rw-r--r--	2019-10-13 01:10
match.scm	2 KB	-rw-r--r--	2019-10-13 01:10
match.upstream.scm	35.6 KB	-rw-r--r--	2019-10-13 01:10
networking.scm	3.33 KB	-rw-r--r--	2019-10-13 01:10
null.scm	1.13 KB	-rw-r--r--	2019-10-13 01:10
occam-channel.scm	7.26 KB	-rw-r--r--	2019-10-13 01:10
optargs.scm	15.75 KB	-rw-r--r--	2019-10-13 01:10
poe.scm	3.3 KB	-rw-r--r--	2019-10-13 01:10
poll.scm	6.02 KB	-rw-r--r--	2019-10-13 01:10
popen.scm	5.67 KB	-rw-r--r--	2019-10-13 01:10
posix.scm	2.73 KB	-rw-r--r--	2019-10-13 01:10
pretty-print.scm	15.83 KB	-rw-r--r--	2019-10-13 01:10
psyntax-pp.scm	162.87 KB	-rw-r--r--	2019-10-13 01:10
psyntax.scm	143.67 KB	-rw-r--r--	2019-10-13 01:10
q.scm	4.2 KB	-rw-r--r--	2019-10-13 01:10
quasisyntax.scm	5.22 KB	-rw-r--r--	2019-10-13 01:10
r4rs.scm	9.42 KB	-rw-r--r--	2019-10-13 01:10
r5rs.scm	1.56 KB	-rw-r--r--	2019-10-13 01:10
r6rs-libraries.scm	8.95 KB	-rw-r--r--	2019-10-13 01:10
rdelim.scm	7.47 KB	-rw-r--r--	2019-10-13 01:10
readline.scm	9.56 KB	-rw-r--r--	2019-10-13 01:10
receive.scm	1.06 KB	-rw-r--r--	2019-10-13 01:10
regex.scm	8.87 KB	-rw-r--r--	2019-10-13 01:10
runq.scm	8.18 KB	-rw-r--r--	2019-10-13 01:10
rw.scm	1.02 KB	-rw-r--r--	2019-10-13 01:10
safe-r5rs.scm	3.72 KB	-rw-r--r--	2019-10-13 01:10
safe.scm	1.25 KB	-rw-r--r--	2019-10-13 01:10
save-stack.scm	2.15 KB	-rw-r--r--	2019-10-13 01:10
scm-style-repl.scm	11.71 KB	-rw-r--r--	2019-10-13 01:10
serialize.scm	3.77 KB	-rw-r--r--	2019-10-13 01:10
session.scm	17.72 KB	-rw-r--r--	2019-10-13 01:10
slib.scm	1.55 KB	-rw-r--r--	2019-10-13 01:10
stack-catch.scm	1.94 KB	-rw-r--r--	2019-10-13 01:10
streams.scm	7.31 KB	-rw-r--r--	2019-10-13 01:10
string-fun.scm	8.59 KB	-rw-r--r--	2019-10-13 01:10
syncase.scm	1.52 KB	-rw-r--r--	2019-10-13 01:10
threads.scm	6.24 KB	-rw-r--r--	2019-10-13 01:10
time.scm	2.04 KB	-rw-r--r--	2019-10-13 01:10
top-repl.scm	2.75 KB	-rw-r--r--	2019-10-13 01:10
unicode.scm	1005 B	-rw-r--r--	2019-10-13 01:10
vlist.scm	21.56 KB	-rw-r--r--	2019-10-13 01:10
weak-vector.scm	1.26 KB	-rw-r--r--	2019-10-13 01:10

Rename

;;;; 	Copyright (C) 2000,2001, 2002, 2003, 2006, 2009, 2010 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 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
;;;; 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:

;; * This module exports:
;;
;; file-commentary      -- a procedure that returns a file's "commentary"
;;
;; documentation-files  -- a search-list of files using the Guile
;;                         Documentation Format Version 2.
;;
;; search-documentation-files -- a procedure that takes NAME (a symbol)
;;                               and searches `documentation-files' for
;;                               associated documentation.  optional
;;                               arg FILES is a list of filenames to use
;;                               instead of `documentation-files'.
;;
;; object-documentation -- a procedure that returns its arg's docstring
;;
;; * Guile Documentation Format
;;
;; Here is the complete and authoritative documentation for the Guile
;; Documentation Format Version 2:
;;
;; HEADER
;; ^LPROC1
;; DOCUMENTATION1
;;
;; ^LPROC2
;; DOCUMENTATION2
;;
;; ^L...
;;
;; The HEADER is completely ignored.  The "^L" are formfeeds.  PROC1, PROC2
;; and so on are symbols that name the element documented.  DOCUMENTATION1,
;; DOCUMENTATION2 and so on are the related documentation, w/o any further
;; formatting.  Note that there are two newlines before the next formfeed;
;; these are discarded when the documentation is read in.
;;
;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
;; not documented anywhere except by this embarrassingly circular comment.)
;;
;; * File Commentary
;;
;; A file's commentary is the body of text found between comments
;;     ;;; Commentary:
;; and
;;     ;;; Code:
;; both of which must be at the beginning of the line.  In the result string,
;; semicolons at the beginning of each line are discarded.
;;
;; You can specify to `file-commentary' alternate begin and end strings, and
;; scrub procedure.  Use #t to get default values.  For example:
;;
;; (file-commentary "documentation.scm")
;; You should see this text!
;;
;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
;; You should see the rest of this file.
;;
;; (file-commentary "documentation.scm" #t #t string-upcase)
;; You should see this text very loudly (note semicolons untouched).

;;; Code:

(define-module (ice-9 documentation)
  :use-module (ice-9 rdelim)
  :export (file-commentary
           documentation-files search-documentation-files
           object-documentation)
  :autoload (ice-9 regex) (match:suffix)
  :no-backtrace)

;;
;; commentary extraction
;;

(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
                        (let ((v (car cust)))
                          (cond ((regexp? v) v)
                                ((string? v) (make-regexp v))
                                (else default-in-line-re)))))
        (after-line-re (if (> 2 (length cust))
                           default-after-line-re
                           (let ((v (cadr cust)))
                             (cond ((regexp? v) v)
                                   ((string? v) (make-regexp v))
                                   (else default-after-line-re)))))
        (scrub (if (> 3 (length cust))
                   default-scrub
                   (let ((v (caddr cust)))
                     (cond ((procedure? v) v)
                           (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)))))))))

;;
;; documentation-files is the list of places to look for documentation
;;
(define documentation-files
  (map (lambda (vicinity)
	 (in-vicinity (vicinity) "guile-procedures.txt"))
       (list %library-dir
	     %package-data-dir
	     %site-dir
	     (lambda () "."))))

(define entry-delimiter "\f")

(define (find-documentation-in-file name file)
  (and (file-exists? file)
       (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)))))))))))

(define (search-documentation-files name . files)
  (or-map (lambda (file)
	    (find-documentation-in-file name file))
          (cond ((null? files) documentation-files)
                (else files))))

(define (object-documentation object)
  "Return the docstring for OBJECT.
OBJECT can be a procedure, macro or any object that has its
`documentation' property set."
  (or (and (procedure? object)
	   (procedure-documentation object))
      (object-property object 'documentation)
      (and (macro? object)
           (object-documentation (macro-transformer object)))
      (and (procedure? object)
	   (procedure-name object)
	   (let ((docstring (search-documentation-files
                             (procedure-name object))))
	     (if docstring
		 (set-procedure-property! object 'documentation docstring))
	     docstring))))

;;; documentation.scm ends here