;; typecheck-fns.lsp - functions to support regression testing
;;   of examples that would normally raise errors. This redefines
;;   error handling to check for proper error reporting rather than
;;   actually raising an error

(setf *skip-command* nil)

(setfn original-error error)

;; This implementation allows up to one occurrence of "#<>" to match
;; "#<*>". The algorithm is split the pattern into 2 strings: "*#<"
;; and ">*". Then see if msg has these strings as prefix and suffix.
;;
;; This code tolerates additional text in msg after the expected pattern.
;;
(defun matching-error-message (msg pattern)
  (prog (prefix suffix prefix-len suffix-loc)
    (setf prefix-len (string-search "#<" pattern))
    (cond ((null prefix-len)
           (return nil)))
    (setf prefix (subseq pattern 0 prefix-len))
    (setf suffix (subseq pattern (+ 2 prefix-len)))
    (display "mem" prefix suffix msg)
    (cond ((/= 0 (string-search ">" suffix))
           (return nil))
          ((/= 0 (string-search prefix msg))
           (return nil)))
    (setf suffix-loc (string-search suffix msg))
    (return (and (not (null suffix-loc))
                 (< (length prefix) suffix-loc)))))

;; Calls to error are redirected here. The expected error message is in
;; *expect-error*, but if *expect-error* contains "#<>", it should match
;; anything (like a sound) of the form "#<Sound: #104040310>"
;;
(defun error (msg &optional value)
  (cond ((or (equal msg *expect-error*)
             (matching-error-message msg *expect-error*)))
        (t (original-error "unexpected value to error" (list msg value))))
  (setf *expect-error* nil
        *skip-command* t)
  (throw 'simulated-error))
     
(setfn original-nyerror ny:error)

(defun ny:error (src index typ val &optional multi (val2 nil second-val))
  ; (display "ny:error" src index typ val multi val2 second-val)
  (cond ((and (equal src (car *expect-nyerror*)))
              (equal index (cadr *expect-nyerror*))
              (equal typ (caddr *expect-nyerror*))
              (equal typ (cadddr *expect-nyerror*)))
         (t (original-error "unexpected call to ny:error")))
  (setf *expect-nyerror* nil
        *skip-command* t)
  (throw 'simulated-error))


(setfn original-sal-print sal-print)

(defun sal-print (&rest args)
  (cond (*skip-command* (setf *skip-command* nil))
        ; use sal-equal so that when 2.0 is printed as 2 and we read it
        ; back as an integer, we get (sal-equal 2 2.0) which is different
        ; from (equal 2 2.0) because that test is false!
        ((and (= (length args) 1) (sal-equal (car args) *expect-print*)))
        (t (original-error "unexpected value to print")))
  (setf *expect-print* nil))

(setfn original-plot s-plot)

(defun s-plot (s)
  (cond (*skip-command* (setf *skip-command* nil))
        (*expect-plot*)
        (t (original-error "unexpected call to plot")))
  (setf *expect-plot* nil))


(setf *expect-print* nil *expect-plot* nil 
      *expect-error* nil *expect-nyerror* nil)

;; this function says what the "unit test" is supposed to do.
;; what can be :print :plot :nyerror or :error
;;
(defun ny:expect (expression what val)
  (cond ((or *expect-print* *expect-plot* *expect-error* *expect-nyerror*)
         (original-error "expected result did not happen")))
  (setf *expect-print* nil *expect-plot* nil 
        *expect-error* nil *expect-nyerror* nil)
  (cond ((eq what :print)
         (setf *expect-print* val))
        ((eq what :plot)
         (setf *expect-plot* val))
        ((eq what :error)
         (setf *expect-error* val))
        ((eq what :nyerror)
         (setf *expect-nyerror* val))))
