n-violation
                             'string-for-each
                             "string arguments must all have the same length"
                             string strings)))
                  ends)
        (let loop ((i 0))
          (unless (= i end)
            (apply proc
                   (string-ref string i)
                   (map (lambda (s) (string-ref s i)) strings))
            (loop (+ i 1))))))))

 (define map
   (case-lambda
     ((f l)
      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
        (if (pair? hare)
            (if move?
                (if (eq? tortoise hare)
                    (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                               (list l) #f)
                    (map1 (cdr hare) (cdr tortoise) #f
                          (cons (f (car hare)) out)))
                (map1 (cdr hare) tortoise #t
                      (cons (f (car hare)) out)))
            (if (null? hare)
                (reverse out)
                (scm-error 'wrong-type-arg "map" "Not a list: ~S"
                           (list l) #f)))))
    
     ((f l1 l2)
      (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
        (cond
         ((pair? h1)
          (cond
           ((not (pair? h2))
            (scm-error 'wrong-type-arg "map"
                       (if (list? h2)
                           "List of wrong length: ~S"
                           "Not a list: ~S")
                       (list l2) #f))
           ((not move?)
            (map2 (cdr h1) (cdr h2) t1 t2 #t
                  (cons (f (car h1) (car h2)) out)))
           ((eq? t1 h1)
            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                       (list l1) #f))
           ((eq? t2 h2)
            (scm-error 'wrong-type-arg "map" "Circular list: ~S"
                       (list l2) #f))
           (else
            (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
                  (cons (f (car h1) (car h2)) out)))))

         ((and (null? h1) (null? h2))
          (reverse out))
        
         ((null? h1)
          (scm-error 'wrong-type-arg "map"
                     (if (list? h2)
                         "List of wrong length: ~S"
                         "Not a list: ~S")
                     (list l2) #f))
         (else
          (scm-error 'wrong-type-arg "map"
                     "Not a list: ~S"
                     (list l1) #f)))))

     ((f l1 . rest)
      (let ((len (length l1)))
        (let mapn ((rest rest))
          (or (null? rest)
              (if (= (length (car rest)) len)
                  (mapn (cdr rest))
                  (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
                             (list (car rest)) #f)))))
      (let mapn ((l1 l1) (rest rest) (out '()))
        (if (null? l1)
            (reverse out)
            (mapn (cdr l1) (map cdr rest)
                  (cons (apply f (car l1) (map car rest)) out)))))))

 (define log
   (case-lambda
     ((n)
      (log-internal n))
     ((n base)
      (/ (log n)
         (log base)))))

 (define (boolean=? . bools)
   (define (boolean=?-internal lst last)
     (or (null? lst)
         (let ((bool (car lst))) 
           (and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
   (or (null? bools)
       (let ((bool (car bools)))
         (and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))

 (define (symbol=? . syms)
   (define (symbol=?-internal lst last)
     (or (null? lst)
         (let ((sym (car lst))) 
           (and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
   (or (null? syms)
       (let ((sym (car syms)))
         (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))

 (define (real-valued? x)
   (and (complex? x)
        (zero? (imag-part x))))

 (define (rational-valued? x)
   (and (real-valued? x)
        (rational? (real-part x))))

 (define (integer-valued? x)
   (and (rational-valued? x)
        (= x (floor (real-part x)))))

 ;; Auxiliary procedure for vector-map and vector-for-each
 (define (vector-lengths who vs)
   (let ((lengths (map vector-length vs)))
     (unless (apply = lengths)
       (error (string-append (symbol->string who)
                             ": Vectors of uneven length.")
              vs))
     (car lengths)))

 (define vector-map
   (case-lambda
     "(vector-map f vec2 vec2 ...) -> vector

Return a new vector of the size of the vector arguments, which must be
of equal length. Each element at index @var{i} of the new vector is
mapped from the old vectors by @code{(f (vector-ref vec1 i)
(vector-ref vec2 i) ...)}.  The dynamic order of application of
@var{f} is unspecified."
     ((f v)
      (let* ((len (vector-length v))
             (result (make-vector len)))
        (let loop ((i 0))
          (unless (= i len)
            (vector-set! result i (f (vector-ref v i)))
            (loop (+ i 1))))
        result))
     ((f v1 v2)
      (let* ((len (vector-lengths 'vector-map (list v1 v2)))
             (result (make-vector len)))
        (let loop ((i 0))
          (unless (= i len)
            (vector-set! result
                         i
                         (f (vector-ref v1 i) (vector-ref v2 i)))
            (loop (+ i 1)))
          result)))
     ((f v . vs)
      (let* ((vs (cons v vs))
             (len (vector-lengths 'vector-map vs))
             (result (make-vector len)))
        (let loop ((i 0))
          (unless (= i len)
            (vector-set! result
                         i
                         (apply f (map (lambda (v) (vector-ref v i)) vs)))
            (loop (+ i 1))))
        result))))

(define vector-for-each
  (case-lambda
    "(vector-for-each f vec1 vec2 ...) -> unspecified

Call @code{(f (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each index
 in the provided vectors, which have to be of equal length. The iteration
is strictly left-to-right."
    ((f v)
     (let ((len (vector-length v)))
       (let loop ((i 0))
         (unless (= i len)
           (f (vector-ref v i))
           (loop (+ i 1))))))
    ((f v1 v2)
     (let ((len (vector-lengths 'vector-for-each (list v1 v2))))
       (let loop ((i 0))
         (unless (= i len)
           (f (vector-ref v1 i) (vector-ref v2 i))
           (loop (+ i 1))))))
    ((f v . vs)
     (let* ((vs (cons v vs))
            (len (vector-lengths 'vector-for-each vs)))
       (let loop ((i 0))
         (unless (= i len)
           (apply f (map (lambda (v) (vector-ref v i)) vs))
           (loop (+ i 1))))))))


 (define-syntax define-proxy
   (syntax-rules (@)
     ;; Define BINDING to point to (@ MODULE ORIGINAL).  This hack is to
     ;; make sure MODULE is loaded lazily, at run-time, when BINDING is
     ;; encountered, rather than being loaded while compiling and
     ;; loading (rnrs base).
     ;; This avoids circular dependencies among modules and makes
     ;; (rnrs base) more lightweight.
     ((_ binding (@ module original))
      (define-syntax binding
        (identifier-syntax
         (module-ref (resolve-interface 'module) 'original))))))

 (define-proxy raise
   (@ (rnrs exceptions) raise))

 (define-proxy condition
   (@ (rnrs conditions) condition))
 (define-proxy make-error
   (@ (rnrs conditions) make-error))
 (define-proxy make-assertion-violation
   (@ (rnrs conditions) make-assertion-violation))
 (define-proxy make-who-condition
   (@ (rnrs conditions) make-who-condition))
 (define-proxy make-message-condition
   (@ (rnrs conditions) make-message-condition))
 (define-proxy make-irritants-condition
   (@ (rnrs conditions) make-irritants-condition))

 (define (error who message . irritants)
   (raise (apply condition
                 (append (list (make-error))
                         (if who (list (make-who-condition who)) '())
                         (list (make-message-condition message)
                               (make-irritants-condition irritants))))))
 
 (define (assertion-violation who message . irritants)
   (raise (apply condition
                 (append (list (make-assertion-violation))
                         (if who (list (make-who-condition who)) '())
                         (list (make-message-condition message)
                               (make-irritants-condition irritants))))))

 (define-syntax assert
   (syntax-rules ()
     ((_ expression)
      (or expression
          (raise (condition
                  (make-assertion-violation)
                  (make-message-condition
                   (format #f "assertion failed: ~s" 'expression))))))))

)
