;; This file defines the error procedure assumed by the textbook
;; Concrete Abstractions: An Introduction to Computer Science Using Scheme
;; by Max Hailperin, Barbara Kaiser, and Karl Knight.
;;
;; This version is specifically for use with Chez Scheme version 6.0.
;;
;; Chez Scheme already has an error procedure, but it takes different arguments
;; from the ones assumed in the textbook.  Therefore, we redefine it here in
;; such a way that it can be used *either* as shown in the textbook, or as
;; shown in the Chez Scheme documentation.
;;
;; This file written by Max Hailperin <max@gustavus.edu>.
;;
;; Revision 1.1 as of 1999/06/15 22:03:11

(define error
  ;; protect against repeated loading
  (if (top-level-bound? '*concabs-error-loaded*)
      error
      (let ((chez-scheme-error error))
        (define format-string
          (lambda (objs)
            (cond ((null? objs) "")
                  ((null? (cdr objs)) "~s")
                  (else (string-append "~s " (format-string (cdr objs)))))))
        (define concabs-error
          (lambda (msg . objs)
            (apply chez-scheme-error "scheme code"
                   (string-append "~a: " (format-string objs))
                   msg objs)))
        (define place-holders
          (lambda (fmt-string)
            (define loop
              (lambda (i count)
                (if (>= i (string-length fmt-string))
                    count
                    (loop (+ i 1)
                          (if (and (eqv? (string-ref fmt-string i) #\~)
                                   (memv (string-ref fmt-string (+ i 1))
                                         '(#\a #\s)))
                              (+ count 1)
                              count)))))
            (loop 0 0)))
        (lambda (arg1 . other-args)
          (cond ((null? other-args) (concabs-error arg1))
                ((not (string? (car other-args)))
                 (apply concabs-error arg1 other-args))
                ((not (string? arg1))
                 (apply chez-scheme-error arg1 other-args))
                ((= (place-holders (car other-args))
                    (length (cdr other-args)))
                 (apply chez-scheme-error arg1 other-args))
                (else
                 (apply concabs-error arg1 other-args)))))))

(define *concabs-error-loaded* #t)