code:
;;;; match.scm -- portable hygienic pattern matcher
;;
;; This code is written by Alex Shinn and placed in the
;; Public Domain.  All warranties are disclaimed.

;; This is a full superset of the popular MATCH package by Andrew
;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
;; in R6RS SYNTAX-RULES), and thus preserving hygiene.

;; This is a simple generative pattern matcher - each pattern is
;; expanded into the required tests, calling a failure continuation if
;; the tests fail.  This makes the logic easy to follow and extend,
;; but produces sub-optimal code in cases where you have many similar
;; clauses due to repeating the same tests.  Nonetheless a smart
;; compiler should be able to remove the redundant tests.  For
;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
;; hit.

;; The original version was written on 2006/11/29 and described in the
;; following Usenet post:
;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
;; and is still available at
;;   http://synthcode.com/scheme/match-simple.scm
;; It's just 80 lines for the core MATCH, and an extra 40 lines for
;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
;;
;; A variant of this file which uses COND-EXPAND in a few places for
;; performance can be found at
;;   http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns
;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
;; 2007/09/04 - fixing quasiquote patterns
;; 2007/07/21 - allowing ellipse patterns in non-final list positions
;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
;;              (thanks to Taylor Campbell)
;; 2007/04/08 - clean up, commenting
;; 2006/12/24 - bugfixes
;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; force compile-time syntax errors with useful messages

(define-syntax match-syntax-error
  (syntax-rules ()
    ((_) (match-syntax-error "invalid match-syntax-error usage"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The basic interface.  MATCH just performs some basic syntax
;; validation, binds the match expression to a temporary variable `v',
;; and passes it on to MATCH-NEXT.  It's a constant throughout the
;; code below that the binding `v' is a direct variable reference, not
;; an expression.

(define-syntax match
  (syntax-rules ()
    ((match)
     (match-syntax-error "missing match expression"))
    ((match atom)
     (match-syntax-error "no match clauses"))
    ((match (app ...) (pat . body) ...)
     (let ((v (app ...)))
       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
    ((match #(vec ...) (pat . body) ...)
     (let ((v #(vec ...)))
       (match-next v (v (set! v)) (pat . body) ...)))
    ((match atom (pat . body) ...)
     (match-next atom (atom (set! atom)) (pat . body) ...))
    ))

;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
;; clauses.  `g+s' is a list of two elements, the get! and set!
;; expressions respectively.

(define-syntax match-next
  (syntax-rules (=>)
    ;; no more clauses, the match failed
    ((match-next v g+s)
     (error 'match "no matching pattern"))
    ;; named failure continuation
    ((match-next v g+s (pat (=> failure) . body) . rest)
     (let ((failure (lambda () (match-next v g+s . rest))))
       ;; match-one analyzes the pattern for us
       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
    ;; anonymous failure continuation, give it a dummy name
    ((match-next v g+s (pat . body) . rest)
     (match-next v g+s (pat (=> failure) . body) . rest))))

;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
;; MATCH-TWO.

(define-syntax match-one
  (syntax-rules ()
    ;; If it's a list of two or more values, check to see if the
    ;; second one is an ellipse and handle accordingly, otherwise go
    ;; to MATCH-TWO.
    ((match-one v (p q . r) g+s sk fk i)
     (match-check-ellipse
      q
      (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
      (match-two v (p q . r) g+s sk fk i)))
    ;; Go directly to MATCH-TWO.
    ((match-one . x)
     (match-two . x))))

;; This is the guts of the pattern matcher.  We are passed a lot of
;; information in the form:
;;
;;   (match-two var pattern getter setter success-k fail-k (ids ...))
;;
;; usually abbreviated
;;
;;   (match-two v p g+s sk fk i)
;;
;; where VAR is the symbol name of the current variable we are
;; matching, PATTERN is the current pattern, getter and setter are the
;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
;; continuation (which is just a thunk call and is thus safe to expand
;; multiple times) and IDS are the list of identifiers bound in the
;; pattern so far.

(define-syntax match-two
  (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
    ((match-two v () g+s (sk ...) fk i)
     (if (null? v) (sk ... i) fk))
    ((match-two v (quote p) g+s (sk ...) fk i)
     (if (equal? v 'p) (sk ... i) fk))
    ((match-two v (quasiquote p) . x)
     (match-quasiquote v p . x))
    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
    ((match-two v (and p q ...) g+s sk fk i)
     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
    ((match-two v (or) g+s sk fk i) fk)
    ((match-two v (or p) . x)
     (match-one v p . x))
    ((match-two v (or p ...) g+s sk fk i)
     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
    ((match-two v (not p) g+s (sk ...) fk i)
     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
    ((match-two v (get! getter) (g s) (sk ...) fk i)
     (let ((getter (lambda () g))) (sk ... i)))
    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    ((match-two v (? pred . p) g+s sk fk i)
     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
    ((match-two v (= proc p) . x)
     (let ((w (proc v))) (match-one w p . x)))
    ((match-two v (p ___ . r) g+s sk fk i)
     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
    ((match-two v (p) g+s sk fk i)
     (if (and (pair? v) (null? (cdr v)))
         (let ((w (car v)))
           (match-one w p ((car v) (set-car! v)) sk fk i))
         fk))
    ((match-two v (p *** q) g+s sk fk i)
     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
    ((match-two v (p *** . q) g+s sk fk i)
     (match-syntax-error "invalid use of ***" (p *** . q)))
    ((match-two v (p . q) g+s sk fk i)
     (if (pair? v)
         (let ((w (car v)) (x (cdr v)))
           (match-one w p ((car v) (set-car! v))
                      (match-one x q ((cdr v) (set-cdr! v)) sk fk)
                      fk
                      i))
         fk))
    ((match-two v #(p ...) g+s . x)
     (match-vector v 0 () (p ...) . x))
    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
    ;; Not a pair or vector or special literal, test to see if it's a
    ;; new symbol, in which case we just bind it, or if it's an
    ;; already bound symbol or some other literal, in which case we
    ;; compare it with EQUAL?.
    ((match-two v x g+s (sk ...) fk (id ...))
     (let-syntax
         ((new-sym?
           (syntax-rules (id ...)
             ((new-sym? x sk2 fk2) sk2)
             ((new-sym? y sk2 fk2) fk2))))
       (new-sym? random-sym-to-match
                 (let ((x v)) (sk ... (id ... x)))
                 (if (equal? v x) (sk ... (id ...)) fk))))
    ))

;; QUASIQUOTE patterns

(define-syntax match-quasiquote
  (syntax-rules (unquote unquote-splicing quasiquote)
    ((_ v (unquote p) g+s sk fk i)
     (match-one v p g+s sk fk i))
    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
     (if (pair? v)
       (match-one v
                  (p . tmp)
                  (match-quasiquote tmp rest g+s sk fk)
                  fk
                  i)
       fk))
    ((_ v (quasiquote p) g+s sk fk i . depth)
     (match-quasiquote v p g+s sk fk i #f . depth))
    ((_ v (unquote p) g+s sk fk i x . depth)
     (match-quasiquote v p g+s sk fk i . depth))
    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
     (match-quasiquote v p g+s sk fk i . depth))
    ((_ v (p . q) g+s sk fk i . depth)
     (if (pair? v)
       (let ((w (car v)) (x (cdr v)))
         (match-quasiquote
          w p g+s
          (match-quasiquote-step x q g+s sk fk depth)
          fk i . depth))
       fk))
    ((_ v #(elt ...) g+s sk fk i . depth)
     (if (vector? v)
       (let ((ls (vector->list v)))
         (match-quasiquote ls (elt ...) g+s sk fk i . depth))
       fk))
    ((_ v x g+s sk fk i . depth)
     (match-one v 'x g+s sk fk i))))

(define-syntax match-quasiquote-step
  (syntax-rules ()
    ((match-quasiquote-step x q g+s sk fk depth i)
     (match-quasiquote x q g+s sk fk i . depth))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities

;; Takes two values and just expands into the first.
(define-syntax match-drop-ids
  (syntax-rules ()
    ((_ expr ids ...) expr)))

(define-syntax match-drop-first-arg
  (syntax-rules ()
    ((_ arg expr) expr)))

;; To expand an OR group we try each clause in succession, passing the
;; first that succeeds to the success continuation.  On failure for
;; any clause, we just try the next clause, finally resorting to the
;; failure continuation fk if all clauses fail.  The only trick is
;; that we want to unify the identifiers, so that the success
;; continuation can refer to a variable from any of the OR clauses.

(define-syntax match-gen-or
  (syntax-rules ()
    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))

(define-syntax match-gen-or-step
  (syntax-rules ()
    ((_ v () g+s sk fk . x)
     ;; no OR clauses, call the failure continuation
     fk)
    ((_ v (p) . x)
     ;; last (or only) OR clause, just expand normally
     (match-one v p . x))
    ((_ v (p . q) g+s sk fk i)
     ;; match one and try the remaining on failure
     (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
    ))

;; We match a pattern (p ...) by matching the pattern p in a loop on
;; each element of the variable, accumulating the bound ids into lists.

;; Look at the body of the simple case - it's just a named let loop,
;; matching each element in turn to the same pattern.  The only trick
;; is that we want to keep track of the lists of each extracted id, so
;; when the loop recurses we cons the ids onto their respective list
;; variables, and on success we bind the ids (what the user input and
;; expects to see in the success body) to the reversed accumulated
;; list IDs.

(define-syntax match-gen-ellipses
  (syntax-rules ()
    ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
     (match-check-identifier p
       ;; simplest case equivalent to (p ...), just bind the list
       (let ((p v))
         (if (list? p)
             (sk ... i)
             fk))
       ;; simple case, match all elements of the list
       (let loop ((ls v) (id-ls '()) ...)
         (cond
           ((null? ls)
            (let ((id (reverse id-ls)) ...) (sk ... i)))
           ((pair? ls)
            (let ((w (car ls)))
              (match-one w p ((car ls) (set-car! ls))
                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
                         fk i)))
           (else
            fk)))))
    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
     ;; general case, trailing patterns to match, keep track of the
     ;; remaining list length so we don't need any backtracking
     (match-verify-no-ellipses
      r
      (let* ((tail-len (length 'r))
             (ls v)
             (len (length ls)))
        (if (< len tail-len)
            fk
            (let loop ((ls ls) (n len) (id-ls '()) ...)
              (cond
                ((= n tail-len)
                 (let ((id (reverse id-ls)) ...)
                   (match-one ls r (#f #f) (sk ... i) fk i)))
                ((pair? ls)
                 (let ((w (car ls)))
                   (match-one w p ((car ls) (set-car! ls))
                              (match-drop-ids
                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                              fk
                              i)))
                (else
                 fk)))))))))

;; This is just a safety check.  Although unlike syntax-rules we allow
;; trailing patterns after an ellipses, we explicitly disable multiple
;; ellipses at the same level.  This is because in the general case
;; such patterns are exponential in the number of ellipses, and we
;; don't want to make it easy to construct very expensive operations
;; with simple looking patterns.  For example, it would be O(n^2) for
;; patterns like (a ... b ...) because we must consider every trailing
;; element for every possible break for the leading "a ...".

(define-syntax match-verify-no-ellipses
  (syntax-rules ()
    ((_ (x . y) sk)
     (match-check-ellipse
      x
      (match-syntax-error
       "multiple ellipse patterns not allowed at same level")
      (match-verify-no-ellipses y sk)))
    ((_ () sk)
     sk)
    ((_ x sk)
     (match-syntax-error "dotted tail not allowed after ellipse" x))))

;; Matching a tree search pattern is only slightly more complicated.
;; Here we allow patterns of the form
;;
;;     (x *** y)
;;
;; to represent the pattern y located somewhere in a tree where the
;; path from the current object to y can be seen as a list of the form
;; (X ...).  Y can immediately match the current object in which case
;; the path is the empty list.  In a sense it's a 2-dimensional
;; version of the ... pattern.
;;
;; As a common case the pattern (_ *** y) can be used to search for Y
;; anywhere in a tree, regardless of the path used.
;;
;; To implement the search, we use two recursive procedures.  TRY
;; attempts to match Y once, and on success it calls the normal SK on
;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
;; call NEXT which first checks if the current value is a list
;; beginning with X, then calls TRY on each remaining element of the
;; list.  Since TRY will recursively call NEXT again on failure, this
;; effects a full depth-first search.
;;
;; The failure continuation throughout is a jump to the next step in
;; the tree search, initialized with the original failure continuation
;; FK.

(define-syntax match-gen-search
  (syntax-rules ()
    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
     (letrec ((try (lambda (w fail id-ls ...)
                     (match-one w q g+s
                                (match-drop-ids
                                 (let ((id (reverse id-ls)) ...)
                                   sk))
                                (next w fail id-ls ...) i)))
              (next (lambda (w fail id-ls ...)
                      (if (not (pair? w))
                          (fail)
                          (let ((u (car w)))
                            (match-one
                             u p ((car w) (set-car! w))
                             (match-drop-ids
                              ;; accumulate the head variables from
                              ;; the p pattern, and loop over the tail
                              (let ((id-ls (cons id id-ls)) ...)
                                (let lp ((ls (cdr w)))
                                  (if (pair? ls)
                                      (try (car ls)
                                           (lambda () (lp (cdr ls)))
                                           id-ls ...)
                                      (fail)))))
                             (fail) i))))))
       ;; the initial id-ls binding here is a dummy to get the right
       ;; number of '()s
       (let ((id-ls '()) ...)
         (try v (lambda () fk) id-ls ...))))))

;; Vector patterns are just more of the same, with the slight
;; exception that we pass around the current vector index being
;; matched.

(define-syntax match-vector
  (syntax-rules (___)
    ((_ v n pats (p q) . x)
     (match-check-ellipse q
                          (match-gen-vector-ellipses v n pats p . x)
                          (match-vector-two v n pats (p q) . x)))
    ((_ v n pats (p ___) sk fk i)
     (match-gen-vector-ellipses v n pats p sk fk i))
    ((_ . x)
     (match-vector-two . x))))

;; Check the exact vector length, then check each element in turn.

(define-syntax match-vector-two
  (syntax-rules ()
    ((_ v n ((pat index) ...) () sk fk i)
     (if (vector? v)
         (let ((len (vector-length v)))
           (if (= len n)
               (match-vector-step v ((pat index) ...) sk fk i)
               fk))
         fk))
    ((_ v n (pats ...) (p . q) . x)
     (match-vector v (+ n 1) (pats ... (p n)) q . x))))

(define-syntax match-vector-step
  (syntax-rules ()
    ((_ v () (sk ...) fk i) (sk ... i))
    ((_ v ((pat index) . rest) sk fk i)
     (let ((w (vector-ref v index)))
       (match-one w pat ((vector-ref v index) (vector-set! v index))
                  (match-vector-step v rest sk fk)
                  fk i)))))

;; With a vector ellipse pattern we first check to see if the vector
;; length is at least the required length.

(define-syntax match-gen-vector-ellipses
  (syntax-rules ()
    ((_ v n ((pat index) ...) p sk fk i)
     (if (vector? v)
       (let ((len (vector-length v)))
         (if (>= len n)
           (match-vector-step v ((pat index) ...)
                              (match-vector-tail v p n len sk fk)
                              fk i)
           fk))
       fk))))

(define-syntax match-vector-tail
  (syntax-rules ()
    ((_ v p n len sk fk i)
     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))

(define-syntax match-vector-tail-two
  (syntax-rules ()
    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
     (let loop ((j n) (id-ls '()) ...)
       (if (>= j len)
         (let ((id (reverse id-ls)) ...) (sk ... i))
         (let ((w (vector-ref v j)))
           (match-one w p ((vector-ref v j) (vetor-set! v j))
                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                      fk i)))))))

;; Extract all identifiers in a pattern.  A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?
;; patterns), and also ignore previously bound identifiers.
;;
;; Calls the continuation with all new vars as a list of the form
;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
;; pair with the original variable (e.g. it's used in the ellipse
;; generation for list variables).
;;
;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))

(define-syntax match-extract-vars
  (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
    ((match-extract-vars (? pred . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars ($ rec . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (= proc p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (quote x) (k ...) i v)
     (k ... v))
    ((match-extract-vars (quasiquote x) k i v)
     (match-extract-quasiquote-vars x k i v (#t)))
    ((match-extract-vars (and . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (or . p) . x)
     (match-extract-vars p . x))
    ((match-extract-vars (not . p) . x)
     (match-extract-vars p . x))
    ;; A non-keyword pair, expand the CAR with a continuation to
    ;; expand the CDR.
    ((match-extract-vars (p q . r) k i v)
     (match-check-ellipse
      q
      (match-extract-vars (p . r) k i v)
      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
    ((match-extract-vars (p . q) k i v)
     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
    ((match-extract-vars #(p ...) . x)
     (match-extract-vars (p ...) . x))
    ((match-extract-vars _ (k ...) i v)    (k ... v))
    ((match-extract-vars ___ (k ...) i v)  (k ... v))
    ((match-extract-vars *** (k ...) i v)  (k ... v))
    ;; This is the main part, the only place where we might add a new
    ;; var if it's an unbound symbol.
    ((match-extract-vars p (k ...) (i ...) v)
     (let-syntax
         ((new-sym?
           (syntax-rules (i ...)
             ((new-sym? p sk fk) sk)
             ((new-sym? x sk fk) fk))))
       (new-sym? random-sym-to-match
                 (k ... ((p p-ls) . v))
                 (k ... v))))
    ))

;; Stepper used in the above so it can expand the CAR and CDR
;; separately.

(define-syntax match-extract-vars-step
  (syntax-rules ()
    ((_ p k i v ((v2 v2-ls) ...))
     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
    ))

(define-syntax match-extract-quasiquote-vars
  (syntax-rules (quasiquote unquote unquote-splicing)
    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
     (match-extract-quasiquote-vars x k i v (#t . d)))
    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
     (match-extract-quasiquote-vars (unquote x) k i v d))
    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
     (match-extract-vars x k i v))
    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
     (match-extract-quasiquote-vars x k i v d))
    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
     (match-extract-quasiquote-vars
      x
      (match-extract-quasiquote-vars-step y k i v d) i ()))
    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
     (match-extract-quasiquote-vars (x ...) k i v d))
    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
     (k ... v))
    ))

(define-syntax match-extract-quasiquote-vars-step
  (syntax-rules ()
    ((_ x k i v d ((v2 v2-ls) ...))
     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gimme some sugar baby.

(define-syntax match-lambda
  (syntax-rules ()
    ((_ clause ...) (lambda (expr) (match expr clause ...)))))

(define-syntax match-lambda*
  (syntax-rules ()
    ((_ clause ...) (lambda expr (match expr clause ...)))))

(define-syntax match-let
  (syntax-rules ()
    ((_ (vars ...) . body)
     (match-let/helper let () () (vars ...) . body))
    ((_ loop . rest)
     (match-named-let loop () . rest))))

(define-syntax match-letrec
  (syntax-rules ()
    ((_ vars . body) (match-let/helper letrec () () vars . body))))

(define-syntax match-let/helper
  (syntax-rules ()
    ((_ let ((var expr) ...) () () . body)
     (let ((var expr) ...) . body))
    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
     (let ((var expr) ...)
       (match-let* ((pat tmp) ...)
         . body)))
    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
     (match-let/helper
      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
     (match-let/helper
      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))

(define-syntax match-named-let
  (syntax-rules ()
    ((_ loop ((pat expr var) ...) () . body)
     (let loop ((var expr) ...)
       (match-let ((pat var) ...)
         . body)))
    ((_ loop (v ...) ((pat expr) . rest) . body)
     (match-named-let loop (v ... (pat expr tmp)) rest . body))))

(define-syntax match-let*
  (syntax-rules ()
    ((_ () . body)
     (begin . body))
    ((_ ((pat expr) . rest) . body)
     (match expr (pat (match-let* rest . body))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Otherwise COND-EXPANDed bits.

;; This *should* work, but doesn't :(
;;   (define-syntax match-check-ellipse
;;     (syntax-rules (...)
;;       ((_ ... sk fk) sk)
;;       ((_ x sk fk) fk)))

;; This is a little more complicated, and introduces a new let-syntax,
;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
;; originally came up with the idea.
(define-syntax match-check-ellipse
  (syntax-rules ()
    ;; these two aren't necessary but provide fast-case failures
    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
    ;; matching an atom
    ((match-check-ellipse id success-k failure-k)
     (let-syntax ((ellipse? (syntax-rules ()
                              ;; iff `id' is `...' here then this will
                              ;; match a list of any length
                              ((ellipse? (foo id) sk fk) sk)
                              ((ellipse? other sk fk) fk))))
       ;; this list of three elements will only many the (foo id) list
       ;; above if `id' is `...'
       (ellipse? (a b c) success-k failure-k)))))

;; This is portable but can be more efficient with non-portable
;; extensions.  This trick was originally discovered by Oleg Kiselyov.

(define-syntax match-check-identifier
  (syntax-rules ()
    ;; fast-case failures, lists and vectors are not identifiers
    ((_ (x . y) success-k failure-k) failure-k)
    ((_ #(x ...) success-k failure-k) failure-k)
    ;; x is an atom
    ((_ x success-k failure-k)
     (let-syntax
         ((sym?
           (syntax-rules ()
             ;; if the symbol `abracadabra' matches x, then x is a
             ;; symbol
             ((sym? x sk fk) sk)
             ;; otherwise x is a non-symbol datum
             ((sym? y sk fk) fk))))
       (sym? abracadabra success-k failure-k)))))


code:
;;; installed-scm-file

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

(eval-when (compile)
  (set-current-module (resolve-module '(guile))))

(define (gethostbyaddr addr) (gethost addr))
(define (gethostbyname name) (gethost name))

(define (getnetbyaddr addr) (getnet addr))
(define (getnetbyname name) (getnet name))

(define (getprotobyname name) (getproto name))
(define (getprotobynumber addr) (getproto addr))

(define (getservbyname name proto) (getserv name proto))
(define (getservbyport port proto) (getserv port proto))

(define (sethostent . stayopen)
  (if (pair? stayopen)
      (sethost (car stayopen))
      (sethost #f)))
(define (setnetent . stayopen)
  (if (pair? stayopen)
      (setnet (car stayopen))
      (setnet #f)))
(define (setprotoent . stayopen)
  (if (pair? stayopen)
      (setproto (car stayopen))
      (setproto #f)))
(define (setservent . stayopen)
  (if (pair? stayopen)
      (setserv (car stayopen))
      (setserv #f)))

(define (gethostent) (gethost))
(define (getnetent) (getnet))
(define (getprotoent) (getproto))
(define (getservent) (getserv))

(define (endhostent) (sethost))
(define (endnetent) (setnet))
(define (endprotoent) (setproto))
(define (endservent) (setserv))

(define (hostent:name obj) (vector-ref obj 0))
(define (hostent:aliases obj) (vector-ref obj 1))
(define (hostent:addrtype obj) (vector-ref obj 2))
(define (hostent:length obj) (vector-ref obj 3))
(define (hostent:addr-list obj) (vector-ref obj 4))

(define (netent:name obj) (vector-ref obj 0))
(define (netent:aliases obj) (vector-ref obj 1))
(define (netent:addrtype obj) (vector-ref obj 2))
(define (netent:net obj) (vector-ref obj 3))

(define (protoent:name obj) (vector-ref obj 0))
(define (protoent:aliases obj) (vector-ref obj 1))
(define (protoent:proto obj) (vector-ref obj 2))

(define (servent:name obj) (vector-ref obj 0))
(define (servent:aliases obj) (vector-ref obj 1))
(define (servent:port obj) (vector-ref obj 2))
(define (servent:proto obj) (vector-ref obj 3))

(define (sockaddr:fam obj) (vector-ref obj 0))
(define (sockaddr:path obj) (vector-ref obj 1))
(define (sockaddr:addr obj) (vector-ref obj 1))
(define (sockaddr:port obj) (vector-ref obj 2))
(define (sockaddr:flowinfo obj) (vector-ref obj 3))
(define (sockaddr:scopeid obj) (vector-ref obj 4))

(define (addrinfo:flags obj) (vector-ref obj 0))
(define (addrinfo:fam obj) (vector-ref obj 1))
(define (addrinfo:socktype obj) (vector-ref obj 2))
(define (addrinfo:protocol obj) (vector-ref obj 3))
(define (addrinfo:addr obj) (vector-ref obj 4))
(define (addrinfo:canonname obj) (vector-ref obj 5))

license: mit


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

;;;; The null environment - only syntactic bindings

(define-module (ice-9 null)
  :re-export-syntax (define quote lambda if set!

		     cond case and or

		     let let* letrec

		     begin do

		     delay

		     quasiquote

		     define-syntax
		     let-syntax letrec-syntax))


code:
;;;; Occam-like channels

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

(define-module (ice-9 occam-channel)
  #:use-module (oop goops)
  #:use-module (ice-9 threads)
  #:export-syntax (alt
		   ;; macro use:
		   oc:lock oc:unlock oc:consequence
		   oc:immediate-dispatch oc:late-dispatch oc:first-channel
		   oc:set-handshake-channel oc:unset-handshake-channel)
  #:export (make-channel
	    ?
	    !
	    make-timer
	    ;; macro use:
	    handshake-channel mutex
	    sender-waiting?
	    immediate-receive late-receive
	    )
  )

(define no-data '(no-data))
(define receiver-waiting '(receiver-waiting))

(define-class <channel> ())

(define-class <data-channel> (<channel>)
  (handshake-channel #:accessor handshake-channel)
  (data #:accessor data #:init-value no-data)
  (cv #:accessor cv #:init-form (make-condition-variable))
  (mutex #:accessor mutex #:init-form (make-mutex)))

(define-method (initialize (ch <data-channel>) initargs)
  (next-method)
  (set! (handshake-channel ch) ch))

(define-method (make-channel)
  (make <data-channel>))

(define-method (sender-waiting? (ch <data-channel>))
  (not (eq? (data ch) no-data)))

(define-method (receiver-waiting? (ch <data-channel>))
  (eq? (data ch) receiver-waiting))

(define-method (immediate-receive (ch <data-channel>))
  (signal-condition-variable (cv ch))
  (let ((res (data ch)))
    (set! (data ch) no-data)
    res))

(define-method (late-receive (ch <data-channel>))
  (let ((res (data ch)))
    (set! (data ch) no-data)
    res))

(define-method (? (ch <data-channel>))
  (lock-mutex (mutex ch))
  (let ((res (cond ((receiver-waiting? ch)
		    (unlock-mutex (mutex ch))
		    (scm-error 'misc-error '?
			       "another process is already receiving on ~A"
			       (list ch) #f))
		   ((sender-waiting? ch)
		    (immediate-receive ch))
		   (else
		    (set! (data ch) receiver-waiting)
		    (wait-condition-variable (cv ch) (mutex ch))
		    (late-receive ch)))))
    (unlock-mutex (mutex ch))
    res))

(define-method (! (ch <data-channel>))
  (! ch *unspecified*))

(define-method (! (ch <data-channel>) (x <top>))
  (lock-mutex (mutex (handshake-channel ch)))
  (cond ((receiver-waiting? ch)
	 (set! (data ch) x)
	 (signal-condition-variable (cv (handshake-channel ch))))
	((sender-waiting? ch)
	 (unlock-mutex (mutex (handshake-channel ch)))
	 (scm-error 'misc-error '! "another process is already sending on ~A"
		    (list ch) #f))
	(else
	 (set! (data ch) x)
	 (wait-condition-variable (cv ch) (mutex ch))))
  (unlock-mutex (mutex (handshake-channel ch))))

;;; Add protocols?

(define-class <port-channel> (<channel>)
  (port #:accessor port #:init-keyword #:port))

(define-method (make-channel (port <port>))
  (make <port-channel> #:port port))

(define-method (? (ch <port-channel>))
  (read (port ch)))

(define-method (! (ch <port-channel>))
  (write (port ch)))

(define-class <timer-channel> (<channel>))

(define the-timer (make <timer-channel>))

(define timer-cv (make-condition-variable))
(define timer-mutex (make-mutex))

(define (make-timer)
  the-timer)

(define (timeofday->us t)
  (+ (* 1000000 (car t)) (cdr t)))

(define (us->timeofday n)
  (cons (quotient n 1000000)
	(remainder n 1000000)))

(define-method (? (ch <timer-channel>))
  (timeofday->us (gettimeofday)))

(define-method (? (ch <timer-channel>) (t <integer>))
  (lock-mutex timer-mutex)
  (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
  (unlock-mutex timer-mutex))

;;; (alt CLAUSE ...)
;;;
;;; CLAUSE ::= ((? CH) FORM ...)
;;;            | (EXP (? CH) FORM ...)
;;;            | (EXP FORM ...)
;;;
;;; where FORM ... can be => (lambda (x) ...)
;;;
;;; *fixme* Currently only handles <data-channel>:s
;;;

(define-syntax oc:lock
  (syntax-rules (?)
    ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
    ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
    ((_ (exp form ...)) #f)))

(define-syntax oc:unlock
  (syntax-rules (?)
    ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
    ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
    ((_ (exp form ...)) #f)))

(define-syntax oc:consequence
  (syntax-rules (=>)
    ((_ data) data)
    ((_ data => (lambda (x) e1 e2 ...))
     (let ((x data)) e1 e2 ...))
    ((_ data e1 e2 ...)
     (begin data e1 e2 ...))))

(define-syntax oc:immediate-dispatch
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     ((sender-waiting? ch)
      (oc:consequence (immediate-receive ch) e1 ...)))
    ((_ (exp (? ch) e1 ...))
     ((and exp (sender-waiting? ch))
      (oc:consequence (immediate-receive ch) e1 ...)))
    ((_ (exp e1 ...))
     (exp e1 ...))))

(define-syntax oc:late-dispatch
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     ((sender-waiting? ch)
      (oc:consequence (late-receive ch) e1 ...)))
    ((_ (exp (? ch) e1 ...))
     ((and exp (sender-waiting? ch))
      (oc:consequence (late-receive ch) e1 ...)))
    ((_ (exp e1 ...))
     (#f))))

(define-syntax oc:first-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...) c2 ...)
     ch)
    ((_ (exp (? ch) e1 ...) c2 ...)
     ch)
    ((_ c1 c2 ...)
     (first-channel c2 ...))))

(define-syntax oc:set-handshake-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...) handshake)
     (set! (handshake-channel ch) handshake))
    ((_ (exp (? ch) e1 ...) handshake)
     (and exp (set! (handshake-channel ch) handshake)))
    ((_ (exp e1 ...) handshake)
     #f)))

(define-syntax oc:unset-handshake-channel
  (syntax-rules (?)
    ((_ ((? ch) e1 ...))
     (set! (handshake-channel ch) ch))
    ((_ (exp (? ch) e1 ...))
     (and exp (set! (handshake-channel ch) ch)))
    ((_ (exp e1 ...))
     #f)))

(define-syntax alt
  (lambda (x)
    (define (else-clause? x)
      (syntax-case x (else)
	((_) #f)
	((_ (else e1 e2 ...)) #t)
	((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))

    (syntax-case x (else)
      ((_ c1 c2 ...)
       (else-clause? x)
       (syntax (begin
		 (oc:lock c1)
		 (oc:lock c2) ...
		 (let ((res (cond (oc:immediate-dispatch c1)
				  (oc:immediate-dispatch c2) ...)))
		   (oc:unlock c1)
		   (oc:unlock c2) ...
		   res))))
      ((_ c1 c2 ...)
       (syntax (begin
		 (oc:lock c1)
		 (oc:lock c2) ...
		 (let ((res (cond (oc:immediate-dispatch c1)
				  (oc:immediate-dispatch c2) ...
				  (else (let ((ch (oc:first-channel c1 c2 ...)))
					  (oc:set-handshake-channel c1 ch)
					  (oc:set-handshake-channel c2 ch) ...
					  (wait-condition-variable (cv ch)
								   (mutex ch))
					  (oc:unset-handshake-channel c1)
					  (oc:unset-handshake-channel c2) ...
					  (cond (oc:late-dispatch c1)
						(oc:late-dispatch c2) ...))))))
		   (oc:unlock c1)
		   (oc:unlock c2) ...
		   res)))))))


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

;;; Commentary:

;;; {Optional Arguments}
;;;
;;; The C interface for creating Guile procedures has a very handy
;;; "optional argument" feature. This module attempts to provide
;;; similar functionality for procedures defined in Scheme with
;;; a convenient and attractive syntax.
;;;
;;; exported macros are:
;;;   let-optional
;;;   let-optional*
;;;   let-keywords
;;;   let-keywords*
;;;   lambda*
;;;   define*
;;;   define*-public
;;;   defmacro*
;;;   defmacro*-public
;;;
;;;
;;; Summary of the lambda* extended parameter list syntax (brackets
;;; are used to indicate grouping only):
;;;
;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
;;;   [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
;;;   [[#:rest identifier]|[. identifier]]?
;;;
;;; ext-var-decl ::= identifier | ( identifier expression )
;;;
;;; The characters `*', `+' and `?' are not to be taken literally; they
;;; mean respectively, zero or more occurences, one or more occurences,
;;; and one or zero occurences.
;;;

;;; Code:

(define-module (ice-9 optargs)
  #:use-module (system base pmatch)
  #:re-export (lambda* define*)
  #:export (let-optional
            let-optional*
            let-keywords
            let-keywords*
            define*-public
            defmacro*
            defmacro*-public))

;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
;;   macros used to bind optional arguments
;;
;; These two macros give you an optional argument interface that is
;; very "Schemey" and introduces no fancy syntax. They are compatible
;; with the scsh macros of the same name, but are slightly
;; extended. Each of binding may be of one of the forms <var> or
;; (<var> <default-value>). rest-arg should be the rest-argument of
;; the procedures these are used from. The items in rest-arg are
;; sequentially bound to the variable namess are given. When rest-arg
;; runs out, the remaining vars are bound either to the default values
;; or to `#f' if no default value was specified. rest-arg remains
;; bound to whatever may have been left of rest-arg.
;;

(define (vars&inits bindings)
  (let lp ((bindings bindings) (vars '()) (inits '()))
    (syntax-case bindings ()
      (()
       (values (reverse vars) (reverse inits)))
      (((v init) . rest) (identifier? #'v)
       (lp #'rest (cons #'v vars) (cons #'init inits)))
      ((v . rest) (identifier? #'v)
       (lp #'rest (cons #'v vars) (cons #'#f inits))))))

(define-syntax let-optional
  (lambda (x)
    (syntax-case x ()
      ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
       (call-with-values (lambda () (vars&inits #'(binding ...)))
         (lambda (vars inits)
           (with-syntax ((n (length vars))
                         (n+1 (1+ (length vars)))
                         (vars (append vars (list #'rest-arg)))
                         ((t ...) (generate-temporaries vars))
                         ((i ...) inits))
             #'(let ((t (lambda vars i))
                     ...)
                 (apply (lambda vars b0 b1 ...)
                        (or (parse-lambda-case '(0 n n n+1 #f '())
                                               (list t ...)
                                               rest-arg)
                            (error "sth" rest-arg)))))))))))

(define-syntax let-optional*
  (lambda (x)
    (syntax-case x ()
      ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
       (call-with-values (lambda () (vars&inits #'(binding ...)))
         (lambda (vars inits)
           (with-syntax ((n (length vars))
                         (n+1 (1+ (length vars)))
                         (vars (append vars (list #'rest-arg)))
                         ((i ...) inits))
             #'(apply (lambda vars b0 b1 ...)
                      (or (parse-lambda-case '(0 n n n+1 #f '())
                                             (list (lambda vars i) ...)
                                             rest-arg)
                          (error "sth" rest-arg))))))))))

;; let-keywords rest-arg allow-other-keys? (binding ...) . body
;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
;;   macros used to bind keyword arguments
;;
;; These macros pick out keyword arguments from rest-arg, but do not
;; modify it. This is consistent at least with Common Lisp, which
;; duplicates keyword args in the rest arg. More explanation of what
;; keyword arguments in a lambda list look like can be found below in
;; the documentation for lambda*.  Bindings can have the same form as
;; for let-optional. If allow-other-keys? is false, an error will be
;; thrown if anything that looks like a keyword argument but does not
;; match a known keyword parameter will result in an error.
;;

(define-syntax let-keywords
  (lambda (x)
    (syntax-case x ()
      ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
       (call-with-values (lambda () (vars&inits #'(binding ...)))
         (lambda (vars inits)
           (with-syntax ((n (length vars))
                         (vars vars)
                         (ivars (generate-temporaries vars))
                         ((kw ...) (map symbol->keyword
                                        (map syntax->datum vars)))
                         ((idx ...) (iota (length vars)))
                         ((t ...) (generate-temporaries vars))
                         ((i ...) inits))
             #'(let ((t (lambda ivars i))
                     ...)
                 (apply (lambda vars b0 b1 ...)
                        (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
                                               (list t ...)
                                               rest-arg)
                            (error "sth" rest-arg))))))))
      ((_ rest-arg aok (binding ...) b0 b1 ...)
       #'(let ((r rest-arg))
           (let-keywords r aok (binding ...) b0 b1 ...))))))

(define-syntax let-keywords*
  (lambda (x)
    (syntax-case x ()
      ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
       (call-with-values (lambda () (vars&inits #'(binding ...)))
         (lambda (vars inits)
           (with-syntax ((n (length vars))
                         (vars vars)
                         ((kw ...) (map symbol->keyword
                                        (map syntax->datum vars)))
                         ((idx ...) (iota (length vars)))
                         ((i ...) inits))
             #'(apply (lambda vars b0 b1 ...)
                      (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
                                             (list (lambda vars i) ...)
                                             rest-arg)
                          (error "sth" rest-arg)))))))
      ((_ rest-arg aok (binding ...) b0 b1 ...)
       #'(let ((r rest-arg))
           (let-keywords* r aok (binding ...) b0 b1 ...))))))

;; lambda* args . body
;;   lambda extended for optional and keyword arguments
;;
;; lambda* creates a procedure that takes optional arguments. These
;; are specified by putting them inside brackets at the end of the
;; paramater list, but before any dotted rest argument. For example,
;;   (lambda* (a b #:optional c d . e) '())
;; creates a procedure with fixed arguments a and b, optional arguments c
;; and d, and rest argument e. If the optional arguments are omitted
;; in a call, the variables for them are bound to `#f'.
;;
;; lambda* can also take keyword arguments. For example, a procedure
;; defined like this:
;;   (lambda* (#:key xyzzy larch) '())
;; can be called with any of the argument lists (#:xyzzy 11)
;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
;; are given as keywords are bound to values.
;;
;; Optional and keyword arguments can also be given default values
;; which they take on when they are not present in a call, by giving a
;; two-item list in place of an optional argument, for example in:
;;   (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
;; foo is a fixed argument, bar is an optional argument with default
;; value 42, and baz is a keyword argument with default value 73.
;; Default value expressions are not evaluated unless they are needed
;; and until the procedure is called.
;;
;; lambda* now supports two more special parameter list keywords.
;;
;; lambda*-defined procedures now throw an error by default if a
;; keyword other than one of those specified is found in the actual
;; passed arguments. However, specifying #:allow-other-keys
;; immediately after the keyword argument declarations restores the
;; previous behavior of ignoring unknown keywords. lambda* also now
;; guarantees that if the same keyword is passed more than once, the
;; last one passed is the one that takes effect. For example,
;;   ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
;;    #:heads 37 #:tails 42 #:heads 99)
;; would result in (99 47) being displayed.
;;
;; #:rest is also now provided as a synonym for the dotted syntax rest
;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
;; all respects to lambda*. This is provided for more similarity to DSSSL,
;; MIT-Scheme and Kawa among others, as well as for refugees from other
;; Lisp dialects.

;; define* args . body
;; define*-public args . body
;;   define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
;; a similar syntax to lambda*. Some examples:
;;   (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.

(define-syntax define*-public
  (lambda (x)
    (syntax-case x ()
      ((_ (id . args) b0 b1 ...)
       #'(define-public id (lambda* args b0 b1 ...)))
      ((_ id val) (identifier? #'id)
       #'(define-public id val)))))

;; defmacro* name args . body
;; defmacro*-public args . body
;;   defmacro and defmacro-public extended for optional and keyword arguments
;;
;; These are just like defmacro and defmacro-public except that they
;; take lambda*-style extended paramter lists, where #:optional,
;; #:key, #:allow-other-keys and #:rest are allowed with the usual
;; semantics. Here is an example of a macro with an optional argument:
;;   (defmacro* transmorgify (a #:optional b)

(define-syntax defmacro*
  (lambda (x)
    (syntax-case x ()
      ((_ id args doc b0 b1 ...) (string? (syntax->datum #'doc))
       #'(define-macro id doc (lambda* args b0 b1 ...)))
      ((_ id args b0 b1 ...)
       #'(define-macro id #f (lambda* args b0 b1 ...))))))
(define-syntax defmacro*-public
  (syntax-rules ()
    ((_ id args b0 b1 ...)
     (begin
       (defmacro* id args b0 b1 ...)
       (export-syntax id)))))

;;; Support for optional & keyword args with the interpreter.
(define *uninitialized* (list 'uninitialized))
(define (parse-lambda-case spec inits args)
  (pmatch spec
    ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
     (define (req args prev tail n)
       (cond
        ((zero? n)
         (if prev (set-cdr! prev '()))
         (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
           (opt (if prev (append! args slots-tail) slots-tail)
                slots-tail tail nopt inits)))
        ((null? tail)
         #f) ;; fail
        (else
         (req args tail (cdr tail) (1- n)))))
     (define (opt slots slots-tail args-tail n inits)
       (cond
        ((zero? n)
         (rest-or-key slots slots-tail args-tail inits rest-idx))
        ((null? args-tail)
         (set-car! slots-tail (apply (car inits) slots))
         (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
        (else
         (set-car! slots-tail (car args-tail))
         (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
     (define (rest-or-key slots slots-tail args-tail inits rest-idx)
       (cond
        (rest-idx
         ;; it has to be this way, vars are allocated in this order
         (set-car! slots-tail args-tail)
         (if (pair? kw-indices)
             (permissive-keys slots (cdr slots-tail) args-tail inits)
             (rest-or-key slots (cdr slots-tail) '() inits #f)))
        ((pair? kw-indices)
         ;; fail early here, because once we're in keyword land we throw
         ;; errors instead of failing
         (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
              (key slots slots-tail args-tail inits)))
        ((pair? args-tail)
         #f) ;; fail
        (else
         slots)))
     (define (permissive-keys slots slots-tail args-tail inits)
       (cond
        ((null? args-tail)
         (if (null? inits)
             slots
             (begin
               (if (eq? (car slots-tail) *uninitialized*)
                   (set-car! slots-tail (apply (car inits) slots)))
               (permissive-keys slots (cdr slots-tail) '() (cdr inits)))))
        ((not (keyword? (car args-tail)))
         (permissive-keys slots slots-tail (cdr args-tail) inits))
        ((and (keyword? (car args-tail))
              (pair? (cdr args-tail))
              (assq-ref kw-indices (car args-tail)))
         => (lambda (i)
              (list-set! slots i (cadr args-tail))
              (permissive-keys slots slots-tail (cddr args-tail) inits)))
        ((and (keyword? (car args-tail))
              (pair? (cdr args-tail))
              allow-other-keys?)
         (permissive-keys slots slots-tail (cddr args-tail) inits))
        (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
                         '() args-tail))))
     (define (key slots slots-tail args-tail inits)
       (cond
        ((null? args-tail)
         (if (null? inits)
             slots
             (begin
               (if (eq? (car slots-tail) *uninitialized*)
                   (set-car! slots-tail (apply (car inits) slots)))
               (key slots (cdr slots-tail) '() (cdr inits)))))
        ((not (keyword? (car args-tail)))
         (if rest-idx
             ;; no error checking, everything goes to the rest..
             (key slots slots-tail '() inits)
             (scm-error 'keyword-argument-error #f "Invalid keyword"
                        '() args-tail)))
        ((and (keyword? (car args-tail))
              (pair? (cdr args-tail))
              (assq-ref kw-indices (car args-tail)))
         => (lambda (i)
              (list-set! slots i (cadr args-tail))
              (key slots slots-tail (cddr args-tail) inits)))
        ((and (keyword? (car args-tail))
              (pair? (cdr args-tail))
              allow-other-keys?)
         (key slots slots-tail (cddr args-tail) inits))
        (else (scm-error 'keyword-argument-error #f "Unrecognized keyword"
                         '() args-tail))))
     (let ((args (list-copy args)))
       (req args #f args nreq)))
    (else (error "unexpected spec" spec))))


code:
;;; installed-scm-file

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

(define-module  (ice-9 poe)
  :use-module (ice-9 hcons)
  :export (pure-funcq perfect-funcq))

;;; {Pure Functions}
;;;
;;; A pure function (of some sort) is characterized by two equality
;;; relations: one on argument lists and one on return values.
;;; A pure function is one that when applied to equal arguments lists
;;; yields equal results.
;;;
;;; If the equality relationship on return values can be eq?, it may make
;;; sense to cache values returned by the function.  Choosing the right
;;; equality relation on arguments is tricky.
;;;

;;; {pure-funcq}
;;;
;;; The simplest case of pure functions are those in which results
;;; are only certainly eq? if all of the arguments are.  These functions
;;; are called "pure-funcq", for obvious reasons.
;;;

(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))

(define (funcq-hash arg-list n)
  (let ((it (let loop ((x 0)
		       (arg-list arg-list))
	      (if (null? arg-list)
		  (modulo x n)
		  (loop (logior x (hashq (car arg-list) 4194303))
			(cdr arg-list))))))
    it))

;; return true if lists X and Y are the same length and each element is `eq?'
(define (eq?-list x y)
  (if (null? x)
      (null? y)
      (and (not (null? y))
	   (eq? (car x) (car y))
	   (eq?-list (cdr x) (cdr y)))))

(define (funcq-assoc arg-list alist)
  (if (null? alist)
      #f
      (if (eq?-list arg-list (caar alist))
	  (car alist)
	  (funcq-assoc arg-list (cdr alist)))))

(define (pure-funcq base-func)
  (lambda args
    (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
      (if cached
	  (begin
	    (funcq-buffer (car cached))
	    (cdr cached))

	  (let ((val (apply base-func args))
		(key (cons base-func args)))
	    (funcq-buffer key)
	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
	    val)))))

;;; {Perfect funq}
;;;
;;; A pure funq may sometimes forget its past but a perfect
;;; funcq never does.
;;;

(define (perfect-funcq size base-func)
  (define funcq-memo (make-hash-table size))

  (lambda args
    (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
      (if cached
	  (begin
	    (funcq-buffer (car cached))
	    (cdr cached))

	  (let ((val (apply base-func args))
		(key (cons base-func args)))
	    (funcq-buffer key)
	    (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
	    val)))))


code:
;; popen emulation, for non-stdio based ports.

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

(define-module (ice-9 popen)
  :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
	   open-output-pipe open-input-output-pipe))

(define (make-rw-port read-port write-port)
  (make-soft-port
   (vector
    (lambda (c) (write-char c write-port))
    (lambda (s) (display s write-port))
    (lambda () (force-output write-port))
    (lambda () (read-char read-port))
    (lambda () (close-port read-port) (close-port write-port)))
   "r+"))

;; a guardian to ensure the cleanup is done correctly when
;; an open pipe is gc'd or a close-port is used.
(define pipe-guardian (make-guardian))

;; a weak hash-table to store the process ids.
(define port/pid-table (make-weak-key-hash-table 31))

(define (ensure-fdes port mode)
  (or (false-if-exception (fileno port))
      (open-fdes *null-device* mode)))

;; run a process connected to an input, an output or an
;; input/output port
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
;; returns port/pid pair.
(define (open-process mode prog . args)
  (let* ((reading (or (equal? mode OPEN_READ)
		      (equal? mode OPEN_BOTH)))
	 (writing (or (equal? mode OPEN_WRITE)
		      (equal? mode OPEN_BOTH)))
	 (c2p (if reading (pipe) #f))  ; child to parent
	 (p2c (if writing (pipe) #f))) ; parent to child

    (if c2p (setvbuf (cdr c2p) _IONBF))
    (if p2c (setvbuf (cdr p2c) _IONBF))
    (let ((pid (primitive-fork)))
      (cond ((= pid 0)
	     ;; child
	     (ensure-batch-mode!)

	     ;; select the three file descriptors to be used as
	     ;; standard descriptors 0, 1, 2 for the new
	     ;; process. They are pipes to/from the parent or taken
	     ;; from the current Scheme input/output/error ports if
	     ;; possible.

	     (let ((input-fdes (if writing
				   (fileno (car p2c))
				   (ensure-fdes (current-input-port)
						O_RDONLY)))
		   (output-fdes (if reading
				    (fileno (cdr c2p))
				    (ensure-fdes (current-output-port)
						 O_WRONLY)))
		   (error-fdes (ensure-fdes (current-error-port)
					    O_WRONLY)))

	       ;; close all file descriptors in ports inherited from
	       ;; the parent except for the three selected above.
	       ;; this is to avoid causing problems for other pipes in
	       ;; the parent.

	       ;; use low-level system calls, not close-port or the
	       ;; scsh routines, to avoid side-effects such as
	       ;; flushing port buffers or evicting ports.

	       (port-for-each (lambda (pt-entry)
				(false-if-exception
				 (let ((pt-fileno (fileno pt-entry)))
				   (if (not (or (= pt-fileno input-fdes)
						(= pt-fileno output-fdes)
						(= pt-fileno error-fdes)))
				       (close-fdes pt-fileno))))))

	       ;; Copy the three selected descriptors to the standard
	       ;; descriptors 0, 1, 2, if not already there

	       (cond ((not (= input-fdes 0))
		      (if (= output-fdes 0)
			  (set! output-fdes (dup->fdes 0)))
		      (if (= error-fdes 0)
			  (set! error-fdes (dup->fdes 0)))
		      (dup2 input-fdes 0)
		      ;; it's possible input-fdes is error-fdes
		      (if (not (= input-fdes error-fdes))
			  (close-fdes input-fdes))))

	       (cond ((not (= output-fdes 1))
		      (if (= error-fdes 1)
			  (set! error-fdes (dup->fdes 1)))
		      (dup2 output-fdes 1)
		      ;; it's possible output-fdes is error-fdes
		      (if (not (= output-fdes error-fdes))
			  (close-fdes output-fdes))))

	       (cond ((not (= error-fdes 2))
		      (dup2 error-fdes 2)
		      (close-fdes error-fdes)))

	       (apply execlp prog prog args)))

	    (else
	     ;; parent
	     (if c2p (close-port (cdr c2p)))
	     (if p2c (close-port (car p2c)))
	     (cons (cond ((not writing) (car c2p))
			 ((not reading) (cdr p2c))
			 (else (make-rw-port (car c2p)
					     (cdr p2c))))
		   pid))))))

(define (open-pipe* mode command . args)
  "Executes the program @var{command} with optional arguments
@var{args} (all strings) in a subprocess.
A port to the process (based on pipes) is created and returned.
@var{modes} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
  (let* ((port/pid (apply open-process mode command args))
	 (port (car port/pid)))
    (pipe-guardian port)
    (hashq-set! port/pid-table port (cdr port/pid))
    port))

(define (open-pipe command mode)
  "Executes the shell command @var{command} (a string) in a subprocess.
A port to the process (based on pipes) is created and returned.
@var{modes} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
  (open-pipe* mode "/bin/sh" "-c" command))

(define (fetch-pid port)
  (let ((pid (hashq-ref port/pid-table port)))
    (hashq-remove! port/pid-table port)
    pid))

(define (close-process port/pid)
  (close-port (car port/pid))
  (cdr (waitpid (cdr port/pid))))

;; for the background cleanup handler: just clean up without reporting
;; errors.  also avoids blocking the process: if the child isn't ready
;; to be collected, puts it back into the guardian's live list so it
;; can be tried again the next time the cleanup runs.
(define (close-process-quietly port/pid)
  (catch 'system-error
	 (lambda ()
	   (close-port (car port/pid)))
	 (lambda args #f))
  (catch 'system-error
	 (lambda ()
	   (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
	     (cond ((= (car pid/status) 0)
		    ;; not ready for collection
		    (pipe-guardian (car port/pid))
		    (hashq-set! port/pid-table
				(car port/pid) (cdr port/pid))))))
	 (lambda args #f)))

(define (close-pipe p)
  "Closes the pipe created by @code{open-pipe}, then waits for the process
to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value."
  (let ((pid (fetch-pid p)))
    (if (not pid)
        (error "close-pipe: pipe not in table"))
    (close-process (cons p pid))))

(define reap-pipes
  (lambda ()
    (let loop ((p (pipe-guardian)))
      (cond (p
	     ;; maybe removed already by close-pipe.
	     (let ((pid (fetch-pid p)))
	       (if pid
		   (close-process-quietly (cons p pid))))
	     (loop (pipe-guardian)))))))

(add-hook! after-gc-hook reap-pipes)

(define (open-input-pipe command)
  "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
  (open-pipe command OPEN_READ))

(define (open-output-pipe command)
  "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
  (open-pipe command OPEN_WRITE))

(define (open-input-output-pipe command)
  "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
  (open-pipe command OPEN_BOTH))


code:
;;; installed-scm-file

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

(eval-when (compile)
  (set-current-module (resolve-module '(guile))))

(define (stat:dev f) (vector-ref f 0))
(define (stat:ino f) (vector-ref f 1))
(define (stat:mode f) (vector-ref f 2))
(define (stat:nlink f) (vector-ref f 3))
(define (stat:uid f) (vector-ref f 4))
(define (stat:gid f) (vector-ref f 5))
(define (stat:rdev f) (vector-ref f 6))
(define (stat:size f) (vector-ref f 7))
(define (stat:atime f) (vector-ref f 8))
(define (stat:mtime f) (vector-ref f 9))
(define (stat:ctime f) (vector-ref f 10))
(define (stat:blksize f) (vector-ref f 11))
(define (stat:blocks f) (vector-ref f 12))
(define (stat:atimensec f) (vector-ref f 15))
(define (stat:mtimensec f) (vector-ref f 16))
(define (stat:ctimensec f) (vector-ref f 17))

;; derived from stat mode.
(define (stat:type f) (vector-ref f 13))
(define (stat:perms f) (vector-ref f 14))

(define (passwd:name obj) (vector-ref obj 0))
(define (passwd:passwd obj) (vector-ref obj 1))
(define (passwd:uid obj) (vector-ref obj 2))
(define (passwd:gid obj) (vector-ref obj 3))
(define (passwd:gecos obj) (vector-ref obj 4))
(define (passwd:dir obj) (vector-ref obj 5))
(define (passwd:shell obj) (vector-ref obj 6))

(define (group:name obj) (vector-ref obj 0))
(define (group:passwd obj) (vector-ref obj 1))
(define (group:gid obj) (vector-ref obj 2))
(define (group:mem obj) (vector-ref obj 3))

(define (utsname:sysname obj) (vector-ref obj 0))
(define (utsname:nodename obj) (vector-ref obj 1))
(define (utsname:release obj) (vector-ref obj 2))
(define (utsname:version obj) (vector-ref obj 3))
(define (utsname:machine obj) (vector-ref obj 4))

(define (getpwent) (getpw))
(define (setpwent) (setpw #t))
(define (endpwent) (setpw))

(define (getpwnam name) (getpw name))
(define (getpwuid uid) (getpw uid))

(define (getgrent) (getgr))
(define (setgrent) (setgr #t))
(define (endgrent) (setgr))

(define (getgrnam name) (getgr name))
(define (getgrgid id) (getgr id))


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

;; From SLIB.

;;"genwrite.scm" generic write used by pretty-print and truncated-print.
;; Copyright (c) 1991, Marc Feeley
;; Author: Marc Feeley (feeley@iro.umontreal.ca)
;; Distribution restrictions: none

(define genwrite:newline-str (make-string 1 #\newline))

(define (generic-write obj display? width per-line-prefix output)

  (define (read-macro? l)
    (define (length1? l) (and (pair? l) (null? (cdr l))))
    (let ((head (car l)) (tail (cdr l)))
      (case head
        ((quote quasiquote unquote unquote-splicing) (length1? tail))
        (else                                        #f))))

  (define (read-macro-body l)
    (cadr l))

  (define (read-macro-prefix l)
    (let ((head (car l)))
      (case head
        ((quote)            "'")
        ((quasiquote)       "`")
        ((unquote)          ",")
        ((unquote-splicing) ",@"))))

  (define (out str col)
    (and col (output str) (+ col (string-length str))))

  (define (wr obj col)
    (cond ((and (pair? obj)
		(read-macro? obj))
	   (wr (read-macro-body obj)
	       (out (read-macro-prefix obj) col)))
	  (else
	   (out (object->string obj (if display? display write)) col))))

  (define (pp obj col)

    (define (spaces n col)
      (if (> n 0)
        (if (> n 7)
          (spaces (- n 8) (out "        " col))
          (out (substring "        " 0 n) col))
        col))

    (define (indent to col)
      (and col
           (if (< to col)
             (and (out genwrite:newline-str col)
		  (out per-line-prefix 0)
		  (spaces to 0))
             (spaces (- to col) col))))

    (define (pr obj col extra pp-pair)
      (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
        (let ((result '())
              (left (min (+ (- (- width col) extra) 1) max-expr-width)))
          (generic-write obj display? #f ""
            (lambda (str)
              (set! result (cons str result))
              (set! left (- left (string-length str)))
              (> left 0)))
          (if (> left 0) ; all can be printed on one line
            (out (reverse-string-append result) col)
            (if (pair? obj)
              (pp-pair obj col extra)
              (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
        (wr obj col)))

    (define (pp-expr expr col extra)
      (if (read-macro? expr)
        (pr (read-macro-body expr)
            (out (read-macro-prefix expr) col)
            extra
            pp-expr)
        (let ((head (car expr)))
          (if (symbol? head)
            (let ((proc (style head)))
              (if proc
                (proc expr col extra)
                (if (> (string-length (symbol->string head))
                       max-call-head-width)
                  (pp-general expr col extra #f #f #f pp-expr)
                  (pp-call expr col extra pp-expr))))
            (pp-list expr col extra pp-expr)))))

    ; (head item1
    ;       item2
    ;       item3)
    (define (pp-call expr col extra pp-item)
      (let ((col* (wr (car expr) (out "(" col))))
        (and col
             (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))

    ; (item1
    ;  item2
    ;  item3)
    (define (pp-list l col extra pp-item)
      (let ((col (out "(" col)))
        (pp-down l col col extra pp-item)))

    (define (pp-down l col1 col2 extra pp-item)
      (let loop ((l l) (col col1))
        (and col
             (cond ((pair? l)
                    (let ((rest (cdr l)))
                      (let ((extra (if (null? rest) (+ extra 1) 0)))
                        (loop rest
                              (pr (car l) (indent col2 col) extra pp-item)))))
                   ((null? l)
                    (out ")" col))
                   (else
                    (out ")"
                         (pr l
                             (indent col2 (out "." (indent col2 col)))
                             (+ extra 1)
                             pp-item)))))))

    (define (pp-general expr col extra named? pp-1 pp-2 pp-3)

      (define (tail1 rest col1 col2 col3)
        (if (and pp-1 (pair? rest))
          (let* ((val1 (car rest))
                 (rest (cdr rest))
                 (extra (if (null? rest) (+ extra 1) 0)))
            (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
          (tail2 rest col1 col2 col3)))

      (define (tail2 rest col1 col2 col3)
        (if (and pp-2 (pair? rest))
          (let* ((val1 (car rest))
                 (rest (cdr rest))
                 (extra (if (null? rest) (+ extra 1) 0)))
            (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
          (tail3 rest col1 col2)))

      (define (tail3 rest col1 col2)
        (pp-down rest col2 col1 extra pp-3))

      (let* ((head (car expr))
             (rest (cdr expr))
             (col* (wr head (out "(" col))))
        (if (and named? (pair? rest))
          (let* ((name (car rest))
                 (rest (cdr rest))
                 (col** (wr name (out " " col*))))
            (tail1 rest (+ col indent-general) col** (+ col** 1)))
          (tail1 rest (+ col indent-general) col* (+ col* 1)))))

    (define (pp-expr-list l col extra)
      (pp-list l col extra pp-expr))

    (define (pp-LAMBDA expr col extra)
      (pp-general expr col extra #f pp-expr-list #f pp-expr))

    (define (pp-IF expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr))

    (define (pp-COND expr col extra)
      (pp-call expr col extra pp-expr-list))

    (define (pp-CASE expr col extra)
      (pp-general expr col extra #f pp-expr #f pp-expr-list))

    (define (pp-AND expr col extra)
      (pp-call expr col extra pp-expr))

    (define (pp-LET expr col extra)
      (let* ((rest (cdr expr))
             (named? (and (pair? rest) (symbol? (car rest)))))
        (pp-general expr col extra named? pp-expr-list #f pp-expr)))

    (define (pp-BEGIN expr col extra)
      (pp-general expr col extra #f #f #f pp-expr))

    (define (pp-DO expr col extra)
      (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))

    ; define formatting style (change these to suit your style)

    (define indent-general 2)

    (define max-call-head-width 5)

    (define max-expr-width 50)

    (define (style head)
      (case head
        ((lambda let* letrec define) pp-LAMBDA)
        ((if set!)                   pp-IF)
        ((cond)                      pp-COND)
        ((case)                      pp-CASE)
        ((and or)                    pp-AND)
        ((let)                       pp-LET)
        ((begin)                     pp-BEGIN)
        ((do)                        pp-DO)
        (else                        #f)))

    (pr obj col 0 pp-expr))

  (out per-line-prefix 0)
  (if width
    (out genwrite:newline-str (pp obj 0))
    (wr obj 0))
  ;; Return `unspecified'
  (if #f #f))

; (reverse-string-append l) = (apply string-append (reverse l))

(define (reverse-string-append l)

  (define (rev-string-append l i)
    (if (pair? l)
      (let* ((str (car l))
             (len (string-length str))
             (result (rev-string-append (cdr l) (+ i len))))
        (let loop ((j 0) (k (- (- (string-length result) i) len)))
          (if (< j len)
            (begin
              (string-set! result k (string-ref str j))
              (loop (+ j 1) (+ k 1)))
            result)))
      (make-string i)))

  (rev-string-append l 0))

(define* (pretty-print obj #:optional port*
                       #:key
                       (port (or port* (current-output-port)))
                       (width 79)
                       (display? #f)
                       (per-line-prefix ""))
  "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
the current output port.  Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
PER-LINE-PREFIX, which is empty by default.  The output lines will be
at most WIDTH characters wide; the default is 79.  If DISPLAY? is
true, display rather than write representation will be used.

Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
  (generic-write obj display?
		 (- width (string-length per-line-prefix))
		 per-line-prefix
		 (lambda (s) (display s port) #t)))

;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
;; genwrite.scm.
(define* (truncated-print x #:optional port*
                          #:key
                          (port (or port* (current-output-port)))
                          (width 79)
                          (display? #f)
                          (breadth-first? #f))
  "Print @var{obj}, truncating the output, if necessary, to make it fit
into @var{width} characters. By default, @var{x} will be printed using
@code{write}, though that behavior can be overriden via the
@var{display?} keyword argument.

The default behaviour is to print depth-first, meaning that the entire
remaining width will be available to each sub-expression of @var{x} --
e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
\"ration\" the available width, trying to allocate it equally to each
sub-expression, via the @var{breadth-first?} keyword argument."

  ;; Make sure string ports are created with the right encoding.
  (with-fluids ((%default-port-encoding (port-encoding port)))

    (define ellipsis
      ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
      ;; on the encoding of PORT.
      (let ((e "…"))
        (catch 'encoding-error
          (lambda ()
            (with-output-to-string
              (lambda ()
                (display e))))
          (lambda (key . args)
            "..."))))

    (let ((ellipsis-width (string-length ellipsis)))

      (define (print-sequence x width len ref next)
        (let lp ((x x)
                 (width width)
                 (i 0))
          (if (> i 0)
              (display #\space))
          (cond
           ((= i len)) ; catches 0-length case
           ((= i (1- len))
            (print (ref x i) (if (zero? i) width (1- width))))
           ((<= width (+ 1 ellipsis-width))
            (display "..."))
           (else
            (let ((str
                   (with-fluids ((%default-port-encoding (port-encoding port)))
                     (with-output-to-string
                           (lambda ()
                             (print (ref x i)
                                    (if breadth-first?
                                        (max 1
                                             (1- (floor (/ width (- len i)))))
                                        (- width (+ 1 ellipsis-width)))))))))
              (display str)
              (lp (next x) (- width 1 (string-length str)) (1+ i)))))))

      (define (print-tree x width)
        ;; width is >= the width of # . #, which is 5
        (let lp ((x x)
                 (width width))
          (cond
           ((or (not (pair? x)) (<= width 4))
            (display ". ")
            (print x (- width 2)))
           (else
            ;; width >= 5
            (let ((str (with-output-to-string
                         (lambda ()
                           (print (car x)
                                  (if breadth-first?
                                      (floor (/ (- width 3) 2))
                                      (- width 4)))))))
              (display str)
              (display " ")
              (lp (cdr x) (- width 1 (string-length str))))))))

      (define (truncate-string str width)
        ;; width is < (string-length str)
        (let lp ((fixes '(("#<" . ">")
                          ("#(" . ")")
                          ("(" . ")")
                          ("\"" . "\""))))
          (cond
           ((null? fixes)
            "#")
           ((and (string-prefix? (caar fixes) str)
                 (string-suffix? (cdar fixes) str)
                 (>= (string-length str)
                     width
                     (+ (string-length (caar fixes))
                        (string-length (cdar fixes))
                        ellipsis-width)))
            (format #f "~a~a~a~a"
                    (caar fixes)
                    (substring str (string-length (caar fixes))
                               (- width (string-length (cdar fixes))
                                  ellipsis-width))
                    ellipsis
                    (cdar fixes)))
           (else
            (lp (cdr fixes))))))

      (define (print x width)
        (cond
         ((<= width 0)
          (error "expected a positive width" width))
         ((list? x)
          (cond
           ((>= width (+ 2 ellipsis-width))
            (display "(")
            (print-sequence x (- width 2) (length x)
                            (lambda (x i) (car x)) cdr)
            (display ")"))
           (else
            (display "#"))))
         ((vector? x)
          (cond
           ((>= width (+ 3 ellipsis-width))
            (display "#(")
            (print-sequence x (- width 3) (vector-length x)
                            vector-ref identity)
            (display ")"))
           (else
            (display "#"))))
         ((uniform-vector? x)
          (cond
           ((>= width 9)
            (format #t  "#~a(" (uniform-vector-element-type x))
            (print-sequence x (- width 6) (uniform-vector-length x)
                            uniform-vector-ref identity)
            (display ")"))
           (else
            (display "#"))))
         ((pair? x)
          (cond
           ((>= width (+ 4 ellipsis-width))
            (display "(")
            (print-tree x (- width 2))
            (display ")"))
           (else
            (display "#"))))
         (else
          (let* ((str (with-output-to-string
                        (lambda () (if display? (display x) (write x)))))
                 (len (string-length str)))
            (display (if (<= (string-length str) width)
                         str
                         (truncate-string str width)))))))

      (with-output-to-port port
        (lambda ()
          (print x width))))))