;;;;
;;;;
;;;; Copyright © 2000-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; 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)
;;;;


(export read-chars read-chars! display-shared gensym
        macro-expand macro-expand*
        improper-list?
        remove remove! delete delete!
        every any
        call-with-input-string call-with-output-string
        read-case-sensitive
        open-input-virtual open-output-virtual
        read-from-string read-from-string-ci
        eval-from-string eval-from-string-ci
        command-line program-name
        create-directories ensure-directories-exist
        posix-error? posix-error-name posix-error-message
        posix-error-errno posix-error-procedure posix-error-arguments
        make-hash-table hash-table->alist alist->hash-table
        hash-table-update! hash-table-update!/default
        hash-table-keys hash-table-values hash-table-fold
        hash-table-merge! hash-table-copy
        fluid-let time tagbody
        dotimes repeat while until
        call/ec
        base64-encode-string base64-decode-string
        md5sum-file
        ansi-color ansi-color-protect do-color
        port->string port->sexp-list port->string-list
        print printerr eprintf printf fprintf
        declare-new-error
        exec exec-list die
        decompose-file-name dirname basename file-separator
        make-path file-suffix file-prefix
        port-idle-register! port-idle-unregister! port-idle-reset!
        chmod
        with-mutex
        error-object-location %push-id %stable-version?
        define-constant
        void?
        default-browser open-in-browser manual man
        exact-integer-log
        receive case-lambda
        radians->degrees degrees->radians
        1+ 1- inc! dec!
        pop! push!
        dolist
        %define-condition-type-accessors
        message-condition? condition-message
        serious-condition?
        error?
        error-message? error-location error-message
        read-with-shared-structure read/ss
        write-with-shared-structure write/ss
        parameterize
        require-extension
        string->keyword
        get-environment-variable get-environment-variables
        implementation-name implementation-version cpu-architecture
        machine-name os-name os-version
        fx-width fx-greatest fx-least
        assume
        version-alist
        port-has-port-position? port-position port-has-set-port-position!?
        set-port-position!
        make-i/o-invalid-position-error i/o-invalid-position-error?
        command-name command-args argc script-file script-directory
        make-nan)


;;;; Deprecated names
(define read-chars read-bytes)
(define read-chars! read-bytes!)


;;;; Aliases
(define display-shared display)


#|
<doc EXT gensym
 * (gensym)
 * (gensym prefix)
 *
 * Creates a new symbol. The print name of the generated symbol
 * consists of a prefix (which defaults to "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 macro-expand* macro-expand
 * (macro-expand form)
 * (macro-expand* form)
 *
 * |macro-expand| returns the macro expansion of |form| if it is a macro call,
 * otherwise |form| is returned unchanged.
 *
 * @lisp
 * (define-macro (add1 x) `(+ ,x 1))
 * (macro-expand '(add1 foo)) => (+ foo 1)
 * (macro-expand '(car bar))  => (car bar)
 * @end lisp
 *
 * |macro-expand| returns the *full* macro expansion of |form|, that is it repeats
 * the macro-expansion, while the expanded form contains macro calls.
 *
 * @lisp
 * (define-macro (add2 x) `(add1 (add1 ,x)))
 * (macro-expand '(add2 foo)) => (add1 (add1 foo))
 * (macro-expand* '(add2 foo)) => (+ (+ foo 1) 1)
 * @end lisp
 *
 * NOTE: |macro-expand| and |macro-expand*| expand only the global macros.
doc>
|#
(define (macro-expand exp)
  (%macro-expand exp #f))

(define (macro-expand* exp)
  (let ((new (%macro-expand exp #f)))
    (if (equal? new exp)
        exp
        (macro-expand* new))))

;;;
;;; List functions
;;;

#|
<doc EXT improper-list?
 * (improper-list? obj)
 *
 * Returns false if and only if |obj| is an improper list.
 * @lisp
 * (improper-list? 2)            => #f
 * (improper-list? '())          => #f
 * (improper-list? '(1 2 3))     => #f
 * (improper-list? '(1 2 . 3))   => #t
 * (improper-list? (cons 'a 'b)) => #t
 * (improper-list? (list 1 2))   => #f
 * (improper-list? #void)        => #f
 * @end lisp
doc>
|#

(define (improper-list? lst)
  (and (pair? lst)
       (not (list? lst))))


#|
<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
  (unless (procedure? pred)
    (error 'every "bad procedure" pred))

  (if (null? others)
      ;; EVERY called with mono argument predicate
      (letrec ((every (lambda (l)
                        (cond
                         ((null? l)        #t)
                         ((null? (cdr l)) (pred (car l)))
                         (else            (and  (pred (car l))
                                                (every (cdr l))))))))
        (every l))

      ;; General case
      (letrec ((every (lambda (l last)
                        (if (memq '() l)
                            last
                            (let ((cars  (map car l))
                                  (cdrs (map cdr l)))
                              (if (memq '() cdrs)
                                  (apply pred cars)
                                  (let ((res (apply pred cars)))
                                    (and res
                                         (every cdrs res)))))))))
        (every (cons l others) #t))))

#|
<doc EXT any
 * (any pred list1 list2 ...)
 *
 * |any| applies the predicate across the lists, returning true if the
 * predicate returns true on any application.
 *
 * If there are n list arguments |list1| ... |listn|, then |pred| must be
 * a procedure taking n arguments.
 *
 * |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.
 *
 * 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
  (unless (procedure? pred)
    (error 'any "bad procedure" pred))

  (if (null? others)
      ;; ANY called with mono argument predicate
      (letrec ((any (lambda (l)
                      (cond
                       ((null? l)       #f)
                       ((null? (cdr l)) (pred (car l)))
                       (else            (or (pred (car l))
                                            (any (cdr l))))))))
        (any l))
      ;; General case
      (letrec ((any (lambda (l last)
                      (if (memq '() l)
                          last
                          (let ((cars  (map car l))
                                (cdrs (map cdr l)))
                            (if (memq '() cdrs)
                                (apply pred cars)
                                (let ((res (apply pred cars)))
                                  (or res
                                      (any cdrs res)))))))))
        (any (cons l others) #f))))


;;;
;;; String Port functions
;;;
#|
<doc EXT call-with-input-string
 * (call-with-input-string string proc)
 *
 * behaves as |call-with1-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)))

;;;
;;; Port functions
;;;

#|
<doc EXT read-case-sensitive
 * (read-case-sensitive)
 * (read-case-sensitive value)
 *
 * This parameter object permits to change the default behaviour of
 * the |read| primitive used on the current input port , when reading a symbol.
 * If this parameter has a true value a symbol is not converted to a default
 * case when interned. Since R7RS requires that symbol are case insignificant,
 * the default value  of this parameter is `#t`.
 *
 * [NOTE]
 * ====
 * * This parameter works on the current input port only and cannot change
 *   read beahviour's globally.
 *
 * * See also syntax for _<<_symbols, special characters>>_ in symbols.
 * ====
doc>
|#
(define-parameter read-case-sensitive
  #t
  (lambda (v)
    (%port-case-sensitive-set! (current-input-port) v)
    (%port-case-sensitive (current-input-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-ci 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. |Read-from-string-ci| uses |read-ci|
 * to read.
 *
 * @lisp
 * (read-from-string "123 456") => 123
 * (read-from-string "")        => an eof object
 * (read-from-string "ABC")     => ABC
 * (read-from-string-ci "ABC")  => abc
 * @end lisp
doc>
|#
(define (read-from-string s)
  (let* ((p    (open-input-string s))
         (expr (read p)))
    (close-port p)
    expr))

(define (read-from-string-ci s)
  (let* ((p    (open-input-string s))
         (expr (read-ci p)))
    (close-port p)
    expr))
 

#|
<doc EXT eval-from-string-ci eval-from-string
 * (eval-from-string str)
 * (eval-from-string str module)
 * (eval-from-string-ci str)
 * (eval-from-string-ci 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|. The primitive |eval-from-string-ci| uses the |read-ci|
 * to read the form to evaluate.
 * @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
 * (eval-from-string "(cons 'A 'B)")              => (A . B)
 * (eval-from-string-ci "(cons 'A 'B)")           => (a . b)
 * @end lisp
doc>
|#
(define (eval-from-string str :optional env)
  (eval (read-from-string str)
        env))

(define (eval-from-string-ci str :optional env)
  (eval (read-from-string-ci str)
        env))


;;;;
;;;; System functions
;;;;
#|
<doc R7RS command-line
 * (command-line)
 *
 * Returns the command line passed to the process as a list
 * of strings. The first string corresponds to the command
 * name.
doc>
|#

(define-parameter command-line
  (let ((script-file (key-get *%system-state-plist* :script-file "")))
    (cons (if (equal? script-file "")
              ""
              (key-get *%system-state-plist* :program-name ""))
          (key-get *%system-state-plist* :argv '())))
  (lambda (val)
    (if (and (list? val)
             (not (null? val))
             (every string? val))
        val
        (error 'command-line "bad command line ~S" val))))


#|
<doc EXT program-name
 * (program-name)
 *
 * Returns the invocation name of the current program as a string. If the file is
 * not a script (in sense of {{quick-link-srfi 193}}), it is the name of the
 * running {{stklos}} interpreter, otherwise it is the name of the running script.
 * This function always returns a string whereas the |command-name| procedure returns
 * `#f` when the program name is not a script.
doc>
|#
(define (program-name)
  (key-get *%system-state-plist* :program-name))



#|
<doc EXT create-directories
 * (create-directories dir)
 * (create-directories dir permissions)
 *
 * Create a directory with name |dir|. No error is signaled if |dir| already exists.
 * Parent directories of |dir| are created as needed. If |permissions| is omitted,
 * it defaults to #o775 (masked by the current umask).
 *
 * NOTE: This function was also called |make-directories|. This old name is
 * obsolete.
doc>
|#
(define (create-directories path :optional (perm #o775))
  (let ((dir (dirname path)))
    (unless (file-is-directory? dir)
      (create-directories dir perm))
    (create-directory path perm)))


#|
<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)
    (create-directories path)))


;;
;; STRFI-170 (POSIX API) compatible functions
;;

#|
<doc EXT posix-error?
 * (posix-error? obj)
 *
 * This procedure returns `#t` if |obj| is a condition object that describes a
 * POSIX error, and `#f` otherwise.
 *
 * This function is defined in {{link-srfi 170}}.
doc>
|#
(define (posix-error? obj)
  (and (condition? obj)
       (condition-has-type? obj &posix-error)))

(define (%posix-error-condition-ref posix-error field)
  (unless (posix-error? posix-error)
    (error "expected a posix-error condition" posix-error))
  (condition-ref posix-error field))

#|
<doc EXT posix-error-name
 * (posix-error-name posix-error)
 *
 * This procedure returns a symbol that is the name associated with the
 * value of |errno| when the POSIX function reported an error. This can be
 * used to provide programmatic recovery when a POSIX function can return
 * more than one value of |errno|.
 *
 * This function is defined in {{link-srfi 170}}.
doc>
|#
(define (posix-error-name posix-error)
  (%posix-error-condition-ref posix-error 'errname))

#|
<doc EXT posix-error-message
 * (posix-error-message posix-error)
 *
 * This procedure returns a string that is an error message reflecting the
 * value of errno when the POSIX function reported an error. This string
 * is useful for reporting the cause of the error to the user
 *
 * This function is defined in {{link-srfi 170}}.
doc>
|#
(define (posix-error-message posix-error)
  (%posix-error-condition-ref posix-error 'r7rs-msg))

#|
<doc EXT posix-error-errno
 * (posix-error-errno posix-error)
 *
 * This procedure returns the value of |errno| (an exact integer).
doc>
|#
(define (posix-error-errno posix-error)
  (%posix-error-condition-ref posix-error 'errno))


#|
<doc EXT posix-error-procedure
 * (posix-error-procedure posix-error)
 *
 * This procedure returns the name of the Scheme procedure that raised
 * the error.
doc>
|#
(define (posix-error-procedure posix-error)
  (condition-ref posix-error 'location))

#|
<doc EXT posix-error-arguments
 * (posix-error-args posix-error)
 *
 * This procedure returns the list of the Scheme procedure arguments
 * that raised the error.
doc>
|#
(define (posix-error-arguments posix-error)
  (condition-ref posix-error 'r7rs-irritants))


;;;;
;;;; 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.
 *
 * If omitted,
 *
 * - |hash| defaults to the |hash-table-hash| procedure
 *  (see _<<hashtablehash, `hash-table-hash` primitive>>_).

 * - |comparison| defaults to the |eq?| procedure
 *   (see _<<eqprim, `eq?` primitive>>_)).
 *
 * 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 performance. 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
 *
 * 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.
 *
 * 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|).
 *
 * 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))))))


#|
<doc EXT-SYNTAX time
 * (time expr1 expr2 ...)
 *
 * Evaluates the expressions |expr1|, |expr2|, ... and returns the
 * result of the last expression. This form also prints the time spent
 * for this evaluation, in milliseconds, and the quantity of bytes
 * alocated on the current error port, as well as the number of garbage
 * collection done.
 * This is CPU time, and not real ("wall") time.
 *
 * @lisp
 * (time (begin (make-list 200) 'finish))
 *     Elapsed time: 0.059 ms
 *     Allocations: 6408 bytes in 201 allocation calls (GC: 0)
 * => finish
 * @end lisp
 *
 * In the example above, the result of the expression is only the symbol
 * |finish|. The two other lines are written to the standard error port.
 *
 * The allocation accounting is independent for each thread, and allocations
 * in children threads do not increase the parent thread counters, as the
 * example below illustrates. Note that, on the other side, the number of GC
 * calls is is a global counter.
 *
 * @lisp
 * (let ((T (make-thread (lambda () (make-list 1_000_000) (eprintf "finish\n")))))
 *   (time (thread-start! T) ;; Launch T wich allocate 1_000_1000 cells
 *         (thread-sleep! 3) ;; wait for the child thread to allocate list
 *         (thread-join! T)
 *         100))
 * finish
 *     Elapsed time: 33.299 ms
 *     Allocations: 800408 bytes in 10 allocation calls (GC: 0)
 * 100
 * @end lisp
 * The ten allocations we can see here are for theads bookeeping and are
 * far from the million cells allocated in thread |T|.
doc>
|#
(define-macro time
  (lambda args
    (let ((time-start  (gensym))
          (res         (gensym))
          (counting?   (gensym))
          (allocs      (gensym))
          (bytes       (gensym))
          (gc-no       (gensym)))
      `(let ((,counting? (%count-allocations))  ;; save if we are counting allocs
             (,gc-no     (begin (gc) (key-get (%gc-stats) #:gc-no 0)))) ;; and GC count
         (%thread-allocation-reset!)            ;; reset thread counters
         (%count-allocations #t)                 ;; count allocations now
         (let* ((,time-start (exact-clock))
                (,res        (begin ,@args))
                (,allocs     (%thread-allocation-counter))
                (,bytes      (%thread-allocation-bytes)))
           (eprintf ";    Elapsed time: ~S ms\n"
                    (/ (- (exact-clock) ,time-start) 1000.0))
           (eprintf ";    Allocations: ~S byte~A in ~S allocation call~A (GC: ~A)\n"
                    ,bytes (if (= ,bytes 1) "" "s") ,allocs (if (= ,allocs 1) "" "s")
                    (- (key-get (%gc-stats) #:gc-no 0) ,gc-no))
           (%count-allocations ,counting?)       ;; restore save state
           ,res)))))                             ;; return computed result

#|
<doc EXT-SYNTAX tagbody ->
 * (tagbody <expression1> <expression2> ...)
 * (-> tag)
 *
 * The `|<expression>|`s are evaluated sequentially from left to right,
 * and the value(s) of the last <expression> is(are) returned as in a
 * |begin| form. Within a |tagbody| form expressions which are keywords
 * are considered as tags and the special form |(-> tag)| is used to
 * transfer execution to the given tag. This is a **very low level**
 * form which is inspired on |tabgody| Common Lisp's form. It can be useful
 * for defining new syntaxes, and should probably not be used as is.
 *
 * @lisp
 * (tagbody               ;; an infinite loop
 *    #:1 (display ".")
 *        (-> #:1))
 *
 * (let ((v 0))
 *   (tagbody
 *    #:top (when (< v 5)
 *            (display v)
 *            (set! v (fx+ v 1))
 *            (-> #:top))))                      @print{} 01234
 *
 * (tagbody (display 1)
 *          (tagbody (display 2)
 *                   (-> #:inner)
 *                   (display "not printed")
 *            #:inner
 *                  (display 3)
 *                  (-> #:outer)
 *                  (display "not printed too"))
 *    #:outer
 *          (display "4"))                        @print{} 1234
 * @end lisp
doc>
|#
(define-macro (tagbody . body)
  (let ((tags  (map (lambda (x) (cons x (%compiler-new-label)))
                    (filter keyword? body))))

    (define (replace code)
      ;; replace knowns tags in (-> tag) expressions
      ;; Unknown tags (inner tagbody forms) are lefts as is
      (if (pair? code)
          (if (and (eq? (car code) '->) (= (length code) 2))
              (let ((t (assq (cadr code) tags)))
                (if t
                    `(%%goto ,(cdr t))
                    code))
              (map replace code))
          code))

    (define (verify code)
      ;; Verify that final expansion doesn't contains still (-> tag).
      ;; Presence of remaining '->' forms denote a goto to an undefined label
      (if (pair? code)
          (cond
             ((and (eq? (car code) '->) (= (length code) 2))
                (error 'tagbody "destination label ~S not defined\n" (cadr code)))
             ((eq? (car code) 'tagbody)  ;; internal tagbody ⇒ skip it
                #void)
             (else
                (map verify code)))))

    (let ((new-body (map (lambda (x)
                           (if (keyword? x)
                               `(%%label ,(cdr (assq x tags)))
                               (replace x)))
                         body)))
      (verify new-body)
      `(begin ,@new-body))))

#|
<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 *_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)
  ;; In the lambda passed to the apply, below:
  ;; If count is a number (not a variable), don't include a
  ;; LET for it -- it won't change anyway!
  ;;
  ;; For example:
  ;; (macro-expand '(dotimes (i MAX) 'work))
  ;;    => (let ((G77 MAX)) (do ((i 0 (+ i 1))) ((>= i G77) (void)) 'work))
  ;;
  ;; (macro-expand '(dotimes2 (i 10) 'work))
  ;;    => (begin (do ((i 0 (fx+ i 1))) ((fx>= i 10) (void)) 'work))
  ;;
  ;; The second case will be faster for nested DOTIMEs, because it
  ;; avoids access to a local variable *and* entering-and-leaving
  ;; a LET.
  ;;
  ;; Also - if count is constant *and* a fixnum, we can use
  ;; fx- and fx>, even though the speed difference is not
  ;; that great.
  ;;
  ;; When count is not a fixnum, we use + and >= :
  ;; (macro-expand '(dotimes (i 1180591620717411303424) 'work))
  ;;   => (begin (do ((i 0 (+ i 1))) ((>= i 1180591620717411303424) (void)) 'work))
  ;;
  (apply (lambda (var count . result)
           (let* ((result (if (null? result) (list '(void)) result))
                  (limit (if (number? count) count (gensym)))
                  (head  (if (number? count)
                             '(begin)
                             `(let ((,limit ,count)))))
                  (plus (if (fixnum? count) 'fx+ '+))
                  (ge   (if (fixnum? count) 'fx>= '>=)))
             `(,@head (do ((,var 0 (,plus ,var 1)))
                          ((,ge ,var ,limit) ,@result)
                        ,@body))))
         bindings))

;; NOTE: I (eg) have tried to implement dotimes using a repeat, to inherit loop
;; unrolling. It's really faster, ... but not thread-safe :-<. The correction to make
;; the expansion thread safe is slower than the previous implementation.
;;
;;(define-macro (dotimes bindings . body)
;;  (apply (lambda (var count . result)
;;           (let* ((result (if (null? result) (list '(void)) result))
;;                  (plus   (if (fixnum? count) 'fx+ '+)))
;;             `(let ((,var 0))
;;                (repeat ,count
;;                        ,@body ;; thread safe version: (let ((,var ,var)) ,@body)
;;                        (set! ,var (,plus ,var 1)))
;;                ,@result)))
;;         bindings))

#|
<doc EXT-SYNTAX repeat
 * (repeat count <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). The result of
 * |repeat| is undefined.
 *
 * This form could be easily simulated with |dotimes|. Its interest is
 * that it is faster.
 * @lisp
 * (repeat 3 (display "."))     => prints "..."
 * (repeat 0 (display "."))     => prints nothing
 * @end lisp
doc>
|#
(define-macro (repeat count . body)

  (define (%repeat n body use-fx?)
    ;; Repeat without loop unrolling (n must be a variable)
    ;; If expr is constant *and* a fixnum, we can use fx- and fx>,
    ;; even though the speed difference is not that great.
    (let ((minus (if use-fx? 'fx- '-))
          (gt    (if use-fx? 'fx> '>)))
      `(tagbody
          #:top
          (when (,gt ,n 0)
            (set! ,n (,minus ,n 1))
            ,@body
            (-> #:top)))))


  (define (%multiply-list L k)
    ;; Multiplies a list...
    ;; (%multiply-list '(a b c) 3) => (a b c a b c a b c)
    (cond ((fx=? k 0) '())
          ((fx=? k 1) (list-copy L))
          (else       (append (list-copy L)
                              (%multiply-list L (fx- k 1))))))

  ;;
  ;; body of repeat starts here
  ;;
  (let* ((it     (compiler:unroll-iterations))
         (inside (%multiply-list body it))
         (c      (gensym))
         (q      (gensym))
         (r      (gensym)))
    (if (fixnum? count)
        ;; We can compute the number of loops at compile time and produce
        ;; simpler code. We can also use fx functions.
        (if (and (= it 1) (positive? count))
            ;; No loop unrolling
            `(let ((,c ,count)) ,(%repeat c body #t))
            ;; Unroll the loop.
            (let ((valq (quotient count it))
                  (valr (remainder count it)))
               `(begin
                  ,(if (positive? valq) ;; We have a "big" loop
                      `(let ((,q ,valq)) ,(%repeat q inside #t))
                      `(void))
                  ,(if (positive? valr);; we have a "small" loop
                       `(let ((,r ,valr)) ,(%repeat r body #t))
                       `(void)))))
        ;; count is not a fixnum.  Compute modulo and reminder at runtime
        (if (= it 1)
            ;; No loop unrolling.
            `(let ((,c ,count)) ,(%repeat c body #f))
            ;; Unroll the loop
            `(let* ((,c ,count)
                    (,q (quotient ,c ,it))
                    (,r (remainder ,c ,it)))
               ,(%repeat q inside #f)
               ,(%repeat r body #f))))))

#|
<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 *_void_*.
doc>
|#
(define-macro (while test . body)
  `(tagbody
    #:top
    (when ,test
      (begin ,@body
             (-> #:top)))))

#|
<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 *_void_*.
doc>
|#
(define-macro (until test . body)
  `(tagbody
    #:top
    (unless ,test
      (begin ,@body
             (-> #:top)))))

#|
<doc EXT 1+ 1-
 * (1+ x)
 * (1- x)
 *
 * These procedures return |x| plus one and |x| minus one, respectively. Note that
 * the value of |x| is not changed.
 *
 * @lisp
 * (define x 10)
 * (1+ x)          => 11
 * x               => 10
 * (1- x)          => 9
 * x               => 10
 * @end lisp
doc>
|#
(define (1+ x) (+ x 1))
(define (1- x) (- x 1))


#|
<doc EXT push! pop!
 * (push! place val)
 * (pop! place)
 *
 * These macros push and pop an element into/from a list, so as to use
 * it as a stack. The result of the |push!| form is undefined, whereas
 * the result of |pop!| is the result of the evaluation of |place|.
 *
 * @lisp
 * (define S (list 20 30 40))
 * (push! S 10)
 * S                         => (10 20 30 40)
 * (pop! S)                  => 10
 * S                         => (20 30 40)
 * @end lisp
 * Since {{stklos}} permits generalized |set!|, |place| may be a list
 * of the form `(proc a1 a2 ...)`. In this case, |push!| calls the setter
 * of |proc|.
 * @lisp
 * (define v (vector (list 1 2) (list 3 4)))
 * (push! (vector-ref v 0) 17)
 * (pop! (vector-ref v 1))                       => 3
 * v                                             => #((17 1 2) (4))
 * @end lisp
doc>
|#
(define (%make-inc-dec-push-body place func val)
  (cond
   ((symbol? place)
    ;; simple xxx! on a variable
    `(set! ,place (,func ,val ,place)))
   ((list? place)
    ;; Generalized xxx!. Do not evaluate arguments two times
    (let ((vars (map (lambda (x) (list (gensym) x)) place)))
      `(let ,vars
         ((setter ,(caar vars))
          ,@(map car (cdr vars))
          (,func ,val ,(map car vars))))))
   (else
    (error "place ~W must be a symbol (variable) or a list (generalized variable)"
           place))))

(define-macro (push! place val)
  (%make-inc-dec-push-body place 'cons val))

(define-macro (pop! place)
  (let ((x (gensym 'res-)))
    (if (symbol? place)
        ;; simple pop! on a variable
        `(let ((,x (car ,place)))
           (set! ,place (cdr ,place))
           ,x)
        ;; Generalized pop!. Do not evaluate argument two times
        (let ((vars (map (lambda (x) (list (gensym) x)) place)))
          `(let ,vars
               (let ((,x ,(map car vars)))
                 ((setter ,(caar vars))
                  ,@(map car (cdr vars))
                  (cdr ,x))
                 (car ,x)))))))

#|
<doc EXT inc! dec!
 * (inc! place)
 * (inc! place val)
 * (dec! place)
 * (dec place val)
 *
 * These forms increment or decrement the value contained in |place| by |val|.
 * If ommitted, |val| defaults to 1. The result of both forms is undefined.
 *
 * Since {{stklos}} permits generalized |set!|, |place| may be a list
 * of the form `(proc a1 a2 ...)`. In this case, these forms call the setter
 * of |proc|.
 *
 * @lisp
 * (define x 10)
 * (inc! x)
 * x                        => 11
 * (dec! x 10)
 * x                        => 1
 * (define l (list 1 2 3))
 * (inc! (car l))
 * (dec! (list-ref l 1) 20)
 * l                        => (2 -18 3)
 * @end lisp
doc>
|#
(define-macro (inc! place :optional (value 1))
  (%make-inc-dec-push-body place '+ value))

(define-macro (dec! place :optional (value 1))
  (%make-inc-dec-push-body place (lambda (a b) (- b a)) value))


#|
<doc EXT dolist
 * (dolist (x lst) body)
 * (dolist (x lst result) body)
 *
 * This macro will iterate over |lst|, executing |body| for each
 * element |x|. The symbol |x| will be captured and bound in |body|.
 * If |result| is provided, and is not |x|, this form returns |result|;
 * otherwise, its result is undefined.
 * @lisp
 * (dolist (x '(10 20 30))
 *   (display (- x)) (newline))
 * -10
 * -20
 * -30
 * (let ((sum 0))
 *   (dolist (x '(1 2 3 4 5) sum)
 *     (inc! sum (square x))))       => 55
 * @end lisp
 * The form |dolist| is borrowed from Common Lisp. However, using |dolist|
 * is not the preferred way to process a list. For instance, the last example
 * could be better rewritten in:
 * @lisp
 * (apply + (map square '(1 2 3 4 5))
 * @end lisp
doc>
|#
(define-macro (dolist binding . body)
  (unless (and (pair? binding)
               (<= 2 (length binding) 3)
               (symbol? (car binding)))
    (error 'dolist "bad dolist binding" binding))
  (let ((x (gensym 'x)))
    (apply (lambda (var lst . result)
             `(begin
                ;; iterate on all the list elements
                (for-each (lambda (,x) (let ((,var ,x)) ,@body))
                          ,lst)
                ;; insert in the begin form the result if present or != of var
                ,@(if (or (null? result) (eq? (car result) var)) '() result)))
           binding)))

#|
<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-decode-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 name)
                       (lambda (str)
                         (unless (string? str)
                           (error name "bad string ~s" 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 'base64-encode-string))
  (set! base64-decode-string
        (encode/decode base64-decode 'base64-decode-string)))

;; ======================================================================
;;      md5sum ...
;; ======================================================================
#|
<doc EXT md5sum-file
 * (md5sum-file str)
 *
 * Return a string contening the md5 sum 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...
;; ======================================================================

#|
<doc EXT ansi-color
 * (ansi-color e1 e2 ... en)
 *
 * |ansi-color| permits to build a string which embeds ANSI codes to
 * colorize texts on a terminal. Each expression e~i~ must be a string,
 * a symbol or an integer.
 *
 * Strings constitute the message to be displayed.
 *
 * A symbol can designate
 *
 * - a color in the set {|black|, |red|, |green|, |yellow|, |blue|,
 *   |magenta|, |cyan|, |white|} for foreground colors
 * - a color in the set {|bg-black|, |bg-red|, |bg-green|, |bg-yellow|,
 *   |bg-blue|, |bg-magenta|, |bg-cyan|, |bg-white|} for background colors.
 * - a qualifier such as |normal|, |bold|, |italic|, |underline|, |blink|,
 *   |reverse| or |no-bold|, |no-italic|, |no-underline|, |no-blink|,
 *   |no-reverse|.
 *
 * Integer values can be used for terminals which are able to display  256 colors.
 * If the number is positive, it is used as a foreground color. Otherwise,
 * it is uses as a background color. Note that not all the terminals are able to
 * use more than eight colors.
 *
 * For instance,
 * @lisp
 * (display (ansi-color "a word in "
 *                      'bold 'red "RED" 'normal
 *                      " and another in "
 *                      'reverse 'blue "BLUE" 'normal))
 * @end lisp
 * will display the words BLUE and RED in color.
doc>
|#
(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-underline   . "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)
      #:ansi-color-protect
      (set! ansi-color-start (string-append start "\e["))
      (set! ansi-color-stop  (string-append "m" stop))))

  ;; ansi-color ...
  (set! ansi-color
    (lambda  args
      #:ansi-color
      (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))))
          ((integer? (car args))
             (Loop (cdr args)
                   #f
                   (string-append res
                                  (if str-prev? ansi-color-start ";")
                                  (if (positive? (car args))
                                      (format "38;5;~a" (car args))
                                      (format "48;5;~a" (car args))))))
          ((symbol? (car args))
             (Loop (cdr args)
                   #f
                   (string-append res
                                  (if  str-prev? ansi-color-start ";")
                                  (code (car args)))))
          ((pair? (car args))
             (Loop (append (car args) (cdr args))
                   str-prev?
                   res))
          (else (error 'ansi-color "bad command ~S" args)))))))


(define do-color
  (let ((term (or (getenv "TERM") "")))
    (if (and (not (key-get *%system-state-plist* :interactive #f))
             (any (lambda(x) (regexp-match x 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 procedures 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 versions of _<<format, `format` primitive>>_.
 * 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 string 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 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)                    ;; FIXME: delete cygwin support?
    [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
 * `{{sharp}}\/` on Unix (or Cygwin) systems and `{{sharp}}\\` on Windows.
doc>
|#
(define (file-separator)
  (case (running-os)
    ((unix cygwin-windows android)    #\/)
    ((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 `#f`.
 * @lisp
 * (file-suffix "./foo.tar.gz") => "gz"
 * (file-suffix "./a.b/c")      => #f
 * (file-suffix "./a.b/c.")     => ""
 * (file-suffix "~/.profile")   => #f
 * @end lisp
doc>
|#
(define (file-suffix pathname)
  (let ((end (string-length pathname))
        (/   (file-separator)))
    (let loop ((i (- end 1)))
      (if (< i 1)
          #f
          (let ((c (string-ref pathname i)))
            (cond
             ((char=? c #\.)
              (and (> i 0)
                   (not (char=? (string-ref pathname (- i 1)) /))
                   (substring pathname (+ i 1) end)))
              ((char=? c /)
               #f)
              (else
               (loop (- i 1)))))))))

#|
<doc EXT file-prefix
 * (file-prefix pathname)
 *
 * Returns the prefix 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 *_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 "~/.config/stklos/stklosrc" 'read 'execute)
 * (chmod "~/.config/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 <thunk>)
 *
 * Executes |thunk|, protected by mutex |mtx|. The mutex will
 * be locked before and released after execution of |body|, and
 * also on entrance or departure of its dynamic context
 * (lock and unlock are used within |dynamic-wind|).
doc>
|#
(define (with-mutex mtx  proc)
  (dynamic-wind
      (lambda () (mutex-lock! mtx))
      proc
      (lambda () (mutex-unlock! mtx))))


#|
<doc EXT error-object-location
 * (error-object-location error-object)
 *
 * Returns the location encapsulated by |error-object| if it exists.
 * Returns `#f` otherwise. The location corresponds generally to the name
 * of the procedure which raised the error.
 * @lisp
 * (guard (cnd
 *          (else (error-object-location cnd)))
 *   (error 'foo "error message"))  => foo
 * @end lisp
doc>
|#
(define (error-object-location obj)
  (if (error-object? obj)
      (condition-ref obj 'location)
      (error "bad error object: ~S" obj)))

#|
<doc EXT define-constant
 * (define-constant <variable> <expression>)
 * (define-constant (<variable> <formals>) body)
 * (define-constant (<variable> . <formal>) body)
 *
 * This form is similar to |define|, except the binding of |<variable>| which
 * is non mutable.
 *
 * @lisp
 * (define-constant a 'hello)
 * (set! a 'goodbye)             => error
 * (define a 2)                  ; is  ok (it's a new binding)
 * (define-constant ((foo a) b)  ; foo is (lambda (a) (lambda (b) ...)))
 *     ...)
 * @end lisp
doc>
|#
(define-macro (define-constant . args)
  (define (rewrite l)
    (if (<= (length l) 1)
        (error "bad constant definition"))
    (let ((bind (car l))
          (body (cdr l)))
      (if (pair? bind)
          (rewrite `(,(car bind) (lambda ,(cdr bind) ,@body)))
          l)))
  (let ((args (rewrite args)))
    (if (= (length args) 2)
        `(begin                   ;; NOTE: this code should be atomic
           (define ,@args)
           (symbol-immutable! ',(car args)))
        (error "bad constant definition ~S" `(define-constant ,@args)))))

#|
<doc EXT void?
 * (void? obj)
 *
 * Returns `#t` if |obj| is `#void`, and `#f` otherwise.
 * The usual "unspecified" result in Scheme standard and in SRFIs is `#void`
 * in STklos, and it is also returned by the procedure |void|.
 *
 * @lisp
 * (void? (void))                    => #t
 * (define x (if #f 'nope))
 * (void? x)                         => #t
 * (void? '())                       => #f
 * (void? 'something)                => #f
 * (void? (for-each print '(1 2 3))) => #t
 * @end lisp
doc>
|#
(define (void? obj) (eq? obj #void))

#|

<doc EXT exact-integer-log
 * (exact-integer-log n b)
 *
 * |Exact-integer-log| is to |log| what |exact-integer-sqrt| is to |sqrt|.
 *
 * Returns two values: the first value is the largest integer number less
 * than or equal to the logarithm of |n| in base |b|. The second value is
 * the difference between |n| and |(expt b k)|, where |k| is the first value.
 *
 * Both arguments must be exact, and the resulting values are exact integers.
 * Also, both arguments are mandatory, since it is no meaningful in this context
 * to use base *e*.
 *
 * @lisp
 * (exact-integer-log 8 2)  => 3,0
 * (exact-integer-log 11 2) => 3,3
 * (exact-integer-log
 *          (expt 3 5)
 *          (expt 3 4))     => 1, 162
 * (exact-integer-log 16 2) => 4, 0
 * (exact-integer-log 19 1) => 4, 3
 * (exact-integer-log
 *          (expt 6 10000)
 *          (expt 6 1000)) => 10, 0
 * (exact-integer-log 2 1) => error
 * (exact-integer-log 0 5) => error
 * (exact-integer-log 0 0) => error
 * @end lisp
doc>
|#
(define (exact-integer-log n b)
  (unless (and (exact-integer? n) (positive? n))
    (error "log exponent ~S is not a positive exact integer" n))
  (unless (and (exact-integer? b) (> b 1))
    (error "log base ~S is not exact integer greater than one" b))
  ;; This is easier and faster than R7RS exact-integer-sqrt, since:
  ;; * log(n b) = log_2(n) / log_2(b).
  ;; * integer-length(n) = floor(log_2(n)) + 1
  ;; We just put it all together.
  (let ((log2-n (- (integer-length n) 1))
        (log2-b (- (integer-length b) 1)))
    (let ((L (quotient log2-n log2-b))
          (step 1))
      ;; Ok, so FLOOR(a/b) can be smaller than FLOOR(a)/FLOOR(b).
      ;; That means we may have overestimated L -- but we should be
      ;; close. If we overestimated, then (expt b L) will be larger
      ;; than n, and we can subtract from it until we find the correct
      ;; number.
      ;; We do increase the step at each iteration in order to speed
      ;; up the process. If we go too far, we correct it later. This is
      ;; fast.
      (while (> (expt b L) n)
        (set! L (- L step))
        (set! step (+ step 2)))

      ;; If we overestimated, then we had to walk down from L.
      ;; In this case, since we added 2 to the step at each
      ;; iteration, we may now have UNDERestimated. But then,
      ;; we undo the last iteration (the "go back" line below),
      ;; and start walking again, this time with a fixed step
      ;; equal to 1.
      (when (> step 1)            ; did we need to walk?
        (set! L (+ L step -2))    ; go back...
        (while (> (expt b L) n)
          (set! L (- L 1))))      ; don't grow the step this time!

      (values L (- n (expt b L))))))

#|
<doc EXT radians->degrees degrees->radians
 * (radians->degrees r)
 * (degrees->radians d)
 *
 * These procedures convert angles from radians into degrees and
 * from degrees into radians.
doc>
|#
(define (radians->degrees r)
  (unless (real? r) (error "bad real number ~S" r))
  (/ (* r 180)
     3.141592653589793115997963468544185161590576171875)) ; pi

(define (degrees->radians d)
  (unless (real? d) (error "bad real number ~S" d))
  (* (/ d 180)
     3.141592653589793115997963468544185161590576171875)) ; pi


;;;;
;;;; Browser & Manual
;;;;


#|
<doc EXT default-browser
 * (default-browser)
 * (default-browser str)
 *
 * This parameter object denotes the name of the browser used by {{stklos}}
 * to open URLs. The value of this parameter is set at initialization time
 * to (in that order):
 *
 * - the value of the shell variable |STKLOS_BROWSER|, if it is set, or
 * - the value of the shell variable |BROWSER|, if it is set, or
 * - the string "open" on macOS, or "xdg-open" on other OS.
doc>
|#
(define-parameter default-browser
  (cond
   ((getenv "STKLOS_BROWSER"))
   ((getenv "BROWSER"))
   ((equal? (os-name) "Darwin") "open")
   (else "xdg-open"))
  (lambda (v)
    (if (not (string? v))
        (error 'default-browser "bad browser name ~s" v)
        v)))

#|
<doc EXT open-in-browser
 * (open-in-browser url)
 *
 * Opens the URL given by the string |url| in the default browser, which is
 * determined by the string contained in the parameter |default-browser|.
doc>
|#
(define (open-in-browser url)
  (let ((cmd (format "~a '~a'" (default-browser) url)))
    (when (positive? (stklos-debug-level))
      (eprintf (format "Running command ~s\n" cmd)))
    (system cmd)))


#|
<doc EXT man manual
 * (manual)
 * (manual entry)
 *
 * Opens the {{stklos}} manual in a browser. If the symbol or the
 * string |entry| is given, the manual is opened on the description
 * of |entry|.
 * NOTE: If the HTML manual file is not installed, the documentation is
 * searched on the {{stklos}} web site, which can incur a non-negligible
 * response time.
 * NOTE: another name for this function is |man|.
doc>
|#
(define (manual :optional complement)
  (let* ((fn (make-path (install-path #:htmldir)
                        "stklos-ref.html"))
         (comp (format "~a" complement))  ;; -> string
         (base (if (file-exists? fn)
                   (string-append "file://" fn)
                   "https://stklos.net/Doc/HTML/stklos-ref.html")))
    (open-in-browser (if complement
                         (string-append base "#P_" comp)
                         base))))

;; Use the usual abbreviation for manual
(define man manual)

;;;
;;; Misc
;;;
(define (%push-id)
  (if (%stable-version?)
      "stable"
      (let ((commit (key-get (%stklos-git) :commit #f)))
        (if commit
            (format "unstable -- ~a" commit)
            "unstable"))))

(when-load-and-compile
 (when (key-get (%vm-config) #:stat-vm)
   ;; We compile this file whereas STAT_VM is defined =>
   ;; 1. define the macro %with-profile-data
   ;; 2. export it
   (define-macro (%with-profile-data filename format . body)
     (let ((expand (lambda (filename format body)
                     (let ((result (gensym 'result-)))
                       `(receive ,result
                            (begin
                              (%vm-reset-stats)
                              (%vm-collect-stats #t)
                              ,@body)
                          (%vm-dump-stats ,filename ,format)
                          (%vm-collect-stats #f)
                          (apply values ,result))))))
       (if (memq format '(#:csv #:scm))
           (expand filename format body)
           (expand filename #:scm (cons format body)))))

   (export %with-profile-data)))


;;;; ======================================================================
;;;;
;;;; 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:
 *
 * - (|<variable~1~>| ... |<variable~n~>|):
 *   The environment in which the
 *   receive-expression is evaluated is extended by binding |<variable~1~>|, ...,
 *   |<variable~n~>| to fresh locations. +
 *   The |<expression>| is evaluated, and its
 *   values are stored into those locations. (It is an error if |<expression>|
 *   does not have exactly n values.)
 *
 * - |<variable>|: 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>|.
 *
 * - (|<variable~1~>| ... |<variable~n~>| . |<variable~n+1~>|):  The environment
 *   in which the receive-expression is evaluated is extended by binding
 *   |<variable~1~>|, ..., |<variable~n+1~>| to fresh locations.
 *   The |<expression>| is evaluated. Its first n values are stored into the
 *   locations bound to |<variable~1~>| ... |<variable~n~>|. Any remaining values
 *   are converted into a newly allocated list, which is stored into the location
 *   bound to |<variable~n+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-35: "Conditions"
;;;

;; 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))))
;;
;; Predefined SRFI-35 conditions
;;
(%define-condition-type-accessors &message &condition   ;; &message
   message-condition?
   (message condition-message))

(%define-condition-type-accessors &serious &condition   ;; &serious
   serious-condition?)

(%define-condition-type-accessors &error &serious       ;; &error
   error?)

(%define-condition-type-accessors &error-message &error ;; &error-message (extension)
   error-message?
   (location error-location)
   (message  error-message))

;;
;; 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 {{link-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)

;;
;; 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 ((tmp1 (map (lambda (_) (gensym)) bindings))
        (tmp2 (map (lambda (_) (gensym)) bindings)))
    `(let (,@(map (lambda (x y) (list y (cadr x)))
                  bindings tmp1)
           ,@(map (lambda (x y) (list y (list (car x))))
                  bindings tmp2))
       (dynamic-wind
           (lambda ()
             ;; Change all parameters values
             ,@(map (lambda (x y) `(,(car x) ,y))
                    bindings tmp1))
           (lambda ()
             ,@body)
           (lambda ()
             ,@(map (lambda (x y) `(,(car x) ,y))
                    bindings tmp2))))))
;;
;; SRFI-45: "Primitives for Expressing Iterative Lazy Algorithms"
;;
;; lazy and eager are now present in R7RS with names delay-force
;; and make-promise. They are implemented in r7rs.stk
;;


;;
;; 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 may have the form:
 *
 * 1. |(srfi number ...)|
 *
 * 2. |(identifier ...)|
 *
 * 3. |identifier|
 *
 * In the first form the functionality of the indicated SRFIs are 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}}.
 *
 * The second and third forms are {{stklos}} extensions.
 * If the form is a list, it is equivalent to an import. That is,
 * @lisp
 * (require-extension (streams primitive) (streams derived))
 * @end lisp
 * is equivalent to
 * @lisp
 * (import (streams primitive) (streams derived))
 * @end lisp
 *
 * The final form permits to use symbolic names for requiring some extensions.
 * For instance,
 * @lisp
 * (require-extension lists and-let*)
 * @end lisp
 * is equivalent to the requiring |srfi-1| and |srfi-2|.

 * A list of available symbolic names for features is given in <<_srfis>>.
doc>
|#

(define-syntax require-extension
  (syntax-rules (srfi)
    ((_ "internal" (srfi id ...))
     (begin (require-feature id) ...))
    ((_ "internal" (x ...))
     (import (x ...)))
    ((_ "internal" id)
     (cond-expand
      (id #void)
      (else (error "cannot require extension named '~s'" 'id))))
    ((_ clause ...)
     (begin (require-extension "internal" clause) ...)) ) )


;;
;; 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 R7RS 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}}.
doc>
|#
(define (get-environment-variable name)
  (getenv name))

#|
<doc R7RS 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}}.
doc>
|#
(define (get-environment-variables)
  (getenv))


;;
;; SRFI-112: "Environment Inquiry"
;;

#|
<doc EXT implementation-name
 * (implementation-name)
 *
 * This function is defined in {{link-srfi 112}}; it returns the Scheme
 * implementation (i.e. the string `"STklos"`).
doc>
|#
(define (implementation-name) "STklos")
(define implementation-version version)

#|
<doc EXT cpu-architecture
 * (cpu-architecture)
 *
 * This function is defined in {{link-srfi 112}}; it returns the CPU
 * architecture, real or virtual, on which this implementation
 * is executing.
doc>
|#
(define (cpu-architecture) (vector-ref (%uname) 4)) ; Posix machine field

#|
<doc EXT machine-name
 * (machine-name)
 *
 * This function is defined in {{link-srfi 112}}; it returns a name for the
 * particular machine on which the implementation is running.
doc>
|#
(define (machine-name)     (vector-ref (%uname) 1)) ; Posix nodename field


#|
<doc EXT os-name
 * (os-name)
 *
 * This function is defined in {{link-srfi 112}}; it returns the name for
 * the operating system, platform, or equivalent on which the
 * implementation is running.
doc>
|#
;(define (os-name)          (vector-ref (%uname) 0)) ; Posix sysname field


#|
<doc EXT os-version
 * (os-version)
 *
 * This function is defined in {{link-srfi 112}}; it returns the version for
 * the operating system, platform, or equivalent on which the
 * implementation is running.
doc>
|#
(define (os-version)
  (let ((u (%uname)))
    (string-append (vector-ref u 2)                 ; Posix version field
                   " "
                   (vector-ref u 3))))              ; Posix release field

;;----------------------------------------------------------------------
;; SRFI-143: "Fixnums"
;; ----------------------------------------------------------------------

;; give new names to some primitives and define some constants so as to comply
;; with SRFI-143 (fixnums):
(define fx-width (fixnum-width))
(define fx-greatest (greatest-fixnum))
(define fx-least (least-fixnum))


;;----------------------------------------------------------------------
;; SRFI-145: "Assumptions"
;; ----------------------------------------------------------------------

#|
<doc EXT-SYNTAX assume
 * (assume obj ...)
 *
 * The special form |assume| is defined in {{link-srfi 145}}.
 * When {{stklos}} is in debug mode, this special form is an expression
 * that evaluates to the value of |obj| if |obj| evaluates to a true
 * value and it is an error if |obj| evaluates to a false value.
 *
 * When {{stklos}} is not in debug mode, the call to |assume| is elided.
doc>
|#
(define-macro (assume expr . args)
  (if (positive? (stklos-debug-level))
      ;; Assumptions are evaluated in debug mode ...
      (let* ((efile (and (%epair? expr) (%epair-file expr)))
             (eline (and (%epair? expr) (%epair-line expr)))
             (fmt   (string-append (if efile
                                       (format "in ~A:~A, " efile eline)
                                       "")
                                   "invalid assumption:")))
        `(or ,expr
             (error ,fmt ',expr ,@args)))
      ;; ... and ignored otherwise
      #void))


;; ----------------------------------------------------------------------
;;  SRFI-176: "Version flag"
;; ----------------------------------------------------------------------

#|
<doc EXT version-alist
 * (version-alist)
 *
 * This function returns an association list of STklos properties as defined by
 * {{link-srfi 176}}.
doc>
|#
(define (version-alist)
  (define (%feature->srfi feature)
    (let* ((srfi- "srfi-")
           (srfi-len 5)
           (feat (symbol->string feature))
           (feat-len (string-length feat)))
      (and (> feat-len srfi-len)
           (string=? srfi- (substring feat 0 srfi-len))
           (string->number (substring feat srfi-len feat-len)))))

  (define (prop name plist plist-key)
    (let ((value (key-get plist plist-key #f)))
      (cond ((or (not value) (null? value)) '())
            ((pair? value) `((,name ,@value)))
            (else `((,name ,value))))))

  (let* ((conf (%stklos-configure))
         (git (%stklos-git))
         (srfis (filter-map %feature->srfi (features)))
         (u (%uname))
         (utf8? (key-get *%system-state-plist* :use-utf8 #f)))
    `((version ,(version))
      (command "stklos")
      (scheme.id stklos)
      (languages scheme r5rs r7rs)
      (encodings ,@(if utf8? '(utf-8) '()))
      (threads ,(%thread-system))
      (install-dir ,(%library-prefix))
      (website "https://stklos.net")
      (scheme.features ,@(features))
      (stklos.binary-load-path ,(%library-prefix 'lib))
      (stklos.scheme-load-path ,(%library-prefix 'data))
      (scheme.path ,@(load-path))
      (scheme.srfi ,@srfis)
      (scheme.srfi.count ,(length srfis))
      ,@(prop 'build.configure conf :configure)
      ,@(prop 'build.git.tag git :tag)
      ,@(prop 'build.git.branch git :branch)
      ,@(prop 'build.git.commit git :commit)
      ,@(prop 'build.git.modified git :modified)
      ,@(prop 'c.version conf :c-version)
      ,@(prop 'c.compile conf :c-compile)
      ,@(prop 'c.link conf :c-link)
      ,@(prop 'c.type-bits conf :c-type-bits)
      ,@(prop 'c.library.compile conf :shlib-compile)
      ,@(prop 'c.library.link conf :shlib-link)
      ,@(prop 'c.library.extension conf :shlib-suffix)
      ,@(prop 'stklos.system-libs conf :system)
      ,@(prop 'stklos.compiled-libs conf :compiled)
      (os.uname ,(vector-ref u 0) ,(vector-ref u 2) ,(vector-ref u 4))
      (os.env.LANG ,(or (getenv "LANG") ""))
      (os.env.TERM ,(or (getenv "TERM") "")))))

;; ----------------------------------------------------------------------
;;  SRFI-192: "Port positioning"
;; ----------------------------------------------------------------------

#|
<doc EXT port-has-port-position?
 * (port-has-port-position? port)
 *
 * The port-has-port-position? procedure returns `#t` if the port
 * supports the port-position operation, and `#f` otherwise. If the port
 * does not support the operation, port-position signals an error.
doc>
|#
(define (port-has-port-position? port)
  (if (not (port? port))
      (error 'port-has-port-position?
             "Not a port: ~A" port)
      #t))

#|
<doc EXT port-position
 * (port-position port)
 *
 * The port-position procedure returns an object representing the
 * information state  about the port current position as is
 * necessary to save and restore that position. This value can be useful
 * only as the pos argument to set-port-position!, if the latter is even
 * supported on the port. However, if the port is binary and the object
 * is an exact integer, then it is the position measured in bytes, and
 * can be used to compute a new position some specified number of bytes
 * away.
doc>
|#
(define port-position port-current-position)

#|
<doc EXT port-has-set-port-position!?
 * (port-has-set-port-position!? port)
 *
 * The port-has-set-port-position!? procedure returns `#t` if the port supports
 * the set-port-position! operation, and `#f` otherwise.
doc>
|#
(define (port-has-set-port-position!? port)
  (if (not (port? port))
      (error 'port-has-set-port-position!?
             "Not a port: ~A" port)
      #t))

#|
<doc EXT set-port-position!
 * (set-port-position! port pos)
 *
 * For a textual port, it is implementation-defined what happens if pos is not
 * the return value of a call to port-position on port. However, a binary port
 * will also accept an exact integer, in which case the port position is set to
 * the specified number of bytes from the beginning of the port data. If this
 * is not sufficient information to specify the port state, or the specified
 * position is uninterpretable by the port, an error satisfying
 * i/o-invalid-position-error? is signaled.
 *
 * If |set-port-position!| procedure is invoked on a port that does not support
 * the operation or if pos is not in the range of valid positions of port,
 * |set-port-position!| signals an error. Otherwise, it sets the current position
 * of the port to pos. If port is an output port, |set-port-position!| first flushes
 * port (even if the port position will not change).
 *
 * If port is a binary output port and the current position is set beyond the
 * current end of the data in the underlying data sink, the object is not extended
 * until new data is written at that position. The contents of any intervening
 * positions are unspecified. It is also possible to set the position of a binary
 * input port beyond the end of the data in the data source, but a read will fail
 * unless the data has been extended by other means. File ports can always be
 * extended in this manner within the limits of the underlying operating system.
 * In other types of ports, if an attempt is made to set the position beyond the
 * current end of data in the underlying object, and the object does not support
 * extension, an error satisfying |i/o-invalid-position-error?| is signaled.
doc>
|#
(define (set-port-position! port pos)
  (when (output-port? port)
    (flush port))
  (port-seek port pos))

#|
<doc EXT make-i/o-invalid-position-error
 * (make-i/o-invalid-position-error pos)
 *
 * Returns a condition object which satisfies i/o-invalid-position-error?.
 * The pos argument represents a position passed to set-position!.
doc>
|#
(define (make-i/o-invalid-position-error pos)
   (make-condition &i/o-bad-parameter 'parameter pos))

#|
<doc EXT i/o-invalid-position-error?
 * (i/o-invalid-position-error? obj)
 *
 * Returns `#t` if |obj| is an object created by
 * |make-i/o-invalid-position-error?| or an object raised in the circumstances
 * described in {{quick-link-srfi 192}} (attempt to access an invalid position in the
 * stream), or `#f` if it is not.
doc>
|#
(define (i/o-invalid-position-error? obj)
  (and (condition? obj)
       (condition-has-type? 'obj &i/o-bad-parameter)))


;; ----------------------------------------------------------------------
;;  SRFI-193: "Command line"
;; ----------------------------------------------------------------------
#|
<doc EXT command-name
 * (command-name)
 *
 * Returnd the name of the running program if it is a standalone and `#f`
 * otherwise. This function is defined in {{link-srfi 193}}.
doc>
|#
(define (command-name)
  (let ((name (car (command-line))))
    (if (string=? name "")
        #f
        (let ((res (basename name)))
          (if (member (file-suffix res) *load-suffixes*)
              (file-prefix res)
              res)))))

#|
<doc EXT argv command-args
 * (command-args)
 * (argv)
 *
 * Returns a list of the arguments given on the shell command line. The
 * interpreter options are no included in the result. The name |argv| is
 * deprecated and should not be used.
doc>
|#
(define (command-args)
  (cdr (command-line)))

#|
<doc EXT argc
 * (argc)
 *
 * Returns the number of arguments present on the command line.
doc>
|#
(define argc (lambda () (length (command-args))))



#|
<doc EXT script-file
 * (script-file)
 *
 * Returns the absolute path of the current script.
 * If the calling program is not a script, `#f` is returned.
 * This function is defined in {{link-srfi 193}}.
doc>
|#
(define (script-file)
  (let ((file (key-get *%system-state-plist* :script-file "")))
    (and (not (equal? file ""))  file)))

#|
<doc EXT script-directory
 * (script-directory)
 *
 * Returns the non-filename part of script-file as a string.
 * As with |script-file|, this is an absolute pathname.
doc>
|#
(define (script-directory)
  (let ((file (key-get *%system-state-plist* :script-file "")))
    (and (not (equal? file ""))
         (string-append (dirname file) "/"))))


;; ----------------------------------------------------------------------
;;  SRFI-208: "NaN procedures"
;; ----------------------------------------------------------------------
#|
<doc EXT make-nan
 * (make-nan negative? quiet? payload)
 * (make-nan negative? quiet? payload float)
 *
 * Returns a NaN whose sign bit is equal to |negative?|  (`#t` for negative,
 * `#f` for positive), whose quiet bit is equal to quiet? (`#t` for quiet,
 * `#f` for signaling), and whose payload is the positive exact integer payload.
 * It is an error if payload is larger than a NaN can hold.
 *
 * The optional parameter |float|, is never used in {{stklos}}.
 *
 * This function is defined in {{quick-link-srfi 208}}.
doc>
|#
(define (make-nan negative? quiet? payload :optional float)
  (%make-nan negative? quiet? payload))


;; ----------------------------------------------------------------------

;; HACK: The documentation of the fx*/carry is here instead of in
;; file fixnum.c because a '*' followed bay a '/' ends a C comment
;; (and we cannot use '//' comment in C documentation.
;; As a consquence the documentation of this function is here
;; Not very proud of that....

#|
<doc EXT fx*/carry
 * (fx*/carry i j k)
 *
 * Returns two values: |i|*|j|+|k|, and carry: it is the value of the computation
 * @lisp
 * (let*-values (((s) (+ (* i j) k))
 *               ((q r) (balanced/ s (expt 2 fx-width))))
 *   (values r q))
 * @end lisp
doc>
|#

;; LocalWords:  doc dotimes R5RS str SRFI optarg
