code:
;;; installed-scm-file

;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (oop goops save)
  :use-module (oop goops internal)
  :use-module (oop goops util)
  :re-export (make-unbound)
  :export (save-objects load-objects restore
	   enumerate! enumerate-component!
	   write-readably write-component write-component-procedure
	   literal? readable make-readable))

;;;
;;; save-objects ALIST PORT [EXCLUDED] [USES]
;;;
;;; ALIST ::= ((NAME . OBJECT) ...)
;;;
;;; Save OBJECT ... to PORT so that when the data is read and evaluated
;;; OBJECT ... are re-created under names NAME ... .
;;; Exclude any references to objects in the list EXCLUDED.
;;; Add a (use-modules . USES) line to the top of the saved text.
;;;
;;; In some instances, when `save-object' doesn't know how to produce
;;; readable syntax for an object, you can explicitly register read
;;; syntax for an object using the special form `readable'.
;;;
;;; Example:
;;;
;;;   The function `foo' produces an object of obscure structure.
;;;   Only `foo' can construct such objects.  Because of this, an
;;;   object such as
;;;
;;;     (define x (vector 1 (foo)))
;;;
;;;   cannot be saved by `save-objects'.  But if you instead write
;;;
;;;     (define x (vector 1 (readable (foo))))
;;;
;;;   `save-objects' will happily produce the necessary read syntax.
;;;
;;; To add new read syntax, hang methods on `enumerate!' and
;;; `write-readably'.
;;;
;;; enumerate! OBJECT ENV
;;;   Should call `enumerate-component!' (which takes same args) on
;;;   each component object.  Should return #t if the composite object
;;;   can be written as a literal.  (`enumerate-component!' returns #t
;;;   if the component is a literal.
;;;
;;; write-readably OBJECT PORT ENV
;;;   Should write a readable representation of OBJECT to PORT.
;;;   Should use `write-component' to print each component object.
;;;   Use `literal?' to decide if a component is a literal.
;;;
;;; Utilities:
;;;
;;; enumerate-component! OBJECT ENV
;;;
;;; write-component OBJECT PATCHER PORT ENV
;;;   PATCHER is an expression which, when evaluated, stores OBJECT
;;;   into its current location.
;;;
;;;   Example:
;;;
;;;     (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
;;;
;;;   write-component is a macro.
;;;
;;; literal? COMPONENT ENV
;;;

(define-method (immediate? (o <top>)) #f)

(define-method (immediate? (o <null>)) #t)
(define-method (immediate? (o <number>)) #t)
(define-method (immediate? (o <boolean>)) #t)
(define-method (immediate? (o <symbol>)) #t)
(define-method (immediate? (o <char>)) #t)
(define-method (immediate? (o <keyword>)) #t)

;;; enumerate! OBJECT ENVIRONMENT
;;;
;;; Return #t if object is a literal.
;;;
(define-method (enumerate! (o <top>) env) #t)

(define-method (write-readably (o <top>) file env)
  ;;(goops-error "No read-syntax defined for object `~S'" o)
  (write o file) ;doesn't catch bugs, but is much more flexible
  )

;;;
;;; Readables
;;;

(define readables (make-weak-key-hash-table 61))

(define-macro (readable exp)
  `(make-readable ,exp ',(copy-tree exp)))

(define (make-readable obj expr)
  (hashq-set! readables obj expr)
  obj)

(define (readable-expression obj)
  `(readable ,(hashq-ref readables obj)))

(define (readable? obj)
  (hashq-get-handle readables obj))

;;;
;;; Strings
;;;

(define-method (enumerate! (o <string>) env) #f)

;;;
;;; Vectors
;;;

(define-method (enumerate! (o <vector>) env)
  (or (not (vector? o))
      (let ((literal? #t))
	(array-for-each (lambda (o)
			  (if (not (enumerate-component! o env))
			      (set! literal? #f)))
			o)
	literal?)))

(define-method (write-readably (o <vector>) file env)
  (if (not (vector? o))
      (write o file)
      (let ((n (vector-length o)))
	(if (zero? n)
	    (display "#()" file)
	    (let ((not-literal? (not (literal? o env))))
	      (display (if not-literal?
			   "(vector "
			   "#(")
		       file)
	      (if (and not-literal?
		       (literal? (vector-ref o 0) env))
		  (display #\' file))
	      (write-component (vector-ref o 0)
			       `(vector-set! ,o 0 ,(vector-ref o 0))
			       file
			       env)
	      (do ((i 1 (+ 1 i)))
		  ((= i n))
		(display #\space file)
		(if (and not-literal?
			 (literal? (vector-ref o i) env))
		    (display #\' file))
		(write-component (vector-ref o i)
				 `(vector-set! ,o ,i ,(vector-ref o i))
				 file
				 env))
	      (display #\) file))))))

;;;
;;; Arrays
;;;

(define-method (enumerate! (o <array>) env)
  (enumerate-component! (shared-array-root o) env))

(define (make-mapper array)
  (let* ((n (array-rank array))
	 (indices (reverse (if (<= n 11)
			       (list-tail '(t s r q p n m l k j i)  (- 11 n))
			       (let loop ((n n)
					  (ls '()))
				 (if (zero? n)
				     ls
				     (loop (- n 1)
					   (cons (gensym "i") ls))))))))
    `(lambda ,indices
       (+ ,(shared-array-offset array)
	  ,@(map (lambda (ind dim inc)
		   `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
		 indices
		 (array-dimensions array)
		 (shared-array-increments array))))))

(define (write-array prefix o not-literal? file env)
  (letrec ((inner (lambda (n indices)
		    (if (not (zero? n))
			(let ((el (apply array-ref o
					 (reverse (cons 0 indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env)))
		    (do ((i 1 (+ 1 i)))
			((= i n))
		      (display #\space file)
		      (let ((el (apply array-ref o
					 (reverse (cons i indices)))))
			  (if (and not-literal?
				   (literal? el env))
			      (display #\' file))
			  (write-component
			   el
			   `(array-set! ,o ,el ,@indices)
			   file
			   env))))))
    (display prefix file)
    (let loop ((dims (array-dimensions o))
	       (indices '()))
      (cond ((null? (cdr dims))
	     (inner (car dims) indices))
	    (else
	     (let ((n (car dims)))
	       (do ((i 0 (+ 1 i)))
		   ((= i n))
		 (if (> i 0)
		     (display #\space file))
		 (display prefix file)
		 (loop (cdr dims) (cons i indices))
		 (display #\) file))))))
    (display #\) file)))

(define-method (write-readably (o <array>) file env)
  (let ((root (shared-array-root o)))
    (cond ((literal? o env)
	   (if (not (vector? root))
	       (write o file)
	       (begin
		 (display #\# file)
		 (display (array-rank o) file)
		 (write-array #\( o #f file env))))
	  ((binding? root env)
	   (display "(make-shared-array " file)
	   (if (literal? root env)
	       (display #\' file))
	   (write-component root
			    (goops-error "write-readably(<array>): internal error")
			    file
			    env)
	   (display #\space file)
	   (display (make-mapper o) file)
	   (for-each (lambda (dim)
		       (display #\space file)
		       (display dim file))
		     (array-dimensions o))
	   (display #\) file))
	  (else
	   (display "(list->uniform-array " file)
	   (display (array-rank o) file)
	   (display " '() " file)
	   (write-array "(list " o #f file env)))))

;;;
;;; Pairs
;;;

;;; These methods have more complex structure than is required for
;;; most objects, since they take over some of the logic of
;;; `write-component'.
;;;

(define-method (enumerate! (o <pair>) env)
  (let ((literal? (enumerate-component! (car o) env)))
    (and (enumerate-component! (cdr o) env)
	 literal?)))

(define-method (write-readably (o <pair>) file env)
  (let ((proper? (let loop ((ls o))
		   (or (null? ls)
		       (and (pair? ls)
			    (not (binding? (cdr ls) env))
			    (loop (cdr ls))))))
	(1? (or (not (pair? (cdr o)))
		(binding? (cdr o) env)))
	(not-literal? (not (literal? o env)))
	(infos '())
	(refs (ref-stack env)))
    (display (cond ((not not-literal?) #\()
		   (proper? "(list ")
		   (1? "(cons ")
		   (else "(cons* "))
	     file)
    (if (and not-literal?
	     (literal? (car o) env))
	(display #\' file))
    (write-component (car o) `(set-car! ,o ,(car o)) file env)
    (do ((ls (cdr o) (cdr ls))
	 (prev o ls))
	((or (not (pair? ls))
	     (binding? ls env))
	 (if (not (null? ls))
	     (begin
	       (if (not not-literal?)
		   (display " ." file))
	       (display #\space file)
	       (if (and not-literal?
			(literal? ls env))
		   (display #\' file))
	       (write-component ls `(set-cdr! ,prev ,ls) file env)))
	 (display #\) file))
      (display #\space file)
      (set! infos (cons (object-info ls env) infos))
      (push-ref! ls env) ;*fixme* optimize
      (set! (visiting? (car infos)) #t)
      (if (and not-literal?
	       (literal? (car ls) env))
	  (display #\' file))
      (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
      )
    (for-each (lambda (info)
		(set! (visiting? info) #f))
	      infos)
    (set! (ref-stack env) refs)
    ))

;;;
;;; Objects
;;;

;;; Doesn't yet handle unbound slots

;; Don't export this function!  This is all very temporary.
;;
(define (get-set-for-each proc class)
  (for-each (lambda (slotdef g-n-s)
	      (let ((g-n-s (cddr g-n-s)))
		(cond ((integer? g-n-s)
		       (proc (standard-get g-n-s) (standard-set g-n-s)))
		      ((not (memq (slot-definition-allocation slotdef)
				  '(#:class #:each-subclass)))
		       (proc (car g-n-s) (cadr g-n-s))))))
	    (class-slots class)
	    (slot-ref class 'getters-n-setters)))

(define (access-for-each proc class)
  (for-each (lambda (slotdef g-n-s)
	      (let ((g-n-s (cddr g-n-s))
		    (a (slot-definition-accessor slotdef)))
		(cond ((integer? g-n-s)
		       (proc (slot-definition-name slotdef)
			     (and a (generic-function-name a))
			     (standard-get g-n-s)
			     (standard-set g-n-s)))
		      ((not (memq (slot-definition-allocation slotdef)
				  '(#:class #:each-subclass)))
		       (proc (slot-definition-name slotdef)
			     (and a (generic-function-name a))
			     (car g-n-s)
			     (cadr g-n-s))))))
	    (class-slots class)
	    (slot-ref class 'getters-n-setters)))

(define-macro (restore class slots . exps)
  "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
  `(let ((o ((@@ (oop goops) %allocate-instance) ,class '())))
     (for-each (lambda (name val)
                 (slot-set! o name val))
               ',slots
               (list ,@exps))
     o))

(define-method (enumerate! (o <object>) env)
  (get-set-for-each (lambda (get set)
		      (let ((val (get o)))
			(if (not (unbound? val))
			    (enumerate-component! val env))))
		    (class-of o))
  #f)

(define-method (write-readably (o <object>) file env)
  (let ((class (class-of o)))
    (display "(restore " file)
    (display (class-name class) file)
    (display " (" file)
    (let ((slotdefs
	   (filter (lambda (slotdef)
		     (not (or (memq (slot-definition-allocation slotdef)
				    '(#:class #:each-subclass))
			      (and (slot-bound? o (slot-definition-name slotdef))
				   (excluded?
				    (slot-ref o (slot-definition-name slotdef))
				    env)))))
		   (class-slots class))))
      (if (not (null? slotdefs))
	  (begin
	    (display (slot-definition-name (car slotdefs)) file)
	    (for-each (lambda (slotdef)
			(display #\space file)
			(display (slot-definition-name slotdef) file))
		      (cdr slotdefs)))))
    (display #\) file)
    (access-for-each (lambda (name aname get set)
		       (display #\space file)
		       (let ((val (get o)))
			 (cond ((unbound? val)
				(display '(make-unbound) file))
			       ((excluded? val env))
			       (else
				(if (literal? val env)
				    (display #\' file))
				(write-component val
						 (if aname
						     `(set! (,aname ,o) ,val)
						     `(slot-set! ,o ',name ,val))
						 file env)))))
		     class)
    (display #\) file)))

;;;
;;; Classes
;;;

;;; Currently, we don't support reading in class objects
;;;

(define-method (enumerate! (o <class>) env) #f)

(define-method (write-readably (o <class>) file env)
  (display (class-name o) file))

;;;
;;; Generics
;;;

;;; Currently, we don't support reading in generic functions
;;;

(define-method (enumerate! (o <generic>) env) #f)

(define-method (write-readably (o <generic>) file env)
  (display (generic-function-name o) file))

;;;
;;; Method
;;;

;;; Currently, we don't support reading in methods
;;;

(define-method (enumerate! (o <method>) env) #f)

(define-method (write-readably (o <method>) file env)
  (goops-error "No read-syntax for <method> defined"))

;;;
;;; Environments
;;;

(define-class <environment> ()
  (object-info 	  #:accessor object-info
	       	  #:init-form (make-hash-table 61))
  (excluded	  #:accessor excluded
		  #:init-form (make-hash-table 61))
  (pass-2?	  #:accessor pass-2?
		  #:init-value #f)
  (ref-stack	  #:accessor ref-stack
		  #:init-value '())
  (objects	  #:accessor objects
		  #:init-value '())
  (pre-defines	  #:accessor pre-defines
		  #:init-value '())
  (locals	  #:accessor locals
		  #:init-value '())
  (stand-ins	  #:accessor stand-ins
		  #:init-value '())
  (post-defines	  #:accessor post-defines
		  #:init-value '())
  (patchers	  #:accessor patchers
		  #:init-value '())
  (multiple-bound #:accessor multiple-bound
		  #:init-value '())
  )

(define-method (initialize (env <environment>) initargs)
  (next-method)
  (cond ((get-keyword #:excluded initargs #f)
	 => (lambda (excludees)
	      (for-each (lambda (e)
			  (hashq-create-handle! (excluded env) e #f))
			excludees)))))

(define-method (object-info o env)
  (hashq-ref (object-info env) o))

(define-method ((setter object-info) o env x)
  (hashq-set! (object-info env) o x))

(define (excluded? o env)
  (hashq-get-handle (excluded env) o))

(define (add-patcher! patcher env)
  (set! (patchers env) (cons patcher (patchers env))))

(define (push-ref! o env)
  (set! (ref-stack env) (cons o (ref-stack env))))

(define (pop-ref! env)
  (set! (ref-stack env) (cdr (ref-stack env))))

(define (container env)
  (car (ref-stack env)))

(define-class <object-info> ()
  (visiting  #:accessor visiting
	     #:init-value #f)
  (binding   #:accessor binding
	     #:init-value #f)
  (literal?  #:accessor literal?
	     #:init-value #f)
  )

(define visiting? visiting)

(define-method (binding (info <boolean>))
  #f)

(define-method (binding o env)
  (binding (object-info o env)))

(define binding? binding)

(define-method (literal? (info <boolean>))
  #t)

;;; Note that this method is intended to be used only during the
;;; writing pass
;;;
(define-method (literal? o env)
  (or (immediate? o)
      (excluded? o env)
      (let ((info (object-info o env)))
	;; write-component sets all bindings first to #:defining,
	;; then to #:defined
	(and (or (not (binding? info))
		 ;; we might be using `literal?' in a write-readably method
		 ;; to query about the object being defined
		 (and (eq? (visiting info) #:defining)
		      (null? (cdr (ref-stack env)))))
	     (literal? info)))))

;;;
;;; Enumeration
;;;

;;; Enumeration has two passes.
;;;
;;; Pass 1: Detect common substructure, circular references and order
;;;
;;; Pass 2: Detect literals

(define (enumerate-component! o env)
  (cond ((immediate? o) #t)
	((readable? o) #f)
	((excluded? o env) #t)
	((pass-2? env)
	 (let ((info (object-info o env)))
	   (if (binding? info)
	       ;; if circular reference, we print as a literal
	       ;; (note that during pass-2, circular references are
	       ;;  forward references, i.e. *not* yet marked with #:pass-2
	       (not (eq? (visiting? info) #:pass-2))
	       (and (enumerate! o env)
		    (begin
		      (set! (literal? info) #t)
		      #t)))))
	((object-info o env)
	 => (lambda (info)
	      (set! (binding info) #t)
	      (if (visiting? info)
		  ;; circular reference--mark container
		  (set! (binding (object-info (container env) env)) #t))))
	(else
	 (let ((info (make <object-info>)))
	   (set! (object-info o env) info)
	   (push-ref! o env)
	   (set! (visiting? info) #t)
	   (enumerate! o env)
	   (set! (visiting? info) #f)
	   (pop-ref! env)
	   (set! (objects env) (cons o (objects env)))))))

(define (write-component-procedure o file env)
  "Return #f if circular reference"
  (cond ((immediate? o) (write o file) #t)
	((readable? o) (write (readable-expression o) file) #t)
	((excluded? o env) (display #f file) #t)
	(else
	 (let ((info (object-info o env)))
	   (cond ((not (binding? info)) (write-readably o file env) #t)
		 ((not (eq? (visiting info) #:defined)) #f) ;forward reference
		 (else (display (binding info) file) #t))))))

;;; write-component OBJECT PATCHER FILE ENV
;;;
(define-macro (write-component object patcher file env)
  `(or (write-component-procedure ,object ,file ,env)
       (begin
         (display #f ,file)
         (add-patcher! ,patcher ,env))))

;;;
;;; Main engine
;;;

(define binding-name car)
(define binding-object cdr)

(define (pass-1! alist env)
  ;; Determine object order and necessary bindings
  (for-each (lambda (binding)
	      (enumerate-component! (binding-object binding) env))
	    alist))

(define (make-local i)
  (string->symbol (string-append "%o" (number->string i))))

(define (name-bindings! alist env)
  ;; Name top-level bindings
  (for-each (lambda (b)
	      (let ((o (binding-object b)))
		(if (not (or (immediate? o)
			     (readable? o)
			     (excluded? o env)))
		    (let ((info (object-info o env)))
		      (if (symbol? (binding info))
			  ;; already bound to a variable
			  (set! (multiple-bound env)
				(acons (binding info)
				       (binding-name b)
				       (multiple-bound env)))
			  (set! (binding info)
				(binding-name b)))))))
	    alist)
  ;; Name rest of bindings and create stand-in and definition lists
  (let post-loop ((ls (objects env))
		  (post-defs '()))
    (cond ((or (null? ls)
	       (eq? (binding (car ls) env) #t))
	   (set! (post-defines env) post-defs)
	   (set! (objects env) ls))
	  ((not (binding (car ls) env))
	   (post-loop (cdr ls) post-defs))
	  (else
	   (post-loop (cdr ls) (cons (car ls) post-defs)))))
  (let pre-loop ((ls (reverse (objects env)))
		 (i 0)
		 (pre-defs '())
		 (locs '())
		 (sins '()))
    (if (null? ls)
	(begin
	  (set! (pre-defines env) (reverse pre-defs))
	  (set! (locals env) (reverse locs))
	  (set! (stand-ins env) (reverse sins)))
	(let ((info (object-info (car ls) env)))
	  (cond ((not (binding? info))
		 (pre-loop (cdr ls) i pre-defs locs sins))
		((boolean? (binding info))
		 ;; local
		 (set! (binding info) (make-local i))
		 (pre-loop (cdr ls)
			   (+ 1 i)
			   pre-defs
			   (cons (car ls) locs)
			   sins))
		((null? locs)
		 (pre-loop (cdr ls)
			   i
			   (cons (car ls) pre-defs)
			   locs
			   sins))
		(else
		 (let ((real-name (binding info)))
		   (set! (binding info) (make-local i))
		   (pre-loop (cdr ls)
			     (+ 1 i)
			     pre-defs
			     (cons (car ls) locs)
			     (acons (binding info) real-name sins)))))))))

(define (pass-2! env)
  (set! (pass-2? env) #t)
  (for-each (lambda (o)
	      (let ((info (object-info o env)))
		(set! (literal? info) (enumerate! o env))
		(set! (visiting info) #:pass-2)))
	    (append (pre-defines env)
		    (locals env)
		    (post-defines env))))

(define (write-define! name val literal? file)
  (display "(define " file)
  (display name file)
  (display #\space file)
  (if literal? (display #\' file))
  (write val file)
  (display ")\n" file))

(define (write-empty-defines! file env)
  (for-each (lambda (stand-in)
	      (write-define! (cdr stand-in) #f #f file))
	    (stand-ins env))
  (for-each (lambda (o)
	      (write-define! (binding o env) #f #f file))
	    (post-defines env)))

(define (write-definition! prefix o file env)
  (display prefix file)
  (let ((info (object-info o env)))
    (display (binding info) file)
    (display #\space file)
    (if (literal? info)
	(display #\' file))
    (push-ref! o env)
    (set! (visiting info) #:defining)
    (write-readably o file env)
    (set! (visiting info) #:defined)
    (pop-ref! env)
    (display #\) file)))

(define (write-let*-head! file env)
  (display "(let* (" file)
  (write-definition! "(" (car (locals env)) file env)
  (for-each (lambda (o)
	      (write-definition! "\n       (" o file env))
	    (cdr (locals env)))
  (display ")\n" file))

(define (write-rebindings! prefix bindings file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (cdr patch) file)
	      (display #\space file)
	      (display (car patch) file)
	      (display ")\n" file))
	    bindings))

(define (write-definitions! selector prefix file env)
  (for-each (lambda (o)
	      (write-definition! prefix o file env)
	      (newline file))
	    (selector env)))

(define (write-patches! prefix file env)
  (for-each (lambda (patch)
	      (display prefix file)
	      (display (let name-objects ((patcher patch))
			 (cond ((binding patcher env)
				=> (lambda (name)
				     (cond ((assq name (stand-ins env))
					    => cdr)
					   (else name))))
			       ((pair? patcher)
				(cons (name-objects (car patcher))
				      (name-objects (cdr patcher))))
			       (else patcher)))
		       file)
	      (newline file))
	    (reverse (patchers env))))

(define (write-immediates! alist file)
  (for-each (lambda (b)
	      (if (immediate? (binding-object b))
		  (write-define! (binding-name b)
				 (binding-object b)
				 #t
				 file)))
	    alist))

(define (write-readables! alist file env)
  (let ((written '()))
    (for-each (lambda (b)
		(cond ((not (readable? (binding-object b))))
		      ((assq (binding-object b) written)
		       => (lambda (p)
			    (set! (multiple-bound env)
				  (acons (cdr p)
					 (binding-name b)
					 (multiple-bound env)))))
		      (else
		       (write-define! (binding-name b)
				      (readable-expression (binding-object b))
				      #f
				      file)
		       (set! written (acons (binding-object b)
					    (binding-name b)
					    written)))))
	      alist)))

(define-method (save-objects (alist <pair>) (file <string>) . rest)
  (let ((port (open-output-file file)))
    (apply save-objects alist port rest)
    (close-port port)
    *unspecified*))

(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
  (let ((excluded (if (>= (length rest) 1) (car rest) '()))
	(uses     (if (>= (length rest) 2) (cadr rest) '())))
    (let ((env (make <environment> #:excluded excluded)))
      (pass-1! alist env)
      (name-bindings! alist env)
      (pass-2! env)
      (if (not (null? uses))
	  (begin
	    (write `(use-modules ,@uses) file)
	    (newline file)))
      (write-immediates! alist file)
      (if (null? (locals env))
	  (begin
	    (write-definitions! post-defines "(define " file env)
	    (write-patches! "" file env))
	  (begin
	    (write-definitions! pre-defines "(define " file env)
	    (write-empty-defines! file env)
	    (write-let*-head! file env)
	    (write-rebindings! "  (set! " (stand-ins env) file env)
	    (write-definitions! post-defines "  (set! " file env)
	    (write-patches! "  " file env)
	    (display "  )\n" file)))
      (write-readables! alist file env)
      (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))

(define-method (load-objects (file <string>))
  (let* ((port (open-input-file file))
	 (objects (load-objects port)))
    (close-port port)
    objects))

(define iface (module-public-interface (current-module)))

(define-method (load-objects (file <input-port>))
  (let ((m (make-module)))
    (module-use! m the-scm-module)
    (module-use! m iface)
    (save-module-excursion
     (lambda ()
       (set-current-module m)
       (let loop ((sexp (read file)))
	 (if (not (eof-object? sexp))
	     (begin
	       (eval sexp m)
	       (loop (read file)))))))
    (module-map (lambda (name var)
		  (cons name (variable-ref var)))
		m)))


code:
;;; installed-scm-file

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

(define-module (oop goops simple)
  :use-module (oop goops accessors)
  :export (define-class)
  :no-backtrace)

(define-syntax define-class
  (syntax-rules ()
    ((_ arg ...)
     (define-class-with-accessors-keywords arg ...))))

(module-use! (module-public-interface (current-module))
             (resolve-interface '(oop goops)))

license: mit


code:
;;;; Copyright (C) 1999,2002, 2006, 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
;;;;

(define-module (oop goops stklos)
  :use-module (oop goops internal)
  :no-backtrace
  )

;;;
;;; This is the stklos compatibility module.
;;;
;;; WARNING: This module is under construction.  While we expect to be able
;;; to run most stklos code without problems in the future, this is not the
;;; case now.  The current compatibility is only superficial.
;;;
;;; Any comments/complaints/patches are welcome.  Tell us about
;;; your incompatibility problems (bug-guile@gnu.org).
;;;

;; Export all bindings that are exported from (oop goops)...
(module-for-each (lambda (sym var)
		   (module-add! (module-public-interface (current-module))
                                sym var))
		 (resolve-interface '(oop goops)))

;; ...but replace the following bindings:
(export define-class define-method)

;; Also export the following
(export write-object)

;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)

(define-syntax define-class
  (syntax-rules ()
    ((_ name supers (slot ...) rest ...)
     (standard-define-class name supers slot ... rest ...))))

(define (toplevel-define! name val)
  (module-define! (current-module) name val))

(define-syntax define-method
  (syntax-rules (setter)
    ((_ (setter name) rest ...)
     (begin
       (if (or (not (defined? 'name))
               (not (is-a? name <generic-with-setter>)))
           (toplevel-define! 'name
                             (ensure-accessor
                              (if (defined? 'name) name #f) 'name)))
       (add-method! (setter name) (method rest ...))))
    ((_ name rest ...)
     (begin
       (if (or (not (defined? 'name))
               (not (or (is-a? name <generic>)
                        (is-a? name <primitive-generic>))))
           (toplevel-define! 'name
                             (ensure-generic
                              (if (defined? 'name) name #f) 'name)))
       (add-method! name (method rest ...))))))


code:
;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 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
;;;;

(define-module (oop goops util)
  :export (mapappend find-duplicate top-level-env top-level-env?
	   map* for-each* length* improper->proper)
  :use-module (srfi srfi-1)
  :re-export  (any every)
  :no-backtrace
  )

;;;
;;; {Utilities}
;;;

(define mapappend append-map)

(define (find-duplicate l)	; find a duplicate in a list; #f otherwise
  (cond
    ((null? l)			#f)
    ((memv (car l) (cdr l))	(car l))
    (else 			(find-duplicate (cdr l)))))

(define (top-level-env)
  (let ((mod (current-module)))
    (if mod
	(module-eval-closure mod)
	'())))

(define (top-level-env? env)
  (or (null? env)
      (procedure? (car env))))

(define (map* fn . l) 		; A map which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))

(define (length* ls)
  (do ((n 0 (+ 1 n))
       (ls ls (cdr ls)))
      ((not (pair? ls)) n)))

(define (improper->proper ls)
  (if (pair? ls)
      (cons (car ls) (improper->proper (cdr ls)))
      (list ls)))


code:
;;; rnrs.scm --- The R6RS composite 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 (6))
  (export ;; (rnrs arithmetic bitwise)

          bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if
	  bitwise-bit-count bitwise-length bitwise-first-bit-set
	  bitwise-bit-set? bitwise-copy-bit bitwise-bit-field
	  bitwise-copy-bit-field bitwise-arithmetic-shift
	  bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
	  bitwise-rotate-bit-field bitwise-reverse-bit-field

	  ;; (rnrs arithmetic fixnums)

	  fixnum? fixnum-width least-fixnum greatest-fixnum fx=? fx>? fx<? fx>=?
	  fx<=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+
	  fx* fx- fxdiv-and-mod fxdiv fxmod fxdiv0-and-mod0 fxdiv0 fxmod0
	  fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxif fxbit-count
	  fxlength fxfirst-bit-set fxbit-set? fxcopy-bit fxbit-field
	  fxcopy-bit-field fxarithmetic-shift fxarithmetic-shift-left
	  fxarithmetic-shift-right fxrotate-bit-field fxreverse-bit-field

	  ;; (rnrs arithmetic flonums)

	  flonum? real->flonum fl=? fl<? fl<=? fl>? fl>=? flinteger? flzero?
	  flpositive? flnegative? flodd? fleven? flfinite? flinfinite? flnan?
	  flmax flmin fl+ fl* fl- fl/ flabs fldiv-and-mod fldiv flmod
	  fldiv0-and-mod0 fldiv0 flmod0 flnumerator fldenominator flfloor
	  flceiling fltruncate flround flexp fllog flsin flcos fltan flacos
	  flasin flatan flsqrt flexpt &no-infinities
	  make-no-infinities-violation no-infinities-violation? &no-nans
	  make-no-nans-violation no-nans-violation? fixnum->flonum

	  ;; (rnrs base)

	  boolean? symbol? char? vector? null? pair? number? string? procedure?
	  define define-syntax syntax-rules lambda let let* let-values
	  let*-values letrec letrec* begin quote lambda if set! cond case or and not
	  eqv? equal? eq? + - * / max min abs numerator denominator gcd lcm
	  floor ceiling truncate round rationalize real-part imag-part
	  make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
	  make-polar magnitude angle complex? real? rational? integer? exact?
	  inexact? real-valued? rational-valued? integer-values? zero?
	  positive? negative? odd? even? nan? finite? infinite? exact inexact =
	  < > <= >= number->string string->number cons car cdr caar cadr cdar
	  cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr
	  caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar cadddr
	  cdaddr cddadr cdddar cddddr list? list length append reverse
	  list-tail list-ref map for-each symbol->string string->symbol symbol=?
	  char->integer integer->char char=? char<? char>? char<=? char>=?
	  make-string string string-length string-ref string=? string<? string>?
	  string<=? string>=? substring string-append string->list list->string
	  string-for-each string-copy vector? make-vector vector vector-length
	  vector-ref vector-set! vector->list list->vector vector-fill!
	  vector-map vector-for-each error assertion-violation assert
	  call-with-current-continuation call/cc call-with-values dynamic-wind
	  values apply quasiquote unquote unquote-splicing let-syntax
	  letrec-syntax syntax-rules identifier-syntax

	  ;; (rnrs bytevectors)

	  endianness native-endianness bytevector? make-bytevector
	  bytevector-length bytevector=? bytevector-fill! bytevector-copy!
	  bytevector-copy uniform-array->bytevector bytevector-u8-ref
	  bytevector-s8-ref bytevector-u8-set! bytevector-s8-set!
	  bytevector->u8-list u8-list->bytevector bytevector-uint-ref
	  bytevector-uint-set! bytevector-sint-ref bytevector-sint-set!
	  bytevector->sint-list bytevector->uint-list uint-list->bytevector
	  sint-list->bytevector bytevector-u16-ref bytevector-s16-ref
	  bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-ref
	  bytevector-s16-native-ref bytevector-u16-native-set!
	  bytevector-s16-native-set! bytevector-u32-ref bytevector-s32-ref
	  bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-ref
	  bytevector-s32-native-ref bytevector-u32-native-set!
	  bytevector-s32-native-set! bytevector-u64-ref bytevector-s64-ref
	  bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-ref
	  bytevector-s64-native-ref bytevector-u64-native-set!
	  bytevector-s64-native-set! bytevector-ieee-single-ref
	  bytevector-ieee-single-set! bytevector-ieee-single-native-ref
	  bytevector-ieee-single-native-set! bytevector-ieee-double-ref
	  bytevector-ieee-double-set! bytevector-ieee-double-native-ref
	  bytevector-ieee-double-native-set! string->utf8 string->utf16
	  string->utf32 utf8->string utf16->string utf32->string

	  ;; (rnrs conditions)

	  &condition condition simple-conditions condition? condition-predicate
	  condition-accessor define-condition-type &message
	  make-message-condition message-condition? condition-message &warning
	  make-warning warning? &serious make-serious-condition
	  serious-condition? &error make-error error? &violation make-violation
	  violation? &assertion make-assertion-violation assertion-violation?
	  &irritants make-irritants-condition irritants-condition?
	  condition-irritants &who make-who-condition who-condition?
	  condition-who &non-continuable make-non-continuable-violation
	  non-continuable-violation? &implementation-restriction
	  make-implementation-restriction-violation
	  implementation-restriction-violation? &lexical make-lexical-violation
	  lexical-violation? &syntax make-syntax-violation syntax-violation?
	  syntax-violation-form syntax-violation-subform &undefined
	  make-undefined-violation undefined-violation?

	  ;; (rnrs control)

	  when unless do case-lambda

	  ;; (rnrs enums)

	  make-enumeration enum-set-universe enum-set-indexer
	  enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
	  enum-set=? enum-set-union enum-set-intersection enum-set-difference
	  enum-set-complement enum-set-projection define-enumeration

	  ;; (rnrs exceptions)

	  guard with-exception-handler raise raise-continuable

	  ;; (rnrs files)

	  file-exists? delete-file &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

	  ;; (rnrs hashtables)

	  make-eq-hashtable make-eqv-hashtable make-hashtable hashtable?
	  hashtable-size hashtable-ref hashtable-set! hashtable-delete!
	  hashtable-contains? hashtable-update! hashtable-copy hashtable-clear!
	  hashtable-keys hashtable-entries hashtable-equivalence-function
	  hashtable-hash-function hashtable-mutable? equal-hash string-hash
	  string-ci-hash symbol-hash

	  ;; (rnrs io ports)

	  eof-object? port? input-port? output-port? eof-object port-transcoder
	  binary-port? transcoded-port port-position set-port-position!
	  port-has-port-position? port-has-set-port-position!? call-with-port
	  open-bytevector-input-port make-custom-binary-input-port get-u8
	  lookahead-u8 get-bytevector-n get-bytevector-n! get-bytevector-some
	  get-bytevector-all open-bytevector-output-port
	  make-custom-binary-output-port put-u8 put-bytevector
          open-string-input-port open-string-output-port

	  ;; (rnrs io simple)

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

	  find for-all exists filter partition fold-left fold-right remp remove
	  remv remq memp member memv memq assp assoc assv assq cons*

	  ;; (rnrs programs)

	  command-line exit

	  ;; (rnrs records inspection)

	  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?

	  ;; (rnrs records procedural)

	  make-record-type-descriptor record-type-descriptor?
	  make-record-constructor-descriptor record-constructor record-predicate
	  record-accessor record-mutator

	  ;; (rnrs records syntactic)

	  define-record-type record-type-descriptor
	  record-constructor-descriptor

	  ;; (rnrs sorting)

	  list-sort vector-sort vector-sort!

	  ;; (rnrs syntax-case)

	  make-variable-transformer syntax syntax-case identifier?
	  bound-identifier=? free-identifier=? syntax->datum datum->syntax
	  generate-temporaries with-syntax quasisyntax unsyntax
	  unsyntax-splicing syntax-violation

	  ;; (rnrs unicode)

	  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 (rnrs arithmetic bitwise (6))
	  (rnrs arithmetic fixnums (6))
	  (rnrs arithmetic flonums (6))
	  (rnrs base (6))

	  (rnrs bytevectors (6))

	  (rnrs conditions (6))
	  (rnrs control (6))
	  (rnrs enums (6))
	  (rnrs exceptions (6))

          ;; These i/o conditions are exported by (io simple), (files), and
          ;; should be exported by (ports) but are not yet. Avoid duplicate
          ;; bindings warnings, then, by excluding these bindings from all but
          ;; (io simple).
	  (except (rnrs files (6))
                  &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)

	  (rnrs hashtables (6))

	  (rnrs io ports (6))

	  (rnrs io simple (6))
	  (rnrs lists (6))
	  (rnrs programs (6))
	  (rnrs records inspection (6))
	  (rnrs records procedural (6))
	  (rnrs records syntactic (6))
	  (rnrs sorting (6))
	  (rnrs syntax-case (6))
	  (rnrs unicode (6))))


code:
;;; bitwise.scm --- The R6RS bitwise arithmetic operations 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 arithmetic bitwise (6))
  (export bitwise-not

	  bitwise-and
	  bitwise-ior
	  bitwise-xor

	  bitwise-if
	  bitwise-bit-count
	  bitwise-length

	  bitwise-first-bit-set
	  bitwise-bit-set?
	  bitwise-copy-bit
	  bitwise-bit-field
	  bitwise-copy-bit-field

	  bitwise-arithmetic-shift
	  bitwise-arithmetic-shift-left
	  bitwise-arithmetic-shift-right
	  bitwise-rotate-bit-field
	  bitwise-reverse-bit-field)
  (import (rnrs base (6))
	  (rnrs control (6))
	  (rename (only (guile) lognot
			        logand
				logior
				logxor
				logcount
				logbit?
				modulo
				ash)
		  (lognot bitwise-not)
		  (logand bitwise-and)
		  (logior bitwise-ior)
		  (logxor bitwise-xor)
		  (logcount bitwise-bit-count)
		  (ash bitwise-arithmetic-shift)))

  (define (bitwise-if ei1 ei2 ei3)
    (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))

  (define (bitwise-length ei)
    (do ((result 0 (+ result 1))
	 (bits (if (negative? ei) (bitwise-not ei) ei)
	       (bitwise-arithmetic-shift bits -1)))
	((zero? bits)
	 result)))

  (define (bitwise-first-bit-set ei)
    (define (bitwise-first-bit-set-inner bits count)
      (cond ((zero? bits) -1)
	    ((logbit? 0 bits) count)
	    (else (bitwise-first-bit-set-inner
		   (bitwise-arithmetic-shift bits -1) (+ count 1)))))
    (bitwise-first-bit-set-inner ei 0))

  (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))

  (define (bitwise-copy-bit ei1 ei2 ei3)
    (bitwise-if (bitwise-arithmetic-shift-left 1 ei2)
		(bitwise-arithmetic-shift-left ei3 ei2)
		ei1))

  (define (bitwise-bit-field ei1 ei2 ei3)
    (bitwise-arithmetic-shift-right
     (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3)))
     ei2))

  (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
    (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2)
			     (bitwise-not
			      (bitwise-arithmetic-shift-left -1 ei3)))
		(bitwise-arithmetic-shift-left ei4 ei2)
		ei1))

  (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
  (define (bitwise-arithmetic-shift-right ei1 ei2)
    (bitwise-arithmetic-shift ei1 (- ei2)))

  (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
    (let ((width (- ei3 ei2)))
      (if (positive? width)
	  (let ((field (bitwise-bit-field ei1 ei2 ei3))
		(count (modulo ei4 width)))
	    (bitwise-copy-bit-field
	     ei1 ei2 ei3
	     (bitwise-ior (bitwise-arithmetic-shift-left field count)
			  (bitwise-arithmetic-shift-right
			   field (- width count)))))
	  ei1)))

  (define (bitwise-reverse-bit-field ei1 ei2 ei3)
    (define (reverse-bit-field-recursive n1 n2 len)
      (if (> len 0)
	  (reverse-bit-field-recursive
	   (bitwise-arithmetic-shift-right n1 1)
	   (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1)
	   (- len 1))
	  n2))
    (let ((width (- ei3 ei2)))
      (if (positive? width)
	  (let ((field (bitwise-bit-field ei1 ei2 ei3)))
	    (bitwise-copy-bit-field
	     ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width)))
	  ei1))))


code:
;;; fixnums.scm --- The R6RS fixnums arithmetic 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 arithmetic fixnums (6))
  (export fixnum?

	  fixnum-width
	  least-fixnum
	  greatest-fixnum

	  fx=?
	  fx>?
	  fx<?
	  fx>=?
	  fx<=?

	  fxzero?
	  fxpositive?
	  fxnegative?
	  fxodd?
	  fxeven?

	  fxmax
	  fxmin

	  fx+
	  fx*
	  fx-

	  fxdiv-and-mod
	  fxdiv
	  fxmod
	  fxdiv0-and-mod0
	  fxdiv0
	  fxmod0

	  fx+/carry
	  fx-/carry
	  fx*/carry

	  fxnot
	  fxand
	  fxior
	  fxxor
	  fxif

	  fxbit-count
	  fxlength
	  fxfirst-bit-set
	  fxbit-set?
	  fxcopy-bit
	  fxbit-field
	  fxcopy-bit-field

	  fxarithmetic-shift
	  fxarithmetic-shift-left
	  fxarithmetic-shift-right

	  fxrotate-bit-field
	  fxreverse-bit-field)
  (import (only (guile) ash
		        cons*
			inexact->exact
			logand
			logbit?
			logcount
			logior
			lognot
			logxor
			most-positive-fixnum
			most-negative-fixnum)
	  (ice-9 optargs)
	  (rnrs base (6))
	  (rnrs arithmetic bitwise (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
	  (rnrs lists (6)))

  (define fixnum-width
    (let ((w (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))
      (lambda () w)))

  (define (greatest-fixnum) most-positive-fixnum)
  (define (least-fixnum) most-negative-fixnum)

  (define (fixnum? obj)
    (and (integer? obj)
	 (exact? obj)
	 (>= obj most-negative-fixnum)
	 (<= obj most-positive-fixnum)))

  (define (assert-fixnum . args)
    (or (for-all fixnum? args) (raise (make-assertion-violation))))

  (define (fx=? fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum args)
      (apply = args)))

  (define (fx>? fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum args)
      (apply > args)))

  (define (fx<? fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum rst)
      (apply < args)))

  (define (fx>=? fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum rst)
      (apply >= args)))

  (define (fx<=? fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum rst)
      (apply <= args)))

  (define (fxzero? fx) (assert-fixnum fx) (zero? fx))
  (define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
  (define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
  (define (fxodd? fx) (assert-fixnum fx) (odd? fx))
  (define (fxeven? fx) (assert-fixnum fx) (even? fx))

  (define (fxmax fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum args)
      (apply max args)))

  (define (fxmin fx1 fx2 . rst)
    (let ((args (cons* fx1 fx2 rst)))
      (apply assert-fixnum args)
      (apply min args)))

  (define (fx+ fx1 fx2)
    (assert-fixnum fx1 fx2)
    (let ((r (+ fx1 fx2)))
      (or (fixnum? r) (raise (make-implementation-restriction-violation)))
      r))

  (define (fx* fx1 fx2)
    (assert-fixnum fx1 fx2)
    (let ((r (* fx1 fx2)))
      (or (fixnum? r) (raise (make-implementation-restriction-violation)))
      r))

  (define* (fx- fx1 #:optional fx2)
    (assert-fixnum fx1)
    (if fx2
	(begin
	  (assert-fixnum fx2)
	  (let ((r (- fx1 fx2)))
	    (or (fixnum? r) (raise (make-assertion-violation)))
	    r))
	(let ((r (- fx1)))
	  (or (fixnum? r) (raise (make-assertion-violation)))
	  r)))

  (define (fxdiv fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (let ((r (div fx1 fx2))) r))

  (define (fxmod fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (let ((r (mod fx1 fx2))) r))

  (define (fxdiv-and-mod fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (div-and-mod fx1 fx2))

  (define (fxdiv0 fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (let ((r (div0 fx1 fx2))) r))

  (define (fxmod0 fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (let ((r (mod0 fx1 fx2))) r))

  (define (fxdiv0-and-mod0 fx1 fx2)
    (assert-fixnum fx1 fx2)
    (if (zero? fx2) (raise (make-assertion-violation)))
    (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
      (lambda (q r) (values q r))))

  (define (fx+/carry fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (let* ((s (+ fx1 fx2 fx3))
	   (s0 (mod0 s (inexact->exact (expt 2 (fixnum-width)))))
	   (s1 (div0 s (inexact->exact (expt 2 (fixnum-width))))))
      (values s0 s1)))

  (define (fx-/carry fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (let* ((d (- fx1 fx2 fx3))
	   (d0 (mod0 d (expt 2 (fixnum-width))))
	   (d1 (div0 d (expt 2 (fixnum-width)))))
      (values d0 d1)))

  (define (fx*/carry fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (let* ((s (+ (* fx1 fx2) fx3))
	   (s0 (mod0 s (expt 2 (fixnum-width))))
	   (s1 (div0 s (expt 2 (fixnum-width)))))
      (values s0 s1)))

  (define (fxnot fx) (assert-fixnum fx) (lognot fx))
  (define (fxand . args) (apply assert-fixnum args) (apply logand args))
  (define (fxior . args) (apply assert-fixnum args) (apply logior args))
  (define (fxxor . args) (apply assert-fixnum args) (apply logxor args))

  (define (fxif fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (bitwise-if fx1 fx2 fx3))

  (define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
  (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
  (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
  (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))

  (define (fxcopy-bit fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (bitwise-copy-bit fx1 fx2 fx3))

  (define (fxbit-field fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (bitwise-bit-field fx1 fx2 fx3))

  (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
    (assert-fixnum fx1 fx2 fx3 fx4)
    (bitwise-copy-bit-field fx1 fx2 fx3 fx4))

  (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
  (define fxarithmetic-shift-left fxarithmetic-shift)

  (define (fxarithmetic-shift-right fx1 fx2)
    (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))

  (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
    (assert-fixnum fx1 fx2 fx3 fx4)
    (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))

  (define (fxreverse-bit-field fx1 fx2 fx3)
    (assert-fixnum fx1 fx2 fx3)
    (bitwise-reverse-bit-field fx1 fx2 fx3))

)


code:
;;; flonums.scm --- The R6RS flonums arithmetic 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 arithmetic flonums (6))
  (export flonum?
	  real->flonum

	  fl=? fl<? fl<=? fl>? fl>=?

	  flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
	  flinfinite? flnan?

	  flmax flmin

	  fl+ fl* fl- fl/

	  flabs

	  fldiv-and-mod
	  fldiv
	  flmod
	  fldiv0-and-mod0
	  fldiv0
	  flmod0

	  flnumerator
	  fldenominator

	  flfloor flceiling fltruncate flround

	  flexp fllog flsin flcos fltan flacos flasin flatan

	  flsqrt flexpt

	  &no-infinities
	  make-no-infinities-violation
	  no-infinities-violation?

	  &no-nans
	  make-no-nans-violation
	  no-nans-violation?

	  fixnum->flonum)
  (import (ice-9 optargs)
	  (only (guile) inf?)
	  (rnrs arithmetic fixnums (6))
	  (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
	  (rnrs lists (6))
	  (rnrs r5rs (6)))

  (define (flonum? obj) (and (number? obj) (inexact? obj)))
  (define (assert-flonum . args)
    (or (for-all flonum? args) (raise (make-assertion-violation))))
  (define (assert-iflonum . args)
    (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
	(raise (make-assertion-violation))))

  (define (real->flonum x)
    (or (real? x) (raise (make-assertion-violation)))
    (exact->inexact x))

  (define (fl=? . args) (apply assert-flonum args) (apply = args))
  (define (fl<? . args) (apply assert-flonum args) (apply < args))
  (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
  (define (fl>? . args) (apply assert-flonum args) (apply > args))
  (define (fl>=? . args) (apply assert-flonum args) (apply >= args))

  (define (flinteger? fl) (assert-flonum fl) (integer? fl))
  (define (flzero? fl) (assert-flonum fl) (zero? fl))
  (define (flpositive? fl) (assert-flonum fl) (positive? fl))
  (define (flnegative? fl) (assert-flonum fl) (negative? fl))
  (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
  (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
  (define (flfinite? fl) (assert-flonum fl) (not (inf? fl)))
  (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
  (define (flnan? fl) (assert-flonum fl) (nan? fl))

  (define (flmax fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply max flargs)))

  (define (flmin fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply min flargs)))

  (define (fl+ fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply + flargs)))

  (define (fl* fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply * flargs)))

  (define (fl- fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply - flargs)))

  (define (fl/ fl1 . args)
    (let ((flargs (cons fl1 args)))
      (apply assert-flonum flargs)
      (apply / flargs)))

  (define (flabs fl) (assert-flonum fl) (abs fl))

  (define (fldiv-and-mod fl1 fl2)
    (assert-iflonum fl1 fl2)
    (if (zero? fl2) (raise (make-assertion-violation)))
    (let ((fx1 (inexact->exact fl1))
	  (fx2 (inexact->exact fl2)))
      (call-with-values (lambda () (div-and-mod fx1 fx2))
	(lambda (div mod) (values (exact->inexact div)
				  (exact->inexact mod))))))

  (define (fldiv fl1 fl2)
    (assert-iflonum fl1 fl2)
    (if (zero? fl2) (raise (make-assertion-violation)))
    (let ((fx1 (inexact->exact fl1))
	  (fx2 (inexact->exact fl2)))
      (exact->inexact (quotient fx1 fx2))))

  (define (flmod fl1 fl2)
    (assert-iflonum fl1 fl2)
    (if (zero? fl2) (raise (make-assertion-violation)))
    (let ((fx1 (inexact->exact fl1))
	  (fx2 (inexact->exact fl2)))
      (exact->inexact (modulo fx1 fx2))))

  (define (fldiv0-and-mod0 fl1 fl2)
    (assert-iflonum fl1 fl2)
    (if (zero? fl2) (raise (make-assertion-violation)))
    (let* ((fx1 (inexact->exact fl1))
	   (fx2 (inexact->exact fl2)))
      (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
	(lambda (q r) (values (real->flonum q) (real->flonum r))))))

  (define (fldiv0 fl1 fl2)
    (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q)))

  (define (flmod0 fl1 fl2)
    (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r)))

  (define (flnumerator fl)
    (assert-flonum fl)
    (case fl
      ((+inf.0) +inf.0)
      ((-inf.0) -inf.0)
      (else (numerator fl))))

  (define (fldenominator fl)
    (assert-flonum fl)
    (case fl
      ((+inf.0) 1.0)
      ((-inf.0) 1.0)
      (else (denominator fl))))

  (define (flfloor fl) (assert-flonum fl) (floor fl))
  (define (flceiling fl) (assert-flonum fl) (ceiling fl))
  (define (fltruncate fl) (assert-flonum fl) (truncate fl))
  (define (flround fl) (assert-flonum fl) (round fl))

  (define (flexp fl) (assert-flonum fl) (exp fl))
  (define* (fllog fl #:optional fl2)
    (assert-flonum fl)
    (cond ((fl=? fl -inf.0) +nan.0)
	  (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
	  (else (log fl))))

  (define (flsin fl) (assert-flonum fl) (sin fl))
  (define (flcos fl) (assert-flonum fl) (cos fl))
  (define (fltan fl) (assert-flonum fl) (tan fl))
  (define (flasin fl) (assert-flonum fl) (asin fl))
  (define (flacos fl) (assert-flonum fl) (acos fl))
  (define* (flatan fl #:optional fl2)
    (assert-flonum fl)
    (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))

  (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
  (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))

  (define-condition-type &no-infinities
    &implementation-restriction
    make-no-infinities-violation
    no-infinities-violation?)

  (define-condition-type &no-nans
    &implementation-restriction
    make-no-nans-violation
    no-nans-violation?)

  (define (fixnum->flonum fx)
    (or (fixnum? fx) (raise (make-assertion-violation)))
    (exact->inexact fx))
)


code:
;;; base.scm --- The R6RS base 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 base (6))
  (export boolean? symbol? char? vector? null? pair? number? string? procedure?

	  define define-syntax syntax-rules lambda let let* let-values
	  let*-values letrec letrec* begin

	  quote lambda if set! cond case

	  or and not

	  eqv? equal? eq?

	  + - * / max min abs numerator denominator gcd lcm floor ceiling
	  truncate round rationalize real-part imag-part make-rectangular angle
	  div mod div-and-mod div0 mod0 div0-and-mod0

	  expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
	  make-polar magnitude angle

	  complex? real? rational? integer? exact? inexact? real-valued?
	  rational-valued? integer-values? zero? positive? negative? odd? even?
	  nan? finite? infinite?

	  exact inexact = < > <= >=

	  number->string string->number

	  cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr
	  cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr
	  cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr

	  list? list length append reverse list-tail list-ref map for-each

	  symbol->string string->symbol symbol=?

	  char->integer integer->char char=? char<? char>? char<=? char>=?

	  make-string string string-length string-ref string=? string<? string>?
	  string<=? string>=? substring string-append string->list list->string
	  string-for-each string-copy

	  vector? make-vector vector vector-length vector-ref vector-set!
	  vector->list list->vector vector-fill! vector-map vector-for-each

	  error assertion-violation assert

	  call-with-current-continuation call/cc call-with-values dynamic-wind
	  values apply

	  quasiquote unquote unquote-splicing

	  let-syntax letrec-syntax

	  syntax-rules identifier-syntax)
 (import (rename (guile) (quotient div) (modulo mod))
	 (srfi srfi-11))

 (define (vector-for-each proc . vecs)
   (apply for-each (cons proc (map vector->list vecs))))
 (define (vector-map proc . vecs)
   (list->vector (apply map (cons proc (map vector->list vecs)))))

 (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r)))

 (define (div0 x y)
   (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q)))

 (define (mod0 x y)
   (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r)))

 (define (div0-and-mod0 x y)
   (call-with-values (lambda () (div-and-mod x y))
     (lambda (q r)
       (cond ((< r (abs (/ y 2))) (values q r))
	     ((negative? y) (values (- q 1) (+ r y)))
	     (else (values (+ q 1) (+ r y)))))))

)


code:
;;;; bytevectors.scm --- R6RS bytevector 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:
;;;
;;; A "bytevector" is a raw bit string.  This module provides procedures to
;;; manipulate bytevectors and interpret their contents in a number of ways:
;;; bytevector contents can be accessed as signed or unsigned integer of
;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
;;; strings.  It is a useful tool to decode binary data.
;;;
;;; Code:

(define-module (rnrs bytevectors)
  #:version (6)
  #:export-syntax (endianness)
  #:export (native-endianness bytevector?
           make-bytevector bytevector-length bytevector=? bytevector-fill!
           bytevector-copy! bytevector-copy
           uniform-array->bytevector
           bytevector-u8-ref bytevector-s8-ref
           bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
           u8-list->bytevector
           bytevector-uint-ref bytevector-uint-set!
           bytevector-sint-ref bytevector-sint-set!
           bytevector->sint-list bytevector->uint-list
           uint-list->bytevector sint-list->bytevector

           bytevector-u16-ref bytevector-s16-ref
           bytevector-u16-set! bytevector-s16-set!
           bytevector-u16-native-ref bytevector-s16-native-ref
           bytevector-u16-native-set! bytevector-s16-native-set!

           bytevector-u32-ref bytevector-s32-ref
           bytevector-u32-set! bytevector-s32-set!
           bytevector-u32-native-ref bytevector-s32-native-ref
           bytevector-u32-native-set! bytevector-s32-native-set!

           bytevector-u64-ref bytevector-s64-ref
           bytevector-u64-set! bytevector-s64-set!
           bytevector-u64-native-ref bytevector-s64-native-ref
           bytevector-u64-native-set! bytevector-s64-native-set!

           bytevector-ieee-single-ref
           bytevector-ieee-single-set!
           bytevector-ieee-single-native-ref
           bytevector-ieee-single-native-set!

           bytevector-ieee-double-ref
           bytevector-ieee-double-set!
           bytevector-ieee-double-native-ref
           bytevector-ieee-double-native-set!

           string->utf8 string->utf16 string->utf32
           utf8->string utf16->string utf32->string))

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

(define-macro (endianness sym)
  (if (memq sym '(big little))
      `(quote ,sym)
      (error "unsupported endianness" sym)))

;;; bytevector.scm ends here


code:
;;; conditions.scm --- The R6RS conditions 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 conditions (6))
  (export &condition
	  condition
	  simple-conditions
	  condition?
	  condition-predicate
	  condition-accessor
	  define-condition-type

	  &message
	  make-message-condition
	  message-condition?
	  condition-message

	  &warning
	  make-warning
	  warning?

	  &serious
	  make-serious-condition
	  serious-condition?

	  &error
	  make-error
	  error?

	  &violation
	  make-violation
	  violation?

	  &assertion
	  make-assertion-violation
	  assertion-violation?

	  &irritants
	  make-irritants-condition
	  irritants-condition?
	  condition-irritants

	  &who
	  make-who-condition
	  who-condition?
	  condition-who

	  &non-continuable
	  make-non-continuable-violation
	  non-continuable-violation?

	  &implementation-restriction
	  make-implementation-restriction-violation
	  implementation-restriction-violation?

	  &lexical
	  make-lexical-violation
	  lexical-violation?

	  &syntax
	  make-syntax-violation
	  syntax-violation?
	  syntax-violation-form
	  syntax-violation-subform

	  &undefined
	  make-undefined-violation
	  undefined-violation?)
  (import (only (guile) and=> @@)
	  (rnrs base (6))
	  (rnrs lists (6))
	  (rnrs records procedural (6)))

  (define &compound-condition (make-record-type-descriptor
			       '&compound-condition #f #f #f #f
			       '#((immutable components))))
  (define compound-condition? (record-predicate &compound-condition))

  (define make-compound-condition
    (record-constructor (make-record-constructor-descriptor
			 &compound-condition #f #f)))
  (define simple-conditions (record-accessor &compound-condition 0))

  (define (condition? obj)
    (or (compound-condition? obj) (condition-internal? obj)))

  (define condition
    (lambda conditions
      (define (flatten cond)
	(if (compound-condition? cond) (simple-conditions cond) (list cond)))
      (or (for-all condition? conditions)
	  (raise (make-assertion-violation)))
      (if (or (null? conditions) (> (length conditions) 1))
	  (make-compound-condition (apply append (map flatten conditions)))
	  (car conditions))))

  (define-syntax define-condition-type
    (syntax-rules ()
      ((_ condition-type supertype constructor predicate
	  (field accessor) ...)
       (letrec-syntax
	   ((transform-fields
	     (syntax-rules ()
	       ((_ (f a) . rest)
		(cons '(immutable f a) (transform-fields rest)))
	       ((_ ((f a))) '((immutable f a)))
	       ((_ ()) '())
	       ((_) '())))

	    (generate-accessors
	     (syntax-rules ()
	       ((_ counter (f a) . rest)
		(begin (define a
                         (condition-accessor
                          condition-type
                          (record-accessor condition-type counter)))
		       (generate-accessors (+ counter 1) rest)))
	       ((_ counter ((f a)))
		(define a
                  (condition-accessor
                   condition-type (record-accessor condition-type counter))))
	       ((_ counter ()) (begin))
	       ((_ counter) (begin)))))
	 (begin
	   (define condition-type
	     (make-record-type-descriptor
	      'condition-type supertype #f #f #f
	      (list->vector (transform-fields (field accessor) ...))))
	   (define constructor
	     (record-constructor
	      (make-record-constructor-descriptor condition-type #f #f)))
	   (define predicate (condition-predicate condition-type))
	   (generate-accessors 0 (field accessor) ...))))))

  (define &condition (@@ (rnrs records procedural) &condition))
  (define &condition-constructor-descriptor
    (make-record-constructor-descriptor &condition #f #f))
  (define condition-internal? (record-predicate &condition))

  (define (condition-predicate rtd)
    (let ((rtd-predicate (record-predicate rtd)))
      (lambda (obj)
	(cond ((compound-condition? obj)
	       (exists rtd-predicate (simple-conditions obj)))
	      ((condition-internal? obj) (rtd-predicate obj))
	      (else #f)))))

  (define (condition-accessor rtd proc)
    (let ((rtd-predicate (record-predicate rtd)))
      (lambda (obj)
	(cond ((rtd-predicate obj) (proc obj))
	      ((compound-condition? obj)
	       (and=> (find rtd-predicate (simple-conditions obj)) proc))
	      (else #f)))))

  (define-condition-type &message &condition
    make-message-condition message-condition?
    (message condition-message))

  (define-condition-type &warning &condition make-warning warning?)

  (define &serious (@@ (rnrs records procedural) &serious))
  (define make-serious-condition
    (@@ (rnrs records procedural) make-serious-condition))
  (define serious-condition? (condition-predicate &serious))

  (define-condition-type &error &serious make-error error?)

  (define &violation (@@ (rnrs records procedural) &violation))
  (define make-violation (@@ (rnrs records procedural) make-violation))
  (define violation? (condition-predicate &violation))

  (define &assertion (@@ (rnrs records procedural) &assertion))
  (define make-assertion-violation
    (@@ (rnrs records procedural) make-assertion-violation))
  (define assertion-violation? (condition-predicate &assertion))

  (define-condition-type &irritants &condition
    make-irritants-condition irritants-condition?
    (irritants condition-irritants))

  (define-condition-type &who &condition
    make-who-condition who-condition?
    (who condition-who))

  (define-condition-type &non-continuable &violation
    make-non-continuable-violation
    non-continuable-violation?)

  (define-condition-type &implementation-restriction
    &violation
    make-implementation-restriction-violation
    implementation-restriction-violation?)

  (define-condition-type &lexical &violation
    make-lexical-violation lexical-violation?)

  (define-condition-type &syntax &violation
    make-syntax-violation syntax-violation?
    (form syntax-violation-form)
    (subform syntax-violation-subform))

  (define-condition-type &undefined &violation
    make-undefined-violation undefined-violation?)

  ;; Condition types that are used by (rnrs files), (rnrs io ports), and
  ;; (rnrs io simple).  These are defined here so as to be easily shareable by
  ;; these three libraries.

  (define-condition-type &i/o &error make-i/o-error i/o-error?)
  (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?)
  (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?)
  (define-condition-type &i/o-invalid-position
    &i/o make-i/o-invalid-position-error i/o-invalid-position-error?
    (position i/o-error-position))
  (define-condition-type &i/o-filename
    &i/o make-i/o-filename-error i/o-filename-error?
    (filename i/o-error-filename))
  (define-condition-type &i/o-file-protection
    &i/o-filename make-i/o-file-protection-error i/o-file-protection-error?)
  (define-condition-type &i/o-file-is-read-only
    &i/o-file-protection make-i/o-file-is-read-only-error
    i/o-file-is-read-only-error?)
  (define-condition-type &i/o-file-already-exists
    &i/o-filename make-i/o-file-already-exists-error
    i/o-file-already-exists-error?)
  (define-condition-type &i/o-file-does-not-exist
    &i/o-filename make-i/o-file-does-not-exist-error
    i/o-file-does-not-exist-error?)
  (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error?
    (port i/o-error-port))
)


code:
;;; control.scm --- The R6RS control structures 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 control (6))
  (export when unless do case-lambda)
  (import (rnrs base (6))
          (only (guile) do case-lambda))

  (define-syntax when
    (syntax-rules ()
      ((when test result1 result2 ...)
       (if test (begin result1 result2 ...)))))

  (define-syntax unless
    (syntax-rules ()
      ((unless test result1 result2 ...)
       (if (not test) (begin result1 result2 ...))))))


code:
;;; enums.scm --- The R6RS enumerations 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 enums (6))
  (export make-enumeration enum-set-universe enum-set-indexer
	  enum-set-constructor enum-set->list enum-set-member? enum-set-subset?
	  enum-set=? enum-set-union enum-set-intersection enum-set-difference
	  enum-set-complement enum-set-projection define-enumeration)
  (import (only (guile) and=>)
	  (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
          (rnrs records procedural (6))
	  (rnrs syntax-case (6))
	  (srfi :1))

  (define enum-set-rtd (make-record-type-descriptor
			'enum-set #f #f #f #f '#((mutable universe)
						 (immutable set))))

  (define make-enum-set
    (record-constructor
     (make-record-constructor-descriptor enum-set-rtd #f #f)))

  (define enum-set-universe-internal (record-accessor enum-set-rtd 0))
  (define enum-set-universe-set! (record-mutator enum-set-rtd 0))

  (define enum-set-set (record-accessor enum-set-rtd 1))

  (define (make-enumeration symbol-list)
    (let ((es (make-enum-set #f symbol-list)))
      (enum-set-universe-set! es es)))

  (define (enum-set-universe enum-set)
    (or (enum-set-universe-internal enum-set)
	enum-set))

  (define (enum-set-indexer enum-set)
    (let* ((symbols (enum-set->list (enum-set-universe enum-set)))
	   (cardinality (length symbols)))
      (lambda (x)
	(and=> (memq x symbols)
	       (lambda (probe) (- cardinality (length probe)))))))

  (define (enum-set-constructor enum-set)
    (lambda (symbol-list)
      (make-enum-set (enum-set-universe enum-set)
		     (list-copy symbol-list))))

  (define (enum-set->list enum-set)
    (lset-intersection eq?
		       (enum-set-set (enum-set-universe enum-set))
		       (enum-set-set enum-set)))

  (define (enum-set-member? symbol enum-set)
    (and (memq symbol (enum-set-set enum-set)) #t))

  (define (enum-set-subset? enum-set-1 enum-set-2)
    (and (lset<= eq?
		 (enum-set-set (enum-set-universe enum-set-1))
		 (enum-set-set (enum-set-universe enum-set-2)))
	 (lset<= eq? (enum-set-set enum-set-1) (enum-set-set enum-set-2))))

  (define (enum-set=? enum-set-1 enum-set-2)
    (and (enum-set-subset? enum-set-1 enum-set-2)
	 (enum-set-subset? enum-set-2 enum-set-1)))

  (define (enum-set-union enum-set-1 enum-set-2)
    (if (eq? (enum-set-universe enum-set-1)
	     (enum-set-universe enum-set-2))
	(make-enum-set (enum-set-universe enum-set-1)
		       (lset-union eq?
				   (enum-set-set enum-set-1)
				   (enum-set-set enum-set-2)))
	(raise (make-assertion-violation))))

  (define (enum-set-intersection enum-set-1 enum-set-2)
    (if (eq? (enum-set-universe enum-set-1)
	     (enum-set-universe enum-set-2))
	(make-enum-set (enum-set-universe enum-set-1)
		       (lset-intersection eq?
					  (enum-set-set enum-set-1)
					  (enum-set-set enum-set-2)))
	(raise (make-assertion-violation))))

  (define (enum-set-difference enum-set-1 enum-set-2)
    (if (eq? (enum-set-universe enum-set-1)
	     (enum-set-universe enum-set-2))
	(make-enum-set (enum-set-universe enum-set-1)
		       (lset-difference eq?
					(enum-set-set enum-set-1)
					(enum-set-set enum-set-2)))
	(raise (make-assertion-violation))))

  (define (enum-set-complement enum-set)
    (let ((universe (enum-set-universe enum-set)))
      (make-enum-set universe
		     (lset-difference
		      eq? (enum-set->list universe) (enum-set-set enum-set)))))

  (define (enum-set-projection enum-set-1 enum-set-2)
    (make-enum-set (enum-set-universe enum-set-2)
		   (lset-intersection eq?
				      (enum-set-set enum-set-1)
				      (enum-set->list
				       (enum-set-universe enum-set-2)))))

  (define-syntax define-enumeration
    (syntax-rules ()
      ((_ type-name (symbol ...) constructor-syntax)
       (begin
	 (define-syntax type-name
	   (lambda (s)
	     (syntax-case s ()
	       ((type-name sym)
		(if (memq (syntax->datum #'sym) '(symbol ...))
		    #'(quote sym)
		    (syntax-violation (symbol->string 'type-name)
				      "not a member of the set"
				      #f))))))
	 (define-syntax constructor-syntax
	   (lambda (s)
	     (syntax-case s ()
	       ((_) (syntax #f))
	       ((_ sym (... ...))
		(let* ((universe '(symbol ...))
		       (syms (syntax->datum #'(sym (... ...))))
		       (quoted-universe
			(datum->syntax s (list 'quote universe)))
		       (quoted-syms (datum->syntax s (list 'quote syms))))
		  (or (every (lambda (x) (memq x universe)) syms)
		      (syntax-violation (symbol->string 'constructor-syntax)
					"not a subset of the universe"
					#f))
		  #`((enum-set-constructor (make-enumeration #,quoted-universe))
		     #,quoted-syms))))))))))
)


code:
;;; eval.scm --- The R6RS `eval' 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 eval (6))
  (export eval environment)
  (import (only (guile) eval
		        make-module
			module-uses
			beautify-user-module!
			set-module-uses!)
	  (rnrs base (6))
	  (rnrs io simple (6))
	  (rnrs lists (6)))

  (define (environment . import-specs)
    (let ((module (make-module))
	  (needs-purify? (not (member '(guile) import-specs))))
      (beautify-user-module! module)
      (for-each (lambda (import-spec) (eval (list 'import import-spec) module))
		import-specs)
      (if needs-purify? (set-module-uses! module (cdr (module-uses module))))
      module))
)


code:
;;; exceptions.scm --- The R6RS exceptions 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 exceptions (6))
  (export guard with-exception-handler raise raise-continuable)
  (import (rnrs base (6))
          (rnrs conditions (6))
	  (rnrs records procedural (6))
	  (only (guile) with-throw-handler *unspecified* @@))

  (define raise (@@ (rnrs records procedural) r6rs-raise))
  (define raise-continuable
    (@@ (rnrs records procedural) r6rs-raise-continuable))
  (define raise-object-wrapper?
    (@@ (rnrs records procedural) raise-object-wrapper?))
  (define raise-object-wrapper-obj
    (@@ (rnrs records procedural) raise-object-wrapper-obj))
  (define raise-object-wrapper-continuation
    (@@ (rnrs records procedural) raise-object-wrapper-continuation))

  (define (with-exception-handler handler thunk)
    (with-throw-handler 'r6rs:exception
     thunk
     (lambda (key . args)
       (if (and (not (null? args))
		(raise-object-wrapper? (car args)))
	   (let* ((cargs (car args))
		  (obj (raise-object-wrapper-obj cargs))
		  (continuation (raise-object-wrapper-continuation cargs))
		  (handler-return (handler obj)))
	     (if continuation
		 (continuation handler-return)
		 (raise (make-non-continuable-violation))))
	   *unspecified*))))

  (define-syntax guard0
    (syntax-rules ()
      ((_ (variable cond-clause ...) body)
       (call/cc (lambda (continuation)
		  (with-exception-handler
		   (lambda (variable)
		     (continuation (cond cond-clause ...)))
		   (lambda () body)))))))

  (define-syntax guard
    (syntax-rules (else)
      ((_ (variable cond-clause ... . ((else else-clause ...))) body)
       (guard0 (variable cond-clause ... (else else-clause ...)) body))
      ((_ (variable cond-clause ...) body)
       (guard0 (variable cond-clause ... (else (raise variable))) body))))
)


code:
;;; files.scm --- The R6RS file system 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 files (6))
  (export file-exists?
	  delete-file

	  &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 (rename (only (guile) file-exists? delete-file catch @@)
		  (delete-file delete-file-internal))
	  (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6)))

  (define (delete-file filename)
    (catch #t
	   (lambda () (delete-file-internal filename))
	   (lambda (key . args) (raise (make-i/o-filename-error filename)))))

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


code:
;;; hashtables.scm --- The R6RS hashtables 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 hashtables (6))
  (export make-eq-hashtable
	  make-eqv-hashtable
	  make-hashtable

	  hashtable?
	  hashtable-size
	  hashtable-ref
	  hashtable-set!
	  hashtable-delete!
	  hashtable-contains?
	  hashtable-update!
	  hashtable-copy
	  hashtable-clear!
	  hashtable-keys
	  hashtable-entries

	  hashtable-equivalence-function
	  hashtable-hash-function
	  hashtable-mutable?

	  equal-hash
	  string-hash
	  string-ci-hash
	  symbol-hash)
  (import (rename (only (guile) string-hash-ci
                                string-hash
                                hashq
                                hashv
                                modulo
                                *unspecified*
                                @@)
		  (string-hash-ci string-ci-hash))
	  (only (ice-9 optargs) define*)
	  (rename (only (srfi :69) make-hash-table
			           hash
				   hash-by-identity
			           hash-table-size
				   hash-table-ref/default
				   hash-table-set!
				   hash-table-delete!
				   hash-table-exists?
				   hash-table-update!/default
				   hash-table-copy
				   hash-table-equivalence-function
				   hash-table-hash-function
				   hash-table-keys
				   hash-table-fold)
		  (hash equal-hash)
		  (hash-by-identity symbol-hash))
	  (rnrs base (6))
	  (rnrs records procedural (6)))

  (define r6rs:hashtable
    (make-record-type-descriptor
     'r6rs:hashtable #f #f #t #t
     '#((mutable wrapped-table)
	(immutable orig-hash-function)
	(immutable mutable))))

  (define hashtable? (record-predicate r6rs:hashtable))
  (define make-r6rs-hashtable
    (record-constructor (make-record-constructor-descriptor
			 r6rs:hashtable #f #f)))
  (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
  (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
  (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
  (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))

  (define hashtable-mutable? r6rs:hashtable-mutable?)

  (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
  (define (wrap-hash-function proc)
    (lambda (key capacity) (modulo (proc key) capacity)))

  (define* (make-eq-hashtable #:optional k)
    (make-r6rs-hashtable
     (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
     symbol-hash
     #t))

  (define* (make-eqv-hashtable #:optional k)
    (make-r6rs-hashtable
     (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
     hash-by-value
     #t))

  (define* (make-hashtable hash-function equiv #:optional k)
    (let ((wrapped-hash-function (wrap-hash-function hash-function)))
      (make-r6rs-hashtable
       (if k
	   (make-hash-table equiv wrapped-hash-function k)
	   (make-hash-table equiv wrapped-hash-function))
       hash-function
       #t)))

  (define (hashtable-size hashtable)
    (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))

  (define (hashtable-ref hashtable key default)
    (hash-table-ref/default
     (r6rs:hashtable-wrapped-table hashtable) key default))

  (define (hashtable-set! hashtable key obj)
    (if (r6rs:hashtable-mutable? hashtable)
	(hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
    *unspecified*)

  (define (hashtable-delete! hashtable key)
    (if (r6rs:hashtable-mutable? hashtable)
	(hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
    *unspecified*)

  (define (hashtable-contains? hashtable key)
    (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))

  (define (hashtable-update! hashtable key proc default)
    (if (r6rs:hashtable-mutable? hashtable)
	(hash-table-update!/default
	 (r6rs:hashtable-wrapped-table hashtable) key proc default))
    *unspecified*)

  (define* (hashtable-copy hashtable #:optional mutable)
    (make-r6rs-hashtable
     (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
     (r6rs:hashtable-orig-hash-function hashtable)
     (and mutable #t)))

  (define* (hashtable-clear! hashtable #:optional k)
    (if (r6rs:hashtable-mutable? hashtable)
	(let* ((ht (r6rs:hashtable-wrapped-table hashtable))
	       (equiv (hash-table-equivalence-function ht))
	       (hash-function (r6rs:hashtable-orig-hash-function hashtable))
	       (wrapped-hash-function (wrap-hash-function hash-function)))
	  (r6rs:hashtable-set-wrapped-table!
	   hashtable
	   (if k
	       (make-hash-table equiv wrapped-hash-function k)
	       (make-hash-table equiv wrapped-hash-function)))))
    *unspecified*)

  (define (hashtable-keys hashtable)
    (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))

  (define (hashtable-entries hashtable)
    (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
	   (size (hash-table-size ht))
	   (keys (make-vector size))
	   (vals (make-vector size)))
      (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
		       (lambda (k v i)
			 (vector-set! keys i k)
			 (vector-set! vals i v)
			 (+ i 1))
		       0)
      (values keys vals)))

  (define (hashtable-equivalence-function hashtable)
    (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))

  (define (hashtable-hash-function hashtable)
    (r6rs:hashtable-orig-hash-function hashtable)))