code:
;;; srfi-35.scm --- Conditions

;; Copyright (C) 2007, 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; 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:

;; This is an implementation of SRFI-35, "Conditions".  Conditions are a
;; means to convey information about exceptional conditions between parts of
;; a program.

;;; Code:

(define-module (srfi srfi-35)
  #:use-module (srfi srfi-1)
  #:export (make-condition-type condition-type?
            make-condition condition? condition-has-type? condition-ref
            make-compound-condition extract-condition
            define-condition-type condition
            &condition
            &message message-condition? condition-message
            &serious serious-condition?
            &error error?))

(cond-expand-provide (current-module) '(srfi-35))

;;;
;;; Condition types.
;;;

(define %condition-type-vtable
  ;; The vtable of all condition types.
  ;;   vtable fields: vtable, self, printer
  ;;   user fields:   id, parent, all-field-names
  (make-vtable-vtable "prprpr" 0
		      (lambda (ct port)
			(if (eq? ct %condition-type-vtable)
			    (display "#<condition-type-vtable>")
			    (format port "#<condition-type ~a ~a>"
				    (condition-type-id ct)
				    (number->string (object-address ct)
						    16))))))

(define (%make-condition-type layout id parent all-fields)
  (let ((struct (make-struct %condition-type-vtable 0
                             (make-struct-layout layout) ;; layout
                             print-condition             ;; printer
                             id parent all-fields)))

    ;; Hack to associate STRUCT with a name, providing a better name for
    ;; GOOPS classes as returned by `class-of' et al.
    (set-struct-vtable-name! struct (cond ((symbol? id) id)
                                          ((string? id) (string->symbol id))
                                          (else         (string->symbol ""))))
    struct))

(define (condition-type? obj)
  "Return true if OBJ is a condition type."
  (and (struct? obj)
       (eq? (struct-vtable obj)
	    %condition-type-vtable)))

(define (condition-type-id ct)
  (and (condition-type? ct)
       (struct-ref ct 3)))

(define (condition-type-parent ct)
  (and (condition-type? ct)
       (struct-ref ct 4)))

(define (condition-type-all-fields ct)
  (and (condition-type? ct)
       (struct-ref ct 5)))

(define (struct-layout-for-condition field-names)
  ;; Return a string denoting the layout required to hold the fields listed
  ;; in FIELD-NAMES.
  (let loop ((field-names field-names)
	     (layout      '("pr")))
    (if (null? field-names)
	(string-concatenate/shared layout)
	(loop (cdr field-names)
	      (cons "pr" layout)))))

(define (print-condition c port)
  (format port "#<condition ~a ~a>"
	  (condition-type-id (condition-type c))
	  (number->string (object-address c) 16)))

(define (make-condition-type id parent field-names)
  "Return a new condition type named ID, inheriting from PARENT, and with the
fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
symbols and must not contain names already used by PARENT or one of its
supertypes."
  (if (symbol? id)
      (if (condition-type? parent)
	  (let ((parent-fields (condition-type-all-fields parent)))
	    (if (and (every symbol? field-names)
		     (null? (lset-intersection eq?
					       field-names parent-fields)))
		(let* ((all-fields (append parent-fields field-names))
		       (layout     (struct-layout-for-condition all-fields)))
		  (%make-condition-type layout
                                        id parent all-fields))
		(error "invalid condition type field names"
		       field-names)))
	  (error "parent is not a condition type" parent))
      (error "condition type identifier is not a symbol" id)))

(define (make-compound-condition-type id parents)
  ;; Return a compound condition type made of the types listed in PARENTS.
  ;; All fields from PARENTS are kept, even same-named ones, since they are
  ;; needed by `extract-condition'.
  (cond ((null? parents)
         (error "`make-compound-condition-type' passed empty parent list"
                id))
        ((null? (cdr parents))
         (car parents))
        (else
         (let* ((all-fields (append-map condition-type-all-fields
                                        parents))
                (layout     (struct-layout-for-condition all-fields)))
           (%make-condition-type layout
                                 id
                                 parents         ;; list of parents!
                                 all-fields)))))

;;;
;;; Conditions.
;;;

(define (condition? c)
  "Return true if C is a condition."
  (and (struct? c)
       (condition-type? (struct-vtable c))))

(define (condition-type c)
  (and (struct? c)
       (let ((vtable (struct-vtable c)))
	 (if (condition-type? vtable)
	     vtable
	     #f))))

(define (condition-has-type? c type)
  "Return true if condition C has type TYPE."
  (if (and (condition? c) (condition-type? type))
      (let loop ((ct (condition-type c)))
        (or (eq? ct type)
            (and ct
                 (let ((parent (condition-type-parent ct)))
                   (if (list? parent)
                       (any loop parent) ;; compound condition
                       (loop (condition-type-parent ct)))))))
      (throw 'wrong-type-arg "condition-has-type?"
             "Wrong type argument")))

(define (condition-ref c field-name)
  "Return the value of the field named FIELD-NAME from condition C."
  (if (condition? c)
      (if (symbol? field-name)
	  (let* ((type   (condition-type c))
		 (fields (condition-type-all-fields type))
		 (index  (list-index (lambda (name)
				       (eq? name field-name))
				     fields)))
	    (if index
		(struct-ref c index)
		(error "invalid field name" field-name)))
	  (error "field name is not a symbol" field-name))
      (throw 'wrong-type-arg "condition-ref"
             "Wrong type argument: ~S" c)))

(define (make-condition-from-values type values)
  (apply make-struct type 0 values))

(define (make-condition type . field+value)
  "Return a new condition of type TYPE with fields initialized as specified
by FIELD+VALUE, a sequence of field names (symbols) and values."
  (if (condition-type? type)
      (let* ((all-fields (condition-type-all-fields type))
	     (inits      (fold-right (lambda (field inits)
				       (let ((v (memq field field+value)))
					 (if (pair? v)
					     (cons (cadr v) inits)
					     (error "field not specified"
						    field))))
				     '()
				     all-fields)))
	(make-condition-from-values type inits))
      (throw 'wrong-type-arg "make-condition"
             "Wrong type argument: ~S" type)))

(define (make-compound-condition . conditions)
  "Return a new compound condition composed of CONDITIONS."
  (let* ((types  (map condition-type conditions))
	 (ct     (make-compound-condition-type 'compound types))
	 (inits  (append-map (lambda (c)
			       (let ((ct (condition-type c)))
				 (map (lambda (f)
					(condition-ref c f))
				      (condition-type-all-fields ct))))
			     conditions)))
    (make-condition-from-values ct inits)))

(define (extract-condition c type)
  "Return a condition of condition type TYPE with the field values specified
by C."

  (define (first-field-index parents)
    ;; Return the index of the first field of TYPE within C.
    (let loop ((parents parents)
	       (index   0))
      (let ((parent (car parents)))
	(cond ((null? parents)
	       #f)
	      ((eq? parent type)
	       index)
	      ((pair? parent)
	       (or (loop parent index)
		   (loop (cdr parents)
			 (+ index
			    (apply + (map condition-type-all-fields
					  parent))))))
	      (else
	       (let ((shift (length (condition-type-all-fields parent))))
		 (loop (cdr parents)
		       (+ index shift))))))))

  (define (list-fields start-index field-names)
    ;; Return a list of the form `(FIELD-NAME VALUE...)'.
    (let loop ((index       start-index)
	       (field-names field-names)
	       (result      '()))
      (if (null? field-names)
	  (reverse! result)
	  (loop (+ 1 index)
		(cdr field-names)
		(cons* (struct-ref c index)
		       (car field-names)
		       result)))))

  (if (and (condition? c) (condition-type? type))
      (let* ((ct     (condition-type c))
             (parent (condition-type-parent ct)))
        (cond ((eq? type ct)
               c)
              ((pair? parent)
               ;; C is a compound condition.
               (let ((field-index (first-field-index parent)))
                 ;;(format #t "field-index: ~a ~a~%" field-index
                 ;;        (list-fields field-index
                 ;;                     (condition-type-all-fields type)))
                 (apply make-condition type
                        (list-fields field-index
                                     (condition-type-all-fields type)))))
              (else
               ;; C does not have type TYPE.
               #f)))
      (throw 'wrong-type-arg "extract-condition"
             "Wrong type argument")))

;;;
;;; Syntax.
;;;

(define-macro (define-condition-type name parent pred . field-specs)
  `(begin
     (define ,name
       (make-condition-type ',name ,parent
			    ',(map car field-specs)))
     (define (,pred c)
       (condition-has-type? c ,name))
     ,@(map (lambda (field-spec)
	      (let ((field-name (car field-spec))
		    (accessor   (cadr field-spec)))
		`(define (,accessor c)
		   (condition-ref c ',field-name))))
	    field-specs)))

(define-macro (condition . type-field-bindings)
  (cond ((null? type-field-bindings)
	 (error "`condition' syntax error" type-field-bindings))
	(else
	 ;; the poor man's hygienic macro
	 (let ((mc   (gensym "mc"))
	       (mcct (gensym "mcct")))
	   `(let ((,mc   (@  (srfi srfi-35) make-condition))
		  (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
	      (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
		   ,@(append-map (lambda (type-field-binding)
				   (append-map (lambda (field+value)
						 (let ((f (car field+value))
						       (v (cadr field+value)))
						   `(',f ,v)))
					       (cdr type-field-binding)))
				 type-field-bindings)))))))

;;;
;;; Standard condition types.
;;;

(define &condition
  ;; The root condition type.
  (make-struct %condition-type-vtable 0
	       (make-struct-layout "")
	       (lambda (c port)
		 (display "<&condition>"))
	       '&condition #f '() '()))

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

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

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

;;; Local Variables:
;;; coding: latin-1
;;; End:

;;; srfi-35.scm ends here


code:
;;; srfi-37.scm --- args-fold

;; 	Copyright (C) 2007, 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;
;; To use this module with Guile, use (cdr (program-arguments)) as
;; the ARGS argument to `args-fold'.  Here is a short example:
;;
;;  (args-fold (cdr (program-arguments))
;; 	    (let ((display-and-exit-proc
;; 		   (lambda (msg)
;; 		     (lambda (opt name arg)
;; 		       (display msg) (quit) (values)))))
;; 	      (list (option '(#\v "version") #f #f
;; 			    (display-and-exit-proc "Foo version 42.0\n"))
;; 		    (option '(#\h "help") #f #f
;; 			    (display-and-exit-proc
;; 			     "Usage: foo scheme-file ..."))))
;; 	    (lambda (opt name arg)
;; 	      (error "Unrecognized option `~A'" name))
;; 	    (lambda (op) (load op) (values)))
;;
;;; Code:

;;;; Module definition & exports
(define-module (srfi srfi-37)
  #:use-module (srfi srfi-9)
  #:export (option option-names option-required-arg?
	    option-optional-arg? option-processor
	    args-fold))

(cond-expand-provide (current-module) '(srfi-37))

;;;; args-fold and periphery procedures

;;; An option as answered by `option'.  `names' is a list of
;;; characters and strings, representing associated short-options and
;;; long-options respectively that should use this option's
;;; `processor' in an `args-fold' call.
;;;
;;; `required-arg?' and `optional-arg?' are mutually exclusive
;;; booleans and indicate whether an argument must be or may be
;;; provided.  Besides the obvious, this affects semantics of
;;; short-options, as short-options with a required or optional
;;; argument cannot be followed by other short options in the same
;;; program-arguments string, as they will be interpreted collectively
;;; as the option's argument.
;;;
;;; `processor' is called when this option is encountered.  It should
;;; accept the containing option, the element of `names' (by `equal?')
;;; encountered, the option's argument (or #f if none), and the seeds
;;; as variadic arguments, answering the new seeds as values.
(define-record-type srfi-37:option
  (option names required-arg? optional-arg? processor)
  option?
  (names option-names)
  (required-arg? option-required-arg?)
  (optional-arg? option-optional-arg?)
  (processor option-processor))

(define (error-duplicate-option option-name)
  (scm-error 'program-error "args-fold"
	     "Duplicate option name `~A~A'"
	     (list (if (char? option-name) #\- "--")
		   option-name)
	     #f))

(define (build-options-lookup options)
  "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
  (let ((lookup (make-hash-table (* 2 (length options)))))
    (for-each
     (lambda (opt)
       (for-each (lambda (name)
		   (let ((assoc (hash-create-handle!
				 lookup name #f)))
		     (if (cdr assoc)
			 (error-duplicate-option (car assoc))
			 (set-cdr! assoc opt))))
		 (option-names opt)))
     options)
    lookup))

(define (args-fold args options unrecognized-option-proc
		   operand-proc . seeds)
  "Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  (let ((lookup (build-options-lookup options)))
    ;; I don't like Guile's `error' here
    (define (error msg . args)
      (scm-error 'misc-error "args-fold" msg args #f))

    (define (mutate-seeds! procedure . params)
      (set! seeds (call-with-values
		      (lambda ()
			(apply procedure (append params seeds)))
		    list)))

    ;; Clean up the rest of ARGS, assuming they're all operands.
    (define (rest-operands)
      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
		args)
      (set! args '()))

    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
    ;; and the seeds.  Depending on OPT's *-arg? specification, get
    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
    ;; if no argument is allowed, call NO-ARG-PROC thunk.
    (define (invoke-option-processor
	     opt name req-arg-proc opt-arg-proc no-arg-proc)
      (mutate-seeds!
       (option-processor opt) opt name
       (cond ((option-required-arg? opt) (req-arg-proc))
	     ((option-optional-arg? opt) (opt-arg-proc))
	     (else (no-arg-proc) #f))))

    ;; Compute and answer a short option argument, advancing ARGS as
    ;; necessary, for the short option whose character is at POSITION
    ;; in the current ARG.
    (define (short-option-argument position)
      (cond ((< (1+ position) (string-length (car args)))
	     (let ((result (substring (car args) (1+ position))))
	       (set! args (cdr args))
	       result))
	    ((pair? (cdr args))
	     (let ((result (cadr args)))
	       (set! args (cddr args))
	       result))
	    (else #f)))

    ;; Interpret the short-option at index POSITION in (car ARGS),
    ;; followed by the remaining short options in (car ARGS).
    (define (short-option position)
      (if (>= position (string-length (car args)))
          (begin
            (set! args (cdr args))
            (next-arg))
	  (let* ((opt-name (string-ref (car args) position))
		 (option-here (hash-ref lookup opt-name)))
	    (cond ((not option-here)
		   (mutate-seeds! unrecognized-option-proc
				  (option (list opt-name) #f #f
					  unrecognized-option-proc)
				  opt-name #f)
		   (short-option (1+ position)))
		  (else
		   (invoke-option-processor
		    option-here opt-name
		    (lambda ()
		      (or (short-option-argument position)
			  (error "Missing required argument after `-~A'" opt-name)))
		    (lambda ()
		      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
		      ;; GNU getopt_long resolves these like I do
		      (short-option-argument position))
		    (lambda () #f))
		   (if (not (or (option-required-arg? option-here)
				(option-optional-arg? option-here)))
		       (short-option (1+ position))))))))

    ;; Process the long option in (car ARGS).  We make the
    ;; interesting, possibly non-standard assumption that long option
    ;; names might contain #\=, so keep looking for more #\= in (car
    ;; ARGS) until we find a named option in lookup.
    (define (long-option)
      (let ((arg (car args)))
	(let place-=-after ((start-pos 2))
	  (let* ((index (string-index arg #\= start-pos))
		 (opt-name (substring arg 2 (or index (string-length arg))))
		 (option-here (hash-ref lookup opt-name)))
	    (if (not option-here)
		;; look for a later #\=, unless there can't be one
		(if index
		    (place-=-after (1+ index))
		    (mutate-seeds!
		     unrecognized-option-proc
		     (option (list opt-name) #f #f unrecognized-option-proc)
		     opt-name #f))
		(invoke-option-processor
		 option-here opt-name
		 (lambda ()
		   (if index
		       (substring arg (1+ index))
		       (error "Missing required argument after `--~A'" opt-name)))
		 (lambda () (and index (substring arg (1+ index))))
		 (lambda ()
		   (if index
		       (error "Extraneous argument after `--~A'" opt-name))))))))
      (set! args (cdr args)))

    ;; Process the remaining in ARGS.  Basically like calling
    ;; `args-fold', but without having to regenerate `lookup' and the
    ;; funcs above.
    (define (next-arg)
      (if (null? args)
	  (apply values seeds)
	  (let ((arg (car args)))
	    (cond ((or (not (char=? #\- (string-ref arg 0)))
		       (= 1 (string-length arg))) ;"-"
		   (mutate-seeds! operand-proc arg)
		   (set! args (cdr args)))
		  ((char=? #\- (string-ref arg 1))
		   (if (= 2 (string-length arg)) ;"--"
		       (begin (set! args (cdr args)) (rest-operands))
		       (long-option)))
		  (else (short-option 1)))
	    (next-arg))))

    (next-arg)))

;;; srfi-37.scm ends here

license: unknown


code:
;;; srfi-39.scm --- Parameter objects

;; 	Copyright (C) 2004, 2005, 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; 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: Jose Antonio Ortega Ruiz <jao@gnu.org>
;;; Date: 2004-05-05

;;; Commentary:

;; This is an implementation of SRFI-39 (Parameter objects).
;;
;; The implementation is based on Guile's fluid objects, and is, therefore,
;; thread-safe (parameters are thread-local).
;;
;; In addition to the forms defined in SRFI-39 (`make-parameter',
;; `parameterize'), a new procedure `with-parameters*' is provided.
;; This procedures is analogous to `with-fluids*' but taking as first
;; argument a list of parameter objects instead of a list of fluids.
;;

;;; Code:

(define-module (srfi srfi-39)
  #:use-module (ice-9 syncase)
  #:use-module (srfi srfi-16)

  #:export (make-parameter)
  #:export-syntax (parameterize)

  ;; helper procedure not in srfi-39.
  #:export (with-parameters*)
  #:replace (current-input-port current-output-port current-error-port))

;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
;;
(cond-expand-provide (current-module) '(srfi-39))

(define make-parameter
  (case-lambda
    ((val) (make-parameter/helper val (lambda (x) x)))
    ((val conv) (make-parameter/helper val conv))))

(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value

(define (make-parameter/helper val conv)
  (let ((value (make-fluid))
        (conv conv))
    (begin
      (fluid-set! value (conv val))
      (lambda new-value
        (cond
         ((null? new-value) (fluid-ref value))
         ((eq? (car new-value) get-fluid-tag) value)
         ((eq? (car new-value) get-conv-tag) conv)
         ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
         (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))

(define-syntax parameterize
  (syntax-rules ()
    ((_ ((?param ?value) ...) ?body ...)
     (with-parameters* (list ?param ...)
                       (list ?value ...)
                       (lambda () ?body ...)))))

(define (current-input-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-input-port))
      (apply set-current-input-port new-value)))

(define (current-output-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-output-port))
      (apply set-current-output-port new-value)))

(define (current-error-port . new-value)
  (if (null? new-value)
      ((@ (guile) current-error-port))
      (apply set-current-error-port new-value)))

(define port-list
  (list current-input-port current-output-port current-error-port))

;; There are no fluids behind current-input-port etc, so those parameter
;; objects are picked out of the list and handled separately with a
;; dynamic-wind to swap their values to and from a location (the "value"
;; variable in the swapper procedure "let").
;;
;; current-input-port etc are already per-dynamic-root, so this arrangement
;; works the same as a fluid.  Perhaps they could become fluids for ease of
;; implementation here.
;;
;; Notice the use of a param local variable for the swapper procedure.  It
;; ensures any application changes to the PARAMS list won't affect the
;; winding.
;;
(define (with-parameters* params values thunk)
  (let more ((params params)
	     (values values)
	     (fluids '())     ;; fluids from each of PARAMS
	     (convs  '())     ;; VALUES with conversion proc applied
	     (swapper noop))  ;; wind/unwind procedure for ports handling
    (if (null? params)
	(if (eq? noop swapper)
	    (with-fluids* fluids convs thunk)
	    (dynamic-wind
		swapper
		(lambda ()
		  (with-fluids* fluids convs thunk))
		swapper))
	(if (memq (car params) port-list)
	    (more (cdr params) (cdr values)
		  fluids convs
		  (let ((param (car params))
			(value (car values))
			(prev-swapper swapper))
		    (lambda ()
		      (set! value (param value))
		      (prev-swapper))))
	    (more (cdr params) (cdr values)
		  (cons ((car params) get-fluid-tag) fluids)
		  (cons (((car params) get-conv-tag) (car values)) convs)
		  swapper)))))


code:
/* srfi-4.c --- Homogeneous numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2004, 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * 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
 */

/* This file is now empty since all its procedures are now in the
   core.  We keep the libguile-srfi-srfi-4.so library around anyway
   since people might still be linking with it.
*/

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <srfi/srfi-4.h>

void scm_init_srfi_4_no_clash_with_libguile (void);

void
scm_init_srfi_4_no_clash_with_libguile (void)
{
}

/* End of srfi-4.c.  */


code:
#ifndef SCM_SRFI_SRFI_4_H
#define SCM_SRFI_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2006 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * 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
 */

/* All SRFI-4 procedures are in in the core now. */

#include <libguile.h>

#endif /* SCM_SRFI_SRFI_4_H */


code:
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes

;; 	Copyright (C) 2001, 2002, 2004, 2006 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; 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: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>

;;; Commentary:

;; This module exports the homogeneous numeric vector procedures as
;; defined in SRFI-4.  They are fully documented in the Guile
;; Reference Manual.

;;; Code:

(define-module (srfi srfi-4))

(re-export
;;; Unsigned 8-bit vectors.
 u8vector? make-u8vector u8vector u8vector-length u8vector-ref
 u8vector-set! u8vector->list list->u8vector

;;; Signed 8-bit vectors.
 s8vector? make-s8vector s8vector s8vector-length s8vector-ref
 s8vector-set! s8vector->list list->s8vector

;;; Unsigned 16-bit vectors.
 u16vector? make-u16vector u16vector u16vector-length u16vector-ref
 u16vector-set! u16vector->list list->u16vector

;;; Signed 16-bit vectors.
 s16vector? make-s16vector s16vector s16vector-length s16vector-ref
 s16vector-set! s16vector->list list->s16vector

;;; Unsigned 32-bit vectors.
 u32vector? make-u32vector u32vector u32vector-length u32vector-ref
 u32vector-set! u32vector->list list->u32vector

;;; Signed 32-bit vectors.
 s32vector? make-s32vector s32vector s32vector-length s32vector-ref
 s32vector-set! s32vector->list list->s32vector

;;; Unsigned 64-bit vectors.
 u64vector? make-u64vector u64vector u64vector-length u64vector-ref
 u64vector-set! u64vector->list list->u64vector

;;; Signed 64-bit vectors.
 s64vector? make-s64vector s64vector s64vector-length s64vector-ref
 s64vector-set! s64vector->list list->s64vector

;;; 32-bit floating point vectors.
 f32vector? make-f32vector f32vector f32vector-length f32vector-ref
 f32vector-set! f32vector->list list->f32vector

;;; 64-bit floating point vectors.
 f64vector? make-f64vector f64vector f64vector-length f64vector-ref
 f64vector-set! f64vector->list list->f64vector
 )


code:
;;; srfi-6.scm --- Basic String Ports

;; 	Copyright (C) 2001, 2002, 2003, 2006 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-6)
  #:re-export (open-input-string open-output-string get-output-string))

;; Currently, guile provides these functions by default, so no action
;; is needed, and this file is just a placeholder.

(cond-expand-provide (current-module) '(srfi-6))

;;; srfi-6.scm ends here


code:
/* srfi-60.c --- Integers as Bits
 *
 * Copyright (C) 2005, 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * 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
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <libguile.h>
#include <srfi/srfi-60.h>

#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))

SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0,
            (SCM n),
	    "Return a count of how many factors of 2 are present in @var{n}.\n"
	    "This is also the bit index of the lowest 1 bit in @var{n}.  If\n"
	    "@var{n} is 0, the return is @math{-1}.\n"
	    "\n"
	    "@example\n"
	    "(log2-binary-factors 6) @result{} 1\n"
	    "(log2-binary-factors -8) @result{} 3\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_log2_binary_factors
{
  SCM ret = SCM_EOL;

  if (SCM_I_INUMP (n))
    {
      long nn = SCM_I_INUM (n);
      if (nn == 0)
        return SCM_I_MAKINUM (-1);
      nn = nn ^ (nn-1);  /* 1 bits for each low 0 and lowest 1 */
      return scm_logcount (SCM_I_MAKINUM (nn >> 1));
    }
  else if (SCM_BIGP (n))
    {
      /* no need for scm_remember_upto_here_1 here, mpz_scan1 doesn't do
         anything that could result in a gc */
      return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L));
    }
  else
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);

  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
            (SCM index, SCM n, SCM bit),
	    "Return @var{n} with the bit at @var{index} set according to\n"
	    "@var{newbit}.  @var{newbit} should be @code{#t} to set the bit\n"
	    "to 1, or @code{#f} to set it to 0.  Bits other than at\n"
	    "@var{index} are unchanged in the return.\n"
	    "\n"
	    "@example\n"
	    "(copy-bit 1 #b0101 #t) @result{} 7\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_copy_bit
{
  SCM r;
  unsigned long ii;
  int bb;

  ii = scm_to_ulong (index);
  bb = scm_to_bool (bit);

  if (SCM_I_INUMP (n))
    {
      long nn = SCM_I_INUM (n);

      /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign,
         which is not what's wanted */
      if (ii < SCM_LONG_BIT-1)
        {
          nn &= ~(1L << ii);  /* zap bit at index */
          nn |= ((long) bb << ii);   /* insert desired bit */
          return scm_from_long (nn);
        }
      else
        {
          /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign
             bit, if this is already the desired "bit" value then no need to
             make a new bignum value */
          if (bb == (nn < 0))
            return n;

          r = scm_i_long2big (nn);
          goto big;
        }
    }
  else if (SCM_BIGP (n))
    {
      /* if the bit is already what's wanted then no need to make a new
         bignum */
      if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii))
        return n;

      r = scm_i_clonebig (n, 1);
    big:
      if (bb)
        mpz_setbit (SCM_I_BIG_MPZ (r), ii);
      else
        mpz_clrbit (SCM_I_BIG_MPZ (r), ii);

      /* changing a high bit might put the result into range of a fixnum */
      return scm_i_normbig (r);
    }
  else
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0,
            (SCM n, SCM count, SCM start, SCM end),
	    "Return @var{n} with the bit field from @var{start} (inclusive)\n"
	    "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n"
	    "\n"
	    "@var{count} can be positive or negative, and it can be more\n"
	    "than the field width (it'll be reduced modulo the width).\n"
	    "\n"
	    "@example\n"
	    "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_rotate_bit_field
{
  unsigned long ss = scm_to_ulong (start);
  unsigned long ee = scm_to_ulong (end);
  unsigned long ww, cc;

  SCM_ASSERT_RANGE (3, end, (ee >= ss));
  ww = ee - ss;

  cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start)));

  if (SCM_I_INUMP (n))
    {
      long nn = SCM_I_INUM (n);

      if (ee <= SCM_LONG_BIT-1)
        {
          /* all within a long */
          long below = nn & ((1L << ss) - 1);  /* before start */
          long above = nn & (-1L << ee);       /* above end */
          long fmask = (-1L << ss) & ((1L << ee) - 1);  /* field mask */
          long ff = nn & fmask;                /* field */

          return scm_from_long (above
                                | ((ff << cc) & fmask)
                                | ((ff >> (ww-cc)) & fmask)
                                | below);
        }
      else
        {
          /* either no movement, or a field of only 0 or 1 bits, result
             unchanged, avoid creating a bignum */
          if (cc == 0 || ww <= 1)
            return n;

          n = scm_i_long2big (nn);
          goto big;
        }
    }
  else if (SCM_BIGP (n))
    {
      mpz_t tmp;
      SCM r;

      /* either no movement, or in a field of only 0 or 1 bits, result
         unchanged, avoid creating a new bignum */
      if (cc == 0 || ww <= 1)
        return n;

    big:
      r = scm_i_ulong2big (0);
      mpz_init (tmp);

      /* portion above end */
      mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee);
      mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee);

      /* field high part, width-count bits from start go to start+count */
      mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
      mpz_fdiv_r_2exp (tmp, tmp, ww - cc);
      mpz_mul_2exp (tmp, tmp, ss + cc);
      mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);

      /* field high part, count bits from end-count go to start */
      mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc);
      mpz_fdiv_r_2exp (tmp, tmp, cc);
      mpz_mul_2exp (tmp, tmp, ss);
      mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);

      /* portion below start */
      mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
      mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);

      mpz_clear (tmp);

      /* bits moved around might leave us in range of an inum */
      return scm_i_normbig (r);
    }
  else
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0,
            (SCM n, SCM start, SCM end),
	    "Return @var{n} with the bits between @var{start} (inclusive) to\n"
	    "@var{end} (exclusive) reversed.\n"
	    "\n"
	    "@example\n"
	    "(reverse-bit-field #b101001 2 4) @result{} #b100101\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_reverse_bit_field
{
  long ss = scm_to_long (start);
  long ee = scm_to_long (end);
  long swaps = (ee - ss) / 2;  /* number of swaps */
  SCM b;

  if (SCM_I_INUMP (n))
    {
      long nn = SCM_I_INUM (n);

      if (ee <= SCM_LONG_BIT-1)
        {
          /* all within a long */
          long smask = 1L << ss;
          long emask = 1L << (ee-1);
          for ( ; swaps > 0; swaps--)
            {
              long sbit = nn & smask;
              long ebit = nn & emask;
              nn ^= sbit ^ (ebit ? smask : 0)  /* zap sbit, put ebit value */
                ^   ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */

              smask <<= 1;
              emask >>= 1;
            }
          return scm_from_long (nn);
        }
      else
        {
          /* avoid creating a new bignum if reversing only 0 or 1 bits */
          if (ee - ss <= 1)
            return n;

          b = scm_i_long2big (nn);
          goto big;
        }
    }
  else if (SCM_BIGP (n))
    {
      /* avoid creating a new bignum if reversing only 0 or 1 bits */
      if (ee - ss <= 1)
        return n;

      b = scm_i_clonebig (n, 1);
    big:

      ee--;
      for ( ; swaps > 0; swaps--)
        {
          int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss);
          int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee);
          if (sbit ^ ebit)
            {
              /* the two bits are different, flip them */
              if (sbit)
                {
                  mpz_clrbit (SCM_I_BIG_MPZ (b), ss);
                  mpz_setbit (SCM_I_BIG_MPZ (b), ee);
                }
              else
                {
                  mpz_setbit (SCM_I_BIG_MPZ (b), ss);
                  mpz_clrbit (SCM_I_BIG_MPZ (b), ee);
                }
            }
          ss++;
          ee--;
        }
      /* swapping zero bits into the high might make us fit a fixnum */
      return scm_i_normbig (b);
    }
  else
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0,
            (SCM n, SCM len),
	    "Return bits from @var{n} in the form of a list of @code{#t} for\n"
	    "1 and @code{#f} for 0.  The least significant @var{len} bits\n"
	    "are returned, and the first list element is the most\n"
	    "significant of those bits.  If @var{len} is not given, the\n"
	    "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n"
	    "Operations}).\n"
	    "\n"
	    "@example\n"
	    "(integer->list 6)   @result{} (#t #t #f)\n"
	    "(integer->list 1 4) @result{} (#f #f #f #t)\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_integer_to_list
{
  SCM ret = SCM_EOL;
  unsigned long ll, i;

  if (SCM_UNBNDP (len))
    len = scm_integer_length (n);
  ll = scm_to_ulong (len);

  if (SCM_I_INUMP (n))
    {
      long nn = SCM_I_INUM (n);
      for (i = 0; i < ll; i++)
        {
          unsigned long shift = SCM_MIN (i, (unsigned long) SCM_LONG_BIT-1);
          int bit = (nn >> shift) & 1;
          ret = scm_cons (scm_from_bool (bit), ret);
        }
    }
  else if (SCM_BIGP (n))
    {
      for (i = 0; i < ll; i++)
        ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)),
                        ret);
      scm_remember_upto_here_1 (n);
    }
  else
    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);

  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0,
            (SCM lst),
	    "Return an integer formed bitwise from the given @var{lst} list\n"
	    "of booleans.  Each boolean is @code{#t} for a 1 and @code{#f}\n"
	    "for a 0.  The first element becomes the most significant bit in\n"
	    "the return.\n"
	    "\n"
	    "@example\n"
	    "(list->integer '(#t #f #t #f)) @result{} 10\n"
	    "@end example")
#define FUNC_NAME s_scm_srfi60_list_to_integer
{
  long len;

  /* strip high zero bits from lst; after this the length tells us whether
     an inum or bignum is required */
  while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst)))
    lst = SCM_CDR (lst);

  SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len);

  if (len <= SCM_I_FIXNUM_BIT - 1)
    {
      /* fits an inum (a positive inum) */
      long n = 0;
      while (scm_is_pair (lst))
        {
          n <<= 1;
          if (! scm_is_false (SCM_CAR (lst)))
            n++;
          lst = SCM_CDR (lst);
        }
      return SCM_I_MAKINUM (n);
    }
  else
    {
      /* need a bignum */
      SCM n = scm_i_ulong2big (0);
      while (scm_is_pair (lst))
        {
          len--;
          if (! scm_is_false (SCM_CAR (lst)))
            mpz_setbit (SCM_I_BIG_MPZ (n), len);
          lst = SCM_CDR (lst);
        }
      return n;
    }
}
#undef FUNC_NAME

/* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a
   newline breaks the snarfer */
SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer);

void
scm_init_srfi_60 (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "srfi/srfi-60.x"
#endif
}


code:
/* srfi-60.h --- SRFI-60 procedures for Guile
 *
 * 	Copyright (C) 2005, 2006 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 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * 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
 */

#ifndef SCM_SRFI_60_H
#define SCM_SRFI_60_H

/* SCM_SRFI60_API is a macro prepended to all function and data definitions
   which should be exported or imported in the resulting dynamic link
   library in the Win32 port. */

#if defined (SCM_SRFI60_IMPORT)
# define SCM_SRFI60_API __declspec (dllimport) extern
#elif defined (SCM_SRFI60_EXPORT) || defined (DLL_EXPORT)
# define SCM_SRFI60_API __declspec (dllexport) extern
#else
# define SCM_SRFI60_API extern
#endif

SCM_SRFI60_API SCM scm_srfi60_log2_binary_factors (SCM n);
SCM_SRFI60_API SCM scm_srfi60_copy_bit (SCM index, SCM n, SCM bit);
SCM_SRFI60_API SCM scm_srfi60_rotate_bit_field (SCM n, SCM count, SCM start, SCM end);
SCM_SRFI60_API SCM scm_srfi60_reverse_bit_field (SCM n, SCM start, SCM end);
SCM_SRFI60_API SCM scm_srfi60_integer_to_list (SCM n, SCM len);
SCM_SRFI60_API SCM scm_srfi60_list_to_integer (SCM lst);

SCM_SRFI60_API void scm_init_srfi_60 (void);

#endif /* SCM_SRFI_60_H */


code:
;;; srfi-60.scm --- Integers as Bits

;; Copyright (C) 2005, 2006 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; 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 (srfi srfi-60)
  #:export (bitwise-and
	    bitwise-ior
	    bitwise-xor
	    bitwise-not
	    any-bits-set?
	    bit-count
	    bitwise-if bitwise-merge
	    log2-binary-factors first-set-bit
	    bit-set?
	    copy-bit
	    bit-field
	    copy-bit-field
	    arithmetic-shift
	    rotate-bit-field
	    reverse-bit-field
	    integer->list
	    list->integer
	    booleans->integer)
  #:re-export (logand
	       logior
	       logxor
	       integer-length
	       logtest
	       logcount
	       logbit?
	       ash))

(load-extension "libguile-srfi-srfi-60-v-2" "scm_init_srfi_60")

(define bitwise-and logand)
(define bitwise-ior logior)
(define bitwise-xor logxor)
(define bitwise-not lognot)
(define any-bits-set? logtest)
(define bit-count logcount)

(define (bitwise-if mask n0 n1)
  (logior (logand mask n0)
          (logand (lognot mask) n1)))
(define bitwise-merge bitwise-if)

(define first-set-bit log2-binary-factors)
(define bit-set? logbit?)
(define bit-field bit-extract)

(define (copy-bit-field n newbits start end)
  (logxor n (ash (logxor (bit-extract n start end)              ;; cancel old
			 (bit-extract newbits 0 (- end start))) ;; insert new
		 start)))

(define arithmetic-shift ash)

(cond-expand-provide (current-module) '(srfi-60))


code:
;;; srfi-69.scm --- Basic hash tables

;; 	Copyright (C) 2007 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; Commentary:

;; My `hash' is compatible with core `hash', so I replace it.
;; However, my `hash-table?' and `make-hash-table' are different, so
;; importing this module will warn about them.  If you don't rename my
;; imports, you shouldn't use both my hash tables and Guile's hash
;; tables in the same module.
;;
;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
;; are compatible with my `string-hash' and `string-ci-hash', and are
;; furthermore primitive in Guile, so I use them as my own.
;;
;; I also have the extension of allowing hash functions that require a
;; second argument to be used as the `hash-table-hash-function', and use
;; these in defaults to avoid an indirection in the hashx functions.  The
;; only deviation this causes is:
;;
;;  ((hash-table-hash-function (make-hash-table)) obj)
;;  error> Wrong number of arguments to #<primitive-procedure hash>
;;
;; I don't think that SRFI 69 actually specifies that I *can't* do this,
;; because it only implies the signature of a hash function by way of the
;; named, exported hash functions.  However, if this matters enough I can
;; add a private derivation of hash-function to the srfi-69:hash-table
;; record type, like associator is to equivalence-function.
;;
;; Also, outside of the issue of how weak keys and values are referenced
;; outside the table, I always interpret key equivalence to be that of
;; the `hash-table-equivalence-function'.  For example, given the
;; requirement that `alist->hash-table' give earlier associations
;; priority, what should these answer?
;;
;;  (hash-table-keys
;;   (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
;;
;;  (let ((ht (make-hash-table string-ci=?)))
;;    (hash-table-set! ht "xY" 2)
;;    (hash-table-set! ht "Xy" 1)
;;    (hash-table-keys ht))
;;
;; My interpretation is that they can answer either ("Xy") or ("xY"),
;; where `hash-table-values' will of course always answer (1), because
;; the keys are the same according to the equivalence function.  In this
;; implementation, both answer ("xY").  However, I don't guarantee that
;; this won't change in the future.

;;; Code:

;;;; Module definition & exports

(define-module (srfi srfi-69)
  #:use-module (srfi srfi-1)	;alist-cons,second&c,assoc
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-13)	;string-hash,string-hash-ci
  #:use-module (ice-9 optargs)
  #:export (;; Type constructors & predicate
	    make-hash-table hash-table? alist->hash-table
	    ;; Reflective queries
	    hash-table-equivalence-function hash-table-hash-function
	    ;; Dealing with single elements
	    hash-table-ref hash-table-ref/default hash-table-set!
	    hash-table-delete! hash-table-exists? hash-table-update!
	    hash-table-update!/default
	    ;; Dealing with the whole contents
	    hash-table-size hash-table-keys hash-table-values
	    hash-table-walk hash-table-fold hash-table->alist
	    hash-table-copy hash-table-merge!
	    ;; Hashing
	    string-ci-hash hash-by-identity)
  #:re-export (string-hash)
  #:replace (hash))

(cond-expand-provide (current-module) '(srfi-37))

;;;; Hashing

;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
;;; though not documented anywhere but libguile/numbers.c.

(define (caller-with-default-size hash-fn)
  "Answer a function that makes `most-positive-fixnum' the default
second argument to HASH-FN, a 2-arg procedure."
  (lambda* (obj #:optional (size most-positive-fixnum))
    (hash-fn obj size)))

(define hash (caller-with-default-size (@ (guile) hash)))

(define string-ci-hash string-hash-ci)

(define hash-by-identity (caller-with-default-size hashq))

;;;; Reflective queries, construction, predicate

(define-record-type srfi-69:hash-table
  (make-srfi-69-hash-table real-table associator size weakness
			   equivalence-function hash-function)
  hash-table?
  (real-table ht-real-table)
  (associator ht-associator)
  ;; required for O(1) by SRFI-69.  It really makes a mess of things,
  ;; and I'd like to compute it in O(n) and memoize it because it
  ;; doesn't seem terribly useful, but SRFI-69 is final.
  (size ht-size ht-size!)
  ;; required for `hash-table-copy'
  (weakness ht-weakness)
  ;; used only to implement hash-table-equivalence-function; I don't
  ;; use it internally other than for `ht-associator'.
  (equivalence-function hash-table-equivalence-function)
  (hash-function hash-table-hash-function))

(define (guess-hash-function equal-proc)
  "Guess a hash function for EQUAL-PROC, falling back on `hash', as
specified in SRFI-69 for `make-hash-table'."
  (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
	((eq? eq? equal-proc) hashq)
	((eq? eqv? equal-proc) hashv)
	((eq? string=? equal-proc) string-hash)
	((eq? string-ci=? equal-proc) string-ci-hash)
	(else (@ (guile) hash))))

(define (without-keyword-args rest-list)
  "Answer REST-LIST with all keywords removed along with items that
follow them."
  (let lp ((acc '()) (rest-list rest-list))
    (cond ((null? rest-list) (reverse! acc))
	  ((keyword? (first rest-list))
	   (lp acc (cddr rest-list)))
	  (else (lp (cons (first rest-list) acc) (cdr rest-list))))))

(define (guile-ht-ctor weakness)
  "Answer the Guile HT constructor for the given WEAKNESS."
  (case weakness
    ((#f) (@ (guile) make-hash-table))
    ((key) make-weak-key-hash-table)
    ((value) make-weak-value-hash-table)
    ((key-or-value) make-doubly-weak-hash-table)
    (else (error "Invalid weak hash table type" weakness))))

(define (equivalence-proc->associator equal-proc)
  "Answer an `assoc'-like procedure that compares the argument key to
alist keys with EQUAL-PROC."
  (cond ((or (eq? equal? equal-proc)
	     (eq? string=? equal-proc)) (@ (guile) assoc))
	((eq? eq? equal-proc) assq)
	((eq? eqv? equal-proc) assv)
	(else (lambda (item alist)
		(assoc item alist equal-proc)))))

(define* (make-hash-table
	  #:optional (equal-proc equal?)
	  (hash-proc (guess-hash-function equal-proc))
	  #:key (weak #f) #:rest guile-opts)
  "Answer a new hash table using EQUAL-PROC as the comparison
function, and HASH-PROC as the hash function.  See the reference
manual for specifics, of which there are many."
  (make-srfi-69-hash-table
   (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
   (equivalence-proc->associator equal-proc)
   0 weak equal-proc hash-proc))

(define (alist->hash-table alist . mht-args)
  "Convert ALIST to a hash table created with MHT-ARGS."
  (let* ((result (apply make-hash-table mht-args))
	 (size (ht-size result)))
    (with-hashx-values (hash-proc associator real-table) result
      (for-each (lambda (pair)
		  (let ((handle (hashx-get-handle hash-proc associator
						  real-table (car pair))))
		    (cond ((not handle)
			   (set! size (1+ size))
			   (hashx-set! hash-proc associator real-table
				       (car pair) (cdr pair))))))
		alist))
    (ht-size! result size)
    result))

;;;; Accessing table items

;; We use this to denote missing or unspecified values to avoid
;; possible collision with *unspecified*.
(define ht-unspecified (cons *unspecified* "ht-value"))

;; I am a macro only for efficiency, to avoid varargs/apply.
(define-macro (hashx-invoke hashx-proc ht-var . args)
  "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
assoc-function, and the hash-table as first args."
  `(,hashx-proc (hash-table-hash-function ,ht-var)
		(ht-associator ,ht-var)
		(ht-real-table ,ht-var)
		. ,args))

(define-macro (with-hashx-values bindings ht-var . body-forms)
  "Bind BINDINGS to the hash-function, associator, and real-table of
HT-VAR, while evaluating BODY-FORMS."
  `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
	 (,(second bindings) (ht-associator ,ht-var))
	 (,(third bindings) (ht-real-table ,ht-var)))
     . ,body-forms))

(define (hash-table-ref ht key . default-thunk-lst)
  "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
isn't present, or signal an error if DEFAULT-THUNK isn't provided."
  (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
    (if (eq? ht-unspecified result)
	(if (pair? default-thunk-lst)
	    ((first default-thunk-lst))
	    (error "Key not in table" key ht))
	result)))

(define (hash-table-ref/default ht key default)
  "Lookup KEY in HT and answer the value.  Answer DEFAULT if KEY isn't
present."
  (hashx-invoke hashx-ref ht key default))

(define (hash-table-set! ht key new-value)
  "Set KEY to NEW-VALUE in HT."
  (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
    (if (eq? ht-unspecified (cdr handle))
	(ht-size! ht (1+ (ht-size ht))))
    (set-cdr! handle new-value))
  *unspecified*)

(define (hash-table-delete! ht key)
  "Remove KEY's association in HT."
  (with-hashx-values (h a real-ht) ht
    (if (hashx-get-handle h a real-ht key)
	(begin
	  (ht-size! ht (1- (ht-size ht)))
	  (hashx-remove! h a real-ht key))))
  *unspecified*)

(define (hash-table-exists? ht key)
  "Return whether KEY is a key in HT."
  (and (hashx-invoke hashx-get-handle ht key) #t))

;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
;;; avoid creating a handle in case DEFAULT-THUNK exits
;;; `hash-table-update!' non-locally.
(define (hash-table-update! ht key modifier . default-thunk-lst)
  "Modify HT's value at KEY by passing its value to MODIFIER and
setting it to the result thereof.  Invoke DEFAULT-THUNK for the old
value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
provided."
  (with-hashx-values (hash-proc associator real-table) ht
    (let ((handle (hashx-get-handle hash-proc associator real-table key)))
      (cond (handle
	     (set-cdr! handle (modifier (cdr handle))))
	    (else
	     (hashx-set! hash-proc associator real-table key
			 (if (pair? default-thunk-lst)
			     (modifier ((car default-thunk-lst)))
			     (error "Key not in table" key ht)))
	     (ht-size! ht (1+ (ht-size ht)))))))
  *unspecified*)

(define (hash-table-update!/default ht key modifier default)
  "Modify HT's value at KEY by passing its old value, or DEFAULT if it
doesn't have one, to MODIFIER, and setting it to the result thereof."
  (hash-table-update! ht key modifier (lambda () default)))

;;;; Accessing whole tables

(define (hash-table-size ht)
  "Return the number of associations in HT.  This is guaranteed O(1)
for tables where #:weak was #f or not specified at creation time."
  (if (ht-weakness ht)
      (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
      (ht-size ht)))

(define (hash-table-keys ht)
  "Return a list of the keys in HT."
  (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))

(define (hash-table-values ht)
  "Return a list of the values in HT."
  (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))

(define (hash-table-walk ht proc)
  "Call PROC with each key and value as two arguments."
  (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec)
		   *unspecified*))

(define (hash-table-fold ht f knil)
  "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
the result of the previous invocation, using KNIL as the first PREV.
Answer the final F result."
  (hash-fold f knil (ht-real-table ht)))

(define (hash-table->alist ht)
  "Return an alist for HT."
  (hash-table-fold ht alist-cons '()))

(define (hash-table-copy ht)
  "Answer a copy of HT."
  (with-hashx-values (h a real-ht) ht
    (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
	   (new-real-ht ((guile-ht-ctor weak) size)))
      (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
		 #f real-ht)
      (make-srfi-69-hash-table		;real,assoc,size,weak,equiv,h
       new-real-ht a size weak
       (hash-table-equivalence-function ht) h))))

(define (hash-table-merge! ht other-ht)
  "Add all key/value pairs from OTHER-HT to HT, overriding HT's
mappings where present.  Return HT."
  (hash-table-fold
   ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
  ht)

;;; srfi-69.scm ends here


code:
;;; srfi-8.scm --- receive

;; Copyright (C) 2000, 2001, 2002, 2006 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-8)
  :use-module (ice-9 receive)
  :re-export-syntax (receive))

(cond-expand-provide (current-module) '(srfi-8))

;;; srfi-8.scm ends here


code:
;;; srfi-88.scm --- Keyword Objects

;; Copyright (C) 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; 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:

;; This is a convenience module providing SRFI-88 "keyword object".  All it
;; does is setup the right reader option and export keyword-related
;; convenience procedures.

;;; Code:

(define-module (srfi srfi-88)
  #:re-export (keyword?)
  #:export (keyword->string string->keyword))

(cond-expand-provide (current-module) '(srfi-88))

(read-set! keywords 'postfix)

(define (keyword->string k)
  "Return the name of @var{k} as a string."
  (symbol->string (keyword->symbol k)))

(define (string->keyword s)
  "Return the keyword object whose name is @var{s}."
  (symbol->keyword (string->symbol s)))

;;; Local Variables:
;;; coding: latin-1
;;; End:

;;; srfi-88.scm ends here


code:
;;; srfi-9.scm --- define-record-type

;; 	Copyright (C) 2001, 2002, 2006 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 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:

;; This module exports the syntactic form `define-record-type', which
;; is the means for creating record types defined in SRFI-9.
;;
;; The syntax of a record type definition is:
;;
;;  <record type definition>
;;    -> (define-record-type <type name>
;;         (<constructor name> <field tag> ...)
;;         <predicate name>
;;         <field spec> ...)
;;
;;  <field spec> -> (<field tag> <accessor name>)
;;               -> (<field tag> <accessor name> <modifier name>)
;;
;;  <field tag> -> <identifier>
;;  <... name>  -> <identifier>
;;
;; Usage example:
;;
;; guile> (use-modules (srfi srfi-9))
;; guile> (define-record-type :foo (make-foo x) foo?
;;                            (x get-x) (y get-y set-y!))
;; guile> (define f (make-foo 1))
;; guile> f
;; #<:foo x: 1 y: #f>
;; guile> (get-x f)
;; 1
;; guile> (set-y! f 2)
;; 2
;; guile> (get-y f)
;; 2
;; guile> f
;; #<:foo x: 1 y: 2>
;; guile> (foo? f)
;; #t
;; guile> (foo? 1)
;; #f

;;; Code:

(define-module (srfi srfi-9)
  :export-syntax (define-record-type))

(cond-expand-provide (current-module) '(srfi-9))

(define-macro (define-record-type type-name constructor/field-tag
		predicate-name . field-specs)
  `(begin
     (define ,type-name
       (make-record-type ',type-name ',(map car field-specs)))
     (define ,(car constructor/field-tag)
       (record-constructor ,type-name ',(cdr constructor/field-tag)))
     (define ,predicate-name
       (record-predicate ,type-name))
     ,@(map
	(lambda (spec)
	  (cond
	   ((= (length spec) 2)
	    `(define ,(cadr spec)
	       (record-accessor ,type-name ',(car spec))))
	   ((= (length spec) 3)
	    `(begin
	       (define ,(cadr spec)
		 (record-accessor ,type-name ',(car spec)))
	       (define ,(caddr spec)
		 (record-modifier ,type-name ',(car spec)))))
	   (else
	    (error "invalid field spec " spec))))
	field-specs)))

;;; srfi-9.scm ends here