src/mload.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;;;       (c) Copyright 1982 Massachusetts Institute of Technology       ;;;
  10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11
  12 (in-package :maxima)
  13 (macsyma-module mload)
  14
  15 (declare-top (special $file_search_lisp $file_search_maxima $file_search_demo $loadprint))
  16
  17 (defun load-and-tell (filename)
  18   (loadfile filename t ;; means this is a lisp-level call, not user-level.
  19             $loadprint))
  20
  21 (defun errset-namestring (x)
  22   (let ((errset nil))
  23     (errset (pathname x))))
  24
  25 (defmfun $filename_merge (&rest file-specs)
  26   (when (or (null file-specs) (cddr file-specs))
  27     (wna-err '$filename_merge))
  28   (setq file-specs (mapcar #'macsyma-namestring-sub file-specs))
  29   (pathname (if (null (cdr file-specs))
  30                 (car file-specs)
  31                 (merge-pathnames (cadr file-specs) (car file-specs)))))
  32
  33 (defun macsyma-namestring-sub (user-object)
  34   (if (pathnamep user-object) user-object
  35       (let* ((system-object
  36               (cond ((and (atom user-object) (not (symbolp user-object)))
  37                      user-object)
  38                     ((atom user-object) ;hence a symbol in view of the
  39                      (print-invert-case (fullstrip1 user-object))) ; first clause
  40                     (($listp user-object)
  41                      (fullstrip (cdr user-object)))
  42                     (t
  43                      (merror (intl:gettext "filename_merge: unexpected argument: ~M") user-object))))
  44              (namestring-try (errset-namestring system-object)))
  45         (if namestring-try (car namestring-try)
  46             ;; know its small now, so print on same line.
  47             (merror (intl:gettext "filename_merge: unexpected argument: ~:M") user-object)))))
  48
  49 ;; Returns the truename corresponding to a stream, or nil (for non-file streams).
  50 ;; Previously we used (subtypep (type-of stream) 'file-stream) to determine whether
  51 ;; a stream is a file stream, but this doesn't work on GCL.
  52 (defun get-stream-truename (stream)
  53   (handler-case
  54     (probe-file stream)
  55     (error () nil)))
  56
  57 (defmvar $load_pathname nil
  58   "The full pathname of the file being loaded")
  59
  60 (defmfun $batchload (filename-or-stream &aux (*mread-prompt* ""))
  61   (declare (special *mread-prompt*))
  62   (if (streamp filename-or-stream)
  63       (batchload-stream filename-or-stream)
  64     (let
  65       ((filename ($file_search1 filename-or-stream '((mlist) $file_search_maxima))))
  66       (with-open-file (in-stream filename)
  67         (batchload-stream in-stream)))))
  68
  69 (defun batchload-stream (in-stream)
  70   (let ($load_pathname)
  71     (let*
  72       ((noevalargs nil)
  73        (*read-base* 10.)
  74        (stream-truename (get-stream-truename in-stream))
  75        (in-stream-string-rep
  76         (if stream-truename
  77           (setq $load_pathname (cl:namestring stream-truename))
  78           (format nil "~A" in-stream)))
  79        (expr nil))
  80       (declare (special *prompt-on-read-hang*))
  81       (when $loadprint
  82         (format t (intl:gettext "~&read and interpret ~A~&") in-stream-string-rep))
  83       (cleanup)
  84       (newline in-stream)
  85       (loop while (and
  86                     (setq  expr (let (*prompt-on-read-hang*) (mread in-stream nil)))
  87                     (consp expr))
  88             do (meval* (third expr)))
  89       in-stream-string-rep)))
  90
  91 ;;returns appropriate error or existing pathname.
  92 ;; the second argument is a maxima list of variables
  93 ;; each of which contains a list of paths.   This is
  94 ;; so users can correct the variable..
  95 (defmfun $file_search1 (name search-lists &aux lis)
  96   (if (pathnamep name)
  97       (setq name (namestring name)))
  98   (setq lis (apply '$append (mapcar 'symbol-value (cdr search-lists))))
  99   (let ((res ($file_search name lis)))
 100     (or res
 101         (merror (intl:gettext "file_search1: ~M not found in ~A.")
 102                 name
 103                 (string-trim "[]" ($sconcat search-lists))))))
 104
 105 (defmfun $load (filename)
 106   "This is the generic file loading function.
 107   LOAD(filename) will either BATCHLOAD or LOADFILE the file,
 108   depending on wether the file contains Macsyma, Lisp, or Compiled
 109   code. The file specifications default such that a compiled file
 110   is searched for first, then a lisp file, and finally a macsyma batch
 111   file. This command is designed to provide maximum utility and
 112   convenience for writers of packages and users of the macsyma->lisp
 113   translator."
 114
 115   (if (or (stringp filename) (symbolp filename) (pathnamep filename))
 116     (let ((searched-for
 117          ($file_search1 filename
 118                         '((mlist) $file_search_maxima $file_search_lisp  )))
 119         type)
 120       (setq type ($file_type searched-for))
 121       (case type
 122         (($maxima)
 123          ($batchload searched-for))
 124         (($lisp $object)
 125          ;; do something about handling errors
 126          ;; during loading. Foobar fail act errors.
 127          (load-and-tell searched-for))
 128         (t
 129          ;; UNREACHABLE MESSAGE: DEFAULT TYPE IS '$OBJECT (SEE $FILE_TYPE BELOW)
 130          (merror "Maxima bug: Unknown file type ~M" type)))
 131       searched-for)
 132     (merror "load: argument must be a string, symbol, or pathname; found: ~M" filename)))
 133
 134 (defmvar $file_type_lisp
 135     (list '(mlist) "l" "lsp" "lisp"))
 136
 137 (defmvar $file_type_maxima
 138     (list '(mlist) "mac" "mc" "demo" "dem" "dm1" "dm2" "dm3" "dmt" "wxm"))
 139
 140 (defmfun $file_type (fil)
 141   (let ((typ ($pathname_type fil)))
 142     (cond
 143       ((member typ (cdr $file_type_lisp) :test #'string=)
 144        '$lisp)
 145       ((member typ (cdr $file_type_maxima) :test #'string=)
 146        '$maxima)
 147       (t
 148        '$object))))
 149
 150 (defmfun $pathname_directory (path)
 151   (let ((pathname (pathname path)))
 152     (namestring (make-pathname :directory (pathname-directory pathname)))))
 153
 154 (defmfun $pathname_name (path)
 155   (let ((pathname (pathname path)))
 156     (pathname-name pathname)))
 157
 158 (defmfun $pathname_type (path)
 159   (let ((pathname (pathname path)))
 160     (pathname-type pathname)))
 161
 162
 163 (defvar *macsyma-startup-queue* nil)
 164
 165 (declaim (special *mread-prompt*))
 166
 167 ;;;; batch & demo search hacks
 168
 169 (defmfun $batch (filename-or-stream &optional (demo :batch)
 170                &aux tem   (possible '(:demo :batch :test)))
 171   "giving a second argument makes it use demo mode, ie pause after evaluation
 172    of each command line"
 173
 174   ;; Try to get rid of testsuite failures on machines that are low on RAM.
 175   ($garbage_collect)
 176   (cond
 177     ((setq tem (member ($mkey demo) possible :test #'eq))
 178      (setq demo (car tem)))
 179     (t (format t (intl:gettext "batch: second argument must be 'demo', 'batch' or 'test'; found: ~A, assumed 'batch'~%") demo)))
 180   (if (streamp filename-or-stream)
 181     (batch-stream filename-or-stream demo)
 182     (let
 183       ((filename ($file_search1 filename-or-stream
 184                                 (if (eql demo :demo)
 185                                   '((mlist) $file_search_demo )
 186                                   '((mlist) $file_search_maxima)))))
 187       (cond
 188         ((eq demo :test)
 189          (test-batch filename nil :show-all t)) ;; NEED TO ACCEPT INPUT STREAM HERE TOO
 190         (t
 191           (with-open-file (in-stream filename)
 192             (batch-stream in-stream demo)))))))
 193
 194 (defun batch-stream (in-stream demo)
 195   (let ($load_pathname)
 196     (let*
 197       ((*read-base* 10.)
 198       (stream-truename (get-stream-truename in-stream))
 199        (in-stream-string-rep
 200         (if stream-truename
 201           (setq $load_pathname (cl:namestring stream-truename))
 202           (format nil "~A" in-stream))))
 203       (format t (intl:gettext "~%read and interpret ~A~%") in-stream-string-rep)
 204       (catch 'macsyma-quit (continue :stream in-stream :batch-or-demo-flag demo))
 205       (incf $linenum)
 206       in-stream-string-rep)))
 207
 208 ;; When either a or b are special float values (NaN or +/-Inf), return true iff
 209 ;; a and b are the both NaN or both +Inf or both -Inf.
 210 ;; Note that float_approx_equal(NaN, NaN) returns true.
 211 ;;
 212 ;; When a and b to finite, nonzero floats, return true iff
 213 ;;
 214 ;;   |a - b| <= float_approx_equal_tolerance * min(2^n, 2^m)
 215 ;;
 216 ;; where a = af * 2^m, |af| < 1, and m is an integer (similarly for b).
 217 ;; See Knuth, "The Art of Computer Programming" (3rd ed.), Vol. 2, Sec. 4.2.2, Eq. 24, page 233.
 218 ;;
 219 ;; Note that Eq. 24 isn't well-defined for a or b equal to zero.
 220 ;; To make progress, let's consider the limit as b --> 0,
 221 ;; therefore n --> -inf. For any finite a, that means that min(2^n, 2^m) = 2^n
 222 ;; and therefore |a - b| --> |a|, but to pass the test,
 223 ;; |a| must be less than or equal to float_approx_equal_tolerance * 2^n --> 0.
 224 ;; Therefore the test fails for all nonzero, finite a, when b = 0.
 225 ;; i.e. when either a or b is zero but not both, return false.
 226 ;;
 227 ;; Note also that if a < 0 and b > 0 or vice versa, the test must fail:
 228 ;; without loss of generality assume |a| > |b|. Then n <= m and min(2^n, 2^m) = 2^n.
 229 ;; Now |a - b| = |a| + |b| since a and b are different signs.
 230 ;; Then |a - b| / min(2^n, 2^m) = |a/min(2^n, 2^m)| + |b/min(2^n, 2^m)| = |af|*2^m/2^n + |bf| >= |af| + |bf| > 1.
 231 ;; So unless float_approx_equal_tolerance is unusually large, the test must fail.
 232 ;;
 233 ;; Otherwise, either a or b is not a float, so return false.
 234
 235 (defmvar $float_approx_equal_tolerance (* 8 flonum-epsilon))
 236
 237 (defmfun $float_approx_equal (a b)
 238   (setq a (if (floatp a) a ($float a)))
 239   (setq b (if (floatp b) b ($float b)))
 240   (and
 241    (floatp a)
 242    (floatp b)
 243    (cond
 244      ;; look for NaN
 245      ((/= a a) (/= b b))
 246      ((/= b b) nil)
 247      ;; look for Inf
 248      ((> (abs a) most-positive-double-float) (= a b))
 249      ((> (abs b) most-positive-double-float) nil)
 250      ;; look for zero
 251      ((= a 0d0) (= b 0d0))
 252      ((= b 0d0) nil)
 253      ;; look for A = B
 254      ((= a b))
 255      (t
 256        ;; Implement test without involving floating-point arithmetic,
 257        ;; to avoid errors which could occur with extreme values.
 258        (let (a-significand a-expt a-sign b-significand b-expt b-sign)
 259          (multiple-value-setq (a-significand a-expt a-sign) (decode-float a))
 260          (multiple-value-setq (b-significand b-expt b-sign) (decode-float b))
 261          (if (or (= a-sign b-sign) (>= $float_approx_equal_tolerance 1d0))
 262            (let (a-b-significand a-b-expt a-b-sign tol-significand tol-expt tol-sign)
 263              (multiple-value-setq (a-b-significand a-b-expt a-b-sign) (integer-decode-float (abs (- a b))))
 264              (multiple-value-setq (tol-significand tol-expt tol-sign) (integer-decode-float $float_approx_equal_tolerance))
 265              (or (< a-b-expt (+ tol-expt (min a-expt b-expt)))
 266                  (and (= a-b-expt (+ tol-expt (min a-expt b-expt)))
 267                       (<= a-b-significand tol-significand))))))))))
 268
 269 ;; Big float version of float_approx_equal. But for bfloat_approx_equal, the tolerance isn't
 270 ;; user settable; instead, it is 32 / 2^fpprec. The factor of 32 is too large, I suppose. But
 271 ;; the test suite gives a few errors with a factor of 16. These errors might be due to
 272 ;; float / big float comparisons.
 273
 274 (defmfun $bfloat_approx_equal (a b)
 275   (setq a (if ($bfloatp a) a ($bfloat a)))
 276   (setq b (if ($bfloatp b) b ($bfloat b)))
 277   (let ((m) (bits))
 278     (and
 279      ($bfloatp a)
 280      ($bfloatp b)
 281      (setq bits (min (third (first a)) (third (first b))))
 282      (setq m (* 32 (expt 2 (- bits)) (min (expt 2 (- (car (last a)) 1)) (expt 2 (- (car (last b)) 1)))))
 283      (setq m (if (rationalp m) (div (numerator m) (denominator m)) m))
 284      (eq t (mgqp m (take '(mabs) (sub a b)))))))
 285
 286
 287 ;; The first argument 'f' is the expected result; the second argument
 288 ;; 'g' is the output of the test. By explicit evaluation, the expected
 289 ;; result *can* be a CL array, CL hashtable, or a taylor polynomial. Such
 290 ;; a test would look something like (yes, it's a silly test)
 291
 292 ;;    taylor(x,x,0,2);
 293 ;;    ''(taylor(x,x,0,2)
 294
 295 (defun approx-alike (f g)
 296
 297   (cond ((floatp f) (and (floatp g) ($float_approx_equal f g)))
 298
 299         (($bfloatp f) (and ($bfloatp g) ($bfloat_approx_equal f g)))
 300
 301         (($taylorp g)
 302          (approx-alike 0 (sub (ratdisrep f) (ratdisrep g))))
 303
 304         ((stringp f)
 305          (and (stringp g) (string= f g)))
 306
 307         ((arrayp f)
 308          (and (arrayp g) (approx-alike ($listarray f) ($listarray g))))
 309
 310         ((hash-table-p f)
 311          (and (hash-table-p g) (approx-alike ($listarray f) ($listarray g))))
 312
 313         ((atom f)
 314          (and (atom g) (equal f g)))
 315
 316         ((op-equalp f 'lambda)
 317          (and (op-equalp g 'lambda)
 318               (approx-alike-list (mapcar #'(lambda (s) (simplifya s nil)) (margs f))
 319                                  (mapcar #'(lambda (s) (simplifya s nil)) (margs g)))))
 320
 321         (($ratp f)
 322          (and ($ratp g) (approx-alike (ratdisrep f) (ratdisrep g))))
 323
 324         ;; maybe we don't want this.
 325         ((op-equalp f 'mquote)
 326          (approx-alike (second f) g))
 327
 328         ;; I'm pretty sure that (mop f) and (mop g) won't signal errors, but
 329         ;; let's be extra careful.
 330
 331         ((and (consp f) (consp (car f)) (consp g) (consp (car g))
 332               (or (approx-alike (mop f) (mop g))
 333                   (and (symbolp (mop f)) (symbolp (mop g))
 334                        (approx-alike ($nounify (mop f)) ($nounify (mop g)))))
 335               (eq ($subvarp f) ($subvarp g))
 336               (approx-alike-list (margs f) (margs g))))
 337
 338         (t nil)))
 339
 340 (defun approx-alike-list (p q)
 341   (cond ((null p) (null q))
 342         ((null q) (null p))
 343         (t (and (approx-alike (first p) (first q)) (approx-alike-list (rest p) (rest q))))))
 344
 345 (defun simple-equal-p (f g)
 346   (approx-alike (simplifya f nil) (simplifya g nil)))
 347
 348 (defun batch-equal-check (expected result)
 349   (let ((answer (catch 'macsyma-quit (simple-equal-p expected result))))
 350     (if (eql answer 'maxima-error) nil answer)))
 351
 352 (defvar *collect-errors* t)
 353
 354 ;; Execute the code in FILENAME as a batch file.  If EXPECTED-ERRORS
 355 ;; is non-NIL, it is a list of numbers denoting which tests in this
 356 ;; file are expected to fail.  OUT specifies the stream where any
 357 ;; output goes (defaulting to *standard-output*).  SHOW-EXPECTED is
 358 ;; non-NIL if the expected results should also be printed.  SHOW-ALL
 359 ;; is non-NIL if all tests (including expected failures) should be
 360 ;; shown.  Finally, SHOWTIME is non-NIL if the execution time should
 361 ;; be displayed.
 362 ;;
 363 ;; This function returns four values:
 364 ;;   1.  the filename
 365 ;;   2.  NIL or a Maxima list of test numbers that failed
 366 ;;   3.  NIL or a Maxima list of test numbers that were expected to
 367 ;;       fail but actually passed.
 368 ;;   4.  Total number of tests in the file
 369 (defun test-batch (filename expected-errors
 370                             &key (out *standard-output*) (show-expected nil)
 371                             (show-all nil) (showtime nil))
 372
 373   (let (result
 374         next-result
 375         next
 376         error-log
 377         all-differences
 378         unexpected-pass
 379         strm
 380         expr
 381         problem-lineinfo
 382         problem-lineno
 383         tmp-output
 384         save-output
 385         ($ratprint nil)
 386         (*mread-prompt* "")
 387         (*read-base* 10.)
 388         (num-problems 0)
 389         (i 0)
 390         (start-run-time 0)
 391         (end-run-time 0)
 392         (start-real-time 0)
 393         (end-real-time 0)
 394         (test-start-run-time 0)
 395         (test-end-run-time 0)
 396         (test-start-real-time 0)
 397         (test-end-real-time 0))
 398
 399     (cond (*collect-errors*
 400            (setq error-log
 401                  (if (streamp *collect-errors*) *collect-errors*
 402                    (handler-case
 403                        (open (alter-pathname filename :type "ERR") :direction :output :if-exists :supersede)
 404                      #-gcl (file-error () nil)
 405                      #+gcl (cl::error () nil))))
 406            (when error-log
 407              (format t (intl:gettext "~%batch: write error log to ~a") error-log)
 408              (format error-log (intl:gettext "~%/* Maxima error log from tests in ~A") filename)
 409              (format error-log " */~2%"))))
 410
 411     (unwind-protect
 412         (progn
 413           (setq strm (open filename :direction :input))
 414           (setq start-real-time (get-internal-real-time))
 415           (setq start-run-time (get-internal-run-time))
 416           (while (not (eq 'eof (setq expr (mread strm 'eof))))
 417             (incf num-problems)
 418             (setq problem-lineinfo (second (first expr)))
 419             (setq problem-lineno (if (and (consp problem-lineinfo) (integerp (first problem-lineinfo)))
 420                                      (1+ (first problem-lineinfo))))
 421             (incf i)
 422             (setf tmp-output (make-string-output-stream))
 423             (setf save-output *standard-output*)
 424             (setf *standard-output* tmp-output)
 425
 426             (unwind-protect
 427                  (progn
 428                    (setq test-start-run-time (get-internal-run-time))
 429                    (setq test-start-real-time (get-internal-real-time))
 430                    (let (($errormsg t))
 431                      (setq result (meval* `(($errcatch) ,(third expr)))))
 432                    (setq result (if ($emptyp result) 'error-catch (second result)))
 433                    (setq test-end-run-time (get-internal-run-time))
 434                    (setq test-end-real-time (get-internal-real-time))
 435                    (setq $% result))
 436               (setf *standard-output* save-output))
 437
 438             (setq next (mread strm 'eof))
 439             (if (eq next 'eof) (merror (intl:gettext "batch: missing expected result in test script.")))
 440
 441             (setq next-result (third next))
 442             (let* ((correct (batch-equal-check next-result result))
 443                    (expected-error (member i expected-errors))
 444                    (pass (or correct expected-error)))
 445               (when (or show-all (not pass) (and correct expected-error)
 446                         (and expected-error show-expected))
 447                 (format out (intl:gettext "~%********************** Problem ~A~A***************")
 448                         i (if problem-lineno (format nil " (line ~S) " problem-lineno) " "))
 449                 (format out (intl:gettext "~%Input:~%"))
 450                 (displa (third expr))
 451                 (format out (intl:gettext "~%~%Result:~%"))
 452                 (format out "~a" (get-output-stream-string tmp-output))
 453                 (displa $%)
 454                 (when (eq showtime '$all)
 455                   (format out (intl:gettext "~%Time:  ~,3F sec (~,3F elapsed)")
 456                           (float (/ (- test-end-run-time test-start-run-time)
 457                                     internal-time-units-per-second))
 458                           (float (/ (- test-end-real-time test-start-real-time)
 459                                     internal-time-units-per-second)))))
 460               (cond ((and correct expected-error)
 461                      (push i unexpected-pass)
 462                      (format t
 463                              (intl:gettext "~%... Which was correct, but was expected ~
 464                               to be wrong due to a known bug in~% Maxima or ~A.~%")
 465                              (lisp-implementation-type)))
 466                     (correct
 467                      (if show-all (format t (intl:gettext "~%... Which was correct.~%"))))
 468                     ((and (not correct) expected-error)
 469                      (when (or show-all show-expected)
 470                        (format t
 471                                (intl:gettext "~%This is a known error in Maxima or in ~A. ~
 472                                     The correct result is:~%")
 473                                (lisp-implementation-type))
 474                        (displa next-result)))
 475                     (t (format t (intl:gettext "~%This differed from the expected result:~%"))
 476                      (push i all-differences)
 477                      (displa next-result)
 478                      (cond ((and *collect-errors* error-log)
 479                             (format error-log (intl:gettext "/* Problem ~A~A*/~%")
 480                                     i (if problem-lineno (format nil " (line ~S) " problem-lineno) " "))
 481                             (mgrind (third expr) error-log)
 482                             (list-variable-bindings (third expr) error-log)
 483                             (format error-log ";~%")
 484                             (format error-log (intl:gettext "/* Erroneous Result?:~%"))
 485                             (mgrind result error-log) (format error-log " */ ")
 486                             (terpri error-log)
 487                             (format error-log (intl:gettext "/* Expected result: */~%"))
 488                             (mgrind next-result error-log)
 489                             (format error-log ";~%~%"))))))))
 490       (close strm))
 491     (setq end-run-time (get-internal-run-time))
 492     (setq end-real-time (get-internal-real-time))
 493     (cond (error-log
 494            (or (streamp *collect-errors*)
 495                (close error-log))))
 496     (let*
 497       ((n-expected-errors (length expected-errors))
 498        (expected-errors-trailer
 499          (if (= n-expected-errors 0)
 500             ""
 501             (format nil (intl:gettext " (not counting ~a expected errors)") n-expected-errors)))
 502        (time (if showtime
 503                  (format nil (intl:gettext "   using ~,3F seconds (~,3F elapsed).~%")
 504                          (float (/ (- end-run-time start-run-time) internal-time-units-per-second))
 505                          (float (/ (- end-real-time start-real-time) internal-time-units-per-second)))
 506                  "")))
 507       (cond ((null all-differences)
 508              (format t (intl:gettext "~a/~a tests passed~a~%~A")
 509                      (- num-problems n-expected-errors) (- num-problems n-expected-errors)
 510                      expected-errors-trailer
 511                      time)
 512              (when unexpected-pass
 513                (multiple-value-bind (plural was-were)
 514                  (if (> (length unexpected-pass) 1)
 515                      (values "s" "were")
 516                      (values "" "was"))
 517                (format t (intl:gettext "~%The following ~A problem~A passed but ~A expected to fail: ~A~%")
 518                        (length unexpected-pass) plural was-were (reverse unexpected-pass))))
 519              (values filename
 520                      nil
 521                      `((mlist) ,@(reverse unexpected-pass))
 522                      num-problems))
 523             (t
 524              (format t (intl:gettext "~%~a/~a tests passed~a~%~A")
 525                      (- num-problems n-expected-errors (length all-differences)) (- num-problems n-expected-errors) expected-errors-trailer
 526                      time)
 527              (let ((s (if (> (length all-differences) 1) "s" "")))
 528                (format t (intl:gettext "~%The following ~A problem~A failed: ~A~%")
 529                        (length all-differences) s (reverse all-differences)))
 530              (when unexpected-pass
 531                (multiple-value-bind (plural was-were)
 532                  (if (> (length unexpected-pass) 1)
 533                      (values "s" "were")
 534                      (values "" "was"))
 535                (format t (intl:gettext "~%The following ~A problem~A passed but ~A expected to fail: ~A~%")
 536                        (length unexpected-pass) plural was-were (reverse unexpected-pass))))
 537              (values filename
 538                      `((mlist) ,@(reverse all-differences))
 539                      `((mlist) ,@(reverse unexpected-pass))
 540                      num-problems))))))
 541
 542 ;;to keep track of global values during the error:
 543 (defun list-variable-bindings (expr &optional str &aux tem)
 544   (loop for v in(cdr ($listofvars  expr))
 545     when (member v $values :test #'equal)
 546     collecting (setq tem`((mequal) ,v ,(meval* v)))
 547     and
 548     do (cond (str (format str ",")(mgrind tem str)))))
 549
 550 ;;in init_max
 551 ;; name = foo or foo.type or dir/foo.type or dir/foo
 552 ;; the empty parts are filled successively from defaults in templates in
 553 ;; the path.   A template may use multiple {a,b,c} constructions to indicate
 554 ;; multiple possibilities.  eg foo.l{i,}sp or foo.{dem,dm1,dm2}
 555 (defmfun $file_search (name &optional paths)
 556   (if (and (symbolp name)
 557            (char= (char (symbol-name name) 0) #\$))
 558       (setq name (subseq (print-invert-case name) 1)))
 559   (if (symbolp name)  (setf name (string name)))
 560   (if (file-exists-p name) (return-from $file_search name))
 561   (or paths (setq paths ($append $file_search_lisp  $file_search_maxima
 562                                  $file_search_demo)))
 563   (atomchk paths '$file_search t)
 564   (new-file-search (string name) (cdr paths)))
 565
 566 ;; Returns T if NAME exists and it does not appear to be a directory.
 567 ;; Note that Clisp throws an error from PROBE-FILE if NAME exists
 568 ;; and is a directory; hence the use of IGNORE-ERRORS.
 569
 570 (defun file-exists-p (name)
 571   (let ((foo (ignore-errors (probe-file name))))
 572     (if foo (not (apparently-a-directory-p foo)))))
 573
 574 (defun apparently-a-directory-p (path)
 575   (eq (pathname-name path) nil))
 576
 577 (defun new-file-search (name template)
 578   (cond ((file-exists-p name))
 579         ((atom template)
 580          (let ((lis (loop for w in (split-string template "{}")
 581                           when (null (position #\, w))
 582                           collect w
 583                           else
 584                           collect (split-string w ","))))
 585            (new-file-search1 name "" lis)))
 586         (t
 587          (let ((temp nil))
 588            (loop for v in template
 589                  when (setq temp (new-file-search name v))
 590                  do (return temp))))))
 591
 592 (defun new-file-search1 (name begin lis)
 593   (cond ((null lis)
 594          (let ((file (namestring ($filename_merge begin name))))
 595            (if (file-exists-p file) file nil)))
 596         ((atom (car lis))
 597          (new-file-search1 name
 598                            (if begin
 599                                ($sconcat begin (car lis)) (car lis))
 600                            (cdr lis)))
 601         (t (loop for v in (car lis) with tem
 602                   when (setq tem  (new-file-search1 name begin (cons v (cdr lis))))
 603                   do (return tem)))))
 604
 605 (defun save-linenumbers (&key (c-lines t) d-lines (from 1) (below $linenum) a-list
 606                          (file  "/tmp/lines")
 607                          &aux input-symbol (linel 79))
 608   (cond ((null a-list) (setq a-list (loop for i from from below below collecting i))))
 609   (with-open-file (st file :direction :output)
 610     (format st "/* -*- Mode: MACSYMA; Package: MACSYMA -*- */")
 611     (format st "~%~%       /*    ~A     */  ~%"
 612             (let ((tem (cdddr
 613                                 (multiple-value-list (get-decoded-time)))))
 614                       (format nil "~a:~a:~a" (car tem) (cadr tem) (caadr tem))))
 615     (loop for i in a-list
 616            when (and c-lines (boundp (setq input-symbol (intern (format nil "$~A~A" '#:c i)))))
 617            do
 618            (format st "~% C~3A;  "   i)
 619            (mgrind (symbol-value input-symbol) st)
 620            (format st ";")
 621            when (and d-lines
 622                      (boundp (setq input-symbol (intern (format nil "$~A~A" '#:d i)))))
 623            do
 624            (format st "~% D~3A:  "   i)
 625            (mgrind (symbol-value input-symbol) st)
 626            (format st "$"))))
 627
 628
 629 (defmfun $printfile (file)
 630   (setq file ($file_search1 file '((mlist) $file_search_usage)))
 631   (with-open-file (st file)
 632     (loop
 633        with tem
 634        while (setq tem (read-char st nil 'eof))
 635        do
 636        (if (eq tem 'eof) (return t))
 637        (princ tem))
 638     (namestring file)))
 639
 640 (defvar *maxima-testsdir*)
 641
 642 (defun intersect-tests (tests)
 643   ;; If TESTS is non-NIL, we assume it's a Maxima list of (maxima)
 644   ;; strings naming the tests we want to run.  They must match the
 645   ;; file names in $testsuite_files.  We ignore any items that aren't
 646   ;; in $testsuite_files.
 647   (flet ((remove-dollarsign (x)
 648            ;; Like stripdollar, but less heavy
 649            (if (symbolp x)
 650                (subseq (maxima-string x) 1)
 651                x)))
 652     (mapcar #'remove-dollarsign
 653             (cond (tests
 654                    (let ((results nil))
 655                      ;; Using INTERSECTION would be convenient, but
 656                      ;; INTERSECTION can return the result in any
 657                      ;; order, and we'd prefer that the order of the
 658                      ;; tests be preserved.  CMUCL and CCL returns the
 659                      ;; intersection in reverse order.  Clisp produces
 660                      ;; the original order.  Fortunately, this doesn't
 661                      ;; have to be very fast, so we do it very naively.
 662                      (dolist (test (mapcar #'remove-dollarsign (cdr tests)))
 663                        (let ((matching-test (find test (cdr $testsuite_files)
 664                                                   :key #'(lambda (x)
 665                                                            (maxima-string (if (listp x)
 666                                                                               (second x)
 667                                                                               x)))
 668                                                   :test #'string=)))
 669                          (when matching-test
 670                            (push matching-test results))))
 671                      (nreverse results)))
 672                   (t
 673                    (cdr $testsuite_files))))))
 674
 675 (defun print-testsuite-summary (errs unexpected-pass error-count total-count)
 676   (flet
 677       ((problem-summary (x)
 678          ;; We want to print all the elements in the list.
 679          (let ((*print-length* nil)
 680                (s (if (> (length (rest x)) 1) "s" "")))
 681            (format t
 682                    (intl:gettext
 683                     "  ~a problem~a:~%    ~a~%")
 684                    (first x)
 685                    s
 686                    (sort (rest x) #'<)))))
 687     (if (null errs)
 688         (format t
 689                 (intl:gettext
 690                  "~%~%No unexpected errors found out of ~:d tests.~%")
 691                 total-count)
 692         (format t (intl:gettext "~%Error summary:~%")))
 693     (when errs
 694       (format t (intl:gettext "Error(s) found:~%"))
 695       (mapcar #'problem-summary (reverse errs)))
 696     (when unexpected-pass
 697       (format t (intl:gettext "Tests that were expected to fail but passed:~%"))
 698       (mapcar #'problem-summary (reverse unexpected-pass)))
 699     (when errs
 700       (format t
 701               (intl:gettext
 702                "~&~:d test~p failed out of ~:d total tests.~%")
 703               error-count
 704               error-count
 705               total-count))))
 706
 707 (defmfun $run_testsuite (&key tests display_all display_known_bugs share_tests time debug)
 708   "Run the testsuite.  Options are
 709   tests                List of tests to run
 710   display_all          Display output from each test entry
 711   display_known_bugs   Include tests that are known to fail.
 712   time                 Display time to run each test entry
 713   share_tests          Whether to include the share testsuite or not
 714   debug                Set to enable some debugging prints.
 715 "
 716   (declare (special $file_search_tests))
 717   (enable-some-lisp-warnings)
 718   (let ((test-file)
 719         (expected-failures)
 720         (test-file-path))
 721     (format t "Testsuite run for ~a ~a:~%"
 722             (lisp-implementation-type) (lisp-implementation-version))
 723     ;; Allow only T and NIL for display_known_bugs and display_all
 724     (unless (member display_known_bugs '(t nil))
 725       (merror (intl:gettext "run_testsuite: display_known_bugs must be true or false; found: ~M") display_known_bugs))
 726     (unless (member display_all  '(t nil))
 727       (merror (intl:gettext "run_testsuite: display_all must be true or false; found: ~M") display_all))
 728     (unless (member time '(t nil $all))
 729       (merror (intl:gettext "run_testsuite: time must be true, false, or all; found: ~M") time))
 730
 731     (unless (member share_tests '(t nil $only))
 732       (merror (intl:gettext "run_testsuite: share_tests must be true, false or only: found ~M") share_tests))
 733
 734     (setq *collect-errors* nil)
 735
 736     (multiple-value-bind (desired-tests desired-search-path)
 737         (ecase share_tests
 738           ((nil)
 739            ;; Do nothing
 740            (values $testsuite_files $file_search_tests))
 741           ((t)
 742            ;; Append the share files and concatenate the search paths
 743            ;; for tests and maxima so we can find both sets of tests.
 744            (values ($append $testsuite_files $share_testsuite_files)
 745                    ;; Is there a better way to do this?
 746                    (concatenate 'list
 747                                 '((mlist))
 748                                 (rest $file_search_tests)
 749                                 (rest $file_search_maxima))))
 750           ($only
 751            ;; Only the share test files
 752            (values $share_testsuite_files $file_search_maxima)))
 753       (let* (($testsuite_files desired-tests)
 754              ($file_search_tests desired-search-path)
 755              (error-break-file)
 756              (tests-to-run (intersect-tests (cond ((consp tests) tests)
 757                                                   (tests (list '(mlist) tests)))))
 758              (test-count 0)
 759              (total-count 0)
 760              (error-count 0)
 761              filename
 762              diff
 763              upass)
 764         (when debug
 765           (let (($stringdisp t))
 766             (mformat t "$testsuite_files = ~M~%" $testsuite_files)
 767             (mformat t "$file_search_tests = ~M~%" $file_search_tests)))
 768         (when debug
 769           (let (($stringdisp t))
 770             (mformat t "tests-to-run = ~M~%" tests-to-run)))
 771         (flet
 772             ((testsuite ()
 773                (loop with errs = 'nil
 774                      with unexpected-pass = nil
 775                      for testentry in tests-to-run
 776                      do (if (atom testentry)
 777                             (progn
 778                               (setf test-file testentry)
 779                               (setf expected-failures nil))
 780                             (progn
 781                               (setf test-file (second testentry))
 782                               (setf expected-failures
 783                                     ;; Support the expected failures list in
 784                                     ;; two formats:
 785                                     ;;
 786                                     ;; ((mlist) "test" 1 2 3)
 787                                     ;; ((mlist) "test" ((mlist) 1 2 3))
 788                                     ;;
 789                                     ;; The first is the old style whereas the
 790                                     ;; second is the new style.  We support
 791                                     ;; the old style for backward
 792                                     ;; compatibility.
 793                                     (if (consp (caddr testentry))
 794                                         (cdaddr testentry)
 795                                         (cddr testentry)))))
 796                         (setf test-file-path ($file_search test-file $file_search_tests))
 797                         (format t
 798                                 (intl:gettext "Running tests in ~a: ")
 799                                 (if (symbolp test-file)
 800                                     (subseq (print-invert-case test-file) 1)
 801                                     test-file))
 802                         (when debug
 803                           (format t (intl:gettext "(~A) ") test-file-path))
 804                         (or
 805                           (errset
 806                             (progn
 807                               (multiple-value-setq (filename diff upass test-count)
 808                                 (test-batch test-file-path
 809                                             expected-failures :show-expected display_known_bugs
 810                                             :show-all display_all :showtime time))
 811                               (incf total-count test-count)
 812                               (when (or (rest diff) (rest upass))
 813                                 (incf error-count (length (rest diff)))
 814                                 (when (rest diff)
 815                                   (push (list* filename (rest diff))
 816                                         errs))
 817                                 (when (rest upass)
 818                                   (push (list* filename (rest upass))
 819                                         unexpected-pass)))))
 820                           (progn
 821                             (setq error-break-file (format nil "~a" test-file))
 822                             (push (list error-break-file "error break")
 823                                   errs)
 824                             (format t
 825                                     (intl:gettext "~%Caused an error break: ~a")
 826                                     test-file)
 827                             ;; If the test failed because we
 828                             ;; couldn't find the file, make a note of
 829                             ;; that.
 830                             (unless test-file-path
 831                               (format t (intl:gettext ": test file not found.")))
 832                             (format t "~%")))
 833                      finally
 834                         (print-testsuite-summary errs unexpected-pass error-count total-count))))
 835           (time (testsuite))))))
 836   (disable-some-lisp-warnings)
 837   '$done)