skint/pre/s.scm

;---------------------------------------------------------------------------------------------
; SCHEME LIBRARY
;---------------------------------------------------------------------------------------------


;---------------------------------------------------------------------------------------------
; Derived expression types
;---------------------------------------------------------------------------------------------

; builtins:
;
; (quote const)
; (set! id expr)
; (set& id)
; (if expr1 expr2)
; (if expr1 expr2 expr3)
; (begin expr ...)
; (lambda args expr ...)
; (lambda* [arity expr] ...)
; (body expr ...) -- lexical scope for definitions
; (letcc id expr) 
; (withcc expr expr ...) 
; (define id expr)
; (define (id . args) expr ...)
; (define-syntax kw form)
; (syntax-lambda (id ...) form ...) 
; (syntax-rules (lit ...) [pat templ] ...) 
; (syntax-rules ellipsis (lit ...) [pat templ] ...)
; (cond-expand [ftest exp ...] ...) 

(define-syntax let-syntax
  (syntax-rules ()
    [(_ ([kw init] ...))
     (begin)]
    [(_ ([kw init] ...) . forms)
     ((syntax-lambda (kw ...) . forms)
      init ...)]))

(define-syntax letrec-syntax
  (syntax-rules ()
    [(_ ([key trans] ...) . forms) 
     (body (define-syntax key trans) ... . forms)]))

(define-syntax letrec
  (syntax-rules ()
    [(_ ([var init] ...) . forms)
     (body (define var init) ... . forms)]))

(define-syntax letrec*
  (syntax-rules ()
    [(_ ([var expr] ...) . forms)
     (let ([var #f] ...)
       (set! var expr)
       ...
       (body . forms))]))

(define-syntax let
  (syntax-rules ()
    [(_ () . forms) (body . forms)]
    [(_ ([var init] ...) . forms)
     ((lambda (var ...) . forms) init ...)]
    [(_ name ([var init] ...) . forms)
     ((letrec ((name (lambda (var ...) . forms))) name) init ...)]))

(define-syntax let*
  (syntax-rules ()
    [(_ () . forms) 
     (body . forms)]
    [(_ (first . more) . forms)
     (let (first) (let* more . forms))]))

(define-syntax let*-values
  (syntax-rules ()
    [(_ () . forms) (body . forms)]
    [(_ ([(a) x] . b*) . forms) (let ([a x]) (let*-values b* . forms))]
    [(_ ([aa x] . b*) . forms) (call-with-values (lambda () x) (lambda aa (let*-values b* . forms)))]))

(define-syntax %let-values-loop
  (syntax-rules ()
    [(_ (new-b ...) new-aa x map-b* () () . forms)
     (let*-values (new-b ... [new-aa x]) (let map-b* . forms))]
    [(_ (new-b ...) new-aa old-x map-b* () ([aa x] . b*) . forms)
     (%let-values-loop (new-b ... [new-aa old-x]) () x map-b* aa b* . forms)]
    [(_ new-b* (new-a ...) x (map-b ...) (a . aa) b* . forms)
     (%let-values-loop new-b* (new-a ... tmp-a) x (map-b ... [a tmp-a]) aa b* . forms)]
    [(_ new-b* (new-a ...) x (map-b ...) a b* . forms) 
     (%let-values-loop new-b* (new-a ... . tmp-a) x (map-b ... [a tmp-a]) () b* . forms)]))

(define-syntax let-values
  (syntax-rules ()
    [(_ () . forms) (let () . forms)]
    [(_ ([aa x] . b*) . forms)
     (%let-values-loop () () x () aa b* . forms)]))

(define-syntax %define-values-loop
  (syntax-rules ()
    [(_ new-aa ([a tmp-a] ...) () x)
     (begin
       (define a (begin)) ...
       (define () (call-with-values (lambda () x) (lambda new-aa (set! a tmp-a) ...))))]
    [(_ (new-a ...) (map-a ...) (a . aa) x) 
     (%define-values-loop (new-a ... tmp-a) (map-a ... [a tmp-a]) aa x)]
    [(_ (new-a ...) (map-a ...) a x) 
     (%define-values-loop (new-a ... . tmp-a) (map-a ... [a tmp-a]) () x)]))

(define-syntax define-values
  (syntax-rules ()
    [(_ () x) (define () (call-with-values (lambda () x) (lambda ())))] ; use idless define
    [(_ aa x) (%define-values-loop () () aa x)]))

(define-syntax and
  (syntax-rules ()
    [(_) #t]
    [(_ test) test]
    [(_ test . tests) (if test (and . tests) #f)]))

(define-syntax or
  (syntax-rules ()
    [(_) #f]
    [(_ test) test]
    [(_ test . tests) (let ([x test]) (if x x (or . tests)))]))

(define-syntax cond
  (syntax-rules (else =>)
    [(_) #f]
    [(_ (else . exps)) (begin . exps)]
    [(_ (x) . rest) (or x (cond . rest))]
    [(_ (x => proc) . rest) (let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
    [(_ (x . exps) . rest) (if x (begin . exps) (cond . rest))]))

(define-syntax %case-test
  (syntax-rules () 
    [(_ k ()) #f]
    [(_ k (datum)) (eqv? k 'datum)] 
    [(_ k data) (memv k 'data)]))

(define-syntax %case
  (syntax-rules (else =>)
    [(_ key) (begin)]
    [(_ key (else => resproc))
     (resproc key)]
    [(_ key (else expr ...))
     (begin expr ...)]
    [(_ key ((datum ...) => resproc) . clauses)
     (if (%case-test key (datum ...))
         (resproc key)
         (%case key . clauses))]
    [(_ key ((datum ...) expr ...) . clauses)
     (if (%case-test key (datum ...))
         (begin expr ...)
         (%case key . clauses))]))

(define-syntax case
  (syntax-rules ()
    [(_ x . clauses) (let ([key x]) (%case key . clauses))]))

(define-syntax %do-step 
  (syntax-rules () 
    [(_ x) x] [(_ x y) y]))

(define-syntax do
  (syntax-rules ()
    [(_ ([var init step ...] ...)
       [test expr ...]
       command ...)
     (let loop ([var init] ...)
       (if test
           (begin expr ...)
           (let () command ...
             (loop (%do-step var step ...) ...))))]))


(define-syntax quasiquote
  (syntax-rules (unquote unquote-splicing quasiquote)
    [(_ ,x) x]
    [(_ (,@x . y)) (append x `y)]
    [(_ `x . d) (cons 'quasiquote (quasiquote (x) d))]
    [(_ ,x   d) (cons 'unquote (quasiquote (x) . d))]
    [(_ ,@x  d) (cons 'unquote-splicing (quasiquote (x) . d))]
    [(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))]
    [(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
    [(_ x . d) 'x]))

(define-syntax when
  (syntax-rules ()
    [(_ test . rest) (if test (begin . rest))]))

(define-syntax unless
  (syntax-rules ()
    [(_ test . rest) (if (not test) (begin . rest))]))

(define-syntax case-lambda
  (syntax-rules ()
    [(_ [args . forms] ...) (lambda* [args (lambda args . forms)] ...)]))

;---------------------------------------------------------------------------------------------
; Delayed evaluation
;---------------------------------------------------------------------------------------------

(define promise? box?)

(define (make-promise o) (box (cons #t o)))
(define (make-lazy-promise o) (box (cons #f o)))

(define (force p)
  (let ([pc (unbox p)])
    (if (car pc)
        (cdr pc)
        (let* ([newp ((cdr pc))] [pc (unbox p)])
          (unless (car pc)
            (set-car! pc (car (unbox newp)))
            (set-cdr! pc (cdr (unbox newp)))
            (set-box! newp pc))
          (force p)))))

(define-syntax delay-force
  (syntax-rules () [(_ x) (make-lazy-promise (lambda () x))]))

(define-syntax delay
  (syntax-rules () [(_ x) (delay-force (make-promise x))]))


;---------------------------------------------------------------------------------------------
; Dynamic bindings
;---------------------------------------------------------------------------------------------

(define make-parameter
  (case-lambda
    [(value) 
     (case-lambda 
       [() value]
       [(x) (set! value x)]
       [(x s) (if s (set! value x) x)])]
    [(init converter)
     (let ([value (converter init)])
       (case-lambda 
         [() value]
         [(x) (set! value (converter x))]
         [(x s) (if s (set! value x) (converter x))]))]))

(define-syntax %parameterize-loop
  (syntax-rules ()
    [(_ ([param value p old new] ...) () body)
     (let ([p param] ...)
       (let ([old (p)] ... [new (p value #f)] ...)
         (dynamic-wind
           (lambda () (p new #t) ...)
           (lambda () . body)
           (lambda () (p old #t) ...))))]
    [(_ args ([param value] . rest) body)
     (%parameterize-loop ([param value p old new] . args) rest body)]))

(define-syntax parameterize
  (syntax-rules ()
    [(_ ([param value] ...) . body)
     (%parameterize-loop () ([param value] ...) body)]))


;---------------------------------------------------------------------------------------------
; Record type definitions
;---------------------------------------------------------------------------------------------

; integrables:
;
; (record? x (rtd))
; (make-record rtd n (fill #f))
; (record-length r)
; (record-ref r i)
; (record-set! r i v)

(define (new-record-type name fields)
  ; should be something like (cons name fields), but that would complicate procedure? 
  ; check that now relies on block tag being a non-immediate object, so we'll better put 
  ; some pseudo-unique immediate object here -- and we don't have to be fast doing that
  (let loop ([fl (cons name fields)] [sl '("rtd://")]) 
     ; NB: can't do (apply string-append ..) -- they are defined w/cover syntax below!
     (cond [(null? fl) (string->symbol (apply-to-list %string-append (reverse sl)))]
           [(null? (cdr fl)) (loop (cdr fl) (cons (symbol->string (car fl)) sl))]
           [else (loop (cdr fl) (cons ":" (cons (symbol->string (car fl)) sl)))]))) 
  
; see http://okmij.org/ftp/Scheme/macro-symbol-p.txt
(define-syntax %id-eq?? 
  (syntax-rules ()
    [(_ id b kt kf)
     ((syntax-lambda (id ok) ((syntax-rules () [(_ b) (id)]) ok))
      (syntax-rules () [(_) kf]) (syntax-rules () [(_) kt]))]))

(define-syntax %id-assq??
  (syntax-rules ()
    [(_ id () kt kf) 
     kf]
    [(_ id ([id0 . r0] . idr*) kt kf) 
     (%id-eq?? id id0 (kt . r0) (%id-assq?? id idr* kt kf))]))
 
(define-syntax %drt-init
  (syntax-rules ()
    [(_  r () fi* (x ...)) 
     (begin x ... r)]
    [(_  r (id0 . id*) fi* (x ...))
     (%id-assq?? id0 fi* 
       (syntax-rules () [(_ i0) (%drt-init r id* fi* (x ... (record-set! r i0 id0)))]) 
       (syntax-error "id in define-record-type constructor is not a field:" id0))]))

(define-syntax %drt-unroll
  (syntax-rules ()
    [(_ rtn (consn id ...) predn () ([f i] ...) ([a ia] ...) ([m im] ...))
     (begin
       (define rtn 
         (new-record-type 'rtn '(f ...)))
       (define consn 
         (lambda (id ...) 
           (let ([r (make-record rtn (syntax-length (f ...)))])
             (%drt-init r (id ...) ([f i] ...) ()))))
       (define predn 
         (lambda (obj) (record? obj rtn)))
       (define a 
         (lambda (obj) (record-ref obj ia)))
       ...
       (define m 
         (lambda (obj val) (record-set! obj im val)))
       ...)]
    [(_ rtn cf* predn ([fn accn] fam ...) (fi ...) (ai ...) (mi ...))
     (%drt-unroll rtn cf* predn (fam ...) 
       (fi ... [fn (syntax-length (fi ...))]) 
       (ai ... [accn (syntax-length (fi ...))]) 
       (mi ...))]
    [(_  rtn cf* predn ([fn accn modn] fam ...) (fi ...) (ai ...) (mi ...))
     (%drt-unroll rtn cf* predn (fam ...) 
       (fi ... [fn (syntax-length (fi ...))]) 
       (ai ... [accn (syntax-length (fi ...))]) 
       (mi ... [modn (syntax-length (fi ...))]))]))

(define-syntax define-record-type
  (syntax-rules ()
    [(_ rtn (consn id ...) predn (fn . am) ...)
     (%drt-unroll rtn (consn id ...) predn ((fn . am) ...) () () ())]))


;---------------------------------------------------------------------------------------------
; Equivalence predicates
;---------------------------------------------------------------------------------------------

; integrables:
;
; (eq? x y)
; (eqv? x y)
; (equal? x y)


;---------------------------------------------------------------------------------------------
; Boxes, aka cells
;---------------------------------------------------------------------------------------------

; integrables:
;
; (box? x)
; (box x)
; (unbox x)
; (set-box! x y)


;---------------------------------------------------------------------------------------------
; Exact integer numbers (fixnums)
;---------------------------------------------------------------------------------------------

; integrables:
;
; (fixnum? o)
; (fxzero? x)
; (fxpositive? x)
; (fxnegative? x)
; (fxeven? x)
; (fxodd? x)
; (fx+ x ...)
; (fx* x ...)
; (fx- x y ...)
; (fx/ x y ...)
; (fxquotient x y)
; (fxremainder x y)
; (fxmodquo x y) +
; (fxmodulo x y) 
; (fxeucquo x y) + a.k.a. euclidean-quotient, R6RS div
; (fxeucrem x y) + a.k.a. euclidean-remainder, R6RS mod
; (fxneg x)
; (fxabs x)
; (fx<? x y z ...)
; (fx<=? x y z ...)
; (fx>? x y z ...)
; (fx>=? x y z ...)
; (fx=? x y z ...)
; (fx!=? x y) +
; (fxmin x y)
; (fxmax x y)
; (fxneg x)
; (fxabs x)
; (fxgcd x y)
; (fxexpt x y)
; (fxsqrt x)
; (fxnot x)
; (fxand x ...)
; (fxior x ...)
; (fxxor x ...)
; (fxsll x y)
; (fxsrl x y)
; (fixnum->flonum x)
; (fixnum->string x (radix 10))
; (string->fixnum s (radix 10))

;TBD:
;
;fx-width
;fx-greatest
;fx-least
;fxarithmetic-shift-right
;fxarithmetic-shift-left
;fxlength cf. integer-length (+ 1 (integer-length i)) 
;  is the number of bits needed to represent i in a signed twos-complement representation
;  0 => 0, 1 => 1, -1 => 0, 7 => 3, -7 => 3, 8 => 4, -8 => 3
;fxbit-count cf. bit-count
;  Returns the population count of 1's (i >= 0) or 0's (i < 0)
;  0 => 0, -1 => 0, 7 => 3, 13 => 3, -13 => 2  


;---------------------------------------------------------------------------------------------
; Inexact floating-point numbers (flonums)
;---------------------------------------------------------------------------------------------

; integrables:
;
; (flonum? o)
; (flzero? x)
; (flpositive? x)
; (flnegative? x)
; (flinteger? x)
; (flnan? x)
; (flinfinite? x)
; (flfinite? x)
; (fleven? x)
; (flodd? x)
; (fl+ x ...)
; (fl* x ...)
; (fl- x y ...)
; (fl/ x y ...)
; (flneg x)
; (flabs x)
; (flgcd x y)
; (flexpt x y)
; (flsqrt x)
; (flfloor x)
; (flceiling x)
; (fltruncate x)
; (flround x)
; (flexp x)
; (fllog x (base fl-e))
; (flsin x)
; (flcos x)
; (fltan x)
; (flasin x)
; (flacos x)
; (flatan (y) x)
; (fl<? x y z ...)
; (fl<=? x y z ...)
; (fl>? x y z ...)
; (fl>=? x y z ...)
; (fl=? x y z ...)
; (fl!=? x y) +
; (flmin x y)
; (flmax x y)
; (flonum->fixnum x)
; (flonum->string x)
; (string->flonum s)


;---------------------------------------------------------------------------------------------
; Numbers (fixnums or flonums)
;---------------------------------------------------------------------------------------------

; integrables:
;
; (number? x)
; (complex? x) == number? what about inf and nan?
; (real? x) == number? what about inf and nan?
; (rational? x)
; (integer? x)
; (exact? x)
; (inexact? x)
; (exact-integer? x) == fixnum?
; (finite? x)
; (infinite? x)
; (nan? x)
; (= x y z ...)
; (< x y z ...)
; (> x y z ...)
; (<= x y z ...)
; (>= x y z ...)
; (zero? x)
; (positive? x)
; (negative? x)
; (odd? x)
; (even? x)
; (max x y ...) 
; (min x y ...) 
; (+ x ...)
; (* x ...)
; (- x y ...)
; (/ x y ...)
; (abs x)
; (floor-quotient x y)
; (floor-remainder x y)
; (truncate-quotient x y)
; (truncate-remainder x y)
; (quotient x y) == truncate-quotient
; (remainder x y) == truncate-remainder
; (modulo x y) == floor-remainder
; (gcd x y)
; (floor x)
; (ceiling x)
; (truncate x)
; (round x)
; (exp x)
; (log x (base fl-e))
; (sin x)
; (cos x)
; (tan x)
; (asin x)
; (acos x)
; (atan (y) x)
; (sqrt x)
; (expt x y)
; (inexact x)
; (exact x)
; (number->string x (radix 10))
; (string->number x (radix 10))

(define (floor/ x y)
  (values (floor-quotient x y) (floor-remainder x y)))

(define (truncate/ x y)
  (values (truncate-quotient x y) (truncate-remainder x y)))

(define (lcm . args)
  (if (null? args) 1
      (let loop ([x (car args)] [args (cdr args)])
        (if (null? args) x
            (let* ([y (car args)] [g (gcd x y)])
              (loop (if (zero? g) g (* (quotient (abs x) g) (abs y))) (cdr args)))))))

(define (numerator n) n)

(define (denominator n) 1)

(define (rationalize n d) n)

(define (square x) (* x x))

(define (exact-integer-sqrt x)
  (let ([r (fxsqrt x)])
    (values r (- x (* r r)))))

(define (make-rectangular r i)
  (if (= i 0) r (error "make-rectangular: nonzero imag part not supported" i)))

(define (make-polar m a)
  (cond [(= a 0) m]
        [(= a 3.141592653589793238462643) (- m)]
        [else (error "make-polar: angle not supported" a)]))

(define (real-part x) x)

(define (imag-part x) 0)

(define (magnitude x) (abs x))

(define (angle x) (if (negative? x) 3.141592653589793238462643 0))


;---------------------------------------------------------------------------------------------
; Booleans
;---------------------------------------------------------------------------------------------

; integrables:
;
; (boolean? x)
; (not x)
; (boolean=? x y z ...)


;---------------------------------------------------------------------------------------------
; Null and Pairs
;---------------------------------------------------------------------------------------------

; integrables:
;
; (null? x)
; (pair? x)
; (cons x y)
; (car p)
; (cdr p)
; (set-car! p v)
; (set-cdr! p v)
; (caar p)
; ...
; (cddddr p)


;---------------------------------------------------------------------------------------------
; Lists
;---------------------------------------------------------------------------------------------

; integrables:
;
; (list? x)
; (list x ...)
; (make-list n (i #f))
; (length l)
; (list-ref l i)
; (list-set! l i x)
; (list-cat l1 l2)  + 2-arg append
; (memq v l)  ; TODO: make sure memq doesn't fail on improper/circular list
; (memv v l)  ; TODO: make sure memv doesn't fail on improper/circular list
; (meme v l)  + 2-arg member; TODO: make sure meme checks list ^
; (assq v y)   
; (assv v y) ; TODO: make sure assv checks list
; (asse v y) + 2-arg assoc; TODO: make sure asse checks list ^
; (list-tail l i)
; (last-pair l)
; (reverse l)
; (reverse! l) +
; (list-copy l) ; TODO: make sure list-copy checks list for circularity
; (circular? x) +

(define (%append . args)
  (let loop ([args args])
    (cond [(null? args) '()]
          [(null? (cdr args)) (car args)]
          [else (list-cat (car args) (loop (cdr args)))])))

(define-syntax append
  (syntax-rules ()
    [(_) '()] [(_ x) x]
    [(_ x y) (list-cat x y)]
    [(_ x y z ...) (list-cat x (append y z ...))]
    [_ %append]))

(define (%member v l . ?eq)
  (if (null? ?eq) 
      (meme v l)
      (let loop ([v v] [l l] [eq (car ?eq)])
        (and (pair? l) 
             (if (eq v (car l)) 
                 l 
                 (loop v (cdr l) eq))))))

(define-syntax member
  (syntax-rules ()
    [(_ v l) (meme v l)] 
    [(_ . args) (%member . args)]
    [_ %member]))

(define (%assoc v al . ?eq)
  (if (null? ?eq) 
      (asse v al)
      (let loop ([v v] [al al] [eq (car ?eq)])
        (and (pair? al) 
             (if (eq v (caar al)) 
                 (car al) 
                 (loop v (cdr al) eq))))))

(define-syntax assoc
  (syntax-rules ()
    [(_ v al) (asse v al)] 
    [(_ . args) (%assoc . args)]
    [_ %assoc]))

(define (list-copy obj)
  (let loop ([obj obj])
    (if (pair? obj)
        (cons (car obj) (loop (cdr obj)))
        obj)))

(define (%list* x . l)
  (let loop ([x x] [l l])
    (if (null? l) x (cons x (loop (car l) (cdr l))))))

(define-syntax list*
  (syntax-rules ()
    [(_ x) x]
    [(_ x y) (cons x y)]
    [(_ x y z ...) (cons x (list* y z ...))]
    [(_ . args) (%list* . args)]
    [_ %list*]))

(define-syntax cons* list*)

(define (list-diff l t) ; +
  (if (or (null? l) (eq? l t))
      '()
      (cons (car l) (list-diff (cdr l) t))))

(define (list-head list index) ; +
  (let loop ([list list] [index index])
    (if (zero? index)
        '()
        (cons (car list) (loop (cdr list) (- index 1))))))

(define (andmap p l) ; +
  (if (pair? l) (and (p (car l)) (andmap p (cdr l))) #t))

(define (ormap p l) ; +
  (if (pair? l) (or (p (car l)) (ormap p (cdr l))) #f))

(define (memp p l) ; +
  (and (pair? l) (if (p (car l)) l (memp p (cdr l))))) 

(define (assp p l) ; +
  (and (pair? l) (if (p (caar l)) (car l) (assp p (cdr l))))) 

(define (posq x l) ; +
  (let loop ([l l] [n 0])
    (cond [(null? l) #f]
          [(eq? x (car l)) n]
          [else (loop (cdr l) (fx+ n 1))])))

(define (rassq x al) ; +
  (and (pair? al)
        (let ([a (car al)])
          (if (eq? x (cdr a)) a (rassq x (cdr al))))))


;---------------------------------------------------------------------------------------------
; Symbols
;---------------------------------------------------------------------------------------------

; integrables:
;
; (symbol? x)
; (symbol->string y)
; (string->symbol s)
; (symbol=? x y z ...)


;---------------------------------------------------------------------------------------------
; Characters
;---------------------------------------------------------------------------------------------

; integrables:
;
; (char? x)
; (char-cmp c1 c2) +
; (char=? c1 c2 c ...)
; (char<? c1 c2 c ...)
; (char>? c1 c2 c ...)
; (char<=? c1 c2 c ...)
; (char>=? c1 c2 c ...)
; (char-ci-cmp c1 c2) +
; (char-ci=? c1 c2 c ...)
; (char-ci<? c1 c2 c ...)
; (char-ci>? c1 c2 c ...)
; (char-ci<=? c1 c2 c ...)
; (char-ci>=? c1 c2 c ...)
; (char-alphabetic? c)
; (char-numeric? x)
; (char-whitespace? c)
; (char-upper-case? c)
; (char-lower-case? c)
; (char-upcase c)
; (char-downcase c)
; (char-foldcase c)
; (digit-value c)
; (char->integer c) 
; (integer->char n)


;---------------------------------------------------------------------------------------------
; Strings
;---------------------------------------------------------------------------------------------

; integrables:
;
; (string? x)
; (string c ...)
; (make-string n (i #\space))
; (string-length s)
; (string-ref x i)
; (string-set! x i v)
; (list->string l)
; (%string->list1 s) + 
; (string-cat s1 s2) +
; (substring s from to)
; (string-position s c) +
; (string-cmp s1 s2) +
; (string=? s1 s2 s ...)
; (string<? s1 s2 s ...)
; (string>? s1 s2 s ...)
; (string<=? s1 s2 s ...)
; (string>=? s1 s2 s ...)
; (string-ci-cmp s1 s2) +
; (string-ci=? s1 s2 s ...)
; (string-ci<? s1 s2 s ...)
; (string-ci>? s1 s2 s ...)
; (string-ci<=? s1 s2 s ...)
; (string-ci>=? s1 s2 s ...)
; (string-upcase s)
; (string-downcase s)
; (string-foldcase s)

(define (substring->list str start end)
  (let loop ([i (fx- end 1)] [l '()])
    (if (fx<? i start) l (loop (fx- i 1) (cons (string-ref str i) l)))))

(define %string->list
  (case-lambda
     [(str) (%string->list1 str)]
     [(str start) (substring->list str start (string-length str))]
     [(str start end) (substring->list str start end)]))

(define-syntax string->list
  (syntax-rules ()
    [(_ x) (%string->list1 x)]
    [(_ . r) (%string->list . r)]
    [_ %string->list]))

(define (substring-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (string-set! to i (string-ref from j)))
        (do ([i (fx+ at (fx- (fx- end start) 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (string-set! to i (string-ref from j))))))

(define string-copy!
  (case-lambda
     [(to at from) (substring-copy! to at from 0 (string-length from))]
     [(to at from start) (substring-copy! to at from start (string-length from))]
     [(to at from start end) (substring-copy! to at from start end)]))

(define string-copy 
  (case-lambda
     [(str) (substring str 0 (string-length str))]  ; TODO: %scpy ?
     [(str start) (substring str start (string-length str))]
     [(str start end) (substring str start end)]))

(define (substring-fill! str c start end)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (string-set! str i c)))

(define string-fill!
  (case-lambda
     [(str c) (substring-fill! str c 0 (string-length str))]
     [(str c start) (substring-fill! str c start (string-length str))]
     [(str c start end) (substring-fill! str c start end)]))

(define (substring-vector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
    (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
      [(fx>=? j limit) to]
      (vector-set! to i (string-ref from j)))))

(define (substring->vector str start end)
  (substring-vector-copy! (make-vector (fx- end start)) 0 str start end))

(define string->vector
  (case-lambda
     [(str) (substring->vector str 0 (string-length str))]
     [(str start) (substring->vector str start (string-length str))]
     [(str start end) (substring->vector str start end)]))

(define (strings-sum-length strs)
  (let loop ([strs strs] [l 0])
    (if (null? strs) l (loop (cdr strs) (fx+ l (string-length (car strs)))))))

(define (strings-copy-into! to strs)
  (let loop ([strs strs] [i 0])
    (if (null? strs)
        to
        (let ([str (car strs)] [strs (cdr strs)])
          (let ([len (string-length str)])
            (substring-copy! to i str 0 len)
            (loop strs (fx+ i len)))))))  

(define (%string-append . strs)
  (strings-copy-into! (make-string (strings-sum-length strs)) strs))

(define-syntax string-append
  (syntax-rules ()
    [(_) ""] [(_ x) (%cks x)]
    [(_ x y) (string-cat x y)]
    [(_ . r) (%string-append . r)]
    [_ %string-append]))

(define (string-trim-whitespace s) ; +
  (let floop ([from 0] [len (string-length s)])
    (if (and (< from len) (char-whitespace? (string-ref s from)))
        (floop (+ from 1) len)
        (let tloop ([to len])
          (if (and (> to from) (char-whitespace? (string-ref s (- to 1))))
              (tloop (- to 1))
              (if (and (= from 0) (= to len)) 
                  s
                  (substring s from to)))))))   


;---------------------------------------------------------------------------------------------
; Vectors
;---------------------------------------------------------------------------------------------

; integrables:
;
; (vector? x)
; (vector x ...)
; (make-vector n (i #f))
; (vector-length v)
; (vector-ref v i)
; (vector-set! v i x)
; (%vector->list1 v) +
; (list->vector l)
; (vector-cat v1 v2) +

(define (subvector->list vec start end)
  (let loop ([i (fx- end 1)] [l '()])
    (if (fx<? i start) l (loop (fx- i 1) (cons (vector-ref vec i) l)))))

(define %vector->list
  (case-lambda
     [(vec) (%vector->list1 vec)]
     [(vec start) (subvector->list vec start (vector-length vec))]
     [(vec start end) (subvector->list vec start end)]))

(define-syntax vector->list
  (syntax-rules ()
    [(_ x) (%vector->list1 x)]
    [(_ . r) (%vector->list . r)]
    [_ %vector->list]))

(define (subvector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (vector-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (vector-set! to i (vector-ref from j)))
        (do ([i (fx+ at (fx- (fx- end start) 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (vector-set! to i (vector-ref from j))))))

(define vector-copy!
  (case-lambda
     [(to at from) (subvector-copy! to at from 0 (vector-length from))]
     [(to at from start) (subvector-copy! to at from start (vector-length from))]
     [(to at from start end) (subvector-copy! to at from start end)]))

(define (subvector vec start end)  ; TODO: %vsub?
  (let ([v (make-vector (fx- end start))])
    (subvector-copy! v 0 vec start end)
    v))

(define vector-copy
  (case-lambda
     [(vec) (subvector vec 0 (vector-length vec))] ; TODO: %vcpy ?
     [(vec start) (subvector vec start (vector-length vec))]
     [(vec start end) (subvector vec start end)]))

(define (subvector-fill! vec x start end)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (vector-set! vec i x)))

(define vector-fill!
  (case-lambda
     [(vec x) (subvector-fill! vec x 0 (vector-length vec))]
     [(vec x start) (subvector-fill! vec x start (vector-length vec))]
     [(vec x start end) (subvector-fill! vec x start end)]))

(define (subvector-string-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (string-length to) at)))])
    (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
      [(fx>=? j limit) to]
      (string-set! to i (vector-ref from j)))))

(define (subvector->string vec start end)
  (subvector-string-copy! (make-string (fx- end start)) 0 vec start end))

(define vector->string
  (case-lambda
     [(vec) (subvector->string vec 0 (vector-length vec))]
     [(vec start) (subvector->string vec start (vector-length vec))]
     [(vec start end) (subvector->string vec start end)]))

(define (vectors-sum-length vecs)
  (let loop ([vecs vecs] [l 0])
    (if (null? vecs) l (loop (cdr vecs) (fx+ l (vector-length (car vecs)))))))

(define (vectors-copy-into! to vecs)
  (let loop ([vecs vecs] [i 0])
    (if (null? vecs)
        to
        (let ([vec (car vecs)] [vecs (cdr vecs)])
          (let ([len (vector-length vec)])
            (subvector-copy! to i vec 0 len)
            (loop vecs (fx+ i len)))))))  

(define (%vector-append . vecs)
  (vectors-copy-into! (make-vector (vectors-sum-length vecs)) vecs))

(define-syntax vector-append
  (syntax-rules ()
    [(_) '#()] [(_ x) (%ckv x)]
    [(_ x y) (vector-cat x y)]
    [(_ . r) (%vector-append . r)]
    [_ %vector-append]))


;---------------------------------------------------------------------------------------------
; Bytevectors
;---------------------------------------------------------------------------------------------

; integrables:
;
; (bytevector? x)
; (make-bytevector n (u8 0))
; (bytevector u8 ...)
; (bytevector-length b)
; (bytevector-u8-ref b i)
; (bytevector-u8-set! b i u8)
; (list->bytevector l)
; (subbytevector b from to) +
; (bytevector=? b1 b2 b ...)

(define (subbytevector->list bvec start end)
  (let loop ([i (fx- end 1)] [l '()])
    (if (fx<? i start) l (loop (fx- i 1) (cons (bytevector-u8-ref bvec i) l)))))

(define bytevector->list
  (case-lambda
     [(bvec) (subbytevector->list bvec 0 (bytevector-length bvec))]
     [(bvec start) (subbytevector->list bvec start (bytevector-length bvec))]
     [(bvec start end) (subbytevector->list bvec start end)]))

(define (subbytevector-copy! to at from start end)
  (let ([limit (fxmin end (fx+ start (fx- (bytevector-length to) at)))])
    (if (fx<=? at start)
        (do ([i at (fx+ i 1)] [j start (fx+ j 1)]) 
          [(fx>=? j limit)]
          (bytevector-u8-set! to i (bytevector-u8-ref from j)))
        (do ([i (fx+ at (fx- end start 1)) (fx- i 1)] [j (fx- limit 1) (fx- j 1)])
          [(fx<? j start)]
          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))

(define bytevector-copy!
  (case-lambda
     [(to at from) (subbytevector-copy! to at from 0 (bytevector-length from))]
     [(to at from start) (subbytevector-copy! to at from start (bytevector-length from))]
     [(to at from start end) (subbytevector-copy! to at from start end)]))

(define bytevector-copy
  (case-lambda
     [(bvec) (subbytevector bvec 0 (bytevector-length bvec))]
     [(bvec start) (subbytevector bvec start (bytevector-length bvec))]
     [(bvec start end) (subbytevector bvec start end)]))

(define (subbytevector-fill! bvec b start end)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (bytevector-u8-set! bvec i b)))

(define bytevector-fill!
  (case-lambda
     [(bvec b) (subbytevector-fill! bvec b 0 (bytevector-length bvec))]
     [(bvec b start) (subbytevector-fill! bvec b start (bytevector-length bvec))]
     [(bvec b start end) (subbytevector-fill! bvec b start end)]))

(define (%bytevectors-sum-length bvecs)
  (let loop ([bvecs bvecs] [l 0])
    (if (null? bvecs) l (loop (cdr bvecs) (fx+ l (bytevector-length (car bvecs)))))))

(define (%bytevectors-copy-into! to bvecs)
  (let loop ([bvecs bvecs] [i 0])
    (if (null? bvecs) to
        (let ([bvec (car bvecs)] [bvecs (cdr bvecs)])
          (let ([len (bytevector-length bvec)])
            (subbytevector-copy! to i bvec 0 len)
            (loop bvecs (fx+ i len)))))))  

(define (bytevector-append . bvecs)
  (%bytevectors-copy-into! (make-bytevector (%bytevectors-sum-length bvecs)) bvecs))

(define (subutf8->string vec start end)
  (let ([p (open-output-string)])
    (write-subbytevector vec start end p)
    ; todo: make a single operation: get-final-output-string (can reuse cbuf?)
    (let ([s (get-output-string p)]) (close-output-port p) s)))

(define utf8->string
  (case-lambda
    [(bvec) (subutf8->string bvec 0 (bytevector-length bvec))]
    [(bvec start) (subutf8->string bvec start (bytevector-length bvec))]
    [(bvec start end) (subutf8->string bvec start end)]))

(define (substring->utf8 str start end)
  (let ([p (open-output-bytevector)])
    (write-substring str start end p)
    ; todo: make a single operation: get-final-output-bytevector (can reuse cbuf?)
    (let ([v (get-output-bytevector p)]) (close-output-port p) v)))

(define string->utf8
  (case-lambda
    [(str) (substring->utf8 str 0 (string-length str))]
    [(str start) (substring->utf8 str start (string-length str))]
    [(str start end) (substring->utf8 str start end)]))


;---------------------------------------------------------------------------------------------
; Control features
;---------------------------------------------------------------------------------------------

; integrables:
;
; (procedure? x)
; (values x ...)
; (call-with-values thunk receiver)

; builtins:
;
; (dynamic-wind before during after)


(define (%apply p x . l)
  (apply-to-list p 
    (let loop ([x x] [l l])
      (if (null? l) x (cons x (loop (car l) (cdr l)))))))

(define-syntax apply
  (syntax-rules ()
    [(_ p l) (apply-to-list p l)]
    [(_ p a b ... l) (apply-to-list p (list* a b ... l))]
    [(_ . args) (%apply . args)]
    [_ %apply]))

; call/cc and dynamic-wind

(define (%call/cc p) (letcc k (p k)))

(define-syntax call/cc
  (syntax-rules ()
    [(_ p) (letcc k (p k))]
    [(_ . args) (%call/cc . args)]
    [_ %call/cc])) 

(define-syntax call-with-current-continuation call/cc)

(define (%map1 p l)
  (let loop ([l l] [r '()])
    (if (pair? l) 
        (loop (cdr l) (cons (p (car l)) r)) 
        (reverse! r))))

(define (%map2 p l1 l2)
  (let loop ([l1 l1] [l2 l2] [r '()])
    (if (and (pair? l1) (pair? l2))
        (loop (cdr l1) (cdr l2) (cons (p (car l1) (car l2)) r))
        (reverse! r))))

(define (%map p l . l*)
  (cond [(null? l*) (%map1 p l)]
        [(null? (cdr l*)) (%map2 p l (car l*))] 
        [else
         (let loop ([l* (cons l l*)] [r '()])
           (if (let lp ([l* l*]) 
                 (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
               (loop (%map1 cdr l*) (cons (apply p (%map1 car l*)) r))
               (reverse! r)))]))

(define-syntax map
  (syntax-rules ()
    [(_ p l) (%map1 p l)]
    [(_ p l1 l2) (%map2 p l1 l2)]
    [(_ . args) (%map . args)]
    [_ %map])) 

(define (%for-each1 p l)
  (let loop ([l l]) 
    (if (pair? l) 
        (begin (p (car l))
               (loop (cdr l))))))

(define (%for-each2 p l1 l2)
  (let loop ([l1 l1] [l2 l2]) 
    (if (and (pair? l1) (pair? l2)) 
        (begin (p (car l1) (car l2)) 
               (loop (cdr l1) (cdr l2))))))

(define (%for-each p l . l*)
  (cond [(null? l*) (%for-each1 p l)]
        [(null? (cdr l*)) (%for-each2 p l (car l*))]
        [else
         (let loop ([l* (cons l l*)])
           (if (let lp ([l* l*]) 
                 (or (null? l*) (and (pair? (car l*)) (lp (cdr l*)))))
               (begin (apply p (map car l*)) (loop (map cdr l*)))))]))

(define-syntax for-each
  (syntax-rules ()
    [(_ p l) (%for-each1 p l)]
    [(_ p l1 l2) (%for-each2 p l1 l2)]
    [(_ . args) (%for-each . args)]
    [_ %for-each]))

(define (string-map p s . s*)
  (if (null? s*)
      (let* ([len (string-length s)] [res (make-string len)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
           (string-set! res i (p (string-ref s i)))))
      (list->string (apply map p (map string->list (cons s s*))))))

(define (vector-map p v . v*)
  (if (null? v*)
      (let* ([len (vector-length v)] [res (make-vector len)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len) res]
          (vector-set! res i (p (vector-ref v i)))))
      (list->vector (apply map p (map vector->list (cons v v*))))))

(define (string-for-each p s . s*)
  (if (null? s*) 
      (let ([len (string-length s)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (string-ref s i))))
      (apply for-each p (map string->list (cons s s*)))))

(define (vector-for-each p v . v*)
  (if (null? v*)
      (let ([len (vector-length v)])
        (do ([i 0 (fx+ i 1)]) [(fx>=? i len)] (p (vector-ref v i))))
      (apply for-each p (map vector->list (cons v v*)))))


;---------------------------------------------------------------------------------------------
; Exceptions
;---------------------------------------------------------------------------------------------

(define (abort) (%abort))

(define (reset) (%exit 1))

(define (set-reset-handler! fn) (set! reset fn))

(define (print-error-message prefix args ep)
  (define (pr-where args ep)
    (when (pair? args) 
      (cond [(not (car args)) 
             (write-string ": " ep)
             (pr-msg (cdr args) ep)]
            [(symbol? (car args)) 
             (write-string " in " ep) (write (car args) ep) (write-string ": " ep)
             (pr-msg (cdr args) ep)]
            [else 
             (write-string ": " ep)
             (pr-msg args ep)]))) 
  (define (pr-msg args ep)
    (when (pair? args) 
      (cond [(string? (car args))
             (display (car args) ep)
             (pr-rest (cdr args) ep)]
            [else (pr-rest args ep)])))
   (define (pr-rest args ep)
     (when (pair? args)
       (write-char #\space ep) (write (car args) ep)
       (pr-rest (cdr args) ep)))
   (cond [(or (string? prefix) (symbol? prefix)) 
          (write-string prefix ep)]
         [else (write-string "Error" ep)])
   (pr-where args ep)
   (newline ep))

(define (simple-error . args)
  (let ([ep (%current-error-port)])
    (newline ep)
    (print-error-message "Error" args ep)
    (reset)))

(define (assertion-violation . args)
  (let ([ep (%current-error-port)])
    (newline ep)
    (print-error-message "Assertion violation" args ep)
    (reset)))

(define-record-type <error-object>
  (error-object kind message irritants)
  error-object?
  (kind error-object-kind)
  (message error-object-message)
  (irritants error-object-irritants))

(define (error msg . args)
  (raise (error-object #f msg args)))

(define current-exception-handler 
  (make-parameter
    (letrec 
      ([default-handler
        (case-lambda 
          [() default-handler] ; make this one its own parent 
          [(obj) 
           (if (error-object? obj)
               (apply simple-error (error-object-kind obj) (error-object-message obj) (error-object-irritants obj)) 
               (simple-error #f "unhandled exception" obj))])])
      default-handler)))

(define (with-exception-handler handler thunk)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (case-lambda [() eh] [(obj) (handler obj)])])
      (thunk)))) 

(define (raise obj)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (eh)])
      (eh obj)
      (raise (error-object 'raise "exception handler returned" (list eh obj))))))

(define (raise-continuable obj)
  (let ([eh (current-exception-handler)])
    (parameterize ([current-exception-handler (eh)])
      (eh obj))))

(define-syntax %guard-aux
  (syntax-rules (else =>)
    [(_ reraise (else result1 result2 ...))
     (begin result1 result2 ...)]
    [(_ reraise (test => result))
     (let ([temp test]) (if temp (result temp) reraise))]
    [(_ reraise (test => result) clause1 clause2 ...)
     (let ([temp test])
       (if temp
           (result temp)
           (%guard-aux reraise clause1 clause2 ...)))]
    [(_ reraise (test)) (or test reraise)]
    [(_ reraise (test) clause1 clause2 ...)
     (let ([temp test])
       (if temp temp (%guard-aux reraise clause1 clause2 ...)))]
    [(_ reraise (test result1 result2 ...))
     (if test (begin result1 result2 ...) reraise)]
    [(_ reraise (test result1 result2 ...) clause1 clause2 ...)
     (if test
         (begin result1 result2 ...)
         (%guard-aux reraise clause1 clause2 ...))]))

(define-syntax guard
  (syntax-rules ()
    [(guard (var clause ...) e1 e2 ...)
    ((call/cc
      (lambda (guard-k)
        (with-exception-handler
          (lambda (condition)
            ((call/cc
                (lambda (handler-k)
                  (guard-k
                    (lambda ()
                      (let ([var condition])
                        (%guard-aux
                          (handler-k
                            (lambda ()
                              (raise-continuable condition)))
                          clause
                          ...))))))))
          (lambda ()
            (call-with-values
              (lambda () e1 e2 ...)
              (lambda args
                (guard-k (lambda () (apply values args))))))))))]))

(define (read-error msg . args)
  (raise (error-object 'read msg args)))

(define (read-error? obj)
  (and (error-object? obj) (eq? (error-object-kind obj) 'read))) 

(define (file-error msg . args)
  (raise (error-object 'file msg args)))

(define (file-error? obj)
  (and (error-object? obj) (eq? (error-object-kind obj) 'file))) 


;---------------------------------------------------------------------------------------------
; Environments and evaluation
;---------------------------------------------------------------------------------------------

; defined in t.scm:
;
; (scheme-report-environment 5)
; (null-environment 5)
; (interaction-environment)
; (environment iset ...)
; (eval exp (env (interaction-environment))) 


;---------------------------------------------------------------------------------------------
; I/O Ports
;---------------------------------------------------------------------------------------------

; integrables:
;
; (input-port? x)
; (output-port? x)
; (input-port-open? p)
; (output-port-open? p)
; (tty-port? p)
; (%current-input-port) +
; (%current-output-port) +
; (%current-error-port) +
; (%set-current-input-port! p) +
; (%set-current-output-port! p) +
; (%set-current-error-port! p) +
; (standard-input-port) +
; (standard-output-port) +
; (standard-error-port) +
; (%open-input-file s) +
; (%open-binary-input-file s) +
; (%open-output-file x) +
; (%open-binary-output-file x) +
; (close-input-port p)
; (close-output-port p)
; (open-input-string s)
; (open-output-string)
; (get-output-string p)
; (open-input-bytevector b)
; (open-output-bytevector)
; (get-output-bytevector p)

(define (port? x) (or (input-port? x) (output-port? x)))
(define textual-port? port?) ; all ports are bimodal
(define binary-port? port?)  ; all ports are bimodal

(define %current-input-port-parameter
  (case-lambda 
    [() (%current-input-port)]
    [(p) (%set-current-input-port! p)]
    [(p s) (if s (%set-current-input-port! p) p)]))

(define-syntax current-input-port
  (syntax-rules ()
    [(_) (%current-input-port)]
    [(_ p) (%set-current-input-port! p)]
    [(_ . r) (%current-input-port-parameter . r)]
    [_ %current-input-port-parameter]))

(define %current-output-port-parameter
  (case-lambda 
    [() (%current-output-port)]
    [(p) (%set-current-output-port! p)]
    [(p s) (if s (%set-current-output-port! p) p)]))

(define-syntax current-output-port
  (syntax-rules ()
    [(_) (%current-output-port)]
    [(_ p) (%set-current-output-port! p)]
    [(_ . r) (%current-output-port-parameter . r)]
    [_ %current-output-port-parameter]))

(define %current-error-port-parameter
  (case-lambda 
    [() (%current-error-port)]
    [(p) (%set-current-error-port! p)]
    [(p s) (if s (%set-current-error-port! p) p)]))

(define-syntax current-error-port
  (syntax-rules ()
    [(_) (%current-error-port)]
    [(_ p) (%set-current-error-port! p)]
    [(_ . r) (%current-error-port-parameter . r)]
    [_ %current-error-port-parameter]))

(define (open-input-file fn)
  (or (%open-input-file fn)
      (file-error "cannot open input file" fn)))

(define (open-output-file fn)
  (or (%open-output-file fn)
      (file-error "cannot open output file" fn)))

(define (open-binary-input-file fn)
  (or (%open-binary-input-file fn)
      (file-error "cannot open binary input file" fn)))

(define (open-binary-output-file fn)
  (or (%open-binary-output-file fn)
      (file-error "cannot open binary output file" fn)))

(define (close-port p)
  (if (input-port? p) (close-input-port p))
  (if (output-port? p) (close-output-port p)))

(define (call-with-port port proc)
  (call-with-values (lambda () (proc port))
    (lambda vals (close-port port) (apply values vals))))

(define (call-with-input-file fname proc)
  (call-with-port (open-input-file fname) proc)) 

(define (call-with-output-file fname proc)
  (call-with-port (open-output-file fname) proc)) 

(define (with-input-from-port port thunk) ; +
  (parameterize ([current-input-port port]) (thunk)))

(define (with-output-to-port port thunk) ; +
  (parameterize ([current-output-port port]) (thunk)))

(define (with-input-from-file fname thunk)
  (call-with-input-file fname (lambda (p) (with-input-from-port p thunk))))

(define (with-output-to-file fname thunk)
  (call-with-output-file fname (lambda (p) (with-output-to-port p thunk))))


;---------------------------------------------------------------------------------------------
; Input
;---------------------------------------------------------------------------------------------

; integrables:
;
; (read-char (p (current-input-port)))
; (peek-char (p (current-input-port)))
; (char-ready? (p (current-input-port)))
; (read-u8 (p (current-input-port)))
; (peek-u8 (p (current-input-port)))
; (u8-ready? (p (current-input-port)))
; (eof-object? x)
; (eof-object)

(define (read-line . ?p)
  (let ([p (if (null? ?p) (current-input-port) (car ?p))]
        [op (open-output-string)])
    (let loop ([read-nothing? #t])
      (let ([c (read-char p)])
        (cond [(or (eof-object? c) (char=? c #\newline))
               (if (and (eof-object? c) read-nothing?) 
                   c
                   (let ([s (get-output-string op)]) 
                     (close-output-port op) 
                     s))]
              [(char=? c #\return) (loop #f)]
              [else (write-char c op) (loop #f)]))))) 

(define (read-substring! str start end p)
  (let loop ([i start])
    (if (fx>=? i end) (fx- i start)
        (let ([c (read-char p)])
          (cond [(eof-object? c) (if (fx=? i start) c (fx- i start))]
                [else (string-set! str i c) (loop (fx+ i 1))])))))

(define (read-substring k p)
  (let ([str (make-string k)])
    (let ([r (read-substring! str 0 k p)])
      (if (eof-object? r) r
          (if (fx=? r k) str (substring str 0 r))))))

(define read-string!
  (case-lambda
    [(str) (read-substring! str 0 (string-length str) (current-input-port))]
    [(str p) (read-substring! str 0 (string-length str) p)]
    [(str p start) (read-substring! str start (string-length str) p)]
    [(str p start end) (read-substring! str start end p)]))

(define read-string
  (case-lambda
    [(k) (read-substring k (current-input-port))]
    [(k p) (read-substring k p)]))

(define (read-subbytevector! bvec start end p)
  (let loop ([i start])
    (if (fx>=? i end) (fx- i start)
        (let ([u8 (read-u8 p)])
          (cond [(eof-object? u8) (if (fx=? i start) u8 (fx- i start))]
                [else (bytevector-u8-set! bvec i u8) (loop (fx+ i 1))])))))

(define (read-subbytevector k p)
  (let ([bvec (make-bytevector k)])
    (let ([r (read-subbytevector! bvec 0 k p)])
      (if (eof-object? r) r
          (if (fx=? r k) bvec (subbytevector bvec 0 r))))))

(define read-bytevector!
  (case-lambda
    [(bvec) (read-subbytevector! bvec 0 (bytevector-length bvec) (current-input-port))]
    [(bvec p) (read-subbytevector! bvec 0 (bytevector-length bvec) p)]
    [(bvec p start) (read-subbytevector! bvec start (bytevector-length bvec) p)]
    [(bvec p start end) (read-subbytevector! bvec start end p)]))

(define read-bytevector
  (case-lambda
    [(k) (read-subbytevector k (current-input-port))]
    [(k p) (read-subbytevector k p)]))

(define (%read port simple?)
  (define-syntax r-error
    (syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)]))
  (define fold-case? (port-fold-case? port))
  (define shared '())
  (define (make-shared-ref loc) (lambda () (unbox loc)))
  (define (shared-ref? form) (procedure? form))
  (define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
  (define (patch-shared! form)
    (cond [(pair? form)
           (if (procedure? (car form)) 
               (set-car! form (patch-ref! (car form)))
               (patch-shared! (car form)))
           (if (procedure? (cdr form)) 
               (set-cdr! form (patch-ref! (cdr form)))
               (patch-shared! (cdr form)))]
          [(vector? form)
           (let loop ([i 0])
             (when (fx<? i (vector-length form))
               (let ([fi (vector-ref form i)])
                 (if (procedure? fi) 
                     (vector-set! form i (patch-ref! fi))
                     (patch-shared! fi)))
               (loop (fx+ i 1))))]
          [(box? form)
           (if (procedure? (unbox form))
               (set-box! form (patch-shared! (unbox form)))
               (patch-shared! (unbox form)))]))
  (define (patch-shared form) (patch-shared! form) form)           

  (define reader-token-marker #f)
  (define close-paren #f)
  (define close-bracket #f)
  (define dot #f)
  (define () ; idless
    (let ([rtm (list 'reader-token)])
          (set! reader-token-marker rtm)
          (set! close-paren (cons rtm "right parenthesis"))
          (set! close-bracket (cons rtm "right bracket"))
          (set! dot (cons rtm "\" . \""))))

  (define (reader-token? form)
    (and (pair? form) (eq? (car form) reader-token-marker)))

  (define (char-symbolic? c)
    (string-position c
      "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))

  (define (char-hex-digit? c)
    (let ([scalar-value (char->integer c)])
      (or (and (>= scalar-value 48) (<= scalar-value 57))
          (and (>= scalar-value 65) (<= scalar-value 70))
          (and (>= scalar-value 97) (<= scalar-value 102)))))

  (define (char-delimiter? c)
    (or (char-whitespace? c)
        (char=? c #\)) (char=? c #\()
        (char=? c #\]) (char=? c #\[)
        (char=? c #\") (char=? c #\;)))

  (define (sub-read-carefully p)
    (let ([form (sub-read p)])
      (cond [(eof-object? form)
             (r-error p "unexpected end of file")]
            [(reader-token? form) 
             (r-error p "unexpected token:" (cdr form))]
            [else form])))

  (define (sub-read-shebang p)
    (if (eqv? (peek-char p) #\space)
        (string->symbol (string-trim-whitespace (read-line p)))
        (sub-read-carefully p)))

  (define (sub-read p)
    (let ([c (read-char p)])
      (cond [(eof-object? c) c]
            [(char-whitespace? c) (sub-read p)]
            [(char=? c #\() (sub-read-list c p close-paren #t)]
            [(char=? c #\)) close-paren]
            [(char=? c #\[) (sub-read-list c p close-bracket #t)]
            [(char=? c #\]) close-bracket]
            [(char=? c #\') (list 'quote (sub-read-carefully p))]
            [(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
            [(char-symbolic? c) (sub-read-number-or-symbol c p)]
            [(char=? c #\;)
             (let loop ([c (read-char p)])
               (or (eof-object? c) (char=? c #\newline)
                   (loop (read-char p))))
             (sub-read p)]
            [(char=? c #\,)
             (let ([next (peek-char p)])
               (cond [(eof-object? next)
                      (r-error p "end of file after ,")]
                     [(char=? next #\@)
                      (read-char p)
                      (list 'unquote-splicing (sub-read-carefully p))]
                     [else (list 'unquote (sub-read-carefully p))]))]
            [(char=? c #\")
             (let loop ([l '()])
               (let ([c (read-char p)])
                 (cond [(eof-object? c)
                        (r-error p "end of file within a string")]
                       [(char=? c #\\)
                        (let ([e (sub-read-strsym-char-escape p 'string)])
                          (loop (if e (cons e l) l)))]
                       [(char=? c #\") (list->string (reverse! l))]
                       [else (loop (cons c l))])))]
            [(char=? c #\|)
             (let loop ([l '()])
               (let ([c (read-char p)])
                 (cond [(eof-object? c)
                        (r-error p "end of file within a |symbol|")]
                       [(char=? c #\\)
                        (let ([e (sub-read-strsym-char-escape p 'symbol)])
                          (loop (if e (cons e l) l)))]
                       [(char=? c #\|) (string->symbol (list->string (reverse! l)))]
                       [else (loop (cons c l))])))]
            [(char=? c #\#)
             (let ([c (peek-char p)])
               (cond [(eof-object? c) (r-error p "end of file after #")]
                     [(char=? c #\!)
                      (read-char p)
                      (let ([name (sub-read-shebang p)])
                        (case name
                          [(fold-case no-fold-case) 
                           (set! fold-case? (eq? name 'fold-case)) 
                           (set-port-fold-case! p fold-case?)
                           (sub-read p)]
                          [else (if (symbol? name) 
                                    (symbol->shebang name)
                                    (r-error p "unexpected name after #!" name))]))]
                     [(or (char-ci=? c #\t) (char-ci=? c #\f))
                      (let ([name (sub-read-carefully p)])
                        (case name [(t true) #t] [(f false) #f]
                          [else (r-error p "unexpected name after #" name)]))]
                     [(or (char-ci=? c #\b) (char-ci=? c #\o)
                          (char-ci=? c #\d) (char-ci=? c #\x)
                          (char-ci=? c #\i) (char-ci=? c #\e))
                      (sub-read-number-or-symbol #\# p)]
                     [(char=? c #\&)
                      (read-char p)
                      (box (sub-read-carefully p))]
                     [(char=? c #\;)
                      (read-char p)
                      (sub-read-carefully p) 
                      (sub-read p)]
                     [(char=? c #\|)
                      (read-char p)
                      (let recur () ;starts right after opening #|
                        (let ([next (read-char p)])
                          (cond
                            [(eof-object? next)
                             (r-error p "end of file in #| comment")]
                            [(char=? next #\|)
                             (let ([next (peek-char p)])
                               (cond
                                 [(eof-object? next)
                                  (r-error p "end of file in #| comment")]
                                 [(char=? next #\#) (read-char p)]
                                 [else (recur)]))]
                            [(char=? next #\#)
                             (let ([next (peek-char p)])
                               (cond
                                 [(eof-object? next)
                                  (r-error p "end of file in #| comment")]
                                 [(char=? next #\|) (read-char p) (recur) (recur)]
                                 [else (recur)]))]
                            [else (recur)])))
                      (sub-read p)]
                     [(char=? c #\() ;)
                      (read-char p)
                      (list->vector (sub-read-list c p close-paren #f))]
                     [(char=? c #\u)
                      (read-char p)
                      (if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
                          (list->bytevector (sub-read-byte-list p))
                          (r-error p "invalid bytevector syntax"))]
                     [(char=? c #\\)
                      (read-char p)
                      (let ([c (peek-char p)])
                        (cond
                          [(eof-object? c)
                           (r-error p "end of file after #\\")]
                          [(char=? #\x c)
                           (read-char p)
                           (if (char-delimiter? (peek-char p))
                               c
                               (sub-read-x-char-escape p #f))]
                          [(char-alphabetic? c)
                           (let ([name (sub-read-carefully p)])
                             (if (= (string-length (symbol->string name)) 1)
                                 c
                                 (case name
                                   [(null) (integer->char #x00)]
                                   [(space) #\space]
                                   [(alarm) #\alarm]
                                   [(backspace) #\backspace]
                                   [(delete) (integer->char #x7F)] ; todo: support by SFC
                                   [(escape) (integer->char #x1B)]
                                   [(tab) #\tab]
                                   [(newline linefeed) #\newline]
                                   [(vtab) #\vtab]
                                   [(page) #\page]
                                   [(return) #\return]
                                   [else (r-error p "unknown #\\ name" name)])))]
                          [else (read-char p) c]))]
                     [(char-numeric? c)
                      (when simple? (r-error p "#N=/#N# notation is not allowed in this mode")) 
                      (let loop ([l '()])
                        (let ([c (read-char p)])
                          (cond [(eof-object? c)
                                 (r-error p "end of file within a #N notation")]
                                [(char-numeric? c)
                                 (loop (cons c l))]
                                [(char=? c #\#) 
                                 (let* ([s (list->string (reverse! l))] [n (string->number s)])
                                   (cond [(and (fixnum? n) (assq n shared)) => cdr]
                                         [else (r-error "unknown #n# reference:" s)]))]   
                                [(char=? c #\=) 
                                 (let* ([s (list->string (reverse! l))] [n (string->number s)])
                                   (cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)]
                                         [(assq n shared) (r-error "duplicate #n= tag:" n)])
                                   (let ([loc (box #f)])
                                     (set! shared (cons (cons n (make-shared-ref loc)) shared))
                                     (let ([form (sub-read-carefully p)])
                                       (cond [(shared-ref? form) (r-error "#n= has another label as target" s)]
                                             [else (set-box! loc form) form]))))]
                                [else (r-error p "invalid terminator for #N notation")])))]
                     [else (r-error p "unknown # syntax" c)]))]
            [else (r-error p "illegal character read" c)])))

  (define (sub-read-list c p close-token dot?)
    (let ([form (sub-read p)])
      (if (eq? form dot)
          (r-error p "missing car -- ( immediately followed by .") ;)
          (let recur ([form form])
            (cond [(eof-object? form)
                   (r-error p "eof inside list -- unbalanced parentheses")]
                  [(eq? form close-token) '()]
                  [(eq? form dot)
                   (if dot?
                       (let* ([last-form (sub-read-carefully p)]
                              [another-form (sub-read p)])
                         (if (eq? another-form close-token)
                             last-form
                             (r-error p "randomness after form after dot" another-form)))
                       (r-error p "dot in #(...)"))]
                  [(reader-token? form)
                   (r-error p "error inside list --" (cdr form))]
                  [else (cons form (recur (sub-read p)))])))))

  (define (sub-read-byte-list p)
    (let recur ([form (sub-read p)])
      (cond [(eof-object? form)
              (r-error p "eof inside bytevector")]
            [(eq? form close-paren) '()]
            [(reader-token? form)
              (r-error p "error inside bytevector --" (cdr form))]
            [(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
              (r-error p "invalid byte inside bytevector --" form)]
            [else (cons form (recur (sub-read p)))])))

  (define (sub-read-strsym-char-escape p what)
    (let ([c (read-char p)])
      (if (eof-object? c)
          (r-error p "end of file within a" what))
      (cond [(or (char=? c #\\) (char=? c #\") (char=? c #\|)) c]
            [(char=? c #\a) #\alarm]
            [(char=? c #\b) #\backspace]
            [(char=? c #\t) #\tab]
            [(char=? c #\n) #\newline]
            [(char=? c #\v) #\vtab]
            [(char=? c #\f) #\page]
            [(char=? c #\r) #\return]
            [(char=? c #\x) (sub-read-x-char-escape p #t)]
            [(and (eq? what 'string) (char-whitespace? c))
             (let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)])
               (cond [(or (eof-object? nc) (not (char-whitespace? nc)))
                      (if gotnl #f (r-error p "no newline in line ending escape"))]
                     [(and gotnl (char=? nc #\newline)) #f]
                     [else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))]
            [else (r-error p "invalid char escape in" what ': c)])))

  (define (sub-read-x-char-escape p in-string?)
    (define (rev-digits->char l)
      (if (null? l)
          (r-error p "\\x escape sequence is too short")
          (integer->char (string->fixnum (list->string (reverse! l)) 16))))
    (let loop ([c (peek-char p)] [l '()] [cc 0])
      (cond [(eof-object? c)
             (if in-string?
               (r-error p "end of file within a string")
               (rev-digits->char l))]
            [(and in-string? (char=? c #\;))
             (read-char p)
             (rev-digits->char l)]
            [(and (not in-string?) (char-delimiter? c))
             (rev-digits->char l)]
            [(not (char-hex-digit? c))
             (r-error p "unexpected char in \\x escape sequence" c)]
            [(> cc 2)
             (r-error p "\\x escape sequence is too long")]
            [else
             (read-char p)
             (loop (peek-char p) (cons c l) (+ cc 1))])))

  (define (suspect-number-or-symbol-peculiar? hash? c l s)
    (cond [(or hash? (char-numeric? c)) #f]
          [(or (string-ci=? s "+i") (string-ci=? s "-i")) #f]
          [(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f]
          [(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f]
          [(or (char=? c #\+) (char=? c #\-))
           (cond [(null? (cdr l)) #t]
                 [(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))]
                 [else (not (char-numeric? (cadr l)))])]
          [else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))]))

  (define (sub-read-number-or-symbol c p)
    (let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
      (cond [(or (eof-object? c) (char-delimiter? c))
             (let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
               (if (or hash? (char-numeric? c) 
                     (char=? c #\+) (char=? c #\-) (char=? c #\.))   
                   (cond [(string=? s ".") dot]
                         [(suspect-number-or-symbol-peculiar? hash? c l s)
                          (if fold-case? 
                              (string->symbol (string-foldcase s))
                              (string->symbol s))]
                         [(string->number s)]
                         [else (r-error p "unsupported number syntax (implementation restriction)" s)])
                   (if fold-case? 
                       (string->symbol (string-foldcase s))
                       (string->symbol s))))]
            [(char=? c #\#)
             (read-char p) 
             (loop (peek-char p) (cons c l) #t)]
            [(char-symbolic? c)
             (read-char p) 
             (loop (peek-char p) (cons c l) hash?)]
            [else (r-error p "unexpected number/symbol char" c)])))
            
  ; body of %read
  (let ([form (sub-read port)])
    (if (not (reader-token? form))
        (if (null? shared) form (patch-shared form))
        (r-error port "unexpected token:" (cdr form)))))

(define read
  (case-lambda
    [() (%read (current-input-port) #f)]
    [(p) (%read p #f)]))

(define read-simple
  (case-lambda
    [() (%read (current-input-port) #t)]
    [(p) (%read p #t)]))


;---------------------------------------------------------------------------------------------
; Output
;---------------------------------------------------------------------------------------------
 
; integrables:
;
; (write x (p (current-output-port)))
; (write-shared x (p (current-output-port)))
; (write-simple x (p (current-output-port)))
; (display x (p (current-output-port)))
; (newline (p (current-output-port)))
; (write-char c (p (current-output-port)))
; (%write-string1 s p) +
; (write-u8 u8 (p (current-output-port)))
; (%write-bytevector1 b p) +
; (flush-output-port (p (current-output-port)))

(define (write-substring from start end p)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (write-char (string-ref from i) p)))

(define write-string
  (case-lambda
    [(str) (%write-string1 str (current-output-port))]
    [(str p) (%write-string1 str p)]
    [(str p start) (write-substring str start (string-length str) p)]
    [(str p start end) (write-substring str start end p)]))

(define (write-subbytevector from start end p)
  (do ([i start (fx+ i 1)]) [(fx>=? i end)] (write-u8 (bytevector-u8-ref from i) p)))

(define write-bytevector
  (case-lambda
    [(bvec) (%write-bytevector1 bvec (current-output-port))]
    [(bvec p) (%write-bytevector1 bvec p)]
    [(bvec p start) (write-subbytevector bvec start (bytevector-length bvec) p)]
    [(bvec p start end) (write-subbytevector bvec start end p)]))


;---------------------------------------------------------------------------------------------
; System interface
;---------------------------------------------------------------------------------------------

; integrables:
;
; (file-exists? s)
; (delete-file s)
; (rename-file sold snew) +
; (%argv-ref i) +
; (get-environment-variable s)
; (current-second)
; (current-jiffy)
; (jiffies-per-second)
; (%system s) +

; defined in t.scm:
;
; (load s (env (interaction-environment))) 

(define current-directory
  (case-lambda 
    [() (%cwd)]
    [(d) (or (%set-cwd! d) (error "cannot change directory to" d))]
    [(d s) (if s (current-directory d) d)]))

(define (%command-line)
  (let loop ([r '()] [i 0])
    (let ([arg (%argv-ref i)])
      (if arg 
          (loop (cons arg r) (fx+ i 1))
          (reverse! r)))))

(define command-line (make-parameter (%command-line))) ; can be changed later in (main)

(define *features* (list r7rs exact-closed skint skint-1.0.0))

(define features
  (case-lambda 
    [() *features*]
    [(f) (if (list? f) (set! *features* f) (error "cannot change features to" f))]
    [(f s) (if s (features f) f)]))

(define (feature-available? f) (and (symbol? f) (memq f (features))))

(define get-environment-variables
  (let ([evl #f])
    (lambda ()
      (or evl
        (let loop ([r '()] [i 0])
          (let ([kvs (%envv-ref i)])
            (if kvs
                (let* ([p (string-position #\= kvs)] ; should be there?
                       [key (if p (substring kvs 0 p) kvs)]
                       [val (if p (substring kvs (fx+ p 1) (string-length kvs)) "")])
                  (loop (cons (cons key val) r) (fx+ i 1)))
                (begin (set! evl (reverse! r)) evl))))))))

(define (emergency-exit . ?obj)
  (if (null? ?obj) (%exit) (%exit (car ?obj))))

(define exit emergency-exit)

(define (%make-exit k)
  (lambda ?obj (if (null? ?obj) (k #t) (k (car ?obj)))))

(let ([status (call/cc (lambda (k) (set! exit (%make-exit k)) 'continue))])
  (unless (eq? status 'continue) (emergency-exit status)))
  

;---------------------------------------------------------------------------------------------
; Selected extras
;---------------------------------------------------------------------------------------------

; SRFI-48 compatible intermediate formatting (advanced functionality accessible via params)

(define format-pretty-print 
  (make-parameter write))
(define format-fixed-print ; TODO: add (number->string/fixed arg ww dd) instruction
  (make-parameter (lambda (arg wd dd p) (display arg p))))
(define format-fresh-line ; TODO: add (fresh-line [p]) instruction for source ports
  (make-parameter newline))
(define format-help-string 
  (make-parameter "supported directives: ~~ ~% ~& ~t ~_ ~a ~s ~w ~y ~c ~b ~o ~d ~x ~f ~? ~k ~* ~!"))

(define (fprintf p fs . args)
  (define (hd args)
    (if (pair? args) (car args) (error "format: no argument for ~ directive")))
  (define (fhd fl)
    (if (pair? fl) (car fl) (error "format: incomplete ~ directive")))
  (define (write-num rx arg p)
    (if (number? arg) (display (number->string arg rx) p) (write arg p)))
  (define (memd fl &w &d)
    (let loop ([fl fl] [c (fhd fl)] [&n &w])
      (cond [(char-numeric? c) 
             (when (< (unbox &n) 0) (set-box! &n 0))
             (set-box! &n (+ (* (unbox &n) 10) (digit-value c)))
             (loop (cdr fl) (fhd (cdr fl)) &n)]
            [(char=? c #\,)
             (loop (cdr fl) (fhd (cdr fl)) &d)]
            [else fl])))
  (let lp ([fl (string->list fs)] [args args])
    (cond [(null? fl) args] ; formally unspecified, but useful value
          [(char=? (car fl) #\~)
           (when (null? (cdr fl)) (error "format: incomplete escape sequence"))
           (let* ([w -1] [d -1] [fl (memd (cdr fl) (set& w) (set& d))])
             (case (char-downcase (car fl))
               [(#\*) (lp (cdr fl) (cddr args))] ;+ CL, skips 1 arg
               [(#\~) (write-char #\~ p) (lp (cdr fl) args)]
               [(#\%) (newline p) (lp (cdr fl) args)]
               [(#\t) (write-char #\tab p) (lp (cdr fl) args)]
               [(#\_) (write-char #\space p) (lp (cdr fl) args)]
               [(#\&) ((format-fresh-line) p) (lp (cdr fl) args)]
               [(#\!) (flush-output-port p) (lp (cdr fl) args)] ;+ common
               [(#\s) (write (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\a) (display (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\w) (write-shared (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\c) (write-char (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\b) (write-num 2 (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\o) (write-num 8 (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\d) (write-num 10 (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\x) (write-num 16 (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\h) (display (format-help-string) p) (lp (cdr fl) args)]
               [(#\y) ((format-pretty-print) (hd args) p) (lp (cdr fl) (cdr args))]
               [(#\f) ((format-fixed-print) (hd args) w d p) (lp (cdr fl) (cdr args))]
               [(#\? #\k) (lp (string->list (hd args)) (hd (hd args))) (lp (cdr fl) (cddr args))]
               [else  (error "format: unrecognized ~ directive" (car fl))]))]
          [else (write-char (car fl) p) (lp (cdr fl) args)])))

(define (format arg . args)
  (cond [(or (eq? arg #f) (string? arg))
         (let ([args (if arg (cons arg args) args)] [p (open-output-string)]) 
           (apply fprintf p args) (get-output-string p))]
        [(eq? arg #t) (apply fprintf (current-output-port) args)]
        [else (apply fprintf arg args)]))

(define (write-to-string obj)
  (let ([p (open-output-string)])
    (write obj p)
    (let ([s (get-output-string p)])
      (close-output-port p)
      s)))

(define (read-from-string str)
  (let* ([p (open-input-string str)]
         [obj (guard (err [else (eof-object)]) (read p))])
    (close-input-port p)
    obj))

; simple AT&T-like command-line options parser
; calls (return keysym optarg restargs) where opt is #f on end-of-options
; optmap is a list of the following opt info records:
; ([keysym "-f" "--foo" needsarg? "foo help"] ...)

(define (get-next-command-line-option args optmap return)
  (define opterr error)
  (define (opt-lookup opt optmap) ;=> #f | (needsarg? keysym)
    (define iref (if (= (string-length opt) 2) cadr caddr))
    (let ([r (memp (lambda (i) (equal? (iref i) opt)) optmap)])
      (and r (cons (cadddr (car r)) (caar r)))))
  (define (ssref s i) ; safe-string-ref
    (and i (< -1 i (string-length s)) (string-ref s i)))
  (cond [(null? args) (return #f #f args)]
        [(string=? (car args) "--") (return #f #f (cdr args))]
        [(string=? (car args) "-") (return #f #f args)]
        [(not (eqv? (ssref (car args) 0) #\-)) (return #f #f args)]
        [(and (eqv? (ssref (car args) 0) #\-) (eqv? (ssref (car args) 1) #\-))
         (let* ([s (car args)] [p (string-position #\= s)])
           (define opt (if p (string-copy s 0 p) s)) ; "--longopt"
           (define ank (opt-lookup opt optmap)) ; #f or (needarg? . keysym)
           (cond [(and ank (car ank) p) ; needs arg, and it is in s
                  (return (cdr ank) (string-copy s (+ 1 p)) (cdr args))]
                 [(and ank (car ank) (pair? (cdr args)))
                  (return (cdr ank) (cadr args) (cddr args))]
                 [(and ank (car ank))
                  (opterr "missing option argument" opt)]
                 [(and ank (not (car ank)) (not p))
                  (return (cdr ank) #f (cdr args))]
                 [(and ank (not (car ank)) p)
                  (opterr "unexpected option argument" s)]
                 [else (opterr "unknown option" opt)]))]
        [else ; char option (with arg or joined with next one)
         (let* ([s (car args)] [l (string-length s)])
           (define opt (string-copy s 0 2)) ; "-o"
           (define ank (opt-lookup opt optmap)) ; #f or (needarg? . keysym)
           (cond [(and ank (car ank) (> l 2)) ; needs arg, and it is in s
                  (return (cdr ank) (string-copy s 2) (cdr args))]
                 [(and ank (car ank) (= l 2) (pair? (cdr args)))
                  (return (cdr ank) (cadr args) (cddr args))]
                 [(and ank (car ank))
                  (opterr "missing option argument" opt)]
                 [(and ank (not (car ank)) (> l 2))
                  (return (cdr ank) #f ; form option string without opt
                     (cons (string-append "-" (string-copy s 2)) (cdr args)))]
                 [(and ank (not (car ank)))
                  (return (cdr ank) #f (cdr args))]
                 [else (opterr "unknown option" opt)]))]))

; printer for optmap options used for --help; returns offset of help lines
(define (print-command-line-options optmap . ?port)
  (define port (if (pair? ?port) (car ?port) (standard-output-port)))
  (define (optlen i)
    (let ([co (cadr i)] [lo (caddr i)] [oa (cadddr i)])
      (define colen (if co (string-length co) 0))
      (define lolen (if lo (string-length lo) 0))
      (define oalen (if oa (string-length oa) 0))
      (when (= (+ colen lolen) 0) (error "invalid options record" i))
      (+ (if (and (> colen 0) (> lolen 0)) (+ colen lolen 2) (+ colen lolen))
         (if (= oalen 0) 0 (+ oalen 1)))))
  (define optlens (map optlen optmap))
  (define max-optlen (apply max (cons 0 optlens)))
  (let loop ([optmap optmap] [optlens optlens])
    (unless (null? optmap)
      (let ([i (car optmap)] [optlen (car optlens)])
        (display "  " port)
        (let ([co (cadr i)] [lo (caddr i)] [oa (cadddr i)] [hl (car (cddddr i))])
          (cond [(and co lo) 
                 (display co port) (display ", " port) (display lo port)
                 (when oa (display "=" port) (display oa port))]
                [co (display co port) (when oa (display " " port) (display oa port))]
                [lo (display lo port) (when oa (display "=" port) (display oa port))])
          (display (make-string (- max-optlen optlen) #\space) port)
          (display "    " port) (display hl port) (newline port)
          (loop (cdr optmap) (cdr optlens))))))
  (+ 2 max-optlen 4))