[ < ] [ > ]   [ << ] [ Up ] [ >> ]         [Top] [Contents] [Index] [ ? ]

10. Dateieingabe und -ausgabe

 
(defmvar $file_search_lisp   '((mlist simp)))
(defmvar $file_search_maxima '((mlist simp)))
(defmvar $file_search_demo   '((mlist simp)))

(defmvar $file_search_tests
         '((mlist simp)
           "/home/dieter/Lisp/kMaxima/kmaxima/tests/###.{mac,mc}"))

(defmvar $testsuite_files nil)

(defparameter *maxima-testsdir* "/home/dieter/Lisp/kMaxima/kmaxima/tests")

;;; ----------------------------------------------------------------------------

(defun split-string (string bag &optional (start 0) &aux all pos v l)
  (declare (fixnum start) (type string string))
  (loop for i from start below (length string)
        do 
        (setq pos (position (setq v (aref string i)) bag))
        (setq start (+ start 1))
        (cond ((null pos) (push v all))
              (t (if all (loop-finish))))
        finally
        (if all
            (return-from split-string
              (cons (make-array (setq l (length all))
                                :fill-pointer l
                                :adjustable t
                                :initial-contents (nreverse all)
                                :element-type
                                ' #.(array-element-type "ab"))
                    (split-string string bag start))))))

(defun alter-pathname (pathname &rest options)
  (apply 'make-pathname :defaults (pathname pathname) options))

;;; ----------------------------------------------------------------------------

(defun list-variable-bindings (expr &optional str &aux tem)
  (loop for v in (cdr ($listofvars  expr))
    when (member v $values :test #'equal)
    collecting (setq tem `((mequal) ,v ,(meval* v)))
    and
    do (cond (str (format str ",")(mgrind tem str)))))

;;; ----------------------------------------------------------------------------

(defun $filename_merge (&rest file-specs)
  (when (or (null file-specs)
            (cddr file-specs))
    (wna-err '$filename_merge))
  (setq file-specs (mapcar #'macsyma-namestring-sub file-specs))
  (pathname (if (null (cdr file-specs))
                (car file-specs)
                (merge-pathnames (cadr file-specs) (car file-specs)))))

(defun macsyma-namestring-sub (user-object)
  (if (pathnamep user-object)
      user-object
      (let* ((system-object
              (cond ((and (atom user-object)
                          (not (symbolp user-object)))
                     user-object)
                    ((atom user-object)
                     (print-invert-case (fullstrip1 user-object)))
                    ((mlistp user-object)
                     (fullstrip (cdr user-object)))
                    (t
                     (merror "filename_merge: unexpected argument: ~A"
                             user-object))))
             (namestring-try (errset-namestring system-object)))
        (if namestring-try
            (car namestring-try)
            (merror "filename_merge: unexpected argument: ~:M"
                    user-object)))))

(defun errset-namestring (x)
  (let ((*errset* nil))
    (errset (pathname x) nil)))

;;; ----------------------------------------------------------------------------

(defun $file_search (name &optional paths)
  (if (and (symbolp name)
           (member (char (symbol-name name) 0) '(#\$) ))
      (setq name (subseq (print-invert-case name) 1)))
  (if (symbolp name)
      (setf name (string name)))
  (if (probe-file name)
      (return-from $file_search name))
  (unless paths
    (setq paths
          (cons '(mlist simp)
                (append (cdr $file_search_lisp)
                        (cdr $file_search_maxima)
                        (cdr $file_search_demo)))))
  (unless (mlistp paths)
    (merror "file_search: The argument `paths' must be a list."))
  (file-search (string name) (cdr paths)))

(defun file-search (name template)
  (cond ((probe-file name))
        ((and (not (null template))
              (atom template))
         (let ((lis (loop for w in (split-string template "{}")
                          when (null (position #\, w))
                          collect w
                          else
                          collect (split-string w ","))))
           (file-search1 name "" lis)))
        (t
         (let ((temp nil))
           (loop for v in template
                 when (setq temp (file-search name v))
                 do (return temp))))))

(defun file-search1 (name begin lis)
  (cond ((null lis)
         (let ((file (namestring ($filename_merge begin name))))
           (if (probe-file file) file nil)))
        ((atom (car lis))
         (file-search1 name
                           (if begin
                               (concatenate 'string begin (car lis))
                               (car lis))
                           (cdr lis)))
        (t
         (loop for v in (car lis) with tem
               when (setq tem
                          (file-search1 name begin (cons v (cdr lis))))
               do (return tem)))))

;;; ----------------------------------------------------------------------------

(defun lispify-maxima-keyword-options (options &optional valid-keywords)
  (unless (listp options)
    (merror "run_testsuite: Invalid Maxima keyword options: ~A" options))
  (when (every #'(lambda (o)
                   (let ((ok (and (listp o)
                                  (= (length o) 3)
                                  (eq (caar o) 'mequal))))
                     (unless ok
                       (merror
                         "run_testsuite: Badly formed keyword option: ~M"
                         o))
                     ok))
               options)
    (mapcan #'(lambda (o)
                (destructuring-bind (mequal opt val)
                    o
                  (declare (ignore mequal))
                  (if (or (null valid-keywords)
                          (member opt valid-keywords))
                      (flet ((keywordify (x)
                               (intern (subseq (symbol-name x) 1) :keyword)))
                        (list (keywordify opt) val))
                      (merror "run_testsuite: Unrecognized keyword: ~M"
                              opt))))
            options)))

(defun $run_testsuite (&rest options)
  (apply #'run-testsuite
         (lispify-maxima-keyword-options options
                                         '($display_all
                                           $display_known_bugs
                                           $tests $time))))

(defun run-testsuite (&key display_known_bugs display_all tests time)
  (declare (special $file_search_tests))
  (let ((test-file)
        (expected-failures))
    (unless (member display_known_bugs '(t nil))
      (merror "run_testsuite: display_known_bugs must be true or false;~
              found: ~A"
              display_known_bugs))
    (unless (member display_all  '(t nil))
      (merror "run_testsuite: display_all must be true or false; found: ~A"
              display_all))
    (unless (member time '(t nil $all))
      (merror "run_testsuite: time must be true, false, or all; found: ~M"
              time))
    (setq *collect-errors* nil)
    (unless $testsuite_files
      (load (concatenate 'string *maxima-testsdir* "/" "testsuite.lisp")))
    (let ((error-break-file)
          (testresult)
          (tests-to-run (intersect-tests tests))
          (test-count 0)
          (total-count 0)
          (error-count 0))
      (time
       (loop with errs = '() for testentry in tests-to-run
             do
             (if (atom testentry)
                 (progn
                   (setf test-file testentry)
                   (setf expected-failures nil))
                 (progn
                   (setf test-file (second testentry))
                   (setf expected-failures (cddr testentry))))
             (format t "Running tests in ~a: "
                       (if (symbolp test-file)
                           (subseq (print-invert-case test-file) 1)
                           test-file))
             (or (errset
                   (progn
                     (multiple-value-setq (testresult test-count)
                       (test-batch ($file_search test-file $file_search_tests)
                                   expected-failures
                                   :show-expected display_known_bugs
                                   :show-all display_all
                                   :showtime time))
                     (setf testresult (rest testresult))
                     (incf total-count test-count)
                     (when testresult
                       (incf error-count (length (cdr testresult)))
                       (setq errs (append errs (list testresult))))))
                 (progn
                   (setq error-break-file (format nil "~a" test-file))
                   (setq errs
                         (append errs
                                 (list (list error-break-file
                                             "error break"))))
                   (format t "~%Caused an error break: ~a~%" test-file)))
             finally
             (cond ((null errs)
                    (format t
                          "~%~%No unexpected errors found out of ~:D tests.~%"
                            total-count))
                   (t
                    (format t "~%Error summary:~%")
                    (mapcar #'(lambda (x)
                                (let ((s (if (> (length (rest x)) 1) "s" "")))
                                  (format t
                                       "Error~a found in ~a, problem~a:~%~a~%"
                                          s (first x) s (sort (rest x) #'<))))
                            errs)
                    (format t "~&~:D test~P failed out of ~:D total tests.~%"
                            error-count error-count total-count)))))))
  '$done)

(defun intersect-tests (tests)
  (flet ((remove-dollarsign (x)
           (if (symbolp x)
               (subseq (print-invert-case x) 1)
               x)))
    (mapcar #'remove-dollarsign
            (cond (tests
                   (let ((results nil))
                     (dolist (test (mapcar #'remove-dollarsign (cdr tests)))
                       (when (find test (cdr $testsuite_files)
                                   :key #'(lambda (x)
                                            (print-invert-case (if (listp x)
                                                                   (second x)
                                                                   x)))
                                   :test #'string= )
                         (push test results)))
                     (nreverse results)))
                  (t
                   (cdr $testsuite_files))))))

(defun test-batch (filename expected-errors
                            &key (out *standard-output*)
                                 (show-expected nil)
                                 (show-all nil) (showtime nil))
  (let ((result)
        (next-result)
        (next)
        (error-log)
        (all-differences nil)
        ($ratprint nil)
        (strm)
        (*mread-prompt* "")
        (expr)
        (num-problems 0)
        (tmp-output)
        (save-output)
        (i 0)
        (start-run-time 0) (end-run-time 0)
        (start-real-time 0) (end-real-time 0)
        (test-start-run-time 0) (test-end-run-time 0)
        (test-start-real-time 0) (test-end-real-time 0))
    (cond (*collect-errors*
           (setq error-log
                 (if (streamp *collect-errors*)
                     *collect-errors*
                     (handler-case
                       (open (alter-pathname filename :type "ERR")
                             :direction
                             :output
                             :if-exists
                             :supersede)
                       #-gcl (file-error () nil)
                       #+gcl (cl::error () nil))))
           (when error-log
             (format t "~%batch: write error log to ~a" error-log)
             (format error-log
                     "~%/* Maxima error log from tests in ~A"
                     filename)
             (format error-log " */~2%"))))
    (unwind-protect
      (progn
        (setq strm (open filename :direction :input))
        (setq start-real-time (get-internal-real-time))
        (setq start-run-time (get-internal-run-time))
        (while (not (eq 'eof (setq expr (mread strm 'eof))))
          (incf num-problems)
          (incf i)
          (setf tmp-output (make-string-output-stream))
          (setf save-output *standard-output*)
          (setf *standard-output* tmp-output)
          (unwind-protect
            (progn
              (setq test-start-run-time (get-internal-run-time))
              (setq test-start-real-time (get-internal-real-time))
              (setq result
                    (maxima-toplevel-eval `(($errcatch) ,(third expr))))
              (setq result (if (alike1 result '((mlist)))
                               'error-catch
                               (second result)))
              (setq test-end-run-time (get-internal-run-time))
              (setq test-end-real-time (get-internal-real-time))
              (setq $% result))
            (setf *standard-output* save-output))
          (setq next (mread strm 'eof))
          (if (eq next 'eof)
              (merror "batch: missing expected result in test script."))
          (setq next-result (third next))
          (let* ((correct (batch-equal-check next-result result))
                 (expected-error (member i expected-errors))
                 (pass (or correct expected-error)))
            (when (or show-all (not pass) (and correct expected-error)
                      (and expected-error show-expected))
              (format out
                      "~%********************** Problem ~A ***************"
                      i)
              (format out "~%Input:~%")
              (mdisplay (third expr))
              (format out "~%~%Result:~%")
              (format out "~a" (get-output-stream-string tmp-output))
              (mdisplay $%)
              (when (eq showtime '$all)
                (format out "~%Time:  ~,3F sec (~,3F elapsed)"
                        (float (/ (- test-end-run-time test-start-run-time)
                                  internal-time-units-per-second))
                        (float (/ (- test-end-run-time test-start-run-time)
                                  internal-time-units-per-second)))))
            (cond ((and correct expected-error)
                   (format t
                           "~%... Which was correct, but was expected ~
                           to be wrong due to a known bug in~% Maxima.~%"))
                  (correct
                   (if show-all (format t "~%... Which was correct.~%")))
                  ((and (not correct) expected-error)
                   (if (or show-all show-expected)
                       (progn
                         (format t
                                 "~%This is a known error in Maxima. ~
                                 The correct result is:~%")
                         (mdisplay next-result))))
                  (t
                   (format t "~%This differed from the expected result:~%")
                   (push i all-differences)
                   (mdisplay next-result)
                   (cond ((and *collect-errors* error-log)
                          (format error-log "/* Problem ~A */~%" i)
                          (mgrind (third expr) error-log)
                          (list-variable-bindings (third expr) error-log)
                          (format error-log ";~%")
                          (format error-log "/* Erroneous Result?:~%")
                          (mgrind result error-log) (format error-log " */ ")
                          (terpri error-log)
                          (format error-log "/* Expected result: */~%")
                          (mgrind next-result error-log)
                          (format error-log ";~%~%"))))))))
      (close strm))
    (setq end-run-time (get-internal-run-time))
    (setq end-real-time (get-internal-real-time))
    (cond (error-log
           (or (streamp *collect-errors*)
               (close error-log))))
    (let
      ((expected-errors-trailer
         (if (or (null expected-errors) (= (length expected-errors) 0))
             ""
             (format nil
                     " (not counting ~a expected errors)"
                     (length expected-errors))))
       (time (if showtime
                 (format nil "   using ~,3F seconds (~,3F elapsed).~%"
                         (float (/ (- end-run-time start-run-time)
                                   internal-time-units-per-second))
                         (float (/ (- end-real-time start-real-time)
                                   internal-time-units-per-second)))
                 "")))
      (cond ((null all-differences)
             (format t "~a/~a tests passed~a~%~A"
                     num-problems num-problems
                     expected-errors-trailer
                     time)
             (values '((mlist)) num-problems))
            (t
             (format t
                     "~%~a/~a tests passed~a~%~A"
                     (- num-problems (length all-differences))
                     num-problems expected-errors-trailer
                     time)
             (let ((s (if (> (length all-differences) 1) "s" "")))
               (format t
                       "~%The following ~A problem~A failed: ~A~%"
                       (length all-differences)
                       s
                       (reverse all-differences)))
             (values `((mlist) ,filename ,@(reverse all-differences))
                     num-problems))))))

;;; ----------------------------------------------------------------------------

(defun batch-equal-check (expected result)
  (let ((answer (catch 'macsyma-quit (simple-equal-p expected result))))
    (if (eql answer 'maxima-error) nil answer)))

(defun simple-equal-p (f g)
  (approx-alike (simplifya f nil) (simplifya g nil)))

(defun approx-alike (f g)
  (cond ((floatp f)
         (and (floatp g)
              ($float_approx_equal f g)))
        ((bigfloatp f)
         (and (bigfloatp g)
              ($bfloat_approx_equal f g)))
        ((atom f) (and (atom g) (equal f g)))
        ((moperatorp f 'lambda)
         (and (moperatorp g 'lambda)
              (approx-alike-list (mapcar #'(lambda (s) (simplifya s nil))
                                         (margs f))
                                 (mapcar #'(lambda (s) (simplifya s nil))
                                         (margs g)))))
        ((arrayp f)
         (and (arrayp g) (approx-alike ($listarray f) ($listarray g))))
        ((hash-table-p f)
         (and (hash-table-p g) (approx-alike ($listarray f) ($listarray g))))
        ((moperatorp f 'mquote)
         (approx-alike (second f) g))
        ((and (consp f)
              (consp (car f))
              (consp g)
              (consp (car g))
              (or (approx-alike (mop f) (mop g))
                  (and (symbolp (mop f)) (symbolp (mop g))
                       (approx-alike ($nounify (mop f)) ($nounify (mop g)))))
              (approx-alike-list (margs f) (margs g))))
        (t nil)))

(defun approx-alike-list (p q)
  (cond ((null p) (null q))
        ((null q) (null p))
        (t
         (and (approx-alike (first p) (first q))
              (approx-alike-list (rest p) (rest q))))))

(defconstant flonum-epsilon double-float-epsilon)
(defmvar $float_approx_equal_tolerance (* 16 flonum-epsilon))

(defun $float_approx_equal (a b)
  (setq a (if (floatp a) a ($float a)))
  (setq b (if (floatp b) b ($float b)))
  (and (floatp a)
       (floatp b)
       (<= (abs (- a b))
           (* $float_approx_equal_tolerance
              (min (expt 2 
                         (- (second (multiple-value-list (decode-float a)))
                            1))
                   (expt 2
                         (- (second (multiple-value-list (decode-float b)))
                            1)))))))

(defun $bfloat_approx_equal (a b)
  (setq a (if (bigfloatp a) a ($bfloat a)))
  (setq b (if (bigfloatp b) b ($bfloat b)))
  (let ((m) (bits))
    (and (bigfloatp a)
         (bigfloatp b)
         (setq bits (min (third (first a)) (third (first b))))
         (setq m (mul 32
                      (expt 2 (- bits))
                      (min (expt 2 (- (car (last a)) 1))
                           (expt 2 (- (car (last b)) 1)))))
         (setq m (if (rationalp m)
                     (div (numerator m) (denominator m))
                     m))
         (setq m (fpdifference (cdr ($bfloat m))
                               (fpabs (fpdifference (cdr a) (cdr b)))))
         (or (eql (car m) 0)
             (fpposp m)))))

[ << ] [ >> ]           [Top] [Contents] [Index] [ ? ]

This document was generated by Dieter Kaiser on Dezember, 13 2011 using texi2html 1.76.