home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / tests / tests.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-04-15  |  3.5 KB  |  114 lines
  1. ;; Test-Suiten ablaufen lassen:
  2.  
  3. #+CLISP
  4. (defmacro with-ignored-errors (&rest forms)
  5.   (let ((b (gensym)))
  6.     `(BLOCK ,b
  7.        (LET ((*ERROR-HANDLER*
  8.                #'(LAMBDA (&REST ARGS) (RETURN-FROM ,b 'ERROR))
  9.             ))
  10.          ,@forms
  11.      ) )
  12. ) )
  13.  
  14. #+AKCL
  15. (defmacro with-ignored-errors (&rest forms)
  16.   (let ((b (gensym))
  17.         (h (gensym)))
  18.     `(BLOCK ,b
  19.        (LET ((,h (SYMBOL-FUNCTION 'SYSTEM:UNIVERSAL-ERROR-HANDLER)))
  20.          (UNWIND-PROTECT
  21.            (PROGN (SETF (SYMBOL-FUNCTION 'SYSTEM:UNIVERSAL-ERROR-HANDLER)
  22.                         #'(LAMBDA (&REST ARGS) (RETURN-FROM ,b 'ERROR))
  23.                   )
  24.                   ,@forms
  25.            )
  26.            (SETF (SYMBOL-FUNCTION 'SYSTEM:UNIVERSAL-ERROR-HANDLER) ,h)
  27.      ) ) )
  28. ) )
  29.  
  30. (defun run-test (testname
  31.                  &aux (logname (merge-pathnames #".erg" testname)) log-empty-p)
  32.   (with-open-file (s (merge-pathnames #".tst" testname) :direction :input)
  33.     (with-open-file (log logname :direction :output)
  34.       (let ((*package* *package*)
  35.             (*print-pretty* nil)
  36.             (eof "EOF"))
  37.         (loop
  38.           (let ((form (read s nil eof))
  39.                 (result (read s nil eof)))
  40.             (when (or (eq form eof) (eq result eof)) (return))
  41.             (print form)
  42.             (let ((my-result
  43.                     (if (equal testname "conditions")
  44.                       (eval form) ; don't disturb the condition system when testing it!
  45.                       (with-ignored-errors (eval form)) ; return ERROR on errors
  46.                  )) )
  47.               (cond ((eql result my-result)
  48.                      (format t "~%EQL-OK: ~S" result)
  49.                     )
  50.                     ((equal result my-result)
  51.                      (format t "~%EQUAL-OK: ~S" result)
  52.                     )
  53.                     ((equalp result my-result)
  54.                      (format t "~%EQUALP-OK: ~S" result)
  55.                     )
  56.                     (t
  57.                      (format t "~%FEHLER!! ~S sollte ~S sein!" my-result result)
  58.                      (format log "~%Form: ~S~%SOLL: ~S~%~A: ~S~%"
  59.                                  form result
  60.                                  #+CLISP "CLISP" #+AKCL "AKCL"
  61.                                  my-result
  62.                     ))
  63.         ) ) ) )
  64.       )
  65.       (setq log-empty-p (zerop (file-length log)))
  66.   ) )
  67.   (when log-empty-p (delete-file logname))
  68.   (values)
  69. )
  70.  
  71. (defun run-all-tests ()
  72.   (mapc #'run-test
  73.         '( #-AKCL     "alltest"
  74.                       "array"
  75.                       "backquot"
  76.            #-AKCL     "characters"
  77.            #+CLISP    "clos"
  78.            #+CLISP    "conditions"
  79.                       "eval20"
  80.                       "format"
  81.            #+CLISP    "genstream"
  82.            #+XCL      "hash"
  83.                       "hashlong"
  84.                       "iofkts"
  85.                       "lambda"
  86.                       "lists151"
  87.                       "lists152"
  88.                       "lists153"
  89.                       "lists154"
  90.                       "lists155"
  91.                       "lists156"
  92.            #+CLISP    "loop"
  93.                       "macro8"
  94.                       "map"
  95.                       "number"
  96.            #+CLISP    "number2"
  97.            #-AKCL     "pack11"
  98.       #-(or AKCL DOS) "path"
  99.            #+XCL      "readtable"
  100.                       "setf"
  101.                       "steele7"
  102.                       "streams"
  103.                       "streamslong"
  104.                       "strings"
  105.            #-AKCL     "symbol10"
  106.                       "symbols"
  107.            #+XCL      "tprint"
  108.            #+XCL      "tread"
  109.                       "type"
  110.   )      )
  111.   t
  112. )
  113.  
  114.