code:
;;;; ports.scm --- R6RS port API                    -*- coding: utf-8 -*-

;;;;	Copyright (C) 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

;;; Author: Ludovic Courtès <ludo@gnu.org>

;;; Commentary:
;;;
;;; The I/O port API of the R6RS is provided by this module.  In many areas
;;; it complements or refines Guile's own historical port API.  For instance,
;;; it allows for binary I/O with bytevectors.
;;;
;;; Code:

(define-module (rnrs io ports)
  #:version (6)
  #:re-export (eof-object? port? input-port? output-port?)
  #:export (eof-object

           ;; input & output ports
           port-transcoder binary-port? transcoded-port
           port-position set-port-position!
           port-has-port-position? port-has-set-port-position!?
           call-with-port

           ;; input ports
           open-bytevector-input-port
           open-string-input-port
           make-custom-binary-input-port

           ;; binary input
           get-u8 lookahead-u8
           get-bytevector-n get-bytevector-n!
           get-bytevector-some get-bytevector-all

           ;; output ports
           open-bytevector-output-port
           open-string-output-port
           make-custom-binary-output-port

           ;; binary output
           put-u8 put-bytevector))

(load-extension (string-append "libguile-" (effective-version))
                "scm_init_r6rs_ports")

;;;
;;; Input and output ports.
;;;

(define (port-transcoder port)
  (error "port transcoders are not supported" port))

(define (binary-port? port)
  ;; So far, we don't support transcoders other than the binary transcoder.
  #t)

(define (transcoded-port port)
  (error "port transcoders are not supported" port))

(define (port-position port)
  "Return the offset (an integer) indicating where the next octet will be
read from/written to in @var{port}."

  ;; FIXME: We should raise an `&assertion' error when not supported.
  (seek port 0 SEEK_CUR))

(define (set-port-position! port offset)
  "Set the position where the next octet will be read from/written to
@var{port}."

  ;; FIXME: We should raise an `&assertion' error when not supported.
  (seek port offset SEEK_SET))

(define (port-has-port-position? port)
  "Return @code{#t} is @var{port} supports @code{port-position}."
  (and (false-if-exception (port-position port)) #t))

(define (port-has-set-port-position!? port)
  "Return @code{#t} is @var{port} supports @code{set-port-position!}."
  (and (false-if-exception (set-port-position! port (port-position port)))
       #t))

(define (call-with-port port proc)
  "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
@var{proc}.  Return the return values of @var{proc}."
  (dynamic-wind
      (lambda ()
        #t)
      (lambda ()
        (proc port))
      (lambda ()
        (close-port port))))

(define (open-string-input-port str)
  "Open an input port that will read from @var{str}."
  (with-fluids ((%default-port-encoding "UTF-8"))
    (open-input-string str)))

(define (open-string-output-port)
  "Return two values: an output port that will collect characters written to it
as a string, and a thunk to retrieve the characters associated with that port."
  (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
                (open-output-string))))
    (values port
            (lambda () (get-output-string port)))))

;;; ports.scm ends here


code:
;;; simple.scm --- The R6RS simple I/O library

;;      Copyright (C) 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

(library (rnrs io simple (6))
  (export eof-object
          eof-object?

	  call-with-input-file
	  call-with-output-file

	  input-port?
	  output-port?

	  current-input-port
	  current-output-port
	  current-error-port

	  with-input-from-file
	  with-output-to-file

	  open-input-file
	  open-output-file

	  close-input-port
	  close-output-port

	  read-char
	  peek-char
	  read
	  write-char
	  newline
	  display
	  write

	  &i/o make-i/o-error i/o-error?
	  &i/o-read make-i/o-read-error i/o-read-error?
	  &i/o-write make-i/o-write-error i/o-write-error?

	  &i/o-invalid-position
	  make-i/o-invalid-position-error
	  i/o-invalid-position-error?
	  i/o-error-position

	  &i/o-filename
	  make-i/o-filename-error
	  i/o-filename-error?
	  i/o-error-filename

	  &i/o-file-protection
	  make-i/o-file-protection-error
	  i/o-file-protection-error?

	  &i/o-file-is-read-only
	  make-i/o-file-is-read-only-error
	  i/o-file-is-read-only-error?

	  &i/o-file-already-exists
	  make-i/o-file-already-exists-error
	  i/o-file-already-exists-error?

	  &i/o-file-does-not-exist
	  make-i/o-file-does-not-exist-error
	  i/o-file-does-not-exist-error?

	  &i/o-port
	  make-i/o-port-error
	  i/o-port-error?
	  i/o-error-port)

  (import (only (rnrs io ports) eof-object
		                eof-object?

                                input-port?
				output-port?)
          (only (guile) @@
                        call-with-input-file
			call-with-output-file

			current-input-port
			current-output-port
			current-error-port

			with-input-from-file
			with-output-to-file

			open-input-file
			open-output-file

			close-input-port
			close-output-port

			read-char
			peek-char
			read
			write-char
			newline
			display
			write)
	  (rnrs base (6))
	  (rnrs conditions (6)))

  (define &i/o (@@ (rnrs conditions) &i/o))
  (define make-i/o-error (@@ (rnrs conditions) make-i/o-error))
  (define i/o-error? (@@ (rnrs conditions) i/o-error?))

  (define &i/o-read (@@ (rnrs conditions) &i/o-read))
  (define make-i/o-read-error (@@ (rnrs conditions) make-i/o-read-error))
  (define i/o-read-error? (@@ (rnrs conditions) i/o-read-error?))

  (define &i/o-write (@@ (rnrs conditions) &i/o-write))
  (define make-i/o-write-error (@@ (rnrs conditions) make-i/o-write-error))
  (define i/o-write-error? (@@ (rnrs conditions) i/o-write-error?))

  (define &i/o-invalid-position (@@ (rnrs conditions) &i/o-invalid-position))
  (define make-i/o-invalid-position-error
    (@@ (rnrs conditions) make-i/o-invalid-position-error))
  (define i/o-invalid-position-error?
    (@@ (rnrs conditions) i/o-invalid-position-error?))
  (define i/o-error-position (@@ (rnrs conditions) i/o-error-position))

  (define &i/o-filename (@@ (rnrs conditions) &i/o-filename))
  (define make-i/o-filename-error
    (@@ (rnrs conditions) make-i/o-filename-error))
  (define i/o-filename-error? (@@ (rnrs conditions) i/o-filename-error?))
  (define i/o-error-filename (@@ (rnrs conditions) i/o-error-filename))

  (define &i/o-file-protection (@@ (rnrs conditions) &i/o-file-protection))
  (define make-i/o-file-protection-error
    (@@ (rnrs conditions) make-i/o-file-protection-error))
  (define i/o-file-protection-error?
    (@@ (rnrs conditions) i/o-file-protection-error?))

  (define &i/o-file-is-read-only (@@ (rnrs conditions) &i/o-file-is-read-only))
  (define make-i/o-file-is-read-only-error
    (@@ (rnrs conditions) make-i/o-file-is-read-only-error))
  (define i/o-file-is-read-only-error?
    (@@ (rnrs conditions) i/o-file-is-read-only-error?))

  (define &i/o-file-already-exists
    (@@ (rnrs conditions) &i/o-file-already-exists))
  (define make-i/o-file-already-exists-error
    (@@ (rnrs conditions) make-i/o-file-already-exists-error))
  (define i/o-file-already-exists-error?
    (@@ (rnrs conditions) i/o-file-already-exists-error?))

  (define &i/o-file-does-not-exist
    (@@ (rnrs conditions) &i/o-file-does-not-exist))
  (define make-i/o-file-does-not-exist-error
    (@@ (rnrs conditions) make-i/o-file-does-not-exist-error))
  (define i/o-file-does-not-exist-error?
    (@@ (rnrs conditions) i/o-file-does-not-exist-error?))

  (define &i/o-port (@@ (rnrs conditions) &i/o-port))
  (define make-i/o-port-error (@@ (rnrs conditions) make-i/o-port-error))
  (define i/o-port-error? (@@ (rnrs conditions) i/o-port-error?))
  (define i/o-error-port (@@ (rnrs conditions) i/o-error-port))
)

license: mit


code:
;;; lists.scm --- The R6RS list utilities library

;;      Copyright (C) 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

(library (rnrs lists (6))
  (export find for-all exists filter partition fold-left fold-right remp remove
	  remv remq memp member memv memq assp assoc assv assq cons*)
  (import (rnrs base (6))
          (only (guile) filter member memv memq assoc assv assq cons*)
	  (rename (only (srfi srfi-1) fold
			              any
				      every
				      remove
				      member
				      assoc
				      find
				      partition
				      fold-right
				      filter-map)
		  (fold fold-left)
		  (any exists)
		  (every for-all)
		  (remove remp)

		  (member memp-internal)
		  (assoc assp-internal)))

  (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
  (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
  (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))

  (define (memp pred list) (memp-internal #f list (lambda (x y) (pred y))))
  (define (assp pred list) (assp-internal #f list (lambda (x y) (pred y))))
)


code:
;;; mutable-pairs.scm --- The R6RS mutable pair library

;;      Copyright (C) 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

(library (rnrs mutable-pairs (6))
  (export set-car! set-cdr!)
  (import (only (guile) set-car! set-cdr!)))


code:
;;; mutable-strings.scm --- The R6RS mutable string library

;;      Copyright (C) 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

(library (rnrs mutable-strings (6))
  (export string-set! string-fill!)
  (import (only (guile) string-set! string-fill!)))


code:
;;; programs.scm --- The R6RS process management library

;;      Copyright (C) 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

(library (rnrs programs (6))
  (export command-line exit)
  (import (only (guile) command-line exit)))


code:
;;; r5rs.scm --- The R6RS / R5RS compatibility library

;;      Copyright (C) 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

(library (rnrs r5rs (6))
  (export exact->inexact inexact->exact

	  quotient remainder modulo

	  delay force

	  null-environment scheme-report-environment)
  (import (only (guile) exact->inexact inexact->exact

			quotient remainder modulo

			delay force)
          (only (ice-9 r5rs) scheme-report-environment)
          (only (ice-9 safe-r5rs) null-environment)))


code:
;;; inspection.scm --- Inspection support for R6RS records

;;      Copyright (C) 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

(library (rnrs records inspection (6))
  (export record?
          record-rtd
	  record-type-name
	  record-type-parent
	  record-type-uid
	  record-type-generative?
	  record-type-sealed?
	  record-type-opaque?
	  record-type-field-names
	  record-field-mutable?)
  (import (rnrs base (6))
	  (rnrs conditions (6))
          (rnrs exceptions (6))
	  (rnrs records procedural (6))
	  (only (guile) struct-ref vtable-index-layout @@))

  (define record-internal? (@@ (rnrs records procedural) record-internal?))

  (define record-index-rtd (@@ (rnrs records procedural) record-index-rtd))

  (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
  (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
  (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
  (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
  (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
  (define rtd-index-field-names
    (@@ (rnrs records procedural) rtd-index-field-names))
  (define rtd-index-field-vtable
    (@@ (rnrs records procedural) rtd-index-field-vtable))

  (define (record? obj)
    (and (record-internal? obj)
	 (not (record-type-opaque? (struct-ref obj record-index-rtd)))))

  (define (record-rtd record)
    (or (and (record-internal? record)
	     (let ((rtd (struct-ref record record-index-rtd)))
	       (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
	(raise (make-assertion-violation))))

  (define (ensure-rtd rtd)
    (if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))

  (define (record-type-name rtd)
    (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
  (define (record-type-parent rtd)
    (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
  (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
  (define (record-type-generative? rtd)
    (ensure-rtd rtd) (not (record-type-uid rtd)))
  (define (record-type-sealed? rtd)
    (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
  (define (record-type-opaque? rtd)
    (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
  (define (record-type-field-names rtd)
    (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
  (define (record-field-mutable? rtd k)
    (ensure-rtd rtd)
    (let ((vt (struct-ref rtd rtd-index-field-vtable)))
      (eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout))
			(+ (* 2 (+ k 2)) 1))
	    #\w)))
)


code:
;;; procedural.scm --- Procedural interface to R6RS records

;;      Copyright (C) 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

(library (rnrs records procedural (6))
  (export make-record-type-descriptor
	  record-type-descriptor?
	  make-record-constructor-descriptor

	  record-constructor
	  record-predicate
	  record-accessor
	  record-mutator)

  (import (rnrs base (6))
          (only (guile) and=>
			throw
			display
		        make-struct
			make-vtable
			map
			simple-format
			string-append

			struct?
			struct-ref
			struct-set!
			struct-vtable
			vtable-index-layout

                        make-hash-table
			hashq-ref
			hashq-set!

			vector->list)
	  (ice-9 receive)
	  (only (srfi :1) fold split-at take))

  (define (record-internal? obj)
    (and (struct? obj)
	 (let* ((vtable (struct-vtable obj))
		(layout (symbol->string
			 (struct-ref vtable vtable-index-layout))))
	   (and (>= (string-length layout) 4)
		(let ((rtd (struct-ref obj record-index-rtd)))
		  (and (record-type-descriptor? rtd)))))))

  (define record-index-parent 0)
  (define record-index-rtd 1)

  (define rtd-index-name 0)
  (define rtd-index-uid 1)
  (define rtd-index-parent 2)
  (define rtd-index-sealed? 3)
  (define rtd-index-opaque? 4)
  (define rtd-index-predicate 5)
  (define rtd-index-field-names 6)
  (define rtd-index-field-vtable 7)
  (define rtd-index-field-binder 8)

  (define rctd-index-rtd 0)
  (define rctd-index-parent 1)
  (define rctd-index-protocol 2)

  (define record-type-vtable
    (make-vtable "prprprprprprprprpr"
		 (lambda (obj port)
		   (simple-format port "#<r6rs:record-type:~A>"
				  (struct-ref obj rtd-index-name)))))

  (define record-constructor-vtable
    (make-vtable "prprpr"
		 (lambda (obj port)
		   (simple-format port "#<r6rs:record-constructor:~A>"
				  (struct-ref (struct-ref obj rctd-index-rtd)
					      rtd-index-name)))))

  (define uid-table (make-hash-table))

  (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
    (define fields-vtable
      (make-vtable (fold (lambda (x p)
			   (string-append p (case (car x)
					      ((immutable) "pr")
					      ((mutable) "pw"))))
			 "prpr" (vector->list fields))
		   (lambda (obj port)
		     (simple-format port "#<r6rs:record:~A>" name))))
    (define field-names (list->vector (map cadr (vector->list fields))))
    (define late-rtd #f)
    (define (private-record-predicate obj)
      (and (record-internal? obj)
	   (let ((rtd (struct-ref obj record-index-rtd)))
	     (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
		 (and=> (struct-ref obj record-index-parent)
			private-record-predicate)))))

    (define (field-binder parent-struct . args)
      (apply make-struct (append (list fields-vtable 0
				       parent-struct
				       late-rtd)
				 args)))
    (if (and parent (struct-ref parent rtd-index-sealed?))
	(r6rs-raise (make-assertion-violation)))

    (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
	  (opaque? (or opaque? (and parent (struct-ref
					    parent rtd-index-opaque?)))))
      (if matching-rtd
	  (if (equal? (list name
			    parent
			    sealed?
			    opaque?
			    field-names
			    (struct-ref fields-vtable vtable-index-layout))
		      (list (struct-ref matching-rtd rtd-index-name)
			    (struct-ref matching-rtd rtd-index-parent)
			    (struct-ref matching-rtd rtd-index-sealed?)
			    (struct-ref matching-rtd rtd-index-opaque?)
			    (struct-ref matching-rtd rtd-index-field-names)
			    (struct-ref (struct-ref matching-rtd
						    rtd-index-field-vtable)
					vtable-index-layout)))
	      matching-rtd
	      (r6rs-raise (make-assertion-violation)))

	  (let ((rtd (make-struct record-type-vtable 0

				  name
				  uid
				  parent
				  sealed?
				  opaque?

				  private-record-predicate
				  field-names
				  fields-vtable
				  field-binder)))
	    (set! late-rtd rtd)
	    (if uid (hashq-set! uid-table uid rtd))
	    rtd))))

  (define (record-type-descriptor? obj)
    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))

  (define (make-record-constructor-descriptor rtd
					      parent-constructor-descriptor
					      protocol)
    (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
    (define (default-inherited-protocol n)
      (lambda args
	(receive
          (n-args p-args)
	  (split-at args (- (length args) rtd-arity))
	  (let ((p (apply n n-args)))
	    (apply p p-args)))))
    (define (default-protocol p) p)

    (let* ((prtd (struct-ref rtd rtd-index-parent))
	   (pcd (or parent-constructor-descriptor
		    (and=> prtd (lambda (d) (make-record-constructor-descriptor
					     prtd #f #f)))))
	   (prot (or protocol (if pcd
				  default-inherited-protocol
				  default-protocol))))
      (make-struct record-constructor-vtable 0 rtd pcd prot)))

  (define (record-constructor rctd)
    (let* ((rtd (struct-ref rctd rctd-index-rtd))
	   (parent-rctd (struct-ref rctd rctd-index-parent))
	   (protocol (struct-ref rctd rctd-index-protocol)))
      (protocol
       (if parent-rctd
	   (let ((parent-record-constructor (record-constructor parent-rctd))
		 (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
	     (lambda args
	       (let ((struct (apply parent-record-constructor args)))
		 (lambda args
		   (apply (struct-ref rtd rtd-index-field-binder)
			  (cons struct args))))))
	   (lambda args (apply (struct-ref rtd rtd-index-field-binder)
			       (cons #f args)))))))

  (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))

  (define (record-accessor rtd k)
    (define (record-accessor-inner obj)
      (if (not (record-internal? obj))
	  (r6rs-raise (make-assertion-violation)))
      (if (eq? (struct-ref obj record-index-rtd) rtd)
	  (struct-ref obj (+ k 2))
	  (record-accessor-inner (struct-ref obj record-index-parent))))
    (lambda (obj) (record-accessor-inner obj)))

  (define (record-mutator rtd k)
    (define (record-mutator-inner obj val)
      (and obj
	   (or (and (eq? (struct-ref obj record-index-rtd) rtd)
		    (struct-set! obj (+ k 2) val))
	       (record-mutator-inner (struct-ref obj record-index-parent)
				     val))))
    (let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
	   (field-layout (symbol->string
			  (struct-ref rtd-vtable vtable-index-layout))))
      (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
	  (r6rs-raise (make-assertion-violation))))
    (lambda (obj val) (record-mutator-inner obj val)))

  ;; Condition types that are used in the current library.  These are defined
  ;; here and not in (rnrs conditions) to avoid a circular dependency.

  (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
  (define &condition-constructor-descriptor
    (make-record-constructor-descriptor &condition #f #f))

  (define &serious (make-record-type-descriptor
		    '&serious &condition #f #f #f '#()))
  (define &serious-constructor-descriptor
    (make-record-constructor-descriptor
     &serious &condition-constructor-descriptor #f))

  (define make-serious-condition
    (record-constructor &serious-constructor-descriptor))

  (define &violation (make-record-type-descriptor
		      '&violation &serious #f #f #f '#()))
  (define &violation-constructor-descriptor
    (make-record-constructor-descriptor
     &violation &serious-constructor-descriptor #f))
  (define make-violation (record-constructor &violation-constructor-descriptor))

  (define &assertion (make-record-type-descriptor
		      '&assertion &violation #f #f #f '#()))
  (define make-assertion-violation
    (record-constructor
     (make-record-constructor-descriptor
      &assertion &violation-constructor-descriptor #f)))

  ;; Exception wrapper type, along with a wrapping `throw' implementation.
  ;; These are used in the current library, and so they are defined here and not
  ;; in (rnrs exceptions) to avoid a circular dependency.

  (define &raise-object-wrapper
    (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
				 '#((immutable obj) (immutable continuation))))
  (define make-raise-object-wrapper
    (record-constructor (make-record-constructor-descriptor
			 &raise-object-wrapper #f #f)))
  (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
  (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
  (define raise-object-wrapper-continuation
    (record-accessor &raise-object-wrapper 1))

  (define (r6rs-raise obj)
    (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
  (define (r6rs-raise-continuable obj)
    (define (r6rs-raise-continuable-internal continuation)
      (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
    (call/cc r6rs-raise-continuable-internal))
)


code:
;;; syntactic.scm --- Syntactic support for R6RS records

;;      Copyright (C) 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

(library (rnrs records syntactic (6))
  (export define-record-type
	  record-type-descriptor
	  record-constructor-descriptor)
  (import (only (guile) *unspecified* and=> gensym unspecified?)
          (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
	  (rnrs hashtables (6))
	  (rnrs lists (6))
	  (rnrs records procedural (6))
	  (rnrs syntax-case (6))
	  (only (srfi :1) take))

  (define record-type-registry (make-eq-hashtable))

  (define (guess-constructor-name record-name)
    (string->symbol (string-append "make-" (symbol->string record-name))))
  (define (guess-predicate-name record-name)
    (string->symbol (string-append (symbol->string record-name) "?")))
  (define (register-record-type name rtd rcd)
    (hashtable-set! record-type-registry name (cons rtd rcd)))
  (define (lookup-record-type-descriptor name)
    (and=> (hashtable-ref record-type-registry name #f) car))
  (define (lookup-record-constructor-descriptor name)
    (and=> (hashtable-ref record-type-registry name #f) cdr))

  (define-syntax define-record-type
    (lambda (stx)
      (syntax-case stx ()
	((_ (record-name constructor-name predicate-name) record-clause ...)
	 #'(define-record-type0
	     (record-name constructor-name predicate-name)
	     record-clause ...))
	((_ record-name record-clause ...)
	 (let* ((record-name-sym (syntax->datum #'record-name))
		(constructor-name
		 (datum->syntax
		  #'record-name (guess-constructor-name record-name-sym)))
		(predicate-name
		 (datum->syntax
		  #'record-name (guess-predicate-name record-name-sym))))
	   #`(define-record-type0
	       (record-name #,constructor-name #,predicate-name)
	       record-clause ...))))))

  (define (sequence n)
    (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
    (reverse (seq-inner n)))
  (define (number-fields fields)
    (define (number-fields-inner fields counter)
      (if (null? fields)
	  '()
	  (cons (cons fields counter)
		(number-fields-inner (cdr fields) (+ counter 1)))))
    (number-fields-inner fields 0))

  (define (process-fields record-name fields)
    (define record-name-str (symbol->string record-name))
    (define (guess-accessor-name field-name)
      (string->symbol (string-append
		       record-name-str "-" (symbol->string field-name))))
    (define (guess-mutator-name field-name)
      (string->symbol
       (string-append
	record-name-str "-" (symbol->string field-name) "-set!")))

    (define (f x)
      (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
	    ((not (list? x)) (error))
	    ((eq? (car x) 'immutable)
	     (cons 'immutable
		   (case (length x)
		     ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
		     ((3) (list (cadr x) (caddr x) #f))
		     (else (error)))))
	    ((eq? (car x) 'mutable)
	     (cons 'mutable
		   (case (length x)
		     ((2) (list (cadr x)
				(guess-accessor-name (cadr x))
				(guess-mutator-name (cadr x))))
		     ((4) (cdr x))
		     (else (error)))))
	    (else (error))))
    (map f fields))

  (define-syntax define-record-type0
    (lambda (stx)
      (syntax-case stx ()
	((_ (record-name constructor-name predicate-name) record-clause ...)
	 (let loop ((fields *unspecified*)
		    (parent *unspecified*)
		    (protocol *unspecified*)
		    (sealed *unspecified*)
		    (opaque *unspecified*)
		    (nongenerative *unspecified*)
		    (constructor *unspecified*)
		    (parent-rtd *unspecified*)
		    (record-clauses (syntax->datum #'(record-clause ...))))
	   (if (null? record-clauses)
	       (let*
		((fields (if (unspecified? fields) '() fields))
		 (field-names
		  (datum->syntax
		   #'record-name
		   (list->vector (map (lambda (x) (take x 2)) fields))))
		 (field-accessors
		  (fold-left (lambda (x c lst)
			       (cons #`(define #,(datum->syntax
						  #'record-name (caddr x))
					 (record-accessor record-name #,c))
				     lst))
			     '() fields (sequence (length fields))))
		 (field-mutators
		  (fold-left (lambda (x c lst)
			       (if (cadddr x)
				   (cons #`(define #,(datum->syntax
						      #'record-name (cadddr x))
					     (record-mutator record-name #,c))
					 lst)
				   lst))
			     '() fields (sequence (length fields))))

		 (parent-cd
		  (datum->syntax
		   stx (cond ((not (unspecified? parent))
			      `(record-constructor-descriptor ,parent))
			     ((not (unspecified? parent-rtd)) (cadr parent-rtd))
			     (else #f))))
		 (parent-rtd
		  (datum->syntax
		   stx (cond ((not (unspecified? parent))
			      `(record-type-descriptor ,parent))
			     ((not (unspecified? parent-rtd)) (car parent-rtd))
			     (else #f))))

		 (protocol (datum->syntax
			    #'record-name (if (unspecified? protocol)
					      #f protocol)))
		 (uid (datum->syntax
		       #'record-name (if (unspecified? nongenerative)
					 #f nongenerative)))
		 (sealed? (if (unspecified? sealed) #f sealed))
		 (opaque? (if (unspecified? opaque) #f opaque))

		 (record-name-sym (datum->syntax
				   stx (list 'quote
					     (syntax->datum #'record-name)))))

		#`(begin
		    (define record-name
		      (make-record-type-descriptor
		       #,record-name-sym
		       #,parent-rtd #,uid #,sealed? #,opaque?
		       #,field-names))
		    (define constructor-name
		      (record-constructor
		       (make-record-constructor-descriptor
			record-name #,parent-cd #,protocol)))
		    (register-record-type
		     #,record-name-sym
		     record-name (make-record-constructor-descriptor
				  record-name #,parent-cd #,protocol))
		    (define predicate-name (record-predicate record-name))
		    #,@field-accessors
		    #,@field-mutators))
	       (let ((cr (car record-clauses)))
		 (case (car cr)
		   ((fields)
		    (if (unspecified? fields)
			(loop (process-fields (syntax->datum #'record-name)
					      (cdr cr))
			      parent protocol sealed opaque nongenerative
			      constructor parent-rtd (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((parent)
		    (if (not (unspecified? parent-rtd))
			(raise (make-assertion-violation)))
		    (if (unspecified? parent)
			(loop fields (cadr cr) protocol sealed opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((protocol)
		    (if (unspecified? protocol)
			(loop fields parent (cadr cr) sealed opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((sealed)
		    (if (unspecified? sealed)
			(loop fields parent protocol (cadr cr) opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((opaque) (if (unspecified? opaque)
				 (loop fields parent protocol sealed (cadr cr)
				       nongenerative constructor parent-rtd
				       (cdr record-clauses))
				 (raise (make-assertion-violation))))
		   ((nongenerative)
		    (if (unspecified? nongenerative)
			(let ((uid (list 'quote
					 (or (and (> (length cr) 1) (cadr cr))
					     (gensym)))))
			  (loop fields parent protocol sealed
				opaque uid constructor
				parent-rtd (cdr record-clauses)))
			(raise (make-assertion-violation))))
		   ((parent-rtd)
		    (if (not (unspecified? parent))
			(raise (make-assertion-violation)))
		    (if (unspecified? parent-rtd)
			(loop fields parent protocol sealed opaque
			      nongenerative constructor (cdr cr)
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   (else (raise (make-assertion-violation)))))))))))

  (define-syntax record-type-descriptor
    (lambda (stx)
      (syntax-case stx ()
	((_ name) #`(lookup-record-type-descriptor
		     #,(datum->syntax
			stx (list 'quote (syntax->datum #'name))))))))

  (define-syntax record-constructor-descriptor
    (lambda (stx)
      (syntax-case stx ()
	((_ name) #`(lookup-record-constructor-descriptor
		     #,(datum->syntax
			stx (list 'quote (syntax->datum #'name))))))))
)


code:
;;; sorting.scm --- The R6RS sorting library

;;      Copyright (C) 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

(library (rnrs sorting (6))
  (export list-sort vector-sort vector-sort!)
  (import (rnrs base (6))
          (only (guile) *unspecified* stable-sort sort!))

  (define (list-sort proc list) (stable-sort list proc))
  (define (vector-sort proc vector) (stable-sort vector proc))
  (define (vector-sort! proc vector) (sort! vector proc) *unspecified*))


code:
;;; syntax-case.scm --- R6RS support for `syntax-case' macros

;;      Copyright (C) 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

(library (rnrs syntax-case (6))
  (export make-variable-transformer
	  syntax-case
	  syntax

	  identifier?
	  bound-identifier=?
	  free-identifier=?

	  syntax->datum
	  datum->syntax
	  generate-temporaries
	  with-syntax

	  quasisyntax
	  unsyntax
	  unsyntax-splicing

	  syntax-violation)
  (import (only (guile) syntax-case
		        syntax

		        identifier?
			bound-identifier=?
			free-identifier=?

			syntax->datum
			datum->syntax
			generate-temporaries
			with-syntax

			quasisyntax
			unsyntax
			unsyntax-splicing)
	  (ice-9 optargs)
	  (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
	  (rnrs records procedural (6)))

  (define* (syntax-violation who message form #:optional subform)
    (let* ((conditions (list (make-message-condition message)
			     (make-syntax-violation form subform)))
	   (conditions (if who
			   (cons (make-who-condition who) conditions)
			   conditions)))
      (raise (apply condition conditions))))
)


code:
;;; unicode.scm --- The R6RS Unicode library

;;      Copyright (C) 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

(library (rnrs unicode (6))
  (export char-upcase
	  char-downcase
	  char-titlecase
	  char-foldcase

	  char-ci=?
	  char-ci<?
	  char-ci>?
	  char-ci<=?
	  char-ci>=?

	  char-alphabetic?
	  char-numeric?
	  char-whitespace?
	  char-upper-case?
	  char-lower-case?
	  char-title-case?

	  char-general-category

	  string-upcase
	  string-downcase
	  string-titlecase
	  string-foldcase

	  string-ci=?
	  string-ci<?
	  string-ci>?
	  string-ci<=?
	  string-ci>=?

	  string-normalize-nfd
	  string-normalize-nfkd
	  string-normalize-nfc
	  string-normalize-nfkc)
  (import (only (guile) char-upcase
		        char-downcase
			char-titlecase

			char-ci=?
			char-ci<?
			char-ci>?
			char-ci<=?
			char-ci>=?

			char-alphabetic?
			char-numeric?
			char-whitespace?
			char-upper-case?
			char-lower-case?

			char-set-contains?
			char-set:title-case

			char-general-category

			char-upcase
			char-downcase
			char-titlecase

			string-upcase
			string-downcase
			string-titlecase

			string-ci=?
			string-ci<?
			string-ci>?
			string-ci<=?
			string-ci>=?

			string-normalize-nfd
			string-normalize-nfkd
			string-normalize-nfc
			string-normalize-nfkc)
	  (rnrs base (6)))

  (define (char-foldcase char)
    (if (or (eqv? char #\460) (eqv? char #\461))
	char (char-downcase (char-upcase char))))

  (define (char-title-case? char) (char-set-contains? char-set:title-case char))

  (define (string-foldcase str) (string-downcase (string-upcase str)))
)


code:
2004-11-09  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* snarf-check-and-output-texi (process-multiline-directive): Allow
	the fname attribute to a sequence of strings and append them all
	to form the fname.  This is needed for string literals like
	"u8""vector?".

2004-09-08  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* Makefile.am (scripts_sources): Added snarf-guile-m4-docs.

2004-08-06  Kevin Ryde  <user42@zip.com.au>

	* scripts/read-rfc822 (parse-message): Correction to header
	continuation, loop with read-line not cdr lines.

2002-12-08  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

2002-10-26  Neil Jerram  <neil@ossau.uklinux.net>

	* lint (lint): Add message telling resolved module name.

2002-10-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* snarf-check-and-output-texi (end-multiline): Use '*function-name*'
	instead of nonexisting 'name'.

2002-10-04  Rob Browning  <rlb@defaultvalue.org>

	* summarize-guile-TODO (as-leaf): make #\: a char-set.

2002-05-18  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* api-diff (group-diff): Also output +N and -N adds and subs
	details, respectively.

2002-05-13  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* read-rfc822: New script.

	* Makefile.am (scripts_sources): Add api-diff and read-rfc822.

	* scan-api (scan-api): No longer include timestamp.

2002-05-11  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
	groups in the presence of the grouper.

	* api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
	Autoload module (srfi srfi-13).
	No longer export `diff-alists'.

	(diff, diff-alists, display-list): Remove.
	(put, get, read-api-alist-file, hang-by-the-roots, diff?,
	diff+note!, group-diff): New procs.
	(api-diff): Rewrite.

2002-05-10  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (add-props): New proc.
	(make-grok-proc): Renamed from `make-grok-hook'.
	(make-members-proc): Renamed from `make-members-hook'.
	(make-grouper): Renamed from `make-grouping-hook'.  Update callers.
	Add handling for multiple grouping-defs files.
	(scan-api): Add handling for multiple grouping-defs files.
	Cache `symbol->string' result; adjust `sort' usage.

2002-05-09  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (scan-C!): Use more robust regexp.

2002-05-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api: New script.
	(scan-api): Handle case where `grouping-hook' is #f.

	Remove top-level `debug-enable' form.
	Add TODO comment; nfc.

	* Makefile.am (scripts_sources): Add "scan-api".

2002-04-30  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO (make-display-item):
	Hoist some lambdas; nfc.

2002-04-29  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Fix commentary typo; nfc.

2002-04-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Use (ice-9 getopt-long).
	Autoload (ice-9 common-list).

	(select-items): New proc.
	(make-display-item): New proc.
	(display-item): Delete.
	(display-items): Use `make-display-item'.
	(summarize-guile-TODO): Add option handling.

2002-04-07  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Add "Bugs" section to commentary.
	Autoload (srfi srfi-13) on `string-tokenize'.

	(as-leaf): New proc.
	(hang-by-the-leaves): Use `as-leaf'.
	(read-TODO-file): Expand regexp and specs
	to handle "D", "X" and "N%".  Fix regexp
	to make isolating `who' easier.
	(display-item): Handle "D", "X" and "N%".

2002-04-06  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: New script.

	* Makefile.am (scripts_sources): Add "summarize-guile-TODO".

2002-04-05  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* read-text-outline (display-outline-tree): No longer export this proc.

	(*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
	display-outline-tree): Delete these vars and procs.

	(??, msub, ??-predicates, make-line-parser,
	make-text-outline-reader): New procs.

	(make-text-outline-reader): Export.
	(read-text-outline-silently): Rewrite
	using `make-text-outline-reader'.

2002-04-04  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* lint: New script.

	* Makefile.am (scripts_sources): Add "lint".

2002-04-02  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* PROGRAM: Update copyright; nfc.

	* read-text-outline: New script.

	* Makefile.am (scripts_sources): Add "read-text-outline".

	* read-text-outline (read-text-outline-silently):
	Move `tp' inside `loop'; nfc.

2002-03-12  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-check-and-output-texi (snarf-check-and-output-texi): If
	supplied, the `--manual' flag arrives as a string, not a symbol,
	so test for it as such.

2002-03-03  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
	docstring lines if possible, rather than just `#'.

2002-02-26  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am: Update path to pre-inst-guile automake frag.

2002-02-22  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* api-diff: New script.

2002-02-05  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Include $(top_srcdir)/pre-inst-guile.am.

	(overview): Use $(preinstguiletool).

2002-01-11  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am (scripts_sources): Add autofrisk.

	* autofrisk: New script.

	* frisk: Fix typo in commentary; nfc.

	* use2dot: Autoload module (ice-9 getopt-long).
	Use module (srfi srfi-13).
	Export `use2dot'.

	(string-append/separator, mapconcat): Delete.
	(vv): Now take list of pairs, and return the mapping..
	(>>header): Use `string-join'.
	(>>): New proc.
	(use2dot): Use `getopt-long'.  Use `>>'.

2002-01-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am (scripts_sources): Add frisk.
	(list): New target.
	(overview): Also report module interfaces.

	* use2dot: Rewrite using (scripts frisk).

	* frisk: Initial revision.

2002-01-02  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* snarf-guile-m4-docs: New script.

2001-11-28  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* punify (write-punily): Handle symbols w/ ":" prefix specially.

	* use2dot (ferret): New proc.
	(grok): Use `ferret'.

2001-11-16  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-check-and-output-texi: Change generated @deffn categories
	from "function" and "primitive" to "C Function" and "Scheme
	Procedure".
	(end-multiline): Take out @findex generation again; not needed
	since index entries are implicit in @deffn forms.

	These changes add a @deffnx C function declaration and function
	index entries for each Guile primitive to the copy of the doc
	snarf output that is used for reference manual synchronization.
	Online help is unchanged.

	* snarf-check-and-output-texi (*manual-flag*,
	snarf-check-and-output-texi): Handle `--manual' invocation arg
	passed through from libguile/Makefile.am.
	(*c-function-name*, begin-multiline, do-command): Pick out C
	function name from snarfed token stream.
	(end-multiline): Add @deffnx C declaration and function index
	entries to output.
	(*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
	Fluff to help insert the C declaration after any "@deffnx
	primitive" lines in the snarfed docstring.

2001-10-05  Thien-Thi Nguyen  <ttn@glug.org>

	* read-scheme-source (quoted?, clump): New procs, exported.

2001-09-30  Thien-Thi Nguyen  <ttn@glug.org>

	* display-commentary (module-name->filename-frag,
	display-module-commentary): New procs.
	(display-commentary): Also handle refs that look like module
	names.

2001-08-25  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".

2001-08-07  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: print optional args in a prettier
	manner.

2001-08-01  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, README, display-commentary, doc-snarf,
	generate-autoload, punify, read-scheme-source,
	snarf-check-and-output-texi, use2dot:
	In boilerplate, use -l$0.
	Thanks to Daniel Skarda.

2001-07-22  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* generate-autoload (autoload-info):
	Also handle `defmacro-public' forms.

2001-07-14  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, display-commentary, doc-snarf, generate-autoload,
	punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
	Re-add authorship info.

2001-07-12  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi (do-argpos): complain to the stderr,
	not stdout.  thanks to Dale P. Smith!
	(nice-sig): cosmetic fix.

2001-07-09  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, generate-autoload, use2dot, punify, display-commentary,
	doc-snarf, read-scheme-source, snarf-check-and-output-texi:
	Remove authorship info.

2001-06-25  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: rewrite.

2001-05-31  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: new file.

	* Makefile.am (scripts_sources): add snarf-check-and-output-texi.

2001-05-14  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, display-commentary, doc-snarf, generate-autoload,
	punify, read-scheme-source, use2dot: Move author tag outside
	commentary; nfc.

2001-05-08  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* read-scheme-source: New file

	* Makefile.am (scripts_sources): Add read-scheme-source.

2001-04-29  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* Makefile.am, PROGRAM, README, display-commentary,
	doc-snarf, generate-autoload, punify, use2dot: New file


code:
;;; PROGRAM --- Does something

;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: J.R.Hacker

;;; Commentary:

;; Usage: PROGRAM [ARGS]
;;
;; PROGRAM does something.
;;
;; TODO: Write it!

;;; Code:

(define-module (scripts PROGRAM)
  :export (PROGRAM))

(define (PROGRAM . args)
  #t)

(define main PROGRAM)

;;; PROGRAM ends here


code:
Overview and Usage
------------------

This directory contains Scheme programs, some useful in maintaining Guile.
On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.

You can invoke a program from the shell, or alternatively, load its file
as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
Typically for any PROGRAM:

  (use-modules (scripts PROGRAM))
  (PROGRAM ARG1 ARG2 ...)

For programs that write to stdout, you might try, instead:

  (use-modules (scripts PROGRAM))
  (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))

Note that all args must be strings.

To see PROGRAM's commentary, which may or may not be helpful:

  (help (scripts PROGRAM))

To see all commentaries and module dependencies, try: "make overview".

If you want to try the programs before installing Guile, you will probably
need to set environment variable GUILE_LOAD_PATH to be the parent directory.
This can be done in Bourne-compatible shells like so:

  GUILE_LOAD_PATH=`(cd .. ; pwd)`
  export GUILE_LOAD_PATH

[FIXME: Can someone supply the csh-compatible equivalent?]

How to Contribute
-----------------

See template file PROGRAM for a quick start.

Programs must follow the "executable module" convention, documented here:

- The file name must not end in ".scm".

- The file must be executable (chmod +x).

- The module name must be "(scripts PROGRAM)".  A procedure named PROGRAM w/
  signature "(PROGRAM . args)" must be exported.  Basically, use some variant
  of the form:

  (define-module (scripts PROGRAM)
    :export (PROGRAM))

  Feel free to export other definitions useful in the module context.

- There must be the alias:

  (define main PROGRAM)

  However, `main' must NOT be exported.

- The beginning of the file must use the following invocation sequence:

  #!/bin/sh
  main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
  exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
  !#

Following these conventions allows the program file to be used as module
(scripts PROGRAM) in addition to as a standalone executable.  Please also
include a helpful Commentary section w/ some usage info.

[README ends here]

path: module/scripts/README


code:
;;; api-diff --- diff guile-api.alist files

;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
;;
;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
;; and display a (count) summary of the groups defined therein.
;; Optional arg "--details" (or "-d") specifies a comma-separated
;; list of groups, in which case api-diff displays instead the
;; elements added and deleted for each of the specified groups.
;;
;; For scheme programming, this module exports the proc:
;;  (api-diff A-file B-file)
;;
;; Note that the convention is that the "older" alist/file is
;; specified first.
;;
;; TODO: Develop scheme interface.

;;; Code:

(define-module (scripts api-diff)
  :use-module (ice-9 common-list)
  :use-module (ice-9 format)
  :use-module (ice-9 getopt-long)
  :autoload (srfi srfi-13) (string-tokenize)
  :export (api-diff))

(define (read-alist-file file)
  (with-input-from-file file
    (lambda () (read))))

(define put set-object-property!)
(define get object-property)

(define (read-api-alist-file file)
  (let* ((alist (read-alist-file file))
         (meta (assq-ref alist 'meta))
         (interface (assq-ref alist 'interface)))
    (put interface 'meta meta)
    (put interface 'groups (let ((ht (make-hash-table 31)))
                             (for-each (lambda (group)
                                         (hashq-set! ht group '()))
                                       (assq-ref meta 'groups))
                             ht))
    interface))

(define (hang-by-the-roots interface)
  (let ((ht (get interface 'groups)))
    (for-each (lambda (x)
                (for-each (lambda (group)
                            (hashq-set! ht group
                                        (cons (car x)
                                              (hashq-ref ht group))))
                          (assq-ref x 'groups)))
              interface))
  interface)

(define (diff? a b)
  (let ((result (set-difference a b)))
    (if (null? result)
        #f                              ; CL weenies bite me
        result)))

(define (diff+note! a b note-removals note-additions note-same)
  (let ((same? #t))
    (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
    (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
    (and same? (note-same))))

(define (group-diff i-old i-new . options)
  (let* ((i-old (hang-by-the-roots i-old))
         (g-old (hash-fold acons '() (get i-old 'groups)))
         (g-old-names (map car g-old))
         (i-new (hang-by-the-roots i-new))
         (g-new (hash-fold acons '() (get i-new 'groups)))
         (g-new-names (map car g-new)))
    (cond ((null? options)
           (diff+note! g-old-names g-new-names
                       (lambda (removals)
                         (format #t "groups-removed: ~A\n" removals))
                       (lambda (additions)
                         (format #t "groups-added: ~A\n" additions))
                       (lambda () #t))
           (for-each (lambda (group)
                       (let* ((old (assq-ref g-old group))
                              (new (assq-ref g-new group))
                              (old-count (and old (length old)))
                              (new-count (and new (length new)))
                              (delta (and old new (- new-count old-count))))
                         (format #t " ~5@A  ~5@A  :  "
                                 (or old-count "-")
                                 (or new-count "-"))
                         (cond ((and old new)
                                (let ((add-count 0) (sub-count 0))
                                  (diff+note!
                                   old new
                                   (lambda (subs)
                                     (set! sub-count (length subs)))
                                   (lambda (adds)
                                     (set! add-count (length adds)))
                                   (lambda () #t))
                                  (format #t "~5@D ~5@D : ~5@D"
                                          add-count (- sub-count) delta)))
                               (else
                                (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
                         (format #t "     ~A\n" group)))
                     (sort (union g-old-names g-new-names)
                           (lambda (a b)
                             (string<? (symbol->string a)
                                       (symbol->string b))))))
          ((assq-ref options 'details)
           => (lambda (groups)
                (for-each (lambda (group)
                            (let* ((old (or (assq-ref g-old group) '()))
                                   (new (or (assq-ref g-new group) '()))
                                   (>>! (lambda (label ls)
                                          (format #t "~A ~A:\n" group label)
                                          (for-each (lambda (x)
                                                      (format #t " ~A\n" x))
                                                    ls))))
                              (diff+note! old new
                                          (lambda (removals)
                                            (>>! 'removals removals))
                                          (lambda (additions)
                                            (>>! 'additions additions))
                                          (lambda ()
                                            (format #t "~A: no changes\n"
                                                    group)))))
                          groups)))
          (else
           (error "api-diff: group-diff: bad options")))))

(define (api-diff . args)
  (let* ((p (getopt-long (cons 'api-diff args)
                         '((details (single-char #\d)
                                    (value #t))
                           ;; Add options here.
                           )))
         (rest (option-ref p '() '("/dev/null" "/dev/null")))
         (i-old (read-api-alist-file (car rest)))
         (i-new (read-api-alist-file (cadr rest)))
         (options '()))
    (cond ((option-ref p 'details #f)
           => (lambda (groups)
                (set! options (cons (cons 'details
                                          (map string->symbol
                                               (string-tokenize
                                                groups
                                                #\,)))
                                    options)))))
    (apply group-diff i-old i-new options)))

(define main api-diff)

;;; api-diff ends here


code:
;;; autofrisk --- Generate module checks for use with auto* tools

;; 	Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: autofrisk [file]
;;
;; This program looks for the file modules.af in the current directory
;; and writes out modules.af.m4 containing autoconf definitions.
;; If given, look for FILE instead of modules.af and output to FILE.m4.
;;
;; After running autofrisk, you should add to configure.ac the lines:
;;   AUTOFRISK_CHECKS
;;   AUTOFRISK_SUMMARY
;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
;;
;; The modules.af file consists of a series of configuration forms (Scheme
;; lists), which have one of the following formats:
;;   (files-glob PATTERN ...)
;;   (non-critical-external MODULE ...)
;;   (non-critical-internal MODULE ...)
;;   (programs (MODULE PROG ...) ...)
;;   (pww-varname VARNAME)
;; PATTERN is a string that may contain "*" and "?" characters to be
;; expanded into filenames.  MODULE is a list of symbols naming a
;; module, such as `(srfi srfi-1)'.  VARNAME is a shell-safe name to use
;; instead of "probably_wont_work", the default.  This var is passed to
;; `AC_SUBST'.  PROG is a string.
;;
;; Only the `files-glob' form is required.
;;
;; TODO: Write better commentary.
;;       Make "please see README" configurable.

;;; Code:

(define-module (scripts autofrisk)
  :autoload (ice-9 popen) (open-input-pipe)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-8)
  :use-module (srfi srfi-13)
  :use-module (srfi srfi-14)
  :use-module (scripts read-scheme-source)
  :use-module (scripts frisk)
  :export (autofrisk))

(define *recognized-keys* '(files-glob
                            non-critical-external
                            non-critical-internal
                            programs
                            pww-varname))

(define (canonical-configuration forms)
  (let ((chk (lambda (condition . x)
               (or condition (apply error "syntax error:" x)))))
    (chk (list? forms) "input not a list")
    (chk (every list? forms) "non-list element")
    (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
    (let ((un #f))
      (chk (every (lambda (form)
                    (let ((key (car form)))
                      (and (symbol? key)
                           (or (eq? 'quote key)
                               (memq key *recognized-keys*)
                               (begin
                                 (set! un key)
                                 #f)))))
                  forms)
           "unrecognized key:" un))
    (let ((bunched (map (lambda (key)
                          (fold (lambda (form so-far)
                                  (or (and (eq? (car form) key)
                                           (cdr form)
                                           (append so-far (cdr form)))
                                      so-far))
                                (list key)
                                forms))
                        *recognized-keys*)))
      (lambda (key)
        (assq-ref bunched key)))))

(define (>>strong modules)
  (for-each (lambda (module)
              (format #t "GUILE_MODULE_REQUIRED~A\n" module))
            modules))

(define (safe-name module)
  (let ((var (object->string module)))
    (string-map! (lambda (c)
                   (if (char-set-contains? char-set:letter+digit c)
                       c
                       #\_))
                 var)
    var))

(define *pww* "probably_wont_work")

(define (>>weak weak-edges)
  (for-each (lambda (edge)
              (let* ((up (edge-up edge))
                     (down (edge-down edge))
                     (var (format #f "have_guile_module~A" (safe-name up))))
                (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
                (format #t "test \"$~A\" = no &&\n  ~A=\"~A $~A\"~A"
                        var *pww* down *pww* "\n\n")))
            weak-edges))

(define (>>program module progs)
  (let ((vars (map (lambda (prog)
                     (format #f "guile_module~Asupport_~A"
                             (safe-name module)
                             prog))
                   progs)))
    (for-each (lambda (var prog)
                (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
              vars progs)
    (format #t "test \\\n")
    (for-each (lambda (var)
                (format #t " \"$~A\" = \"\" -o \\\n" var))
              vars)
    (format #t "~A &&\n~A=\"~A $~A\"\n\n"
            (list-ref (list "war = peace"
                            "freedom = slavery"
                            "ignorance = strength")
                      (random 3))
            *pww* module *pww*)))

(define (>>programs programs)
  (for-each (lambda (form)
              (>>program (car form) (cdr form)))
            programs))

(define (unglob pattern)
  (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
    (map symbol->string (read p))))

(define (>>checks forms)
  (let* ((cfg (canonical-configuration forms))
         (files (apply append (map unglob (cfg 'files-glob))))
         (ncx (cfg 'non-critical-external))
         (nci (cfg 'non-critical-internal))
         (report ((make-frisker) files))
         (external (report 'external)))
    (let ((pww-varname (cfg 'pww-varname)))
      (or (null? pww-varname) (set! *pww* (car pww-varname))))
    (receive (weak strong)
        (partition (lambda (module)
                     (or (member module ncx)
                         (every (lambda (i)
                                  (member i nci))
                                (map edge-down (mod-down-ls module)))))
                   external)
      (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
      (>>strong strong)
      (format #t "\n~A=~S\n\n" *pww* "")
      (>>weak (fold (lambda (module so-far)
                      (append so-far (mod-down-ls module)))
                    (list)
                    weak))
      (>>programs (cfg 'programs))
      (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))

(define (>>summary)
  (format #t
          (symbol->string
           '#{
AC_DEFUN([AUTOFRISK_SUMMARY],[
if test ! "$~A" = "" ; then
    p="         ***"
    echo "$p"
    echo "$p NOTE:"
    echo "$p The following modules probably won't work:"
    echo "$p   $~A"
    echo "$p They can be installed anyway, and will work if their"
    echo "$p dependencies are installed later.  Please see README."
    echo "$p"
fi
])
}#)
          *pww* *pww*))

(define (autofrisk . args)
  (let ((file (if (null? args) "modules.af" (car args))))
    (or (file-exists? file)
        (error "could not find input file:" file))
    (with-output-to-file (format #f "~A.m4" file)
      (lambda ()
        (>>checks (read-scheme-source-silently file))
        (>>summary)))))

(define main autofrisk)

;; Local variables:
;; eval: (put 'receive 'scheme-indent-function 2)
;; End:

;;; autofrisk ends here


code:
;;; Compile --- Command-line Guile Scheme compiler  -*- coding: iso-8859-1 -*-

;; Copyright 2005,2008,2009,2010 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Ludovic Court�s <ludo@gnu.org>
;;; Author: Andy Wingo <wingo@pobox.com>

;;; Commentary:

;; Usage: compile [ARGS]
;;
;; A command-line interface to the Guile compiler.

;;; Code:

(define-module (scripts compile)
  #:use-module ((system base compile) #:select (compile-file))
  #:use-module (system base message)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-13)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 format)
  #:export (compile))

(define (fail . messages)
  (format (current-error-port)
	  (string-concatenate `("error: " ,@messages "~%")))
  (exit 1))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda (opt name arg result)
		  (alist-cons 'help? #t result)))
        (option '("version") #f #f
                (lambda (opt name arg result)
                  (show-version)
                  (exit 0)))

	(option '(#\L "load-path") #t #f
		(lambda (opt name arg result)
		  (let ((load-path (assoc-ref result 'load-path)))
		    (alist-cons 'load-path (cons arg load-path)
				result))))
	(option '(#\o "output") #t #f
		(lambda (opt name arg result)
		  (if (assoc-ref result 'output-file)
		      (fail "`-o' option cannot be specified more than once")
		      (alist-cons 'output-file arg result))))

        (option '(#\W "warn") #t #f
                (lambda (opt name arg result)
                  (if (string=? arg "help")
                      (begin
                        (show-warning-help)
                        (exit 0))
                      (let ((warnings (assoc-ref result 'warnings)))
                        (alist-cons 'warnings
                                    (cons (string->symbol arg) warnings)
                                    (alist-delete 'warnings result))))))

	(option '(#\O "optimize") #f #f
		(lambda (opt name arg result)
		  (alist-cons 'optimize? #t result)))
	(option '(#\f "from") #t #f
		(lambda (opt name arg result)
                  (if (assoc-ref result 'from)
                      (fail "`--from' option cannot be specified more than once")
                      (alist-cons 'from (string->symbol arg) result))))
	(option '(#\t "to") #t #f
		(lambda (opt name arg result)
                  (if (assoc-ref result 'to)
                      (fail "`--to' option cannot be specified more than once")
                      (alist-cons 'to (string->symbol arg) result))))))

(define (parse-args args)
  "Parse argument list @var{args} and return an alist with all the relevant
options."
  (args-fold args %options
             (lambda (opt name arg result)
               (format (current-error-port) "~A: unrecognized option" name)
	       (exit 1))
             (lambda (file result)
	       (let ((input-files (assoc-ref result 'input-files)))
		 (alist-cons 'input-files (cons file input-files)
			     result)))

	     ;; default option values
             '((input-files)
	       (load-path)
               (warnings unsupported-warning))))

(define (show-version)
  (format #t "compile (GNU Guile) ~A~%" (version))
  (format #t "Copyright (C) 2009 Free Software Foundation, Inc.
License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.~%"))

(define (show-warning-help)
  (format #t "The available warning types are:~%~%")
  (for-each (lambda (wt)
              (format #t "  ~22A ~A~%"
                      (format #f "`~A'" (warning-type-name wt))
                      (warning-type-description wt)))
            %warning-types)
  (format #t "~%"))

(define (compile . args)
  (let* ((options         (parse-args args))
         (help?           (assoc-ref options 'help?))
         (compile-opts    (let ((o `(#:warnings
                                     ,(assoc-ref options 'warnings))))
                            (if (assoc-ref options 'optimize?)
                                (cons #:O o)
                                o)))
         (from            (or (assoc-ref options 'from) 'scheme))
         (to              (or (assoc-ref options 'to) 'objcode))
	 (input-files     (assoc-ref options 'input-files))
	 (output-file     (assoc-ref options 'output-file))
	 (load-path       (assoc-ref options 'load-path)))
    (if (or help? (null? input-files))
        (begin
          (format #t "Usage: compile [OPTION] FILE...
Compile each Guile source file FILE into a Guile object.

  -h, --help           print this help message

  -L, --load-path=DIR  add DIR to the front of the module load path
  -o, --output=OFILE   write output to OFILE

  -W, --warn=WARNING   emit warnings of type WARNING; use `--warn=help'
                       for a list of available warnings

  -f, --from=LANG      specify a source language other than `scheme'
  -t, --to=LANG        specify a target language other than `objcode'

Note that autocompilation will be turned off.

Report bugs to <~A>.~%"
                  %guile-bug-report-address)
          (exit 0)))

    (set! %load-path (append load-path %load-path))
    (set! %load-should-autocompile #f)

    (if (and output-file
             (or (null? input-files)
                 (not (null? (cdr input-files)))))
        (fail "`-o' option can only be specified "
              "when compiling a single file"))

    (for-each (lambda (file)
                (format #t "wrote `~A'\n"
                        (compile-file file
                                      #:output-file output-file
                                      #:from from
                                      #:to to
                                      #:opts compile-opts)))
              input-files)))

(define main compile)


code:
;;; Disassemble --- Disassemble .go files into something human-readable

;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Ludovic Courtès <ludo@gnu.org>
;;; Author: Andy Wingo <wingo@pobox.com>

;;; Commentary:

;; Usage: disassemble [ARGS]

;;; Code:

(define-module (scripts disassemble)
  #:use-module (system vm objcode)
  #:use-module ((language assembly disassemble)
                #:renamer (symbol-prefix-proc 'asm:))
  #:export (disassemble))

(define (disassemble . files)
  (for-each (lambda (file)
              (asm:disassemble (load-objcode file)))
            files))

(define main disassemble)


code:
;;; display-commentary --- As advertized

;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen

;;; Commentary:

;; Usage: display-commentary REF1 REF2 ...
;;
;; Display Commentary section from REF1, REF2 and so on.
;; Each REF may be a filename or module name (list of symbols).
;; In the latter case, a filename is computed by searching `%load-path'.

;;; Code:

(define-module (scripts display-commentary)
  :use-module (ice-9 documentation)
  :export (display-commentary))

(define (display-commentary-one file)
  (format #t "~A commentary:\n~A" file (file-commentary file)))

(define (module-name->filename-frag ls) ; todo: export or move
  (let ((ls (map symbol->string ls)))
    (let loop ((ls (cdr ls)) (acc (car ls)))
      (if (null? ls)
          acc
          (loop (cdr ls) (string-append acc "/" (car ls)))))))

(define (display-module-commentary module-name)
  (cond ((%search-load-path (module-name->filename-frag module-name))
         => (lambda (file)
              (format #t "module ~A\n" module-name)
              (display-commentary-one file)))))

(define (display-commentary . refs)
  (for-each (lambda (ref)
              (cond ((string? ref)
                     (if (equal? 0 (string-index ref #\())
                         (display-module-commentary
                          (with-input-from-string ref read))
                         (display-commentary-one ref)))
                    ((list? ref)
                     (display-module-commentary ref))))
            refs))

(define main display-commentary)

;;; display-commentary ends here


code:
;;; doc-snarf --- Extract documentation from source files

;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;
;; This program 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, or
;; (at your option) any later version.
;;
;; This program 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 software; see the file COPYING.LESSER.  If
;; not, write to the Free Software Foundation, Inc., 51 Franklin
;; Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Martin Grabmueller

;;; Commentary:

;; Usage: doc-snarf FILE
;;
;; This program reads in a Scheme source file and extracts docstrings
;; in the format specified below.  Additionally, a procedure protoype
;; is infered from the procedure definition line starting with
;; (define... ).
;;
;; Currently, two output modi are implemented: texinfo and plaintext.
;; Default is plaintext, texinfo can be switched on with the
;; `--texinfo, -t' command line option.
;;
;; Format: A docstring can span multiple lines and a docstring line
;; begins with `;; ' (two semicoli and a space). A docstring is ended
;; by either a line beginning with (define ...) or one or more lines
;; beginning with `;;-' (two semicoli and a dash). These lines are
;; called `options' and begin with a keyword, followed by a colon and
;; a string.
;;
;; Additionally, "standard internal docstrings" (for Scheme source) are
;; recognized and output as "options".  The output formatting is likely
;; to change in the future.
;;
;; Example:

;; This procedure foos, or bars, depending on the argument @var{braz}.
;;-Author: Martin Grabmueller
(define (foo/bar braz)
  (if braz 'foo 'bar))

;;; Which results in the following docstring if texinfo output is
;;; enabled:
#!
foo/bar
@deffn procedure foo/bar braz
This procedure foos, or bars, depending on the argument @var{braz}.
@c Author: Martin Grabmueller
@end deffn
!#

;;; Or in this if plaintext output is used:
#!
Procedure: foo/bar braz
This procedure foos, or bars, depending on the argument @var{braz}.
;; Author: Martin Grabmueller
^L
!#

;; TODO: Convert option lines to alist.
;;       More parameterization.
;;       (maybe) Use in Guile build itself.

(define doc-snarf-version "0.0.2") ; please update before publishing!

;;; Code:

(define-module (scripts doc-snarf)
  :use-module (ice-9 getopt-long)
  :use-module (ice-9 regex)
  :use-module (ice-9 string-fun)
  :use-module (ice-9 rdelim)
  :export (doc-snarf))

(define command-synopsis
  '((version (single-char #\v) (value #f))
    (help    (single-char #\h) (value #f))
    (output  (single-char #\o) (value #t))
    (texinfo (single-char #\t) (value #f))
    (lang    (single-char #\l) (value #t))))

;; Display version information and exit.
;;-ttn-mod: use var
(define (display-version)
  (display "doc-snarf ") (display doc-snarf-version) (newline))

;; Display the usage help message and exit.
;;-ttn-mod: change option "source" to "lang"
(define (display-help)
  (display "Usage: doc-snarf [options...] inputfile\n")
  (display "  --help, -h              Show this usage information\n")
  (display "  --version, -v           Show version information\n")
  (display
   "  --output=FILE, -o       Specify output file [default=stdout]\n")
  (display "  --texinfo, -t           Format output as texinfo\n")
  (display "  --lang=[c,scheme], -l   Specify the input language\n"))

;; Main program.
;;-ttn-mod: canonicalize lang
(define (doc-snarf . args)
  (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
    (let ((help-wanted (option-ref options 'help #f))
	  (version-wanted (option-ref options 'version #f))
	  (texinfo-wanted (option-ref options 'texinfo #f))
	  (lang (string->symbol
                 (string-downcase (option-ref options 'lang "scheme")))))
      (cond
       (version-wanted (display-version))
       (help-wanted (display-help))
       (else
	(let ((input (option-ref options '() #f))
	      (output (option-ref options 'output #f)))
	  (if
           ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
           ;; (and input (pair? input))
           (pair? input)
           (snarf-file (car input) output texinfo-wanted lang)
           (display-help))))))))

(define main doc-snarf)

;; Supported languages and their parameters.  Each element has form:
;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
;; LANG supports "standard internal docstring" (a string after the formals),
;; everything else is a string specifying a regexp.
;;-ttn-mod: new var
(define supported-languages
  '((c
     "^/\\*(.*)"
     "^ \\*/"
     "^ \\* (.*)"
     "^ \\*-(.*)"
     "NOTHING AT THIS TIME!!!"
     #f
     )
    (scheme
     "^;; (.*)"
     "^;;\\."
     "^;; (.*)"
     "^;;-(.*)"
     "^\\(define"
     #t
     )))

;; Get @var{lang}'s @var{parameter}.  Both args are symbols.
;;-ttn-mod: new proc
(define (lang-parm lang parm)
  (list-ref (assq-ref supported-languages lang)
            (case parm
              ((docstring-start)  0)
              ((docstring-end)    1)
              ((docstring-prefix) 2)
              ((option-prefix)    3)
              ((signature-start)  4)
              ((std-int-doc?)     5))))

;; Snarf all docstrings from the file @var{input} and write them to
;; file @var{output}.  Use texinfo format for the output if
;; @var{texinfo?} is true.
;;-ttn-mod: don't use string comparison, consult table instead
(define (snarf-file input output texinfo? lang)
  (or (memq lang (map car supported-languages))
      (error "doc-snarf: input language must be c or scheme."))
  (write-output (snarf input lang) output
                (if texinfo? format-texinfo format-plain)))

;; fixme: this comment is required to trigger standard internal
;; docstring snarfing...  ideally, it wouldn't be necessary.
;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
(define (find-std-int-doc line input-port)
  "Unread @var{line} from @var{input-port}, then read in the entire form and
return the standard internal docstring if found.  Return #f if not."
  (unread-string line input-port)       ; ugh
  (let ((form (read input-port)))
    (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
                (< 3 (length form))
                (eq? 'define (car form))
                (pair? (cadr form))
                (symbol? (caadr form))
                (string? (caddr form)))
           (caddr form))
          ((and (list? form)            ; (define VAR (lambda ARGS "DOC" ...))
                (< 2 (length form))
                (eq? 'define (car form))
                (symbol? (cadr form))
                (list? (caddr form))
                (< 3 (length (caddr form)))
                (eq? 'lambda (car (caddr form)))
                (string? (caddr (caddr form))))
           (caddr (caddr form)))
          (else #f))))

;; Split @var{string} into lines, adding @var{prefix} to each.
;;-ttn-mod: new proc
(define (split-prefixed string prefix)
  (separate-fields-discarding-char
   #\newline string
   (lambda lines
     (map (lambda (line)
            (string-append prefix line))
          lines))))

;; snarf input-file output-file
;; Extract docstrings from the input file @var{input}, presumed
;; to be written in language @var{lang}.
;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;-Created: 2001-02-17
;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
(define (snarf input-file lang)
  (let* ((i-p (open-input-file input-file))
         (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
         (docstring-start  (parm-regexp 'docstring-start))
         (docstring-end    (parm-regexp 'docstring-end))
         (docstring-prefix (parm-regexp 'docstring-prefix))
         (option-prefix    (parm-regexp 'option-prefix))
         (signature-start  (parm-regexp 'signature-start))
         (augmented-options
          (lambda (line i-p options)
            (let ((int-doc (and (lang-parm lang 'std-int-doc?)
                                (let ((d (find-std-int-doc line i-p)))
                                  (and d (split-prefixed d "internal: "))))))
              (if int-doc
                  (append (reverse int-doc) options)
                  options)))))

    (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
	     (options '()) (entries '()) (lno 0))
      (cond
       ((eof-object? line)
	(close-input-port i-p)
	(reverse entries))

       ;; State 'neutral: we're currently not within a docstring or
       ;; option section
       ((eq? state 'neutral)
	(let ((m (regexp-exec docstring-start line)))
	  (if m
	    (lp (read-line i-p) 'doc-string
		(list (match:substring m 1)) '() entries (+ lno 1))
	    (lp (read-line i-p) state '() '() entries (+ lno 1)))))

       ;; State 'doc-string: we have started reading a docstring and
       ;; are waiting for more, for options or for a define.
       ((eq? state 'doc-string)
	(let ((m0 (regexp-exec docstring-prefix line))
	      (m1 (regexp-exec option-prefix line))
	      (m2 (regexp-exec signature-start line))
	      (m3 (regexp-exec docstring-end line)))
	  (cond
	   (m0
	    (lp (read-line i-p) 'doc-string
		(cons (match:substring m0 1) doc-strings) '() entries
		(+ lno 1)))
	   (m1
	    (lp (read-line i-p) 'options
		doc-strings (cons (match:substring m1 1) options) entries
		(+ lno 1)))
	   (m2
            (let ((options (augmented-options line i-p options))) ; ttn-mod
              (lp (read-line i-p) 'neutral '() '()
                  (cons (parse-entry doc-strings options line input-file lno)
                        entries)
                  (+ lno 1))))
           (m3
	    (lp (read-line i-p) 'neutral '() '()
		(cons (parse-entry doc-strings options #f input-file lno)
		      entries)
		(+ lno 1)))
	   (else
	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))

       ;; State 'options: We're waiting for more options or for a
       ;; define.
       ((eq? state 'options)
	(let ((m1 (regexp-exec option-prefix line))
	      (m2 (regexp-exec signature-start line))
	      (m3 (regexp-exec docstring-end line)))
	  (cond
	   (m1
	    (lp (read-line i-p) 'options
		doc-strings (cons (match:substring m1 1) options) entries
		(+ lno 1)))
	   (m2
            (let ((options (augmented-options line i-p options))) ; ttn-mod
              (lp (read-line i-p) 'neutral '() '()
                  (cons (parse-entry doc-strings options line input-file lno)
                        entries)
                  (+ lno 1))))
	   (m3
	    (lp (read-line i-p) 'neutral '() '()
		(cons (parse-entry doc-strings options #f input-file lno)
		      entries)
		(+ lno 1)))
	   (else
	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))

(define (make-entry symbol signature docstrings options filename line)
  (vector 'entry symbol signature docstrings options filename line))
(define (entry-symbol e)
  (vector-ref e 1))
(define (entry-signature e)
  (vector-ref e 2))
(define (entry-docstrings e)
  (vector-ref e 3))
(define (entry-options e)
  (vector-ref e 4))
(define (entry-filename e)
  (vector-ref e 5))
(define (entry-line e)
  "This docstring will not be snarfed, unfortunately..."
  (vector-ref e 6))

;; Create a docstring entry from the docstring line list
;; @var{doc-strings}, the option line list @var{options} and the
;; define line @var{def-line}
(define (parse-entry docstrings options def-line filename line-no)
;  (write-line docstrings)
  (cond
   (def-line
     (make-entry (get-symbol def-line)
		 (make-prototype def-line) (reverse docstrings)
		 (reverse options) filename
		 (+ (- line-no (length docstrings) (length options)) 1)))
   ((> (length docstrings) 0)
    (make-entry (string->symbol (car (reverse docstrings)))
		(car (reverse docstrings))
		(cdr (reverse docstrings))
		(reverse options) filename
		(+ (- line-no (length docstrings) (length options)) 1)))
   (else
    (make-entry 'foo "" (reverse docstrings) (reverse options) filename
		(+ (- line-no (length docstrings) (length options)) 1)))))

;; Create a string which is a procedure prototype.  The necessary
;; information for constructing the prototype is taken from the line
;; @var{def-line}, which is a line starting with @code{(define...}.
(define (make-prototype def-line)
  (call-with-input-string
   def-line
   (lambda (s-p)
     (let* ((paren (read-char s-p))
	    (keyword (read s-p))
	    (tmp (read s-p)))
       (cond
	((pair? tmp)
	 (join-symbols tmp))
	((symbol? tmp)
	 (symbol->string tmp))
	(else
	 ""))))))

(define (get-symbol def-line)
  (call-with-input-string
   def-line
   (lambda (s-p)
     (let* ((paren (read-char s-p))
	    (keyword (read s-p))
	    (tmp (read s-p)))
       (cond
	((pair? tmp)
	 (car tmp))
	((symbol? tmp)
	 tmp)
	(else
	 'foo))))))

;; Append the symbols in the string list @var{s}, separated with a
;; space character.
(define (join-symbols s)
  (cond ((null? s)
	 "")
	((symbol? s)
	 (string-append ". " (symbol->string s)))
	((null? (cdr s))
	 (symbol->string (car s)))
	(else
	 (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))

;; Write @var{entries} to @var{output-file} using @var{writer}.
;; @var{writer} is a proc that takes one entry.
;; If @var{output-file} is #f, write to stdout.
;;-ttn-mod: new proc
(define (write-output entries output-file writer)
  (with-output-to-port (cond (output-file (open-output-file output-file))
                             (else (current-output-port)))
    (lambda () (for-each writer entries))))

;; Write an @var{entry} using texinfo format.
;;-ttn-mod: renamed from `texinfo-output', distilled
(define (format-texinfo entry)
  (display "\n\f")
  (display (entry-symbol entry))
  (newline)
  (display "@c snarfed from ")
  (display (entry-filename entry))
  (display ":")
  (display (entry-line entry))
  (newline)
  (display "@deffn procedure ")
  (display (entry-signature entry))
  (newline)
  (for-each (lambda (s) (write-line s))
            (entry-docstrings entry))
  (for-each (lambda (s) (display "@c ") (write-line s))
            (entry-options entry))
  (write-line "@end deffn"))

;; Write an @var{entry} using plain format.
;;-ttn-mod: renamed from `texinfo-output', distilled
(define (format-plain entry)
  (display "Procedure: ")
  (display (entry-signature entry))
  (newline)
  (for-each (lambda (s) (write-line s))
            (entry-docstrings entry))
  (for-each (lambda (s) (display ";; ") (write-line s))
            (entry-options entry))
  (display "Snarfed from ")
  (display (entry-filename entry))
  (display ":")
  (display (entry-line entry))
  (newline)
  (write-line "\f"))

;;; doc-snarf ends here