diff --git a/Makefile.in b/Makefile.in index 4f52193fe..6cf71a81e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -118,9 +118,7 @@ distclean: clean realclean: distclean check: - cd build && $(MAKE) check -recheck: - cd build && $(MAKE) recheck + cd build && $(MAKE) check TESTS="$(TESTS)" # ==================== Various means of distribution ==================== diff --git a/src/Makefile.in b/src/Makefile.in index caa5f13be..1711be345 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -369,9 +369,8 @@ test_changes: # Run test suite # check: - cd tests && $(MAKE) -recheck: - cd tests && $(MAKE) clean && $(MAKE) + cd tests && $(MAKE) clean && $(MAKE) check TESTS="$(TESTS)" + # # Rebuild ECL using its own image and compare. Does not work # right now. diff --git a/src/tests/Makefile.in b/src/tests/Makefile.in index 0a61340da..2b9ac315c 100755 --- a/src/tests/Makefile.in +++ b/src/tests/Makefile.in @@ -8,9 +8,10 @@ ECL=@prefix@/@bindir@/ecl@EXEEXT@ all: check check: config.lsp - $(ECL) -norc -load config.lsp \ - -eval '(ecl-tests::run-tests)' \ - -eval '(ext:quit)' \ + $(ECL) -norc \ + -load config.lsp \ + -eval "(ecl-tests::run-tests '($(TESTS)))" \ + -eval "(ext:quit)" \ 2>&1 | tee check.log clean: diff --git a/src/tests/config.lsp.in b/src/tests/config.lsp.in index 417fa5707..ff512e8bc 100755 --- a/src/tests/config.lsp.in +++ b/src/tests/config.lsp.in @@ -21,8 +21,6 @@ when (probe-file "configure.ac") return *default-pathname-defaults*)) -(defvar *test-sources* (merge-pathnames "tests/" *ecl-sources*)) - (defvar *here* (merge-pathnames "@builddir@/")) (defvar *cache* (merge-pathnames "./cache/" *here*)) @@ -31,13 +29,6 @@ #+windows (namestring (truename "sys:ecl.exe")) #-windows "@prefix@/bin/ecl")) -(defvar *test-image-args* - `("-norc" - "-eval" "(print (ext:getenv \"ECLDIR\"))" - "-eval" "(ignore-errors (require :cmp))" - "-load" ,(namestring (merge-pathnames "doit.lsp" *test-sources*)) - "-eval" "(quit)")) - #+ecl (ext:setenv "ECLDIR" (namestring (truename "SYS:"))) @@ -82,8 +73,11 @@ ;;; ;;; RUNNING TESTS ;;; - -(defun run-tests () +(defun run-tests (suites + &aux (suites (cond + ((null suites) "make-check") + ((null (cdr suites)) (car suites)) + (T suites)))) ;; Cleanup stray files (delete-everything *sandbox*) (ensure-directories-exist *sandbox*) @@ -91,8 +85,20 @@ (progn (ext:chdir *sandbox*) (ext:run-program *test-image* - *test-image-args* + `("-norc" + "-eval" "(print (ext:getenv \"ECLDIR\"))" + "-eval" "(ignore-errors (require :cmp))" + "-load" ,(namestring + (merge-pathnames + "tests/doit.lsp" *ecl-sources*)) + "-eval" "(in-package cl-test)" + "-eval" ,(format nil "(2am-ecl:run '~a)" suites) + "-eval" "(ext:exit)") :input nil :output t :error :output)) - (ext:chdir *here*))) + (ext:chdir *here*) + #+ (or) + (format t "~%Known fails: ~%~{~a~%~}~%" + '(SEM-SIGNAL-N-PROCESSES + SEM-SIGNAL-ONLY-N-PROCESSES)))) diff --git a/src/tests/doit.lsp b/src/tests/doit.lsp index 603d18ddf..1ae1a0f09 100644 --- a/src/tests/doit.lsp +++ b/src/tests/doit.lsp @@ -1,7 +1,8 @@ (in-package #:common-lisp-user) (eval-when (:compile-toplevel :load-toplevel :execute) - (require :asdf)) + (require :asdf) + (require :package-locks)) (let ((cache (merge-pathnames "./cache/" *default-pathname-defaults*))) (ensure-directories-exist cache) @@ -9,4 +10,4 @@ (asdf:load-asd (merge-pathnames "ecl-tests.asd" *load-pathname*))) (asdf:operate 'asdf:load-source-op 'ecl-tests) -(2am-ecl:run 'cl-test::make-check) +#+ (or) (2am-ecl:run 'cl-test::make-check) diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd index 24fa6fdbb..e16dfee1e 100644 --- a/src/tests/ecl-tests.asd +++ b/src/tests/ecl-tests.asd @@ -5,37 +5,33 @@ :author "Daniel Kochmański " :license "LGPL-2.1+" :serial t - :components ((:file "2am") ; continuous integration + :components ((:file "1am") ; for stress tests + (:file "2am") ; continuous integration (:file "ecl-tests") (:file "universe") - (:module regressions + (:module normal-tests :default-component-class asdf:cl-source-file.lsp :components ((:file "ansi") (:file "mixed") (:file "compiler") + (:file "multiprocessing" :if-feature :threads) (:file "embedding" :if-feature (:not :ecl-bytecmp)) (:file "foreign-interface" :if-feature :ffi) (:file "metaobject-protocol" :if-feature :clos) - (:file "multiprocessing" :if-feature :threads))) - (:module features - :default-component-class asdf:cl-source-file.lsp - :components - ((:file "external-formats" :if-feature :unicode) (:file "ieee-fp" :if-feature :ieee-floating-point) (:file "package-locks" :if-feature :package-locks) - (:file "external-process") - (:file "multiprocessing"))))) + (:file "external-formats" :if-feature :unicode))) + (:module stress-tests + :default-component-class asdf:cl-source-file.lsp + :components + ((:file "multiprocessing" :if-feature :threads))))) (asdf:defsystem #:ecl-tests/stress :serial t :components - ((:file "1am") ; for stress tests - (:module stress - :default-component-class asdf:cl-source-file.lsp - :components - (#+threads - (:file "multiprocessing"))))) + ( + )) ;;; General tests (asdf:defsystem #:ecl-tests/ansi) diff --git a/src/tests/ecl-tests.lisp b/src/tests/ecl-tests.lisp index 094fbb27c..5fb6acc99 100644 --- a/src/tests/ecl-tests.lisp +++ b/src/tests/ecl-tests.lisp @@ -21,37 +21,10 @@ ;;;; Declare the suites (suite 'ecl-tests - '(regressions - features)) + '(eformat ieee-fp eprocess package-locks ansi+ mixed cmp emb ffi mop mp)) (suite 'make-check - '(features/eformat - features/ieee-fp - features/eprocess - features/package-locks - regressions/ansi+ - regressions/mixed - regressions/cmp - regressions/emb - regressions/ffi - regressions/mop - ;; disable regressions/mp due to fails - #+ (or) regressions/mp)) - -(suite 'regressions - '(regressions/ansi+ - regressions/mixed - regressions/cmp - regressions/emb - regressions/ffi - regressions/mop - regressions/mp)) - -(suite 'features - '(features/eformat - features/ieee-fp - features/eprocess - features/mp)) + '(ieee-fp eprocess package-locks ansi+ mixed cmp emb ffi mop)) ;;; Some syntactic sugar for 2am diff --git a/src/tests/features/external-process.lsp b/src/tests/features/external-process.lsp deleted file mode 100644 index d65059ce6..000000000 --- a/src/tests/features/external-process.lsp +++ /dev/null @@ -1,27 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Daniel Kochmański -;;;; Created: 2016-09-07 -;;;; Contains: External process interaction API -;;;; - -(in-package :cl-test) - -(suite 'features/eprocess) - -(test external-process.0001.run-program/wait/terminate - (let ((p (nth-value 2 (ext:run-program #-windows "sleep" - #+windows "timeout" - (list "3") :wait nil)))) - (is (eql :running (ext:external-process-wait p nil)) - "process doesn't run") - (ext:terminate-process p) - (sleep 1) - (multiple-value-bind (status code) - (ext:external-process-wait p nil) - (is (eql :signaled status) - "status is ~s, should be ~s" status :signalled) - (is (eql ext:+sigterm+ code) - "signal code is ~s, should be ~s" code ext:+sigterm+)) - (finishes (ext:terminate-process p)))) diff --git a/src/tests/features/multiprocessing.lsp b/src/tests/features/multiprocessing.lsp deleted file mode 100644 index 00f62eceb..000000000 --- a/src/tests/features/multiprocessing.lsp +++ /dev/null @@ -1,28 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Daniel Kochmański -;;;; Created: 2016-10-05 -;;;; Contains: Multithreading API tests - -(in-package :cl-test) -(suite 'features/mp) -;;; Date: 2016-10-05 -;;; From: Daniel Kochmański -;;; Description: -;;; -;;; HOLDING-LOCK-P verifies, if the current process holds the -;;; lock. -;;; -(test mp-holding-lock-p - (let ((lock (mp:make-lock :name "mp-holding-lock-p" :recursive nil))) - (is-false (mp:holding-lock-p lock)) - (mp:with-lock (lock) - (is-true (mp:holding-lock-p lock)) - (mp:process-run-function - "mp-holding-lock-p" - #'(lambda () (is-false (mp:holding-lock-p lock))))) - (is-false (mp:holding-lock-p lock)) - (mp:process-run-function - "mp-holding-lock-p" - #'(lambda () (is-false (mp:holding-lock-p lock)))))) diff --git a/src/tests/regressions/ansi.lsp b/src/tests/normal-tests/ansi.lsp similarity index 99% rename from src/tests/regressions/ansi.lsp rename to src/tests/normal-tests/ansi.lsp index 2cdcd2cb4..b72545004 100644 --- a/src/tests/regressions/ansi.lsp +++ b/src/tests/normal-tests/ansi.lsp @@ -3,7 +3,7 @@ (in-package :cl-test) -(suite 'regressions/ansi+) +(suite 'ansi+) ;; HyperSpec – 3.* diff --git a/src/tests/regressions/compiler.lsp b/src/tests/normal-tests/compiler.lsp similarity index 99% rename from src/tests/regressions/compiler.lsp rename to src/tests/normal-tests/compiler.lsp index 42af71556..0a19100ba 100644 --- a/src/tests/regressions/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -7,7 +7,7 @@ (in-package :cl-test) -(suite 'regressions/cmp) +(suite 'cmp) ;; cl-001 diff --git a/src/tests/regressions/embedding.lsp b/src/tests/normal-tests/embedding.lsp similarity index 99% rename from src/tests/regressions/embedding.lsp rename to src/tests/normal-tests/embedding.lsp index c51210474..042a95ca2 100644 --- a/src/tests/regressions/embedding.lsp +++ b/src/tests/normal-tests/embedding.lsp @@ -7,7 +7,7 @@ (in-package :cl-test) -(suite 'regressions/emb) +(suite 'emb) (defun test-C-program (c-code &key capture-output) (ensure-directories-exist "tmp/") diff --git a/src/tests/features/external-formats.lsp b/src/tests/normal-tests/external-formats.lsp similarity index 99% rename from src/tests/features/external-formats.lsp rename to src/tests/normal-tests/external-formats.lsp index 755b3d564..d7d2c45c6 100644 --- a/src/tests/features/external-formats.lsp +++ b/src/tests/normal-tests/external-formats.lsp @@ -10,7 +10,7 @@ (in-package :cl-test) -(suite 'features/eformat) +(suite 'eformat) ;;; eformat-001 diff --git a/src/tests/regressions/foreign-interface.lsp b/src/tests/normal-tests/foreign-interface.lsp similarity index 99% rename from src/tests/regressions/foreign-interface.lsp rename to src/tests/normal-tests/foreign-interface.lsp index 1f32679a7..4fbfe105f 100644 --- a/src/tests/regressions/foreign-interface.lsp +++ b/src/tests/normal-tests/foreign-interface.lsp @@ -7,7 +7,7 @@ ;;;; Contains: Foreign Function Interface regression tests (in-package :cl-test) -(suite 'regressions/ffi) +(suite 'ffi) ;;; Date: 23/03/2006 ;;; From: Klaus Falb diff --git a/src/tests/features/ieee-fp.lsp b/src/tests/normal-tests/ieee-fp.lsp similarity index 98% rename from src/tests/features/ieee-fp.lsp rename to src/tests/normal-tests/ieee-fp.lsp index c6899d311..3696913dc 100644 --- a/src/tests/features/ieee-fp.lsp +++ b/src/tests/normal-tests/ieee-fp.lsp @@ -8,7 +8,7 @@ (in-package :cl-test) -(suite 'features/ieee-fp) +(suite 'ieee-fp) (test ieee-fp.0001.infinity-eql (let ((sfni ext:single-float-negative-infinity) diff --git a/src/tests/regressions/metaobject-protocol.lsp b/src/tests/normal-tests/metaobject-protocol.lsp similarity index 99% rename from src/tests/regressions/metaobject-protocol.lsp rename to src/tests/normal-tests/metaobject-protocol.lsp index eb3b0ee5e..b9b1f5ece 100644 --- a/src/tests/regressions/metaobject-protocol.lsp +++ b/src/tests/normal-tests/metaobject-protocol.lsp @@ -8,7 +8,7 @@ (in-package #:cl-test) -(suite 'regressions/mop) +(suite 'mop) ;; mop-001 diff --git a/src/tests/regressions/mixed.lsp b/src/tests/normal-tests/mixed.lsp similarity index 86% rename from src/tests/regressions/mixed.lsp rename to src/tests/normal-tests/mixed.lsp index 418d9fcf0..cf0470a36 100644 --- a/src/tests/regressions/mixed.lsp +++ b/src/tests/normal-tests/mixed.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(suite 'regressions/mixed) +(suite 'mixed) ;;; (EXT:PACKAGE-LOCK) returned the wrong value. @@ -174,3 +174,24 @@ "Not-file stream would cause internal error on this ECL (skipped)"))) +;;;; Author: Daniel Kochmański +;;;; Created: 2016-09-07 +;;;; Contains: External process interaction API +;;;; +(test external-process.0001.run-program/wait/terminate + (let ((p (nth-value 2 (ext:run-program #-windows "sleep" + #+windows "timeout" + (list "3") :wait nil)))) + (is (eql :running (ext:external-process-wait p nil)) + "process doesn't run") + (ext:terminate-process p) + (sleep 1) + (multiple-value-bind (status code) + (ext:external-process-wait p nil) + (is (eql :signaled status) + "status is ~s, should be ~s" status :signalled) + (is (eql ext:+sigterm+ code) + "signal code is ~s, should be ~s" code ext:+sigterm+)) + (finishes (ext:terminate-process p)))) + + diff --git a/src/tests/regressions/multiprocessing.lsp b/src/tests/normal-tests/multiprocessing.lsp similarity index 97% rename from src/tests/regressions/multiprocessing.lsp rename to src/tests/normal-tests/multiprocessing.lsp index 7278725bd..56f2dbbad 100644 --- a/src/tests/regressions/multiprocessing.lsp +++ b/src/tests/normal-tests/multiprocessing.lsp @@ -7,7 +7,7 @@ (in-package :cl-test) -(suite 'regressions/mp) +(suite 'mp) ;; Auxiliary routines for multithreaded tests @@ -542,3 +542,24 @@ creating stray processes." ;;; Description: CLASS-OF called on rwlock crashed lisp process (test rwlock (finishes (class-of (mp:make-rwlock)))) + + +;;; Date: 2016-10-05 +;;; From: Daniel Kochmański +;;; Description: +;;; +;;; HOLDING-LOCK-P verifies, if the current process holds the +;;; lock. +;;; +(test mp-holding-lock-p + (let ((lock (mp:make-lock :name "mp-holding-lock-p" :recursive nil))) + (is-false (mp:holding-lock-p lock)) + (mp:with-lock (lock) + (is-true (mp:holding-lock-p lock)) + (mp:process-run-function + "mp-holding-lock-p" + #'(lambda () (is-false (mp:holding-lock-p lock))))) + (is-false (mp:holding-lock-p lock)) + (mp:process-run-function + "mp-holding-lock-p" + #'(lambda () (is-false (mp:holding-lock-p lock)))))) diff --git a/src/tests/features/package-locks.lsp b/src/tests/normal-tests/package-locks.lsp similarity index 99% rename from src/tests/features/package-locks.lsp rename to src/tests/normal-tests/package-locks.lsp index 0161f7a32..4643c156c 100644 --- a/src/tests/features/package-locks.lsp +++ b/src/tests/normal-tests/package-locks.lsp @@ -8,7 +8,7 @@ (in-package :cl-test) -(suite 'features/package-locks) +(suite 'package-locks) (defmacro with-fresh-package (name &body body) `(progn diff --git a/src/tests/regressions/external-formats.lsp b/src/tests/regressions/external-formats.lsp deleted file mode 100644 index d8982c8ce..000000000 --- a/src/tests/regressions/external-formats.lsp +++ /dev/null @@ -1,339 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: - -;;;; Author: Juan Jose Garcia-Ripoll -;;;; Created: Sat Jan 03 2:56:03 CEST 2007 -;;;; Contains: External format tests -;;;; -;;;; Based on the code and files from FLEXI-STREAMS 1.0.7 -;;;; - -(in-package :cl-test) - -(suite 'features/eformat) - - -;;; eformat-001 - -(defconstant +buffer-size+ 8192 - "Size of buffers for COPY-STREAM* below.") - -(defparameter *copy-function* 'copy-stream - "Which function to use when copying from one stream to the other - -see for example COPY-FILE below.") - -(defparameter *eformat-test-files* - '(("unicode_demo" (:utf8 :ucs2 :ucs4)) - ("kafka" (:utf8 :latin1 :cp1252)) - ("hebrew" (:utf8 :latin8)) - ("russian" (:utf8 :koi8r)) - ("tilton" (:utf8 :ascii)) - ) - "A list of test files where each entry consists of the name -prefix and a list of encodings.") - -(defun create-file-variants (file-name symbol) - "For a name suffix FILE-NAME and a symbol SYMBOL denoting an -encoding returns a list of pairs where the car is a full file -name and the cdr is the corresponding external format. This list -contains all possible variants w.r.t. to line-end conversion and -endianness." - (let ((variants (ecase symbol - (:ascii '(:us-ascii)) - (:latin1 '(:latin-1)) - (:latin8 '(:iso-8859-8)) - (:cp1252 '(:windows-cp1252)) - (:koi8r '(:koi8-r)) - (:utf8 '(:utf-8)) - (:ucs2 '(:ucs-2be :ucs-2le)) - (:ucs4 '(:ucs-4be :ucs-4le))))) - (loop for arg in variants - nconc (let* ((endian-suffix (case arg - ((:ucs-2be :ucs-4be) "_be") - ((:ucs-2le :ucs-4le) "_le") - (t "")))) - (loop for eol-style in '(:lf :cr :crlf) - collect (cons (format nil "~A_~(~A~)_~(~A~)~A.txt" - file-name symbol eol-style endian-suffix) - (list eol-style arg))))))) - -(defun create-test-combinations (file-name symbols &optional simplep) - "For a name suffix FILE-NAME and a list of symbols SYMBOLS denoting -different encodings of the corresponding file returns a list of lists -which can be used as arglists by DO-EFORMAT-TEST-001. If SIMPLEP is true, a -list which can be used for the string and sequence tests below is -returned." - (let ((file-variants (loop for symbol in symbols - nconc (create-file-variants file-name symbol)))) - (loop for (name-in . external-format-in) in file-variants - when simplep - collect (list name-in external-format-in) - else - nconc (loop for (name-out . external-format-out) in file-variants - collect (list name-in external-format-in name-out external-format-out))))) - -(defun file-equal (file1 file2) - "Returns a true value iff FILE1 and FILE2 have the same -contents \(viewed as binary files)." - (with-open-file (stream1 file1 :element-type '(unsigned-byte 8)) - (with-open-file (stream2 file2 :element-type '(unsigned-byte 8)) - (if (= (file-length stream1) (file-length stream2)) - (loop for p1 = (file-position stream1) - for byte1 = (read-byte stream1 nil nil) - for byte2 = (read-byte stream2 nil nil) - while (and byte1 byte2) - unless (= byte1 byte2) - do (return (values nil p1)) - finally (return (values t 0))) - (values nil -1))))) - -(defun copy-stream (in out) - "Copies the contents of the binary stream STREAM-IN to the -binary stream STREAM-OUT using flexi streams - STREAM-IN is read -with the external format EXTERNAL-FORMAT-IN and STREAM-OUT is -written with EXTERNAL-FORMAT-OUT." - (loop for line = (read-line in nil nil) - while line - do (write-line line out))) - -(defun copy-stream* (in out) - "Like COPY-STREAM, but uses READ-SEQUENCE and WRITE-SEQUENCE instead -of READ-LINE and WRITE-LINE." - (let ((buffer (make-array +buffer-size+ :element-type 'char*))) - (loop - (let ((position (read-sequence buffer in))) - (when (zerop position) (return)) - (write-sequence buffer out :end position))))) - -(defun do-eformat-test-001 (*copy-function*) - "Each test in this suite copies the contents of one file \(in the -`test' directory) to another file \(in a temporary directory) using -flexi streams with different external formats. The resulting file is -compared with an existing file in the `test' directory to check if the -outcome is as expected. Uses various variants of the :DIRECTION -keyword when opening the files. - -Returns a true value iff all tests succeeded. Prints information -about each individual comparison if VERBOSE is true." - (labels - ((copy-file (path-in external-format-in path-out external-format-out - direction-out direction-in) - (with-open-file (in path-in - :element-type 'character - :direction direction-in - :if-does-not-exist :error - :if-exists :overwrite - :external-format external-format-in) - (with-open-file (out path-out - :element-type 'character - :direction direction-out - :if-does-not-exist :create - :if-exists :supersede - :external-format external-format-out) - (funcall *copy-function* in out)))) - (one-comparison (path-in external-format-in path-out external-format-out) - (loop with full-path-in = (merge-pathnames path-in "./eformat-tests/") - and full-path-out = (ensure-directories-exist - (merge-pathnames path-out "./eformat-tmp/")) - and full-path-orig = (merge-pathnames path-out "./eformat-tests/") - for direction-out in '(:output :io) - nconc (loop for direction-in in '(:input :io) - for args = (list path-in external-format-in direction-in - path-out external-format-out direction-out) - with ok = nil - with pos = 0 - unless (progn - (copy-file full-path-in external-format-in - full-path-out external-format-out - direction-out direction-in) - (is (multiple-value-setq (ok pos) - (file-equal full-path-out full-path-orig)) - "~%~A -> ~A" path-in path-out)) - collect (progn - (format t "~%;;; Discordance at pos ~D~%between ~A~% and ~A~%" - pos full-path-out full-path-orig) - args))))) - (loop with do-eformat-test-001-args-list = - (loop for (file-name symbols) in *eformat-test-files* - nconc (create-test-combinations file-name symbols)) - for (path-in external-format-in path-out external-format-out) in do-eformat-test-001-args-list - nconc (one-comparison path-in external-format-in path-out external-format-out)))) - -;;; Date: 02/01/2007 -;;; From: Juanjo -;;; Fixed: Not a bug -;;; Description: -;;; -;;; Test external formats by transcoding several files into all possible -;;; supported formats and checking against the expected results. This -;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. -;;; -(test external-format.0001-transcode-read-char - (is-false (do-eformat-test-001 'copy-stream))) - -;;; Date: 02/01/2007 -;;; From: Juanjo -;;; Fixed: Not a bug -;;; Description: -;;; -;;; Test external formats by transcoding several files into all possible -;;; supported formats and checking against the expected results. This -;;; test uses READ/WRITE-CHAR via READ/WRITE-LINE. -;;; -(test external-format.0002-transcode-read-char - (is-false (do-eformat-test-001 'copy-stream*))) - - -;;; eformat-002 - -(load "sys:encodings;tools") - -(setf *print-circle* t) ; some mappings contain circular structures - -(defun binary-dump (filename &optional (position 0) (limit nil)) - (format t "~%FILE: ~A from ~D, ~D bytes" filename position limit) - (with-open-file (file filename :element-type '(unsigned-byte 8)) - (file-position file position) - (loop for i from 0 - for byte = (read-byte file nil nil) - for c = (and byte (code-char byte)) - while (and byte (or (null limit) (< i limit))) - do (progn (when (zerop (mod i 8)) (terpri)) - (format t "~5X ~3A" byte - (cond ((and (< 31 byte 127) (standard-char-p c)) - c) - ((eql c #\Esc) "ESC") - (t " "))) - ))) - (terpri) - (force-output)) - -(defun random-strings (char-bag n) - (if (consp char-bag) - (apply #'concatenate 'string - (loop for i from 0 below 2 - for actual-bag = (elt char-bag (random (length char-bag))) - collect (random-strings actual-bag (random n)))) - (concatenate 'string - (loop for i from 0 to n - for c = (char char-bag (random (length char-bag))) - unless (eql c #\Newline) - collect c)))) - -(defun compare-files (a b &optional all-chars) - (with-open-file (sa a :direction :input :element-type '(unsigned-byte 8)) - (with-open-file (sb b :direction :input :element-type '(unsigned-byte 8)) - (loop for b1 = (read-byte sa nil nil) - for b2 = (read-byte sb nil nil) - while (or b1 b2) - do (unless (eql b1 b2) - (let* ((position (1- (file-position sa))) - (start-dump (max 0 (- position 8)))) - (setf position (logandc2 position 3)) - (binary-dump a start-dump 32) - (binary-dump b start-dump 32) - (format t "~%Mismatch between~%~T~A~% and~T~A~% at file position ~D~%" - a b position) - (when all-chars - (loop with imin = (floor start-dump 4) - with imax = (min (+ imin 9) (length all-chars)) - for i from imin below imax - for j from 0 - for c = (char all-chars i) - do (progn (when (zerop (mod j 8)) (terpri)) - (format t "~4X " (char-code c)))) - (terpri)) - (return nil))) - finally (return t))))) - -(defun test-output (format-name &optional iconv-name (nlines 128) (nchars 10)) - (set 'ext::foo format-name) - (let* ((*print-circle* t) - (mappings (loop for table = (ext::make-encoding format-name) - while (and table (symbolp table)) - do (setf format-name table) - finally (return (or table format-name)))) - (char-bags (all-valid-unicode-chars mappings)) - (encoded-filename (format nil "eformat-tmp/iconv-~A.txt" format-name)) - (decoded-filename (format nil "eformat-tmp/iconv-~A-utf32.txt" format-name)) - (iconv-filename (format nil "eformat-tmp/iconv-~A-iconv-utf32.txt" format-name)) - (random-lines (loop for line from 1 to nlines - collect (random-strings char-bags nchars))) - (all-chars (apply #'concatenate 'string - (loop for i in random-lines - nconc (list i (list #\Newline)))))) - (ensure-directories-exist encoded-filename) - ;; Output in that format - (with-open-file (out encoded-filename :direction :output :external-format format-name - :if-exists :supersede) - (loop for i in random-lines - do (write-line i out))) - (with-open-file (out decoded-filename :direction :output :external-format :ucs-4be - :if-exists :supersede) - (loop for i in random-lines - do (write-line i out))) - (with-open-file (in encoded-filename :direction :input :external-format format-name) - (loop for line = (read-line in nil nil) - for i in random-lines - for n from 1 - while line - unless (string= i line) - do (progn - (format t "Mismatch on line ~D between~% ~S and~% ~S" n line i) - (return-from test-output nil)))) - (when iconv-name - (let ((command (format nil "iconv -f ~A -t UTF-32BE ~A > ~A" - iconv-name encoded-filename iconv-filename))) - (if (zerop - (si::system command)) - (compare-files decoded-filename iconv-filename all-chars) - (prog1 T - (format t "~&;;; iconv command failed:~A~%" command))))))) - -;;; Date: 09/01/2007 -;;; From: Juanjo -;;; Fixed: Not a bug -;;; Description: -;;; -;;; Test external formats by transcoding random sequences of characters using -;;; ECL and iconv. -;;; -#-msvc -;; In Windows SYSTEM does not fail with a nonzero code when it -;; fails to execute a command. Hence in that case we assume -;; we simply can not run these tests -(when (zerop (si::system "iconv -l >/dev/null 2>&1")) - (test external-format.simple-iconv-check - (is-false - (loop for name in '(:ISO-8859-1 :ISO-8859-2 :ISO-8859-3 :ISO-8859-4 - :ISO-8859-5 :ISO-8859-6 :ISO-8859-7 :ISO-8859-8 - :ISO-8859-9 :ISO-8859-10 :ISO-8859-11 :ISO-8859-13 - :ISO-8859-14 :ISO-8859-15 :ISO-8859-16 - - :KOI8-R :KOI8-U - - :IBM437 :IBM850 :IBM852 :IBM855 :IBM857 :IBM860 - :IBM861 :IBM862 :IBM863 :IBM864 :IBM865 :IBM866 - :IBM869 - - :CP936 :CP949 :CP950 - - :WINDOWS-1250 :WINDOWS-1251 :WINDOWS-1252 :WINDOWS-1253 - :WINDOWS-1254 :WINDOWS-1256 :WINDOWS-1257 - - ;; :CP932 :WINDOWS-1255 :WINDOWS-1258 with - ;; iconv may output combined characters, when ECL would - ;; output the base and the comibining one. Hence, no simple - ;; comparison is possible. - - :ISO-2022-JP - ;; :ISO-2022-JP-1 - ;; iconv doesn't support ISO-2022-JP-1 (hue hue hue) - ) - unless (progn - (loop for i from 1 to 10 - always (is (test-output name (symbol-name name)) - "iconv test ~s failed" name))) - collect name)))) - - diff --git a/src/tests/stress/multiprocessing.lsp b/src/tests/stress-tests/multiprocessing.lsp similarity index 100% rename from src/tests/stress/multiprocessing.lsp rename to src/tests/stress-tests/multiprocessing.lsp