;;;;
;;;; bonus.stk	-- Useful primitives not in R5RS
;;;;
;;;; Copyright © 2000-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 27-May-2011 22:58 (eg)
;;;;


#|
<doc EXT gensym
 * (gensym)
 * (gensym prefix)
 *
 * Creates a new symbol. The print name of the generated symbol
 * consists of a prefix (which defaults to ,(q [G|])) followed by the decimal
 * representation of a number. If |prefix| is specified, it must be
 * either a string or a symbol.
 * @lisp
 * (gensym)        => @pipeG100@pipe
 * (gensym "foo-") => foo-101
 * (gensym 'foo-)  => foo-102
 * @end lisp
doc>
|#
(define gensym
  (let ((counter 0))
    (lambda (:optional (prefix "G"))
      (when (symbol? prefix)
	(set! prefix (symbol->string prefix))
	(unless (string? prefix)
	  (error 'gensym "bad gensym prefix ~S" prefix)))
      (set! counter (+ counter 1))
      (string->uninterned-symbol (string-append prefix
						(number->string counter))))))


#|
<doc EXT remove remove!
 * (remove pred list)
 *
 * |Remove| returns |list| without the elements that satisfy predicate |pred|:
 * @l
 * The list is not disordered -- elements that appear in the result list occur
 * in the same order as they occur in the argument list. |Remove!| does the
 * same job than |remove| by physically modifying its |list| argument
 * @lisp
 * (remove even? '(0 7 8 8 43 -4)) => (7 43)
 * @end lisp
doc>
|#
(define (remove  pred l) (filter  (lambda (x) (not (pred x))) l))
(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))


#|
<doc EXT delete delete!
 * (delete  x list [=])
 * (delete! x list [=])
 *
 * |Delete| uses the comparison procedure |=|, which defaults to
 * |equal?|, to find all elements of |list| that are equal to |x|, and
 * deletes them from |list|. The dynamic order in which the various
 * applications of |=| are made is not specified.
 * @l
 * The list is not disordered -- elements that appear in the result
 * list occur in the same order as they occur in the argument list.
 * @l
 * The comparison procedure is used in this way: |(= x ei)|. That is,
 * |x| is always the first argument, and a list element is always the
 * second argument. The comparison procedure will be used to compare
 * each element of list exactly once; the order in which it is applied
 * to the various |ei| is not specified. Thus, one can reliably remove
 * all the numbers greater than five from a list with
 * @lisp
 * (delete 5 list <)
 * @end lisp
 *
 * |delete!| is the linear-update variant of |delete|. It is allowed,
 * but not required, to alter the cons cells in its argument |list| to
 * construct the result.
doc>
|#
(define (delete  x l :optional (comp equal?))
  (filter  (lambda (y) (not (comp x y))) l))

(define (delete! x l :optional (comp equal?))
  (filter! (lambda (y) (not (comp x y))) l))


#|
<doc EXT every
 * (every pred list1 list2 ...)
 *
 * |every| applies the predicate |pred| across the lists, returning true if
 * the predicate returns true on every application.
 * @l
 * If there are n list arguments |list1| ... |listn|, then |pred| must be
 * a procedure taking n arguments and returning a boolean result.
 * @l
 * |every| applies pred to the first elements of the |listi| parameters. If
 * this application returns false, every immediately returns |%f|.
 * Otherwise, it iterates, applying |pred| to the second elements of the |listi|
 * parameters, then the third, and so forth. The iteration stops when a
 * false value is produced or one of the lists runs out of values.
 * In the latter case, |every| returns the true value produced by its final
 * application of pred. The application of pred to the last element of the
 * lists is a tail call.
 * @l
 * If one of the |listi| has no elements, |every| simply returns |%t|.
 * @l
 * Like |any|, every's name does not end with a question mark -- this is to
 * indicate that it does not return a simple boolean (|%t| or |%f|), but a
 * general value.
doc>
|#
(define (every pred l . others)		;; compatible with SRFI-1
  (if (null? others)
      ;; EVERY called with mono argument predicate
      (letrec ((every (lambda (l)
			(if (null? l)
			    #t
			    (and (pred (car l)) (every (cdr l)))))))
	(every l))
      ;; General case
      (letrec ((every (lambda (l)
			(if (memq '() l)
			    #t
			    (and (apply pred (map car l))
				 (every (map cdr l)))))))
	(every (cons l others)))))

#|
<doc EXT any
 * (any pred list1 list2 ...)
 *
 * |any| applies the predicate across the lists, returning true if the
 * predicate returns true on any application.
 * @l
 * If there are n list arguments |list1| ... |listn|, then |pred| must be
 * a procedure taking n arguments.
 * @l
 * |any| applies |pred| to the first elements of the |listi| parameters. If
 * this application returns a true value, |any| immediately returns that value.
 * Otherwise, it iterates, applying |pred| to the second elements of the |listi|
 * parameters, then the third, and so forth. The iteration stops when a true
 * value is produced or one of the lists runs out of values; in the latter case,
 * any returns |%f|. The application of |pred| to the last element of the
 * lists is a tail call.
 * @l
 * Like every, |any|'s name does not end with a question mark -- this is
 * to indicate that it does not return a simple boolean (|%t| or |%f|), but
 * a general value.
 *
 * @lisp
 * (any integer? '(a 3 b 2.7))   => #t
 * (any integer? '(a 3.1 b 2.7)) => #f
 * (any < '(3 1 4 1 5)
 *        '(2 7 1 8 2))          => #t
 * @end lisp
doc>
|#
(define (any pred l . others)		;; compatible with SRFI-1
  (if (null? others)
      ;; ANY called with mono argument predicate
      (letrec ((any (lambda (l)
			(if (null? l)
			    #f
			    (or (pred (car l)) (any (cdr l)))))))
	(any l))
      ;; General case
      (letrec ((any (lambda (l)
			(if (memq '() l)
			    #f
			    (or (apply pred (map car l))
				 (any (map cdr l)))))))
	(any (cons l others)))))


;;;
;;; String Port functions
;;;
#|
<doc EXT call-with-input-string
 * (call-with-input-string string proc)
 *
 * behaves as |call-with-input-file| except that the port passed to |proc|
 * is the sting port obtained from |port|.
 * @lisp
 * (call-with-input-string "123 456"
 *   (lambda (x)
 *      (let* ((n1 (read x))
 *             (n2 (read x)))
 *         (cons n1 n2))))          => (123 . 456)
 * @end lisp
doc>
|#

(define call-with-input-string (%call-with open-input-string))

#|
<doc EXT call-with-output-string
 * (call-with-output-string proc)
 *
 * |Proc| should be a procedure of one argument. |Call-with-output-string|
 * calls |proc| with a freshly opened output string port. The result of
 * this procedure is a string containing all the text that has been written
 * on the string port.
 * @lisp
 * (call-with-output-string
 *   (lambda (x) (write 123 x) (display "Hello" x))) => "123Hello"
 * @end lisp
doc>
|#
(define (call-with-output-string proc)
  (let ((port (open-output-string)))
    (proc port)
    (close-port port)
    (get-output-string port)))

;;;
;;; Virtual Port functions
;;;
(define (open-input-virtual :key (read-char #f) (ready? #f) (eof? #f) (close #f))
  (%open-input-virtual (vector read-char ready? eof? close)))


(define (open-output-virtual :key (write-char #f) (write-string #f)
			     (flush #f) (close #f))
  (%open-output-virtual (vector write-char write-string flush close)))



;;;;
;;;; String functions
;;;;

#|
<doc EXT read-from-string
 * (read-from-string str)
 *
 * Performs a read from the given |str|. If |str| is the empty string,
 * an end of file object is returned.
 *
 * @lisp
 * (read-from-string "123 456") => 123
 * (read-from-string "")        => an eof object
 * @end lisp
doc>
|#
(define (read-from-string s)
  (let* ((p    (open-input-string s))
	 (expr (read p)))
    (close-port p)
    expr))

#|
<doc EXT eval-from-string
 * (eval-from-string str)
 * (eval-from-string str module)
 *
 * Read an expression from |str| and evaluates it with |eval|. If a |module|
 * is passed, the evaluation takes place in the environment of this module.
 * Otherwise, the evaluation takes place in the environment returned by
 * |current-module|.
 * @lisp
 * (define x 10)
 * (define-module M
 *   (define x 100))
 * (eval-from-string "(+ x x)")                   => 20
 * (eval-from-string "(+ x x)" (find-module 'M))  => 200
 * @end lisp
doc>
|#
(define (eval-from-string str :optional env)
  (eval (read-from-string str)
	env))




;;;;
;;;; System functions
;;;;

#|
<doc EXT argv
 * (argv)
 *
 * Returns a list of the arguments given on the shell command line. The
 * interpreter options are no included in the result
doc>
|#
(define (argv)
  (key-get *%program-args* :argv '()))

#|
<doc EXT program-name
 * (program-name)
 *
 * Returns the invocation name of the current program as a string.
doc>
|#
(define (program-name)
  (key-get *%program-args* :program-name))


#|
<doc EXT make-directories
 * (make-directories str)
 *
 * Create a directory with name |dir|. No error is signaled if |dir| already exists,
 * Parent directories of |dir| are created as needed.
doc>
|#
(define (make-directories path)
  (let ((dir (dirname path)))
    (unless (file-is-directory? dir)
      (make-directories dir))
    (make-directory path)))


#|
<doc EXT ensure-directories-exist
 * (ensure-directories-exist path)
 *
 * Create a directory with name |dir| (and its parent directories if needed), if it
 * does not exist yet.
doc>
|#
(define (ensure-directories-exist path)
  (unless (file-is-directory? path)
    (make-directories path)))

;;;;
;;;; Hash-tables functions
;;;;

#|
<doc EXT make-hash-table
 * (make-hash-table)
 * (make-hash-table comparison)
 * (make-hash-table comparison hash)
 *
 * |Make-hash-table| admits three different forms.  The most general form
 * admit two arguments. The first argument is a comparison function which
 * determines how keys are compared; the second argument is a function which
 * computes a hash code for an object and returns the hash code as a non
 * negative integer. Objets with the same hash code are stored in an A-list
 * registered in the bucket corresponding to the key.
 * @l
 * If omitted,
 * ,(itemize
 * (item [|hash| defaults to the |hash-table-hash| procedure (see
 * ,(ref :mark "hash-table-hash")).])
 * (item [|comparison| defaults to the |eq?| procedure (see ,(ref :mark "eq?")).])
 * )
 * Consequently,
 * @lisp
 * (define h (make-hash-table))
 * @end lisp
 * is equivalent to
 * @lisp
 * (define h (make-hash-table eq? hash-table-hash))
 * @end lisp
 *
 * An interesting example is
 * @lisp
 * (define h (make-hash-table string-ci=? string-length))
 * @end lisp
 * which defines a new hash table which uses |string-ci=?| for
 * comparing keys. Here, we use the string-length as a (very simple)
 * hashing function. Of course, a function which gives a key depending
 * of the characters composing the string gives a better repartition
 * and should probably enhance performances. For instance, the following
 * call to |make-hash-table| should return a more efficient, even if
 * not perfect, hash table:
 * @lisp
 * (make-hash-table
 *    string-ci=?
 *    (lambda (s)
 *      (let ((len (string-length s)))
 *        (do ((h 0)  (i 0 (+ i 1)))
 *            ((= i len) h)
 *          (set! h
 *                (+ h (char->integer
 *                       (char-downcase (string-ref s i)))))))))
 * @end lisp
 *
 * ,(bold "Note:") Hash tables with a comparison function equal to |eq?| or
 * |string=?| are handled in an more efficient way (in fact, they don't use
 * the |hash-table-hash| function to speed up hash table retrievals).
doc>
|#
(define (make-hash-table :optional (comparison eq?) (hash-func hash-table-hash))
  (%make-hash-table comparison hash-func))


#|
<doc EXT hash-table->alist
 * (hash-table->alist hash)
 *
 * Returns an ``association list'' built from the entries in |hash|.
 * Each entry in |hash| will be represented as a pair whose |car| is the
 * entry's key and whose |cdr| is its value.
 * @l
 * ,(bold "Note:") the order of pairs in the resulting list is unspecified.
 * @lisp
 * (let ((h (make-hash-table)))
 *   (dotimes (i 5)
 *     (hash-table-set! h i (number->string i)))
 *   (hash-table->alist h))
 *        => ((3 . "3") (4 . "4") (0 . "0")
 *            (1 . "1") (2 . "2"))
 * @end lisp
doc>
|#
(define (hash-table->alist h)
  (hash-table-map h cons))

#|
<doc EXT alist->hash-table
 * (alist->hash-table alist)
 * (alist->hash-table alist comparison)
 * (alist->hash-table alist comparison hash)
 *
 * Returns hash-table built from the ``association list''
 * |alist|. This function maps the |car| of every element in |alist|
 * to the |cdr| of corresponding elements in |alist|. the |comparison| and
 * |hash| functions are interpreted as in |make-hash-table|. If some key
 * occurs multiple times in |alist|, the value in the first
 * association will take precedence over later ones.
 *
doc>
|#
(define (alist->hash-table lst :optional (comp eq?) (hash hash-table-hash))
  (let ((ht (make-hash-table comp hash)))
    (for-each (lambda (x)
		(if (not (hash-table-exists? ht (car x)))
		    (hash-table-set! ht (car x) (cdr x))))
	      lst)
    ht))


#|
<doc EXT  hash-table-update!/default hash-table-update!
 * (hash-table-update! hash key update-fun thunk)
 * (hash-table-update!/default hash key update-fun default)
 *
 * Update the value associated to |key| in table |hash| if key is already in
 * table with the value |(update-fun current-value)|. If no value is
 * associated to |key|, a new entry in the table is first inserted
 * before updating it (this new entry being the result of calling |thunk|).
 * @l
 * Note that the expression
 * @lisp
 * (hash-table-update!/default hash key update-fun default)
 * @end lisp
 * is equivalent to
 * @lisp
 * (hash-table-update! hash key update-fun (lambda () default))
 * @end lisp
 *
 * @lisp
 * (let ((h   (make-hash-table))
 *       (1+  (lambda (n) (+ n 1))))
 *   (hash-table-update!/default h 'test 1+ 100)
 *   (hash-table-update!/default h 'test 1+)
 *   (hash-table-ref h 'test))             => 102
 * @end lisp
doc>
|#
(define (hash-table-update! hash key func :optional (thunk #f thunk?))
  (let ((value (if thunk?
		   (hash-table-ref hash key thunk)
		   (hash-table-ref hash key))))
    (hash-table-set! hash key (func value))))

(define (hash-table-update!/default hash key func default)
  (let ((value (hash-table-ref/default hash key default)))
    (hash-table-set! hash key (func value))))


#|
<doc EXT hash-table-values hash-table-keys
 * (hash-table-keys hash)
 * (hash-table-values hash)
 *
 * Returns the keys or the values of |hash|.
doc>
|#
(define (hash-table-keys ht)
  (hash-table-map ht (lambda (x y) x)))

(define (hash-table-values ht)
  (hash-table-map ht (lambda (x y) y)))

#|
<doc EXT hash-table-fold
 * (hash-table-fold hash func init-value)
 *
 * This procedure calls |func| for every association in |hash|
 * with three arguments: the key of the association key, the value
 * of the association value, and an accumulated value, |val|. |Val| is
 * init-value for the first invocation of |func|, and for subsequent
 * invocations of |func|, the return value of the previous invocation of
 * |func|. The value |final-value| returned by |hash-table-fold| is the
 * return value of the last invocation of |func|. The order in which |func| is
 * called for different associations is unspecified.
 * @l
 * For instance, the following expression
 * @lisp
 * (hash-table-fold ht (lambda (k v acc) (+ acc 1)) 0)
 * @end lisp
 * computes the number of associations present in the |ht| hash table.
doc>
|#
(define (hash-table-fold ht func val)
  (hash-table-for-each ht
		       (lambda (key value)
			 (set! val (func key value val))))
  val)

#|
<doc EXT hash-table-merge!
 * (hash-table-merge! hash1 hash2)
 *
 * Adds all mappings in |hash2| into |hash1| and returns the resulting
 * hash table. This function may modify |hash1| destructively.
doc>
|#
(define (hash-table-merge! ht1 ht2)
  (hash-table-for-each ht2 (lambda (key val) (hash-table-set! ht1 key val)))
  ht1)


#|
<doc EXT hash-table-copy
 * (hash-table-copy hash)
 *
 * Returns a copy of |hash|.
doc>
|#
(define (hash-table-copy ht)
  (let ((new (make-hash-table (hash-table-equivalence-function ht)
			      (hash-table-hash-function ht))))
    (hash-table-merge! new ht)))

;; ======================================================================



#|
<doc EXT-SYNTAX fluid-let
 * (fluid-let <bindings> <body>)
 *
 * The |<bindings>| are evaluated in the current environment, in some
 * unspecified order, the current values of the variables present in
 * |<bindings>| are saved, and the new evaluated values are assigned to the
 * |<bindings>| variables. Once this is done, the expressions of |<body>|
 * are evaluated sequentially in the current environment; the value of the
 * last expression is the result of |fluid-let|. Upon exit, the stored
 * variables values are restored. An error is signalled if any of the
 * |<bindings>| variable is unbound.
 * @lisp
 * (let* ((a 'out)
 *        (f (lambda () a)))
 *   (list (f)
 *         (fluid-let ((a 'in)) (f))
 *         (f))) => (out in out)
 * @end lisp
 *
 * When the body of a |fluid-let| is exited by invoking a continuation,
 * the new variable values are saved, and the variables are set to their old
 * values. Then, if the body is reentered by invoking a continuation, the old
 * values are saved and new values are restored. The following example illustrates
 * this behavior
 *
 * @lisp
 * (let ((cont #f)
 *       (l    '())
 *       (a    'out))
 *   (set! l (cons a l))
 *   (fluid-let ((a 'in))
 *     (set! cont (call-with-current-continuation (lambda (k) k)))
 *     (set! l (cons a l)))
 *   (set! l (cons a l))
 *
 *   (if cont (cont #f) l)) =>  (out in out in out)
 * @end lisp
doc>
|#
(define-macro (fluid-let bindings . body)
  (let* ((vars (map car bindings))
	 (vals (map cadr bindings))
	 (tmps (map (lambda (x) (gensym)) vars)))
    `(let ,(map list tmps vars)
       (dynamic-wind
	  (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals))
	  (lambda () ,@body)
	  (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps))))))

;;;;
;;;; SETTERS
;;;;
#|
<doc setter
 * (setter proc)
 *
 * Returns the setter associated to a |proc|. Setters are defined in the
 * ,(link-srfi 17) document. A setter proc, can be used in a generalized
 * assignment, as described in |set!|.
 * @l
 * To associate |s| to the procedure |p|, use the following form:
 * @lisp
 * (set! (setter p) s)
 * @end lisp
 * For instance, we can write
 * @lisp
 * (set! (setter car) set-car!)
 * @end lisp
 *
 * The following standard procedures have pre-defined setters:
 * @lisp
 * (set! (car x) v)              == (set-car! x v)
 * (set! (cdr x) v)              == (set-cdr! x v)
 * (set! (string-ref x i) v)     == (string-set! x i v)
 * (set! (vector-ref x i) v)     == (vector-set! x i v)!
 * (set! (slot-ref x 'name) v)   == (slot-set! x 'name v)
 * (set! (struct-ref x 'name) v) == (struct-set! x 'name v)
 * @end lisp
 * Furhermore, ,(ref :section "Parameter Objects" :text "parameters objects")
 * are their own setter:
 * @lisp
 * (real-precision)              => 15
 * (set! (real-precision) 12)
 * (real-precision)              => 12
 * @end lisp
doc>
|#
(define (setter proc)
  (if (or (generic? proc) (parameter? proc))
      proc
      (or (key-get (%procedure-plist proc) :setter #f)
	  (error 'setter "no setter defined for ~S" proc))))


;; Initialize the setter of setter !!
(%set-procedure-plist!
         setter
	 (list :setter
	       (lambda (proc setter)
		 (%set-procedure-plist! proc
					(key-set! (%procedure-plist proc)
						  :setter
						  setter)))))

;; And now set some setter for primitive functions
(set! (setter car) 	  	set-car!)
(set! (setter cdr) 	  	set-cdr!)
(set! (setter vector-ref) 	vector-set!)
(set! (setter string-ref) 	string-set!)
(set! (setter slot-ref) 	slot-set!)
(set! (setter struct-ref) 	struct-set!)


;=============================================================================

#|
<doc EXT-SYNTAX time
 * (time expr1 expr2 ...)
 *
 * Evaluates the expressions |expr1|, |expr2|, ... and returns the
 * result of the last expression. This form prints also the time spent
 * for this evaluation on the current error port.
doc>
|#
(define-macro time
  (lambda args
    (let ((tmp1 (gensym))
	  (tmp2 (gensym)))
      `(let* ((,tmp1 (clock))
	      (,tmp2 (begin ,@args)))
	 (format (current-error-port) "Elapsed time: ~S ms\n" (- (clock) ,tmp1))
	 ,tmp2))))




#|
<doc EXT-SYNTAX dotimes
 * (dotimes [var count] <expression1> <expression2> ... )
 * (dotimes [var count result] <expression1> <expression2> ... )
 *
 * Evaluates the |count| expression, which must return an
 * integer and then evaluates the |<expression>|s once for each
 * integer from zero (inclusive) to |count| (exclusive), in order,
 * with the symbol |var| bound to the integer; if the value of
 * |count| is zero or negative, then the |<expression>|s are not
 * evaluated. When the loop completes, |result| is evaluated and its
 * value is returned as the value of the |dotimes| construction. If
 * |result| is omitted, |dotimes| result is ,(emph "void").
 * @lisp
 * (let ((l '()))
 *   (dotimes (i 4 l)
 *      (set! l (cons i l)))) => (3 2 1 0)
 * @end lisp
doc>
|#
(define-macro (dotimes bindings . body)
  (apply (lambda (var count . result)
	   (let ((limit  (gensym))
		 (result (if (null? result) (list '(void)) result)))
	     `(let ((,limit ,count))
		(do ((,var 0 (+ ,var 1)))
		    ((>= ,var ,limit) ,@result)
		  ,@body))))
	 bindings))

#|
<doc EXT-SYNTAX while
 * (while <test> <expression1> <expression2> ...)
 *
 * |While| evaluates the |<expression>|s until |<test>| returns a false
 * value. The value returned by this form is ,(emph "void").
doc>
|#
(define-macro (while test . body)
  (let ((lab (gensym)))
    `(let ,lab ()
	  (when ,test ,@body (,lab)))))

#|
<doc EXT-SYNTAX until
 * (until <test> <expression1> <expression2> ...)
 *
 * |Until| evaluates the |<expression>|s until |<while>| returns a false
 * value. The value returned by this form is ,(emph "void").
doc>
|#
(define-macro (until test . body)
  (let ((lab (gensym)))
    `(let ,lab ()
	  (unless ,test ,@body (,lab)))))



#|
<doc EXT call/ec
 * (call/ec proc)
 *
 * |call/ec| is an short name for |call-with-escape-continuation|. |call/ec|
 * calls |proc| with one parameter, which is the current escape continuation
 * (a continuation which can only be used to abort a computation and hence
 * cannot be "re-enterered".
 *
 * @lisp
 * (list 1
 *       (call/ec (lambda (return) (list 'a (return 'b) 'c)))
 *       3)        => (1 b 3)
 * @end lisp
 * |call/ec| is cheaper than the full call/cc. It is particularily useful
 * when all the power of |call/cc| is not needded.
doc>
|#
(define (call/ec proc)
  (let ((tag   (gensym "call/ec")))
    (with-handler
        (lambda (c)
	  (if (and (pair? c) (eq? (car c) tag))
	      (apply values (cdr c))
	      (raise c)))
	(proc (lambda l (raise (cons tag l)))))))


;; ======================================================================
;;	base64 ...
;; ======================================================================
#|
<doc EXT base64-encode-string
 * (base64-encode-string str)
 *
 * Return a string contening the contents of |str| converted to Base64
 * encoded format
doc>

<doc EXT base64-decode-string
 * (base64-encode-string str)
 *
 * Decode the contents of |str| expressed in Base64.
doc>
|#
(define base64-encode-string #f)
(define base64-decode-string #f)
(let ((encode/decode (lambda (op)
		       (lambda (str)
			 (let ((in  (open-input-string str))
			       (out (open-output-string)))
			   (op in out)
			   (get-output-string out))))))

  (set! base64-encode-string (encode/decode base64-encode))
  (set! base64-decode-string (encode/decode base64-decode)))

;; ======================================================================
;;	md5sum ...
;; ======================================================================
#|
<doc EXT md5sum-file
 * (md5sum-file str)
 *
 * Return a string contening the md5 dum of the file whose name is |str|.
doc>
|#
(define (md5sum-file path)
  (let ((port (open-file path "r")))
    (if port
	(let ((res (md5sum port)))
	  (close-input-port port)
	  res)
	(error "cannot read file ~s" path))))

;; ======================================================================
;;	ansi-color  & ansi-color-protect...
;; ======================================================================
(define ansi-color 	   #f)
(define ansi-color-protect #f)

(let ((ansi-color-start   "\e[")
      (ansi-color-stop    "m"))

  (define (code c)
    (let ((alist '((normal	. "0")
		   (bold 	. "1")  (no-bold 	. "21")
		   (italic 	. "2")  (no-italic	. "22")
		   (underline	. "4")  (no-undeline	. "24")
		   (blink 	. "5")  (no-blink	. "25")
		   (reverse 	. "7")  (no-reverse	. "27")
		   (black 	. "30") (bg-black	. "40")
		   (red 	. "31") (bg-red		. "41")
		   (green 	. "32") (bg-green	. "42")
		   (yellow 	. "33") (bg-yellow	. "43")
		   (blue 	. "34") (bg-blue	. "44")
		   (magenta	. "35") (bg-magenta	. "45")
		   (cyan 	. "36") (bg-cyan	. "46")
		   (white 	. "37") (bg-white	. "47"))))
      (let ((v (assoc c alist)))
	(if v (cdr v) ""))))

  ;; ansi-color-protect ...
  (set! ansi-color-protect
    (lambda (start stop)
      (set! ansi-color-start (string-append start "\e["))
      (set! ansi-color-stop  (string-append "m" stop))))

  ;; ansi-color ...
  (set! ansi-color
    (lambda  args
      (let Loop ((args        args)
		 (str-prev?  #t)
		 (res         ""))
	(cond
	  ((null? args)
	     (if str-prev?
		 res
		 (string-append res ansi-color-stop)))
	  ((string? (car args))
	     (Loop (cdr args)
		   #t
		   (string-append res
				  (if str-prev? "" ansi-color-stop)
				  (car args))))
	  ((symbol? (car args))
	     (Loop (cdr args)
		   #f
		   (string-append res
				  (if  str-prev? ansi-color-start ";")
				  (code (car args)))))
	  (else (error 'ansi-color "bad command ~S" args)))))))

(define do-color
  (if (and (not (key-get *%program-args* :interactive #f))
	   (member (getenv "TERM")
		   '("rxvt" "xterm" "xterm-color" "linux" "cygwin" "cons25")))
      ;; Terminal accepts color
      ansi-color
      ;; Provide a procedure which ignore color indications
      (lambda args
	(apply string-append
	       (map (lambda (x) (if (string? x) x ""))
		    args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Port conversions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
<doc EXT port->string  port->sexp-list port->string-list
 * (port->string port)
 * (port->sexp-list port)
 * (port->string-list port)
 *
 * All these procedure take a port opened for reading. |Port->string| reads
 * |port| until the it reads an end of file object and returns all the
 * characters read as a string. |Port->sexp-list)| and |port->string-list|
 * do the same things except that they return a list of S-expressions and
 * a list of strings respectively. For the following example we suppose that
 * file |"foo"| is formed of two lines which contains respectively the number
 * |100| and the string |"bar"|.
 * @lisp
 * (port->sexp-list (open-input-file "foo"))   => (100 "bar")
 * (port->string-list (open-input-file "foo")) => ("100" "\"bar\"")
 * @end lisp
doc>
|#
(define (%port->list reader p)
  (unless (input-port? p) (error 'port->list "bad port ~S" p))
  ;; Read all the lines of port and put them in a list
  (let loop ((res '()) (sexp (reader p)))
    (if (eof-object? sexp)
	(values (reverse res))
	(loop (cons sexp res) (reader p)))))

(define (port->string p)
  (unless (input-port? p) (error "bad port ~S" p))
  (with-output-to-string
    (lambda () (copy-port p (current-output-port)))))

(define (port->sexp-list p)
  (%port->list read p))

(define (port->string-list p)
  (%port->list read-line p))


#|
<doc EXT print printerr
 * (print obj ...)
 * (printerr obj ...)
 *
 * These procedures display all their arguments followed by a newline. The
 * procedure |print| uses the standard output port, whereas |printerr| uses the
 * current error port
doc>
|#
(define (print . l)
  (for-each display l)
  (newline))

(define (printerr . l)
  (let ((p (current-error-port)))
    (for-each (lambda (x) (display x p)) l)
    (newline p)))


#|
<doc EXT printf fprintf eprintf
 * (printf fmt obj ...)
 * (fprintf port fmt obj ...)
 * (eprintf fmt obj ...)
 *
 * These procedures are specialized version of |,(ref :mark "format" "format")|.
 * In these procedures, |fmt| is a string using the |format| conventions.
 * |printf| outputs go on the current output port.
 * |fprintf| outputs go on the specified |port|.
 * |eprintf| outputs go on the current error port (note that eprintf always
 * flushes the characters printed).
doc>
|#
(define (eprintf fmt . args)
  (display (apply format fmt args) (current-error-port))
  (flush-output-port (current-error-port)))

(define (printf fmt . args)
  (display (apply format fmt args)))

(define (fprintf port fmt . args)
  (display (apply format fmt args) port))


#|
<doc EXT-SYNTAX declare-new-error
 * (declare-new-error name)
 *
 * TODO
 *
doc>
|#
(define-macro (declare-new-error name)
  (let ((cond-name (string->symbol (format "&~a" name)))
	(predicate (string->symbol (format "&~a?" name)))
	(args      (gensym)))
    `(begin
       (define-condition-type ,cond-name &error-message ,predicate)
       (define (,name . ,args)
	 (if (and (not (null? ,args))
		  (symbol? (car ,args)))
	     (apply signal-error ,cond-name ,args)
	     (apply signal-error ,cond-name ',name ,args))))))

#|
<doc EXT  exec exec-list
 * (exec str)
 * (exec-list str)
 *
 * These procedures execute the command given in |str|. The command given
 * in |str| is passed to |/bin/sh|. |Exec| returns a strings which contains
 * all the characters that the command |str| has printed on it's standard
 * output, whereas |exec-list| returns a list of the lines which constitute
 * the output of |str|.
 * @lisp
 * (exec "echo A; echo B")                => "A\\nB\\n"
 * (exec-list "echo A; echo B")           => ("A" "B")
 * @end lisp
doc>
|#
(define (exec command)
  (call-with-input-file (string-append "| " command) port->string))

(define (exec-list command)
  (call-with-input-file (string-append "| " command) port->string-list))


#|
<doc EXT argc
 * (argc)
 *
 * Returns the number of argument present on the command line
doc>
|#
(define argc (lambda () (length (argv))))


#|
<doc EXT apropos
 * (apropos obj)
 * (apropos obj module)
 *
 * |Apropos| returns a list of symbols whose print name contains the
 * characters of |obj| as a substring . The given |obj| can be a string or
 * symbol. This function returns the list of matched symbols which can
 * be accessed from the given |module| (defaults to the current module if not
 * provided).
 *
doc>
|#
(define (apropos str :optional (module (current-module)))

  (define (list->set lst res)
    (cond
      ((null? lst) res)
      ((memq (car lst) res) (list->set (cdr lst) res))
      (else (list->set (cdr lst) (cons (car lst) res)))))

  (define (symbol<? s1 s2)
    (string<? (symbol->string s1) (symbol->string s2)))

  ;; Sanity check
  (unless (module? module)
    (error 'apropos "bad module ~S" module))

  ;; Here we go
  (let ((s        (if (symbol? str) (symbol->string str) str))
	(external (apply append (map module-exports (module-imports module))))
	(internal (module-symbols module)))
    (let Loop ((symbs (list->set (append internal external) '()))
	       (res   '()))
      (cond
	((null? symbs)
	   (and (not (null? res)) (sort res symbol<?)))
	((string-find? s (symbol->string (car symbs)))
	   (Loop (cdr symbs) (cons (car symbs) res)))
	(else
	   (Loop (cdr symbs) res))))))

#|
<doc EXT die
 * (die message)
 * (die message status)
 *
 * |Die| prints the given |message| on the current error port and exits
 * the program with the |status| value. If |status| is omitted, it
 * defaults to 1.
doc>
|#
(define (die message :optional (status 1))
  (format (current-error-port) "**** ~A\n**** EXIT\n" message)
  (exit status))


#|
<doc EXT decompose-file-name
 * (decompose-file-name string)
 *
 * Returns an ``exploded'' list of the path name components given in
 * |string|.
 * The first element in the list denotes if the given |string| is an
 * absolute path or a relative one, being "/" or "." respectively.
 * Each component of this list is a string.
 * @lisp
 * (decompose-file-name "/a/b/c.stk") => ("/" "a" "b" "c.stk")
 * (decompose-file-name "a/b/c.stk")  => ("." "a" "b" "c.stk")
 * @end lisp
doc>

<doc EXT dirname
 * (dirname str)
 *
 * Returns a string containing all but the last component of the path
 * name given in |str|.
 * @lisp
 * (dirname "/a/b/c.stk") => "/a/b"
 * @end lisp
doc>

<doc EXT basename
 * (basename str)
 *
 * Returns a string containing the last component of the path name
 * given in |str|.
 * @lisp
 * (basename "/a/b/c.stk") => "c.stk"
 * @end lisp
doc>
|#
(if (eq? (running-os) 'cygwin-windows)
    [begin
      (define (decompose-file-name str)
	(let ((str (posixify-file-name str)))
	  (cons (if (and (> (string-length str) 0)
			 (char=? (string-ref str 0) #\/))
		    "/"
		    ".")
		(string-split str "/"))))

      (define (dirname str)
	(let ((str (posixify-file-name str)))
	  (let ((res (regexp-replace "^(.*)/(.+)$" str "\\1")))
	    (cond
	      ((string=? res "")   "/")
	      ((string=? res str)  ".")
	      (else		 res)))))

      (define (basename str)
	(let ((str (posixify-file-name str)))
	  (regexp-replace "^(.*)/(.*)$" str "\\2")))
    ]
    [begin
      (define (decompose-file-name str)
	(cons (if (and (> (string-length str) 0)
		       (char=? (string-ref str 0) #\/))
		  "/"
		  ".")
	      (string-split str "/")))

      (define (dirname str)
	(let ((res (regexp-replace "^(.*)/(.+)$" str "\\1")))
	  (cond
	    ((string=? res "")   "/")
	    ((string=? res str)  ".")
	    (else		 res))))

      (define (basename str)
	(regexp-replace "^(.*)/(.*)$" str "\\2"))
      ])

#|
<doc EXT file-separator
 * (file-separator)
 *
 * Retuns the operating system file separator as a character. This is typically
 * #\\/ on Unix (or Cygwin) systems and #\\\\ on Windows.
doc>
|#
(define (file-separator)
  (case (running-os)
    ((unix cygwin-windows)    #\/)
    ((windows) 		      #\\)
    (else      		      #\?)))

#|
<doc EXT make-path
 * (make-path dirname .  names)
 *
 * Builds a file name from the directory |dirname| and |names|. For instance,
 * on a Unix system:
 * @lisp
 * (make-path "a" "b" "c")   => "a/b/c"
 * @end lisp
doc>
|#
(define (make-path dirname . names)
  (if (null? names)
      dirname
      (apply make-path
	     (format "~A~A~A" dirname (file-separator) (car names))
	     (cdr names))))


#|
<doc EXT file-suffix
 * (file-suffix pathname)
 *
 * Returns the suffix of given |pathname|. If no suffix is found, |file-suffix|
 * returns an empty string.
 * @lisp
 * (file-suffix "./foo.tar.gz") => "gz"
 * (file-suffix "./a.b/c")      => ""
 * @end lisp
doc>
|#
(define (file-suffix pathname)
  (let ((end (string-length pathname)))
    (let loop ((i (- end 1)))
      (if (< i 0)
          ""
          (let ((c (string-ref pathname i)))
            (cond
	      ((char=? c #\.)
	       (substring pathname (+ i 1) end))
	      ((char=? c (file-separator))
	       "")
	      (else
	       (loop (- i 1)))))))))

#|
<doc EXT file-prefix
 * (file-prefix pathname)
 *
 * Returns the suffix of given |pathname|.
 * @lisp
 * (file-prefix "./foo.tar.gz") => "./foo.tar"
 * (file-prefix "./a.b/c")      => "./a.b/c"
 * @end lisp
doc>
|#
(define (file-prefix pathname)
  (let ((end (string-length pathname)))
    (let loop ((i (- end 1)))
      (if (< i 0)
          pathname
          (let ((c (string-ref pathname i)))
            (cond
	      ((char=? c #\.)
	       (substring pathname 0 i))
	      ((char=? c (file-separator))
	       pathname)
	      (else
	       (loop (- i 1)))))))))


#|
<doc  EXT port-idle-register! port-idle-unregister! port-idle-reset!
 * (port-idle-register! port thunk)
 * (port-idle-unregister! port thunk)
 * (port-idle-reset! port)
 *
 * |port-idle-register!| allows to register |thunk| as an idle handler
 * when reading on port. That means that |thunk| will be called continuously
 * while waiting  an input on |port| (and only while using a reading
 * primitive on this port). |port-idle-unregister!| can be used to
 * unregister a handler previously set by |port-idle-register!|. The
 * primitive |port-idle-reset!| unregisters all the handlers set on
 * |port|.
 *
 * Hereafter is a (not too realistic) example: a message will be displayed
 * repeatedly until a ,(emph "sexpr") is read on the current input port.
 *
 * @lisp
 * (let ((idle (lambda () (display "Nothing to read!\\n"))))
 *   (port-idle-register! (current-input-port) idle)
 *   (let ((result (read)))
 *     (port-idle-unregister! (current-input-port) idle)
 *     result))
 * @end lisp
doc>
|#

(define (port-idle-register! port proc)
  (unless (procedure? proc) (error 'port-idle-register! "bad procedure ~S" proc))
  (let ((idle (%port-idle port)))
    (%port-idle port (cons proc idle))))

(define (port-idle-unregister! port proc)
  (unless (procedure? proc) (error 'port-idle-unregister! "bad procedure ~S" proc))
  (let ((idle (%port-idle port)))
    (%port-idle port (delete! proc idle))))

(define (port-idle-reset! port)
  (%port-idle port '()))



#|
<doc EXT chmod
 * (chmod str)
 * (chmod str option1 ...)
 *
 * Change the access mode of the file whose path name is given in |string|.
 * The options must be composed of either an integer or one of the
 * following symbols |read|, |write| or |execute|. Giving no option to |chmod|
 * is equivalent to pass it the integer |0|. If the operation succeeds,
 * |chmod| returns |%t|; otherwise it returns |%f|.
 *
 * @lisp
 * (chmod "~/.stklos/stklosrc" 'read 'execute)
 * (chmod "~/.stklos/stklosrc" #o644)
 * @end lisp
doc>
|#
(define (chmod file . opt)
  (let ((file (if (string? file) (expand-file-name file) file))
	(mode 0))
    (let Loop ((opt opt))
      (cond
	((null? opt)
	   (%chmod file mode))
	((symbol? (car opt))
	   (case (car opt)
	     ((read)    (set! mode (bit-or mode #o400)))
	     ((write)   (set! mode (bit-or mode #o200)))
	     ((execute) (set! mode (bit-or mode #o100)))
	     (else      (error 'chmod "bad option ~S" (car opt))))
	   (Loop (cdr opt)))
	((integer? (car opt))
	 (%chmod file (car opt)))
	(else
	   (error 'chmod "bad option ~S" (car opt)))))))

#|
<doc EXT with-mutex
 * (with-mutex mtx <body>)
 *
doc>
|#
(define (with-mutex mtx  proc)
  (dynamic-wind
      (lambda () (mutex-lock! mtx))
      (proc)
      (lambda () (mutex-unlock! mtx))))


;;;; ======================================================================
;;;;
;;;; SRFIs support
;;;;
;;;; ======================================================================

;;;
;;; SRFI-8
;;;


#|
<doc EXT-SYNTAX receive
 * (receive <formals> <expression> <body>)
 *
 * This form is defined in ,(link-srfi 8). It simplifies
 * the usage of multiple values. Specifically, |<formals>| can have any
 * of three forms:
 * ,(itemize
 * (item [(|<variable1>| ... |<variablen>|):
 * ,(linebreak)
 * The environment in which the
 * receive-expression is evaluated is extended by binding |<variable1>|, ...,
 * |<variablen>| to fresh locations.
 * @l
 * The |<expression>| is evaluated, and its
 * values are stored into those locations. (It is an error if |<expression>|
 * does not have exactly n values.)
 * ])
 * (item [|<variable>|:
 * ,(linebreak)
 * The environment in which the receive-expression is
 * evaluated is extended by binding |<variable>| to a fresh location.
 * The |<expression>| is evaluated, its values are converted into a newly
 * allocated list, and the list is stored in the location bound to |<variable>|.
 * ])
 * (item [(|<variable1>| ... |<variablen>| . |<variablen + 1>|):
 * ,(linebreak)
 * The environment
 * in which the receive-expression is evaluated is extended by binding
 * |<variable1>|, ..., |<variablen + 1>| to fresh locations.
 * The |<expression>| is evaluated. Its first n values are stored into the
 * locations bound to |<variable1>| ... |<variablen>|. Any remaining values
 * are converted into a newly allocated list, which is stored into the location
 * bound to |<variablen + 1>|. (It is an error if |<expression>| does not have
 * at least n values.)])
 * )
 *
 * In any case, the expressions in |<body>| are evaluated sequentially in
 * the extended environment. The results of the last expression in the body
 * are the values of the receive-expression.
 * @lisp
 * (let ((n 123))
 *   (receive (q r)
 *      (values (quotient n 10) (modulo n 10))
 *      (cons q r)))
 *               => (12 . 3)
 * @end lisp
doc>
|#
(define-macro (receive vars producer . body)
  `(call-with-values (lambda () ,producer)
		     (lambda ,vars ,@body)))

;;
;; SRFI-16: "Syntax for procedures of variable arity"
;;
#|
<doc EXT-SYNTAX case-lambda
 * (case-lambda <clause> ...)
 *
 * Each |<clause>| should have the form |(<formals> <body>)|, where
 * |<formals>| is a formal arguments list as for |lambda|.
 * Each |<body>| is a |<tail-body>|, as defined in R5RS.
 * @l
 * A |case-lambda| expression evaluates to a procedure that
 * accepts a variable number of arguments and is lexically scoped in
 * the same manner as procedures resulting from |lambda|
 * expressions. When the procedure is called with some arguments
 * |v1 ... vk|, then the first |<clause>| for which the arguments agree
 * with |<formals>| is selected, where agreement is specified as for the
 * |<formals>| of a |lambda| expression. The variables of |<formals>|
 * are bound to fresh locations, the values |v1 ... vk| are stored in those
 * locations, the |<body>| is evaluated in the extended environment,
 * and the results of |<body>| are returned as the results of the
 * procedure call.
 * @l
 * It is an error for the arguments not to agree with the |<formals>|
 * of any |<clause>|.
 * @l
 * This form is defined in ,(link-srfi 16).
 *
 * @lisp
 *  (define plus
 *    (case-lambda
 *     (() 0)
 *     ((x) x)
 *     ((x y) (+ x y))
 *     ((x y z) (+ (+ x y) z))
 *     (args (apply + args))))
 *
 *  (plus)                     => 0
 *  (plus 1)                   => 1
 *  (plus 1 2 3)               => 6
 *
 *  ((case-lambda
 *    ((a) a)
 *    ((a b) (* a b)))
 *   1 2 3)                    => error
 * @end lisp
doc>
|#
(define-macro (case-lambda . clauses)
  (let ((len  (gensym))
	(args (gensym))
	(compute-arity (in-module STKLOS-COMPILER compute-arity)))
    `(lambda ,args
       (let ((,len (length ,args)))
	 (cond
	   ,@(map (lambda (x)
		    (unless (>= (length x) 2)
		      (error 'case-lambda "bad clause ~S" x))
		    (let* ((formals (car x))
			   (body    (cdr x))
			   (arity   (compute-arity formals)))
		      (cond
			((positive? arity)
			    `((= ,len ,arity)
			      (apply (lambda ,formals ,@body) ,args)))
			((zero? arity)
			    `((= ,len ,arity)
			      ,@body))
			(else
			    `((>= ,len ,(- (- arity) 1))
			        (apply (lambda ,formals ,@body) ,args))))))
		  clauses)
	   (else (error 'case-lambda "no matching clause in list ~S for ~S"
			',(map car clauses) ,args)))))))

;;
;; SRFI-38: "External Representation for Data With Shared Structure"
;;
(define read-with-shared-structure read)

(define (write-with-shared-structure obj :optional (port (current-output-port))
				     		   (optarg #f))
  ;; optarg is unspecified in SRFI-38, it is a hook for implementation
  ;; We don't use it
  (write* obj port))

(define read/ss read-with-shared-structure)
(define write/ss write-with-shared-structure)

;;
;; Macro used by SRFI-35 & SRFI-36 implementations
;;
(define-macro (%define-condition-type-accessors name supertype predicate . slots)
  (let ((obj (gensym)))
    `(begin
       ;; define the predicate
       (define (,predicate ,obj)
	 (and (condition? ,obj) (condition-has-type? ,obj ,name)))
       ;; define the accessors
       ,@(map (lambda(x)
		`(define (,(cadr x) ,obj)
		   (unless (,predicate ,obj)
		     (error ',(cadr x) "bad type for condition ~S" ,obj))
		   (condition-ref ,obj ',(car x))))
	      slots))))

;;
;; SRFI-39: "Parameter Objects"
;;

#|
<doc EXT-SYNTAX parameterize
 * (parameterize ((expr1 expr2) ...) <body>)
 *
 * The expressions |expr1| and |expr2| are evaluated in an unspecified order.
 * The value of the |expr1| expressions must be parameter objects.
 * For each |expr1| expression and in an unspecified order, the local
 * dynamic environment is extended with a binding of the parameter object
 * |expr1| to a new cell whose content is the result of the call
 * |(converter val)|, where |val| is the value of |expr2| and converter
 * is the conversion procedure of the parameter object. The resulting
 * dynamic environment is then used for the evaluation of |<body>|
 * (which refers to the R5RS grammar nonterminal of that name).
 * The result(s) of the parameterize form are the result(s) of
 * the |<body>|.
 *
 * @lisp
 * (radix)                                              =>  2
 * (parameterize ((radix 16)) (radix))                  =>  16
 * (radix)                                              =>  2
 *
 * (define (f n) (number->string n (radix)))
 *
 * (f 10)                                               =>  "1010"
 * (parameterize ((radix 8)) (f 10))                    =>  "12"
 * (parameterize ((radix 8) (prompt (f 10))) (prompt))  =>  "1010"
 * @end lisp
doc>
|#
(define-macro (parameterize bindings . body)
  (let ((tmp (map (lambda (_) (gensym)) bindings)))
    `(let ,(map (lambda (x y) (list y (cadr x)))
		 bindings tmp)
       (dynamic-wind
	   (lambda ()
	     ;; First push all the current parameter values
	     ,@(map (lambda (x) `(%parameter-dynenv-push! ,(car x)))
		    bindings)
	     ;; Change all parameters values
	     ,@(map (lambda (x y) `(,(car x) ,y))
		    bindings tmp))
	   (lambda ()
	     ,@body)
	   (lambda ()
	     ,@(map (lambda (x) `(%parameter-dynenv-pop! ,(car x)))
		   bindings))))))

;;
;; SRFI-55: "require-extension"
;;
#|
<doc EXT-SYNTAX require-extension
 * (require-extension <clause> ...)
 *
 * The syntax of require-extension is as follows:
 * @lisp
 * (require-extension <clause> ...)
 * @end lisp
 * A clause has the form:
 * @lisp
 *  (srfi <extension-argument> ...)
 * @end lisp
 * where |<extension-argument>|s may be any Scheme-values.
 * @l
 * If an |<extension-argument>| is a nonnegative integer, the functionality
 * of the indicated SRFIs is made available in the context in
 * which the require-extension form appears. For instance,
 * @lisp
 * (require-extension (srfi 1 2))
 *                ; Make the SRFI 1 and 2 available
 * @end lisp
 * This form is compatible with ,(link-srfi 55). However, STklos
 * accepts also some symbolic names for requiring some extensions.
 * For instance,
 * @lisp
 * (require-extension (srfi lists and-let*))
 * @end lisp
 * is equivalent to the previous |require-extension|. A list of available
 *  symbols as  |<extension-argument>| is given in chapter
 * ,(ref :chapter "SRFIs").
doc>
|#
(define-macro (require-extension . clauses)
  (when (null? clauses)
    (error 'require-extension "requires at least one clause"))
  `(let ((%has-feature? (in-module SRFI-0 %has-feature?)))
     ,@(map (lambda (x)
	      `(cond
		((and (pair? ',x) (eq? (car ',x) 'srfi) (not (null? (cdr ',x))))
		 (let ((ok? (lambda (x)
			      (let ((x (if (integer? x)
					   (string->symbol (format "srfi-~a" x))
					   x)))
				(or (%has-feature? x)
				    (error 'require-extension
					   "extension ~S is absent" x))))))
		   (and ,@(map (lambda (x) `(ok? ',x))
			       (cdr x))
			(void))))
		(else (error 'require-extension "bad clause ~S" ',x))))
	    clauses)))

;;
;; SRFI-88: "keyword objects"
;;
#|
<doc EXT string->keyword
 * (string->keyword str)
 *
 * This function function has been added to be compatibe with SRFI-88.
 * It is equivalent to make-keyword, except that the parameter cannot be
 * a symbol.
doc>
|#
(define (string->keyword str)
  (unless (string? str)
    (error "bad string ~S" str))
  (make-keyword str))

;;
;; SRFI-98: "An interface to access environment variables"
;;

#| <doc EXT get-environment-variable
 * (get-environment-variable name)
 *
 * Returns the value of the named environment variable as a string, or
 * |%f| if the named environment variable is not found. The name argument
 * is expected to be a string. This function is similar to the |getenv|. It
 * has been added to be  support ,(link-srfi 98).
|#
(define (get-environment-variable name)
  (getenv name))

#| <doc EXT get-environment-variables
 * (get-environment-variables)
 *
 * Returns names and values of all the environment variables as an a-list.
 * This function is defined by ,(link-srfi 98)
|#
(define (get-environment-variables)
  (getenv))


;; LocalWords:  doc dotimes R5RS str SRFI optarg