;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains the base library from r7rs.
;;;;
(define-library (scheme base)
  (import (scheme cyclone common))
  (export
    member
    assoc
    cons-source
    syntax-rules
    letrec*
    guard
    guard-aux
    ;; Record types
    define-record-type
    record?
    register-simple-type
    make-type-predicate
    make-constructor
    make-getter
    make-setter
    slot-set!
    type-slot-offset
    ;; END records
    receive
    abs
    max
    min
    modulo
    floor-remainder
    even?
    exact-integer?
    exact-integer-sqrt
    exact?
    inexact?
    odd?
    complex?
    rational?
    gcd
    lcm
    quotient
    remainder
    truncate-quotient 
    truncate-remainder 
    truncate/ 
    floor-quotient 
    floor-remainder 
    floor/ 
    square
    expt
    call-with-current-continuation
    call/cc
    call-with-values
    dynamic-wind
    values
    char=?
    char<?
    char>?
    char<=?
    char>=?
    string=?
    string<?
    string<=?
    string>?
    string>=?
    foldl
    foldr
    not
    list?
    zero?
    positive?
    negative?
    append
    list
    make-list
    list-copy
    map
    for-each
    list-tail
    list-ref
    list-set!
    reverse
    boolean=?
    symbol=?
    Cyc-obj=?
    vector
    vector-append
    vector-copy
    vector-copy!
    vector-fill!
    vector->list
    vector->string
    vector-map
    vector-for-each
    make-string
    string
    string-copy
    string-copy!
    string-fill!
    string->list
    string->vector
    string-map
    string-for-each
    make-parameter
    current-output-port
    current-input-port
    current-error-port
    call-with-port
    ; TODO: error-object?
    ; TODO: error-object-message
    ; TODO: error-object-irritants
    ; TODO: file-error?
    ; TODO: read-error?
    error
    raise
    raise-continuable
    with-exception-handler
    Cyc-add-exception-handler
    Cyc-remove-exception-handler
    newline
    write-char
    write-string
    flush-output-port
    read-line
    read-string
    input-port?
    output-port?
    input-port-open?
    output-port-open?
    get-output-string
    open-output-string
    open-input-string
    get-output-bytevector
    open-input-bytevector
    open-output-bytevector
    features
    Cyc-version
    any
    every
    and
    or
    let
    let*
    letrec
    let*-values
    let-values
    begin
    case
    cond
    cond-expand
    do
    when
    unless
    quasiquote
    floor
    ceiling
    truncate
    round
    exact
    inexact
    eof-object
    syntax-error
    bytevector-copy
    bytevector-copy!
    utf8->string
    string->utf8
    denominator
    numerator
    parameterize

;;;;
; Possibly missing functions:
;
;    ; following byte vector functions are not implemented yet:
;    read-bytevector
;    read-bytevector!
;    write-bytevector
;
;    : No unicode support at this time
;    peek-u8
;    read-u8
;    u8-ready?
;    write-u8
;
;    ; No complex or rational numbers at this time
;    rationalize
;
;    ;; no binary/text ports yet
;    binary-port?
;    textual-port?
;
;    ;; syntax-rules
;    define-values
;
; unclassified TODO's:
;    import
;    include
;    let-syntax
;    letrec-syntax
;;;;
  )
  (begin
    ;; Features implemented by this Scheme
    (define (features) 
      (cons 
        'cyclone
        (cons
          (string->symbol 
            (string-append "version-" *version-number*))
          '(r7rs 
            ieee-float
            posix))))

    (define (Cyc-version) *version-number*)

    (define-syntax and
      (er-macro-transformer
       (lambda (expr rename compare)
         (cond ((null? (cdr expr)) #t)
               ((null? (cddr expr)) (cadr expr))
               (else (list (rename 'if) (cadr expr)
                           (cons (rename 'and) (cddr expr))
                           #f))))))
    (define-syntax or
      (er-macro-transformer
        (lambda (expr rename compare)
          (cond ((null? (cdr expr)) #f)
                ((null? (cddr expr)) (cadr expr))
                (else
                 (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
                       (list (rename 'if) (rename 'tmp)
                             (rename 'tmp)
                             (cons (rename 'or) (cddr expr)))))))))
    (define-syntax let
      (er-macro-transformer
        (lambda (expr rename compare)
          (if (null? (cdr expr)) (error "empty let" expr))
          (if (null? (cddr expr)) (error "no let body" expr))
          ((lambda (bindings)
             (if (list? bindings) #f (error "bad let bindings"))
             (if (every (lambda (x)
                          (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
                        bindings)
                 ((lambda (vars vals)
                    (if (symbol? (cadr expr))
                        `((,(rename 'lambda) ,vars
                           (,(rename 'letrec) ((,(cadr expr)
                                                (,(rename 'lambda) ,vars
                                                 ,@(cdr (cddr expr)))))
                            (,(cadr expr) ,@vars)))
                          ,@vals)
                        `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
                  (map car bindings)
                  (map cadr bindings))
                 (error "bad let syntax" expr)))
           (if (symbol? (cadr expr)) (car (cddr expr)) (cadr expr))))))
    (define-syntax let*
      (er-macro-transformer
        (lambda (expr rename compare)
          (if (null? (cdr expr)) (error "empty let*" expr))
          (if (null? (cddr expr)) (error "no let* body" expr))
          (if (null? (cadr expr))
              `(,(rename 'let) () ,@(cddr expr))
              (if (if (list? (cadr expr))
                      (every
                       (lambda (x)
                         (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
                       (cadr expr))
                      #f)
                  `(,(rename 'let) (,(caar (cdr expr)))
                    (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
                  (error "bad let* syntax"))))))
    (define-syntax letrec 
      (er-macro-transformer
        (lambda (exp rename compare)
          (let* ((bindings  (cadr exp)) ;(letrec->bindings exp)
                 (namings   (map (lambda (b) (list (car b) #f)) bindings))
                 (names     (map car (cadr exp))) ;(letrec->bound-vars exp)
                 (sets      (map (lambda (binding) 
                                   (cons 'set! binding))
                                 bindings))
                 (args      (map cadr (cadr exp)))) ;(letrec->args exp)
            `(let ,namings
               (begin ,@(append sets (cddr exp)))))))) ;(letrec->exp exp)
;; NOTE: chibi uses the following macro. turns vars into defines?
;;(define-syntax letrec
;;  (er-macro-transformer
;;   (lambda (expr rename compare)
;;     ((lambda (defs)
;;        `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
;;      (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
    (define-syntax begin 
      (er-macro-transformer
        (lambda (exp rename compare)
          (define (singlet? l)
            (and (list? l)
                 (= (length l) 1)))
          
          (define (dummy-bind exps)
            (cond
              ((singlet? exps)  (car exps))
              
              ; JAE - should be fine until CPS phase
              ((pair? exps)
               `((lambda ()
                 ,@exps)))))
              ;((pair? exps)     `(let (($_ ,(car exps)))
              ;                    ,(dummy-bind (cdr exps))))))
          (dummy-bind (cdr exp)))))
    (define-syntax cond-expand
      (er-macro-transformer
        ;; Based on the cond-expand macro from Chibi scheme
        (lambda (expr rename compare)
          (define (_library-exists? import . ext)
            (file-exists?
              (_lib:import->filename 
                (_lib:import->library-name import)
                (if (null? ext) ".sld" (car ext)))))
          (define (_lib:import->filename import . ext)
            (let* ((file-ext 
                    (if (null? ext)
                        ".sld"
                        (car ext)))
                   (filename*
                    (string-append
                      (apply
                        string-append
                        (map 
                          (lambda (i) 
                            (string-append 
                              "/" 
                              (cond
                                ((symbol? i) (symbol->string i))
                                ((number? i) (number->string i))
                                (else (error "Unexpected type in import set")))))
                          import))
                      file-ext))
                   (filename
                     (substring filename* 1 (string-length filename*))))
              (if (or (equal? 'scheme (car import))
                      (equal? 'srfi   (car import)))
                (string-append (Cyc-installation-dir 'sld) "/" filename) ;; Built-in library
                filename)))
          (define (_lib:import->library-name import)
            (cond
              ((and (pair? import)
                    (or (equal? 'only   (car import))
                        (equal? 'except (car import))
                        (equal? 'prefix (car import))
                        (equal? 'rename (car import))))
               (_lib:import->library-name 
                 (cadr import)))
              (else
               import)))
          (define (check x)
            (if (pair? x)
                (case (car x)
                  ((and) (every check (cdr x)))
                  ((or) (any check (cdr x)))
                  ((not) (not (check (cadr x))))
                  ((library) (_library-exists? (cadr x))) ;(eval `(find-module ',(cadr x)) (%meta-env)))
                  (else (error "cond-expand: bad feature" x)))
                (memq x (features))))
          (let expand ((ls (cdr expr)))
            (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
                  ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
                  ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls)))
                   (if (pair? (cdr ls))
                       (error "cond-expand: else in non-final position")
                       `(,(rename 'begin) ,@(cdar ls))))
                  ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
                  (else (expand (cdr ls))))))))
    (define-syntax cond
      (er-macro-transformer
          (lambda (expr rename compare)
            (if (null? (cdr expr))
                #f ;(if #f #f)
                ((lambda (cl)
                   (if (compare (rename 'else) (car cl))
                       (if (pair? (cddr expr))
                           (error "non-final else in cond" expr)
                           (list (cons (rename 'lambda) (cons '() (cdr cl)))))
                       (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
                           (list (list (rename 'lambda) (list (rename 'tmp))
                                       (list (rename 'if) (rename 'tmp)
                                             (if (null? (cdr cl))
                                                 (rename 'tmp)
                                                 (list (car (cddr cl)) (rename 'tmp)))
                                             (cons (rename 'cond) (cddr expr))))
                                 (car cl))
                           (list (rename 'if)
                                 (car cl)
                                 (list (cons (rename 'lambda) (cons '() (cdr cl))))
                                 (cons (rename 'cond) (cddr expr))))))
                 (cadr expr))))))
    (define-syntax case
      (er-macro-transformer
          (lambda (expr rename compare)
            (define (body exprs)
              (cond
               ((null? exprs)
                (rename 'tmp))
               ((compare (rename '=>) (car exprs))
                `(,(cadr exprs) ,(rename 'tmp)))
               (else
                `(,(rename 'begin) ,@exprs))))
            (define (clause ls)
              (cond
               ((null? ls) #f)
               ((compare (rename 'else) (caar ls))
                (body (cdar ls)))
               ((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
                `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
                                 (,(rename 'quote) ,(car (caar ls))))
                  ,(body (cdar ls))
                  ,(clause (cdr ls))))
               (else
                `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
                                 (,(rename 'quote) ,(caar ls)))
                  ,(body (cdar ls))
                  ,(clause (cdr ls))))))
            `(let ((,(rename 'tmp) ,(cadr expr)))
               ,(clause (cddr expr))))))
    (define-syntax when
      (er-macro-transformer
        (lambda (exp rename compare)
          (if (null? (cdr exp)) (error "empty when" exp))
          (if (null? (cddr exp)) (error "no when body" exp))
          `(if ,(cadr exp)
               ((lambda () ,@(cddr exp)))
               #f))))
    (define-syntax unless
      (er-macro-transformer
        (lambda (exp rename compare)
          (if (null? (cdr exp)) (error "empty unless" exp))
          (if (null? (cddr exp)) (error "no unless body" exp))
          `(if ,(cadr exp)
               #f
               ((lambda () ,@(cddr exp)))))))
  (define-syntax do
    (er-macro-transformer
     (lambda (expr rename compare)
       (let* ((body
               `(,(rename 'begin)
                 ,@(cdr (cddr expr))
                 (,(rename 'lp)
                  ,@(map (lambda (x)
                           (if (pair? (cddr x))
                               (if (pair? (cdr (cddr x)))
                                   (error "too many forms in do iterator" x)
                                   (car (cddr x)))
                               (car x)))
                         (cadr expr)))))
              (check (car (cddr expr)))
              (wrap
               (if (null? (cdr check))
                   `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
                     (,(rename 'if) ,(rename 'tmp)
                      ,(rename 'tmp)
                      ,body))
                   `(,(rename 'if) ,(car check)
                     (,(rename 'begin) ,@(cdr check))
                     ,body))))
         `(,(rename 'let) ,(rename 'lp)
           ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
           ,wrap)))))
    (define-syntax quasiquote
      (er-macro-transformer
        ;; Based on the quasiquote macro from Chibi scheme
        (lambda (expr rename compare)
          (define (qq x d)
            (cond
             ((pair? x)
              (cond
               ((compare (rename 'unquote) (car x))
                (if (<= d 0)
                    (cadr x)
                    (list (rename 'list) (list (rename 'quote) 'unquote)
                          (qq (cadr x) (- d 1)))))
               ((compare (rename 'unquote-splicing) (car x))
                (if (<= d 0)
                    (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
                    (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
                          (qq (cadr x) (- d 1)))))
               ((compare (rename 'quasiquote) (car x))
                (list (rename 'list) (list (rename 'quote) 'quasiquote)
                      (qq (cadr x) (+ d 1))))
               ((and (<= d 0) (pair? (car x))
                     (compare (rename 'unquote-splicing) (caar x)))
                (if (null? (cdr x))
                    (cadr (car x))
                    (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
               (else
                (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
             ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
             ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
             (else x)))
          (qq (cadr expr) 0))))

    (define-syntax syntax-error
      (er-macro-transformer
        (lambda (expr rename compare)
          (apply error (cdr expr)))))

    ;; TODO: The whitespace characters are space, tab, line feed, form feed (not in parser yet), and carriage return.
    (define call-with-current-continuation call/cc)
    ;; TODO: this is from r7rs, but is not really good enough by itself
    ;(define (values . things)
    ;  (call/cc
    ;    (lambda (cont) (apply cont things))))
    (define values 
      (lambda args
        (if (and (not (null? args)) (null? (cdr args)))
            (car args)
            (cons (cons 'multiple 'values) args)))) 
    ;; TODO: just need something good enough for bootstrapping (for now)
    ;; does not have to be perfect (this is not, does not handle call/cc or exceptions)
    (define call-with-values
      (lambda (producer consumer)
        (let ((x (producer)))
          (if ;(magic? x)
              (and (pair? x) (equal? (car x) (cons 'multiple 'values)))
              (apply consumer (cdr x))
              (consumer x)))))

    (define (dynamic-wind before thunk after)
      (before)
      (let ((result (thunk)))
        (after)
        result)
      ;(call-with-values
      ;  thunk
      ;  (lambda (result) ;results
      ;    (after)
      ;    result)))
          ;(apply values results))))
    )
    (define (call-with-port port proc)
      (let ((result (proc port)))
        (close-port port)
        result))
    (define (Cyc-bin-op cmp x lst)
      (cond
        ((null? lst) #t)
        ((cmp x (car lst))
         (Cyc-bin-op cmp (car lst) (cdr lst)))
        (else #f)))
    (define (Cyc-bin-op-char cmp c cs)
      (Cyc-bin-op
        (lambda (x y) 
          (cmp (char->integer x) (char->integer y)))
        c
        cs))
    (define (char=?  c1 c2 . cs) (Cyc-bin-op-char =  c1 (cons c2 cs)))
    (define (char<?  c1 c2 . cs) (Cyc-bin-op-char <  c1 (cons c2 cs)))
    (define (char>?  c1 c2 . cs) (Cyc-bin-op-char >  c1 (cons c2 cs)))
    (define (char<=? c1 c2 . cs) (Cyc-bin-op-char <= c1 (cons c2 cs)))
    (define (char>=? c1 c2 . cs) (Cyc-bin-op-char >= c1 (cons c2 cs)))
    ; TODO: char-ci predicates (in scheme/char library)


    (define (string=? str1 str2)  (equal? (string-cmp str1 str2) 0))
    (define (string<? str1 str2)  (<  (string-cmp str1 str2) 0))
    (define (string<=? str1 str2) (<= (string-cmp str1 str2) 0))
    (define (string>? str1 str2)  (>  (string-cmp str1 str2) 0))
    (define (string>=? str1 str2) (>= (string-cmp str1 str2) 0))
    ; TODO: generalize to multiple arguments: (define (string<? str1 str2 . strs)

    (define (member-helper obj lst cmp-proc)
     (cond 
       ((null? lst) #f)
       ((cmp-proc obj (car lst)) lst)
       (else (member-helper obj (cdr lst) cmp-proc))))
    (define (member obj lst . compare) 
        (if (pair? compare)
            (member-helper obj lst (car compare))
            (member-helper obj lst equal?)))
    ;(define (memq obj lst) (member-helper obj lst eq?))
    ;(define (memv obj lst) (member-helper obj lst eqv?))
    
    (define (assoc-helper obj lst cmp?)
     (cond 
       ((null? lst) #f)
       ((and (pair? (car lst))
             (cmp? obj (car (car lst))))
        (car lst))
       (else (assoc-helper obj (cdr lst) cmp?))))
      
    (define (assoc obj alist . compare)
        (if (pair? compare)
            (assoc-helper obj alist (car compare))
            (assoc-helper obj alist equal?)))
    ;(define (assq obj alist) (assoc-helper obj alist eq?))
    ;(define (assv obj alist) (assoc-helper obj alist eqv?))

    (define (foldl func accum lst)
      (if (null? lst)
        accum
        (foldl func (func (car lst) accum) (cdr lst))))
    (define (foldr func end lst)
      (if (null? lst)
        end
        (func (car lst) (foldr func end (cdr lst)))))
    (define (read-line . port)
      (if (null? port)
        (Cyc-read-line (current-input-port))
        (Cyc-read-line (car port))))
    (define (read-string k . opts)
      (let ((port (if (null? opts)
                      (current-input-port)
                      (car opts))))
        (let loop ((acc '())
                   (i k)
                   (chr #f))
          (cond
            ((eof-object? chr)
             (list->string 
               (reverse acc)))
            ((zero? i)
             (list->string 
               (reverse 
                 (if chr (cons chr acc) acc))))
            (else
             (loop (if chr (cons chr acc) acc)
                   (- i 1)
                   (read-char port)))))))
    (define (flush-output-port . port)
      (if (null? port)
        (Cyc-flush-output-port (current-output-port))
        (Cyc-flush-output-port (car port))))
    (define (write-string str . port)
      (if (null? port)
        (Cyc-display str (current-output-port))
        (Cyc-display str (car port))))
    (define (write-char char . port)
      (if (null? port)
        (Cyc-write-char char (current-output-port))
        (Cyc-write-char char (car port))))
    (define (newline . port) 
      (apply write-char (cons #\newline port)))
    (define (not x) (if x #f #t))
    (define (list? o)
      (define (_list? obj)
        (cond
          ((null? obj) #t)
          ((pair? obj)
           (_list? (cdr obj)))
          (else #f)))
      (if (Cyc-has-cycle? o)
        #t
        (_list? o)))
    (define (zero? n) (= n 0))
    (define (positive? n) (> n 0))
    (define (negative? n) (< n 0))
    ; append accepts a variable number of arguments, per R5RS. So a wrapper
    ; has been provided for the standard 2-argument version of (append).
    ;
    ; We return the given value if less than 2 arguments are given, and
    ; otherwise fold over each arg, appending it to its predecessor. 
    (define (append . lst)
      (define append-2
              (lambda (inlist alist)
                      (foldr (lambda (ap in) (cons ap in)) alist inlist)))
      (if (null? lst)
          lst
          (if (null? (cdr lst))
              (car lst)
              (foldl (lambda (a b) (append-2 b a)) (car lst) (cdr lst)))))
    (define (list . objs)  objs)
    (define (make-list k . fill)
      (letrec ((x (if (null? fill) 
                   #f
                   (car fill)))
               (make
                 (lambda (n obj)
                   (if (zero? n)
                   '()
                   (cons obj (make (- n 1) obj) )))))
      (make k x)))
    (define (list-copy lst)
      (foldr (lambda (x y) (cons x y)) '() lst))
    ;; Implementation of receive from SRFI 8
    (define-syntax receive
      (er-macro-transformer
       (lambda (expr rename compare)
        ;(if (or (not (pair? expr))
        ;        (< (length expr) 3))
        ;    (syntax-error "Invalid syntax for receive" expr))
        (let ((formals (cadr expr))
              (val-expr (caddr expr))
              (body (cdddr expr)))
          `(call-with-values 
             (lambda () ,val-expr)
             (lambda ,formals ,@body))))))
;
; for example:
; (call-with-values (lambda () (values 1 2)) (lambda (x y) (write `(,x ,y))))
; ==>(1 2)
;
;(receive (x y) (values 1 2) (write `(,x ,y)))
; ==>(1 2)
;

; Added the following support functions from SRFI 1
(define (car+cdr pair) (values (car pair) (cdr pair)))
(define (%cars+cdrs lists)
  (call-with-current-continuation
    (lambda (abort)
      (let recur ((lists lists))
        (if (pair? lists)
          (receive (list other-lists) (car+cdr lists)
            (if (null? list) (abort '() '()) ; LIST is empty -- bail out
              (receive (a d) (car+cdr list)
                (receive (cars cdrs) (recur other-lists)
                  (values (cons a cars) (cons d cdrs))))))
          (values '() '()))))))
; END support functions

    (define (map f lis1 . lists)
    ;  (check-arg procedure? f map-in-order)
      (if (pair? lists)
          (let recur ((lists (cons lis1 lists)))
            (receive (cars cdrs) (%cars+cdrs lists)
              (if (pair? cars)
                  (let ((x (apply f cars)))		; Do head first,
                    (cons x (recur cdrs)))		; then tail.
                  '())))
          ;; Fast path.
         (foldr (lambda (x y) (cons (f x) y)) '() lis1)))

    (define (for-each f lis1 . lists)
      (if (not (null? lis1))
        (if (pair? lists)
          (let recur ((lists (cons lis1 lists)))
            (receive (cars cdrs) (%cars+cdrs lists)
              (if (pair? cars)
                  (begin
                    (apply f cars)
                    (recur cdrs)))))
          ;; Fast path.
          (if (eq? 1 (length lis1))
            (f (car lis1))
            (begin (f (car lis1))
                   (for-each f (cdr lis1)))))))
    (define (list-tail lst k) 
      (if (zero? k)
        lst
        (list-tail (cdr lst) (- k 1))))
    (define (list-ref lst k)  (car (list-tail lst k)))
    (define (list-set! lst k obj)
      (let ((kth (list-tail lst k)))
        (set-car! kth obj)))
    (define (reverse lst)   (foldl cons '() lst))

    (define (vector . objs) (list->vector objs))
    (define (vector->list vec . opts)
      (letrec ((len (vector-length vec))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i lst)
                       (if (= i end)
                           (reverse lst)
                           (loop (+ i 1) 
                                 (cons (vector-ref vec i) lst))))))
        (loop start '())))
    (define (bytevector-copy bv . opts)
      (letrec ((len (bytevector-length bv))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len)))
        (Cyc-bytevector-copy bv start end)))
    (define (bytevector-copy! to at from . o)
      (let* ((start (if (pair? o) (car o) 0))
             (end (if (and (pair? o) (pair? (cdr o)))
                      (cadr o)
                      (bytevector-length from)))
             (limit (min end (+ start (- (bytevector-length to) at)))))
        (if (<= at start)
            (do ((i at (+ i 1)) (j start (+ j 1)))
                ((>= j limit))
              (bytevector-u8-set! to i (bytevector-u8-ref from j)))
            (do ((i (+ at (- end start 1)) (- i 1)) (j (- limit 1) (- j 1)))
                ((< j start))
              (bytevector-u8-set! to i (bytevector-u8-ref from j))))))
    (define (utf8->string bv . opts)
      (letrec ((len (bytevector-length bv))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len)))
        (Cyc-utf8->string bv start end)))
    (define (string->utf8 str . opts)
      (letrec ((len (string-length str))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len)))
        (Cyc-string->utf8 str start end)))
    (define (vector->string vec . opts)
      (let ((lst (apply vector->list (cons vec opts))))
        (list->string lst)))
    (define (string->list str . opts)
      (letrec ((len (string-length str))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i lst)
                       (if (= i end)
                           (reverse lst)
                           (loop (+ i 1) 
                                 (cons (string-ref str i) lst))))))
        (loop start '())))
    (define (string->vector str . opts)
      (list->vector
        (apply string->list (cons str opts))))
    (define (string-copy str . opts)
      (letrec ((len (string-length str))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len)))
        (substring str start end)))
    (define (string-copy! to at from . opts)
      (letrec ((len (string-length from))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i-at i-from)
                       (cond
                        ((= i-from end) to)
                        (else
                          (string-set! to i-at (string-ref from i-from))
                          (loop (+ i-at 1) (+ i-from 1)))))))
        (loop at start)))
    (define (string-fill! str fill . opts)
      ;; TODO: technically this is not per spec, because end references len.
      ;;       Should change to use letrec*
      (letrec ((len (string-length str))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i)
                       (cond
                        ((= i end) str)
                        (else
                          (string-set! str i fill)
                          (loop (+ i 1)))))))
        (loop start)))
    (define (string-map func str1 . strs)
      (list->string
        (apply map `(,func ,(string->list str1) ,@(map string->list strs)))))
    (define (string-for-each func str1 . strs)
      (apply for-each `(,func ,(string->list str1) ,@(map string->list strs))))
    (define (vector-map func vec1 . vecs)
      (list->vector
        (apply map `(,func ,(vector->list vec1) ,@(map vector->list vecs)))))
    (define (vector-for-each func vec1 . vecs)
      (apply for-each `(,func ,(vector->list vec1) ,@(map vector->list vecs))))
    (define (vector-append . vecs)
      (list->vector
        (apply append (map vector->list vecs))))
    (define (vector-copy vec . opts)
      (letrec ((len (vector-length vec))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i new-vec)
                       (cond
                        ((= i end)
                         new-vec)
                        (else
                           (vector-set! new-vec (- i start) (vector-ref vec i))
                           (loop (+ i 1) new-vec))))))
        (loop start (make-vector (- end start) #f))))
    ;; TODO: does not quite meet r7rs spec, should check if vectors overlap
    (define (vector-copy! to at from . opts)
      (letrec ((len (vector-length from))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i-at i-from)
                       (cond
                        ((= i-from end) to)
                        (else
                          (vector-set! to i-at (vector-ref from i-from))
                          (loop (+ i-at 1) (+ i-from 1)))))))
        (loop at start)))
    ;; TODO: this len/start/end/loop pattern is common, could use a macro for it
    (define (vector-fill! vec fill . opts)
      (letrec ((len (vector-length vec))
               (start (if (> (length opts) 0) (car opts) 0))
               (end (if (> (length opts) 1) (cadr opts) len))
               (loop (lambda (i)
                       (cond
                        ((= i end) vec)
                        (else
                          (vector-set! vec i fill)
                          (loop (+ i 1)))))))
        (loop start)))

    (define (boolean=? b1 b2 . bs)
      (Cyc-obj=? boolean? b1 (cons b2 bs)))
    (define (symbol=? sym1 sym2 . syms)
      (Cyc-obj=? symbol? sym1 (cons sym2 syms)))
    (define (Cyc-obj=? type? obj objs)
      (and
        (type? obj)
        (call/cc
          (lambda (return)
            (for-each 
              (lambda (o)
                (if (not (eq? o obj))
                  (return #f)))
              objs)
              #t))))
    (define (string . chars)
      (list->string chars))
    (define (make-string k . fill)
      (let ((fill* (if (null? fill)
                      '(#\space)
                      fill)))
        (list->string
          (apply make-list (cons k fill*)))))
    (define-syntax parameterize
      (syntax-rules ()
        ((parameterize
           ("step")
           ((param value p old new) ...)
           ()
           body)
         (let ((p param) ...)
           (let ((old (p))
                 ...
                 (new ((p '<param-convert>) value))
                 ...)
             (dynamic-wind
               (lambda () (p '<param-set!> new) ...)
               (lambda () . body)
               (lambda () (p '<param-set!> old) ...)))))
        ((parameterize
           ("step")
           args
           ((param value) . rest)
           body)
         (parameterize
           ("step")
           ((param value p old new) . args)
           rest
           body))
        ((parameterize ((param value) ...) . body)
         (parameterize
           ("step")
           ()
           ((param value) ...)
           body))))
    (define (make-parameter init . o)
      (let* ((converter
               (if (pair? o) (car o) (lambda (x) x)))
             (value (converter init)))
        (lambda args
          (cond
            ((null? args)
             value)
            ((eq? (car args) '<param-set!>)
             (set! value (cadr args)))
            ((eq? (car args) '<param-convert>)
             converter)
           (else
             ;(error "bad parameter syntax" args)
             (set! value (converter (car args)))
           )))))
    (define current-output-port
      (make-parameter (Cyc-stdout)))
    (define current-input-port
      (make-parameter (Cyc-stdin)))
    (define current-error-port
      (make-parameter (Cyc-stderr)))
    (define (error msg . args)
      (raise (cons msg args)))
    (define (raise obj)
      ((Cyc-current-exception-handler) 
        (cons 'raised (if (pair? obj) obj (list obj)))))
    (define (raise-continuable obj)
      ((Cyc-current-exception-handler) 
        (cons 'continuable (if (pair? obj) obj (list obj)))))
    (define (with-exception-handler handler thunk)
      (let ((result #f)
            (my-handler 
              (lambda (obj)
                (let ((result #f)
                      (continuable? (and (pair? obj) 
                                         (equal? (car obj) 'continuable))))
                  ;; Unregister this handler since it is no longer needed
                  (Cyc-remove-exception-handler)
                  (set! result (handler (cdr obj))) ;; Actual handler
                  (if continuable?
                      result
                      (error "exception handler returned"))))))
      ;; No cond-expand below, since this is part of our internal lib
      (Cyc-add-exception-handler my-handler)
      (set! result (thunk))
      (Cyc-remove-exception-handler) ; Only reached if no ex raised
      result))
    (define-c Cyc-add-exception-handler
      "(void *data, int argc, closure _, object k, object h)"
      " gc_thread_data *thd = (gc_thread_data *)data;
        make_pair(c, h, thd->exception_handler_stack);
        thd->exception_handler_stack = &c;
        return_closcall1(data, k, &c); ")
    (define-c Cyc-remove-exception-handler
      "(void *data, int argc, closure _, object k)"
      " gc_thread_data *thd = (gc_thread_data *)data;
        if (thd->exception_handler_stack) {
          thd->exception_handler_stack = cdr(thd->exception_handler_stack);
        }
        return_closcall1(data, k, thd->exception_handler_stack); ")

  ;; Simplified versions of every/any from SRFI-1
  (define (any pred lst)
    (let any* ((l (map pred lst)))
        (cond
          ((null? l) #f) ; Empty list
          ((car l)   #t) ; Done
          (else 
             (any* (cdr l))))))
  (define (every pred lst)
    (let every* ((l (map pred lst)))
        (cond
          ((null? l) #t) ; Empty list
          ((car l)
             (every* (cdr l)))
          (else 
             #f))))

  (define-c floor
    "(void *data, int argc, closure _, object k, object z)"
    " return_exact_double_op(data, k, floor, z); ")
  (define-c ceiling
    "(void *data, int argc, closure _, object k, object z)"
    " return_exact_double_op(data, k, ceil, z); ")
  (define-c truncate
    "(void *data, int argc, closure _, object k, object z)"
    " return_exact_double_op(data, k, (int), z); ")
  (define-c round
    "(void *data, int argc, closure _, object k, object z)"
    " return_exact_double_op(data, k, round, z); ")
  (define exact truncate)
  (define-c inexact
    "(void *data, int argc, closure _, object k, object z)"
    " return_inexact_double_op(data, k, (double), z); ")
  (define-c abs
    "(void *data, int argc, closure _, object k, object num)"
    " Cyc_check_num(data, num);
      if (obj_is_int(num)) {
        return_closcall1(data, k, obj_int2obj( abs( obj_obj2int(num))));
      } else {
        make_double(d, fabs(((double_type *)num)->value));
        return_closcall1(data, k, &d);
      } ")
  ;; Apparently C % is actually the remainder, not modulus
  (define-c remainder
    "(void *data, int argc, closure _, object k, object num1, object num2)"
    " int i, j;
      Cyc_check_num(data, num1);
      Cyc_check_num(data, num2);
      if (obj_is_int(num1)) {
        i = obj_obj2int(num1);
      } else /* Must be double: if (type_of(num1) == double_tag)*/ { 
        i = ((double_type *)num1)->value; 
      }
      if (obj_is_int(num2)) {
        j = obj_obj2int(num2);
      } else /* Must be double: if (type_of(num2) == double_tag)*/ { 
        j = ((double_type *)num2)->value; 
      }
      {
        object result = obj_int2obj(i % j);
        return_closcall1(data, k, result); 
      }")
  ;; From chibi scheme. Cannot use C % operator
  (define (modulo a b)
    (let ((res (remainder a b)))
      (if (< b 0)
        (if (<= res 0) res (+ res b))
        (if (>= res 0) res (+ res b)))))
  (define (odd? num)   (= (modulo num 2) 1))
  (define (even? num)  (= (modulo num 2) 0))
  ;; from mosh
  (define (exact-integer-sqrt k)
    (unless (and (exact? k)
                 (integer? k)
                 (not (negative? k)))
      (error "exact non-negative integer required" k))
    (let* ((s (exact (truncate (sqrt k))))
           (r (- k (* s s))))
      (values s r)))
  (define-c sqrt
    "(void *data, int argc, closure _, object k, object z)"
    " return_inexact_double_op(data, k, sqrt, z);")
  (define (exact-integer? num)
    (and (exact? num) (integer? num)))
  (define-c exact?
    "(void *data, int argc, closure _, object k, object num)"
    " Cyc_check_num(data, num);
      if (obj_is_int(num) || type_of(num) == integer_tag)
        return_closcall1(data, k, boolean_t);
      return_closcall1(data, k, boolean_f); ")
  (define (inexact? num) (not (exact? num)))
  (define complex? number?) 
  (define rational? number?)
  (define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))
  (define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))
  ; Implementations of gcd and lcm using Euclid's algorithm
  ;
  ; Also note that each form is written to accept either 0 or
  ; 2 arguments, per R5RS. This could probably be generalized
  ; even further, if necessary.
  ;
  (define gcd gcd/entry)
  (define lcm lcm/entry)
  ; Main GCD algorithm
  (define (gcd/main a b)
    (if (= b 0)
      (abs a)
      (gcd/main b (modulo a b))))

  ; A helper function to reduce the input list
  (define (gcd/entry . nums)
    (if (eqv? nums '())
      0
      (foldl gcd/main (car nums) (cdr nums))))

  ; Main LCM algorithm
  (define (lcm/main a b)
    (abs (/ (* a b) (gcd/main a b))))

  ; A helper function to reduce the input list
  (define (lcm/entry . nums)
    (if (eqv? nums '())
      1
      (foldl lcm/main (car nums) (cdr nums))))
  ;; END gcd lcm

  ;; Placeholders
  (define (denominator n) 1)
  (define (numerator n) n)

  (define (quotient x y)
    (truncate (/ x y)))

  (define truncate-quotient quotient)
  (define truncate-remainder remainder)
  (define (truncate/ n m)
    (values (truncate-quotient n m) (truncate-remainder n m)))
  
  (define (floor-quotient n m)
    (let ((res (floor (/ n m))))
      (if (and (exact? n) (exact? m))
          (exact res)
          res)))
  (define (floor-remainder n m)
    (- n (* m (floor-quotient n m))))
  (define (floor/ n m)
    (values (floor-quotient n m) (floor-remainder n m)))
  (define (square z) (* z z))
  (define-c expt
    "(void *data, int argc, closure _, object k, object z1, object z2)"
    " make_double(d, 0.0);
      Cyc_check_num(data, z1);
      Cyc_check_num(data, z2);
      d.value = pow( unbox_number(z1), unbox_number(z2) );
      return_closcall1(data, k, &d); ")
  (define-c eof-object
    "(void *data, int argc, closure _, object k)"
    " return_closcall1(data, k, Cyc_EOF); ")
  (define-c input-port?
    "(void *data, int argc, closure _, object k, object port)"
    " port_type *p = (port_type *)port;
      Cyc_check_port(data, port);
      return_closcall1(
        data, 
        k, 
       ((p->mode == 1) ? boolean_t : boolean_f)); ")
  (define-c output-port?
    "(void *data, int argc, closure _, object k, object port)"
    " port_type *p = (port_type *)port;
      Cyc_check_port(data, port);
      return_closcall1(
        data, 
        k, 
       ((p->mode == 0) ? boolean_t : boolean_f)); ")
  (define-c input-port-open?
    "(void *data, int argc, closure _, object k, object port)"
    " port_type *p = (port_type *)port;
      Cyc_check_port(data, port);
      return_closcall1(
        data, 
        k, 
       ((p->mode == 1 && p->fp != NULL) ? boolean_t : boolean_f)); ")
  (define-c output-port-open?
    "(void *data, int argc, closure _, object k, object port)"
    " port_type *p = (port_type *)port;
      Cyc_check_port(data, port);
      return_closcall1(
        data, 
        k, 
       ((p->mode == 0 && p->fp != NULL) ? boolean_t : boolean_f)); ")
  (define-c open-input-string
    "(void *data, int argc, closure _, object k, object str)"
    " port_type *p = Cyc_io_open_input_string(data, str);
      return_closcall1(data, k, p); ")
  (define-c open-output-string
    "(void *data, int argc, closure _, object k)"
    " port_type *p = Cyc_io_open_output_string(data);
      return_closcall1(data, k, p); ")
  (define-c get-output-string
    "(void *data, int argc, closure _, object k, object port)"
    " Cyc_io_get_output_string(data, k, port);
    ")
  (define-c get-output-bytevector
    "(void *data, int argc, closure _, object k, object port)"
    " Cyc_io_get_output_bytevector(data, k, port);
    ")
  (define-c open-input-bytevector
    "(void *data, int argc, closure _, object k, object bv)"
    " port_type *p = Cyc_io_open_input_bytevector(data, bv);
      return_closcall1(data, k, p); ")
  (define open-output-bytevector open-output-string)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax-rules
(define identifier? symbol?)
(define (identifier->symbol obj) obj)
(define (find-tail pred ls)
  (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))

(define (find pred ls)
  (cond ((find-tail pred ls) => car) (else #f)))
(define (cons-source kar kdr source)
  (cons kar kdr))

(define-syntax syntax-rules
  (er-macro-transformer
   (lambda (expr rename compare)
;(Cyc-write `(syntax-rules expand ,expr) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
     (let ((ellipsis-specified? (identifier? (cadr expr)))
           (count 0)
           (_er-macro-transformer (rename 'er-macro-transformer))
           (_lambda (rename 'lambda))      (_let (rename 'let))
           (_begin (rename 'begin))        (_if (rename 'if))
           (_and (rename 'and))            (_or (rename 'or))
           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
           (_car (rename 'car))            (_cdr (rename 'cdr))
           (_cons (rename 'cons))          (_pair? (rename 'pair?))
           (_null? (rename 'null?))        (_expr (rename 'expr))
           (_rename (rename 'rename))      (_compare (rename 'compare))
           (_quote (rename 'quote)) (_apply (rename 'apply))
           ;(_quote (rename 'syntax-quote)) (_apply (rename 'apply))
           (_append (rename 'append))      (_map (rename 'map))
           (_vector? (rename 'vector?))    (_list? (rename 'list?))
           (_len (rename'len))             (_length (rename 'length))
           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
           (_reverse (rename 'reverse))
           (_vector->list (rename 'vector->list))
           (_list->vector (rename 'list->vector))
           (_cons3 (rename 'cons-source)))
       (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
       (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
       (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
       (define (next-symbol s)
         (set! count (+ count 1))
         (rename (string->symbol (string-append s (number->string count)))))
       (define (expand-pattern pat tmpl)
         (let lp ((p (cdr pat))
                  (x (list _cdr _expr))
                  (dim 0)
                  (vars '())
                  (k (lambda (vars)
                       (list _cons (expand-template tmpl vars) #f))))
;(Cyc-write (list 'PATTERN p 'vars vars) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
           (let ((v (next-symbol "v.")))
             (list
              _let (list (list v x))
              (cond
               ((identifier? p)
                (if (any (lambda (l) (compare p l)) lits)
                    (list _and
                          (list _compare v (list _rename (list _quote p)))
                          (k vars))
                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
               ((ellipsis? p)
                (cond
                 ((not (null? (cdr (cdr p))))
                  (cond
                   ((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
                         (cddr p))
                    (error "multiple ellipses" p))
                   (else
                    (let ((len (length (cdr (cdr p))))
                          (_lp (next-symbol "lp.")))
                      `(,_let ((,_len (,_length ,v)))
                         (,_and (,_>= ,_len ,len)
                                (,_let ,_lp ((,_ls ,v)
                                             (,_i (,_- ,_len ,len))
                                             (,_res (,_quote ())))
                                  (,_if (,_>= 0 ,_i)
                                      ,(lp `(,(cddr p) 
                                             (,(car p) ,(car (cdr p))))
                                           `(,_cons ,_ls
                                                    (,_cons (,_reverse ,_res)
                                                            (,_quote ())))
                                           dim
                                           vars
                                           k)
                                      (,_lp (,_cdr ,_ls)
                                            (,_- ,_i 1)
                                            (,_cons3 (,_car ,_ls)
                                                     ,_res
                                                     ,_ls))))))))))
                 ((identifier? (car p))
                  (list _and (list _list? v)
                        (list _let (list (list (car p) v))
                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
                 (else
                  (let* ((w (next-symbol "w."))
                         (_lp (next-symbol "lp."))
                         (new-vars (all-vars (car p) (+ dim 1)))
                         (ls-vars (map (lambda (x)
                                         (next-symbol
                                          (string-append
                                           (symbol->string
                                            (identifier->symbol (car x)))
                                           "-ls")))
                                       new-vars))
                         (once
                          (lp (car p) (list _car w) (+ dim 1) '()
                              (lambda (_)
                                (cons
                                 _lp
                                 (cons
                                  (list _cdr w)
                                  (map (lambda (x l)
                                         (list _cons (car x) l))
                                       new-vars
                                       ls-vars)))))))
                    (list
                     _let
                     _lp (cons (list w v)
                               (map (lambda (x) (list x (list _quote '()))) ls-vars))
                     (list _if (list _null? w)
                           (list _let (map (lambda (x l)
                                             (list (car x) (list _reverse l)))
                                           new-vars
                                           ls-vars)
                                 (k (append new-vars vars)))
                           (list _and (list _pair? w) once)))))))
               ((pair? p)
                (list _and (list _pair? v)
                      (lp (car p)
                          (list _car v)
                          dim
                          vars
                          (lambda (vars)
                            (lp (cdr p) (list _cdr v) dim vars k)))))
               ((vector? p)
                (list _and
                      (list _vector? v)
                      (lp (vector->list p) (list _vector->list v) dim vars k)))
               ((null? p) (list _and (list _null? v) (k vars)))
               (else (list _and (list _equal? v p) (k vars))))))))
       (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
       (define (ellipsis? x)
         (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
       (define (ellipsis-depth x)
         (if (ellipsis? x)
             (+ 1 (ellipsis-depth (cdr x)))
             0))
       (define (ellipsis-tail x)
         (if (ellipsis? x)
             (ellipsis-tail (cdr x))
             (cdr x)))
       (define (all-vars x dim)
         (let lp ((x x) (dim dim) (vars '()))
           (cond ((identifier? x)
                  (if (any (lambda (lit) (compare x lit)) lits)
                      vars
                      (cons (cons x dim) vars)))
                 ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
                 ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
                 ((vector? x) (lp (vector->list x) dim vars))
                 (else vars))))
       (define (free-vars x vars dim)
         (let lp ((x x) (free '()))
           (cond
            ((identifier? x)
             (if (and (not (memq x free))
                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
                            (else #f)))
                 (cons x free)
                 free))
            ((pair? x) (lp (car x) (lp (cdr x) free)))
            ((vector? x) (lp (vector->list x) free))
            (else free))))
       (define (expand-template tmpl vars)
         (let lp ((t tmpl) (dim 0))
;(Cyc-write (list 't t) (current-output-port))
;(Cyc-display "\n" (current-output-port))
;(Cyc-write (list 'vars vars 'TMPL tmpl ) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
           (cond
            ((identifier? t)
;(Cyc-write (list 't t 'vars vars) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
             (cond
              ((find (lambda (v) (eq? t (car v))) vars)
               => (lambda (cell)
                    (if (<= (cdr cell) dim)
                        t
                        (error "too few ...'s"))))
              (else
               (list _rename (list _quote t)))))
            ((pair? t)
             (cond
              ((ellipsis-escape? t)
               (list _quote
                     (if (pair? (cdr t))
                         (if (pair? (cddr t)) (cddr t) (cadr t))
                         (cdr t))))
              ((ellipsis? t)
               (let* ((depth (ellipsis-depth t))
                      (ell-dim (+ dim depth))
                      (ell-vars (free-vars (car t) vars ell-dim)))
                 (cond
                  ((null? ell-vars)
                   (error "too many ...'s"))
                  ((and (null? (cdr (cdr t))) (identifier? (car t)))
                   ;; shortcut for (var ...)
                   (lp (car t) ell-dim))
                  (else
                   (let* ((once (lp (car t) ell-dim))
                          (nest (if (and (null? (cdr ell-vars))
                                         (identifier? once)
                                         (eq? once (car vars)))
                                    once ;; shortcut
                                    (cons _map
                                          (cons (list _lambda ell-vars once)
                                                ell-vars))))
                          (many (do ((d depth (- d 1))
                                     (many nest
                                           (list _apply _append many)))
                                    ((= d 1) many))))
                     (if (null? (ellipsis-tail t))
                         many ;; shortcut
                         (list _append many (lp (ellipsis-tail t) dim))))))))
              (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
            ((null? t) (list _quote '()))
            (else t))))
       (list
        _er-macro-transformer
        (list _lambda (list _expr _rename _compare)
;(Cyc-write `(syntax-rules expand ,_expr) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
;(list 'Cyc-write (list 'syntax-rules 'expand _expr) (list 'current-output-port))
;(list 'Cyc-display "\n"  (list 'current-output-port))
              (list
               _car
               (cons
                _or
                (append
                 (map
                  (lambda (clause) (expand-pattern (car clause) (cadr clause)))
                  forms)
                 (list
                  (list _cons
                        (list _error "no expansion for"
                             _expr ; (list (rename 'strip-syntactic-closures) _expr)
                              )
                        #f)))))))))))

(define-syntax letrec*
  (syntax-rules ()
    ((letrec* ((var val) ...) . body)
     (let () (define var val) ... . body))))

(define-syntax let*-values
  (syntax-rules ()
    ((let*-values () . body)
     (begin . body))
    ((let*-values (((a) expr) . rest) . body)
     (let ((a expr)) (let*-values rest . body)))
    ((let*-values ((params expr) . rest) . body)
     (call-with-values (lambda () expr)
       (lambda params (let*-values rest . body))))))

#;(define-syntax let-values
  (syntax-rules ()
    ((let-values ("step") (binds ...) bind expr maps () () . body)
     (let*-values (binds ... (bind expr)) (let maps . body)))
    ((let-values ("step") (binds ...) bind old-expr maps () ((params expr) . rest) . body)
     (let-values ("step") (binds ... (bind old-expr)) () expr maps params rest . body))
    ((let-values ("step") binds (bind ...) expr (maps ...) (x . y) rest . body)
     (let-values ("step") binds (bind ... tmp) expr (maps ... (x tmp)) y rest . body))
    ((let-values ("step") binds (bind ...) expr (maps ...) x rest . body)
     (let-values ("step") binds (bind ... . tmp) expr (maps ... (x tmp)) () rest . body))
    ((let-values ((params expr) . rest) . body)
     (let-values ("step") () () expr () params rest . body))
    ))

(define-syntax
  let-values
  (syntax-rules
    ()
    ((let-values (binding ...) body0 body1 ...)
     (let-values
       "bind"
       (binding ...)
       ()
       ((lambda () body0 body1 ...))))
       ;(begin body0 body1 ...)))
    ((let-values "bind" () tmps body)
     (let tmps body))
    ((let-values
       "bind"
       ((b0 e0) binding ...)
       tmps
       body)
     (let-values
       "mktmp"
       b0
       e0
       ()
       (binding ...)
       tmps
       body))
    ((let-values
       "mktmp"
       ()
       e0
       args
       bindings
       tmps
       body)
     (call-with-values
       (lambda () e0)
       (lambda args
         (let-values "bind" bindings tmps body))))
    ((let-values
       "mktmp"
       (a . b)
       e0
       (arg ...)
       bindings
       (tmp ...)
       body)
     (let-values
       "mktmp"
       b
       e0
       (arg ... x)
       bindings
       (tmp ... (a x))
       body))
    ((let-values
       "mktmp"
       a
       e0
       (arg ...)
       bindings
       (tmp ...)
       body)
     (call-with-values
       (lambda () e0)
       ;(lambda (arg ... x)
       (lambda (arg ... . x)
         (let-values "bind" bindings (tmp ... (a x)) body))))))

(define-syntax guard
  (syntax-rules ()
    ((guard (var clause ...) e1 e2 ...)
     ((call-with-current-continuation
       (lambda (guard-k)
         (with-exception-handler
          (lambda (condition)
            ((call-with-current-continuation
              (lambda (handler-k)
                (guard-k
                 (lambda ()
                   (let ((var condition))      ; clauses may SET! var
                     (guard-aux (handler-k (lambda ()
                                             (raise-continuable condition)))
                                clause ...))))))))
          (lambda ()
            (let ((res (begin e1 e2 ...)))
              (guard-k (lambda () res)))))))))))

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

;; Record-type definitions
(define record-marker (list 'record-marker))
(define (register-simple-type name parent field-tags)
  (let ((new (make-vector 3 #f)))
    (vector-set! new 0 record-marker)
    (vector-set! new 1 name)
    (vector-set! new 2 field-tags)
    new))
(define (make-type-predicate pred name)
  (lambda (obj)
    (and (vector? obj)
         (equal? (vector-ref obj 0) record-marker)
         (equal? (vector-ref obj 1) name))))
(define (make-constructor make name)
  (lambda ()
    (let* ((field-tags (vector-ref name 2))
           (field-values (make-vector (length field-tags) #f))
           (new (make-vector 3 #f))
          )
      (vector-set! new 0 record-marker)
      (vector-set! new 1 name)
      (vector-set! new 2 field-values)
      new)))
(define (type-slot-offset name sym)
  (let ((field-tags (vector-ref name 2)))
    (_list-index sym field-tags)))
(define (slot-set! name obj idx val)
  (let ((vec obj)) ;; TODO: get actual slots from obj
    (vector-set! (vector-ref vec 2) idx val)))
(define (make-getter sym name idx)
  (lambda (obj)
    (vector-ref (vector-ref obj 2) idx)))
(define (make-setter sym name idx)
  (lambda (obj val)
    (vector-set! (vector-ref obj 2) idx val)))

;; Find index of element in list, or -1 if not found
(define _list-index
  (lambda (e lst)
    (if (null? lst)
      -1
      (if (eq? (car lst) e)
        0
        (if (= (_list-index e (cdr lst)) -1) 
          -1
          (+ 1 (_list-index e (cdr lst))))))))

(define (record? obj)
  (and (vector? obj)
       (> (vector-length obj) 0)
       (equal? record-marker (vector-ref obj 0))))

(define-syntax define-record-type
  (er-macro-transformer
   (lambda (expr rename compare)
     (let* ((name+parent (cadr expr))
            (name (if (pair? name+parent) (car name+parent) name+parent))
            (parent (and (pair? name+parent) (cadr name+parent)))
            (name-str (symbol->string name)) ;(identifier->symbol name)))
            (procs (cddr expr))
            (make (caar procs))
            (make-fields (cdar procs))
            (pred (cadr procs))
            (fields (cddr procs))
            (_define (rename 'define))
            (_lambda (rename 'lambda))
            (_let (rename 'let))
            (_register (rename 'register-simple-type))
            (_slot-set! (rename 'slot-set!))
            (_type_slot_offset (rename 'type-slot-offset)))
       ;; catch a common mistake
       (if (eq? name make)
           (error "same binding for record rtd and constructor" name))
       `(,(rename 'begin)
         ;; type
         (,_define ,name (,_register 
                          ,name ;,name-str 
                          ,parent 
                          ',(map car fields)))
         ;; predicate
         (,_define ,pred (,(rename 'make-type-predicate)
                          ,pred ;(symbol->string pred) ;(identifier->symbol pred))
                          ,name))
         ;; fields
         ,@(map (lambda (f)
                  (and (pair? f) (pair? (cdr f))
                       `(,_define ,(cadr f)
                          (,(rename 'make-getter)
                           ,(symbol->string
                             (cadr f)
                             ;(identifier->symbol (cadr f))
                            )
                           ,name
                           (,_type_slot_offset ,name ',(car f))))))
                fields)
         ,@(map (lambda (f)
                  (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
                       `(,_define ,(car (cddr f))
                          (,(rename 'make-setter)
                           ,(symbol->string
                             (car (cddr f))
                             ;(identifier->symbol (car (cddr f)))
                            )
                           ,name
                           (,_type_slot_offset ,name ',(car f))))))
                fields)
         ;; constructor
         (,_define ,make
           ,(let lp ((ls make-fields) (sets '()))
              (cond
               ((null? ls)
                `(,_let ((%make (,(rename 'make-constructor)
                                 ,(symbol->string make) ;(identifier->symbol make))
                                 ,name)))
                   (,_lambda ,make-fields
                     (,_let ((res (%make)))
                       ,@sets
                       res))))
               (else
                (let ((field (assq (car ls) fields)))
                  (cond
                   ((not field)
                    (error "unknown record field in constructor" (car ls)))
                   ((pair? (cddr field))
                    (lp (cdr ls)
                        (cons `(,(car (cddr field)) res ,(car ls)) sets)))
                   (else
                    (lp (cdr ls)
                        (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
                              sets)))))))))
  )))))
))