pkgs/development/lisp-modules-new-obsolete/test/test.lisp

   1 #!/usr/bin/env -S sbcl --script
   2
   3 (require :uiop)
   4
   5 ;; prevent glibc hell
   6 (setf (uiop:getenv "LD_LIBRARY_PATH") "")
   7
   8 (defparameter packages (uiop:read-file-lines "./lispPackagesToTest.txt"))
   9
  10 (defparameter lisp (or (cadr sb-ext:*posix-argv*) "sbcl"))
  11
  12 (defparameter nix-build "nix-build -E 'with import ../../../../default.nix {}; lispPackages_new.~aPackages.~a'")
  13
  14 (defparameter cpu-count
  15   (length
  16    (remove-if-not
  17     (lambda (line)
  18       (uiop:string-prefix-p "processor" line))
  19     (uiop:read-file-lines "/proc/cpuinfo"))))
  20
  21 (defparameter sem (sb-thread:make-semaphore :count cpu-count))
  22
  23 (defparameter statuses (make-hash-table :synchronized t))
  24
  25 (defparameter log-lock (sb-thread:make-mutex))
  26
  27 (format *error-output* "Testing ~a on ~a cores~%" lisp cpu-count)
  28
  29 (defun clear-line ()
  30   (write-char #\Return *error-output*)
  31   (write-char #\Escape *error-output*)
  32   (write-char #\[ *error-output*)
  33   (write-char #\K *error-output*))
  34
  35 (declaim (type fixnum errors))
  36 (defglobal errors 0)
  37
  38 (defmacro when-let (bindings &rest body)
  39   (reduce
  40    (lambda (expansion form)
  41      (destructuring-bind (var test) form
  42        (let ((testsym (gensym (symbol-name var))))
  43          `(let ((,testsym ,test))
  44             (when ,testsym
  45               (let ((,var ,testsym))
  46                 ,expansion))))))
  47    (reverse bindings)
  48    :initial-value `(progn ,@body)))
  49
  50 (dolist (pkg packages)
  51   (sb-thread:wait-on-semaphore sem)
  52   (sb-thread:make-thread
  53    (lambda ()
  54      (handler-case
  55          (unwind-protect
  56               (multiple-value-bind (out err code)
  57                   (uiop:run-program
  58                    (format nil nix-build lisp pkg)
  59                    :error-output '(:string :stripped t)
  60                    :ignore-error-status t)
  61                 (declare (ignorable err))
  62                 (setf (gethash pkg statuses) code)
  63                 (when-let ((pos (search "LOAD-FOREIGN-LIBRARY-ERROR" err :test #'string=))
  64                            (lines (uiop:split-string (subseq err pos) :separator '(#\Newline))))
  65                   (setf (gethash pkg statuses)
  66                         (fourth lines)))
  67                 (sb-thread:with-mutex (log-lock)
  68                   (clear-line)
  69                   (format *error-output* "[~a/~a] ~[OK~:;ERROR~] ~a~[~:;~%~]"
  70                           (hash-table-count statuses)
  71                           (length packages)
  72                           code
  73                           pkg
  74                           code)
  75                   (force-output *error-output*))
  76                 (unless (zerop code)
  77                   (sb-ext:atomic-incf errors)))
  78            (sb-thread:signal-semaphore sem))
  79        (error (e)
  80          (format t "~a~%" e)
  81          (sb-ext:quit :recklessly-p t :unix-status 1))))))
  82
  83 (sb-thread:wait-on-semaphore sem :n cpu-count)
  84
  85 (format t "~%Done (~a/~a)."
  86         (- (length packages) errors)
  87         (length packages))
  88
  89 (when (plusp errors)
  90   (format t "~%~%~a Errors: " errors)
  91   (maphash (lambda (k v)
  92              (unless (and (numberp v) (zerop v))
  93                (format t "~%  ~a: ~a" k v)))
  94            statuses))