1.1--- a/lisp/lib/net/net.asd Thu May 23 19:07:51 2024 -0400
1.2+++ b/lisp/lib/net/net.asd Thu May 23 20:59:01 2024 -0400
1.3@@ -16,7 +16,7 @@
1.4 :components ((:file "pkg")
1.5 (:file "err")
1.6 (:file "obj")
1.7- ;; (:file "sans-io")
1.8+ (:file "sans-io")
1.9 (:file "util")
1.10 (:file "udp")
1.11 (:file "tcp")
2.1--- a/lisp/lib/net/pkg.lisp Thu May 23 19:07:51 2024 -0400
2.2+++ b/lisp/lib/net/pkg.lisp Thu May 23 20:59:01 2024 -0400
2.3@@ -19,9 +19,9 @@
2.4 (:use :cl :obj :dat/proto :std :log :net/core :sb-bsd-sockets)
2.5 (:export :get-address-by-name))
2.6
2.7-;; (defpackage :net/sans-io
2.8-;; (:use :cl :obj :dat/proto :std :net/core :sb-bsd-sockets)
2.9-;; (:export))
2.10+(defpackage :net/sans-io
2.11+ (:use :cl :obj :dat/proto :std :net/core :sb-bsd-sockets)
2.12+ (:export))
2.13
2.14 (defpackage :net/udp
2.15 (:nicknames :udp)
2.16@@ -311,7 +311,7 @@
2.17 :net/core
2.18 :net/tcp
2.19 :net/udp
2.20- ;; :net/sans-io
2.21+ :net/sans-io
2.22 :net/codec/dns
2.23 :net/codec/osc
2.24 :net/codec/tlv
3.1--- a/lisp/lib/net/tests.lisp Thu May 23 19:07:51 2024 -0400
3.2+++ b/lisp/lib/net/tests.lisp Thu May 23 20:59:01 2024 -0400
3.3@@ -8,7 +8,7 @@
3.4 (in-readtable :std)
3.5 (deftest sanity ())
3.6
3.7-(deftest sans-io ()
3.8+(deftest sans-io (:disabled t)
3.9 (defclass mock-transport-config (transport-config)
3.10 (max-bidi-streams
3.11 max-uni-streams
3.12@@ -48,7 +48,7 @@
3.13
3.14 (deftest osc ())
3.15
3.16-(deftest crew ()
3.17+(deftest crew (:disabled t)
3.18 (let ((pool (make-worker-pool (make-instance 'crew-connection-info :host-name "localhost" :port 9999)
3.19 (list (make-instance 'crew-connection-info :host-name "localhost" :port 10000))
3.20 #'connect-worker)))
3.21@@ -119,8 +119,6 @@
3.22 ;; update-count 0)
3.23 ;; (eval-repeatedly-async-state pool work-form 10 #'update-state))))
3.24
3.25-(deftest crew ())
3.26-
3.27 (deftest http ()
3.28 (let ((req (make-http-request))
3.29 (cb (make-callbacks)))
3.30@@ -137,5 +135,5 @@
3.31 Cookie: name=wookie
3.32
3.33 "#))
3.34- (is req)
3.35- (is cb)))
3.36+ (is cb)
3.37+ (is req)))
4.1--- a/lisp/lib/rt/pkg.lisp Thu May 23 19:07:51 2024 -0400
4.2+++ b/lisp/lib/rt/pkg.lisp Thu May 23 20:59:01 2024 -0400
4.3@@ -290,9 +290,8 @@
4.4 (defgeneric find-test (self name &key &allow-other-keys)
4.5 (:documentation "Find `test' object specified by name and optional keys."))
4.6
4.7-(defgeneric do-test (self &optional test)
4.8- (:documentation
4.9- "Run `test' SELF, printing results to `*standard-output*'. The second
4.10+(defgeneric do-test (self &optional context)
4.11+ (:documentation "Run test SELF, printing results to *standard-output*. The second
4.12 argument is an optional fixture.
4.13
4.14 SELF can also be a `test-suite', in which case the TESTS slot is
4.15@@ -391,17 +390,18 @@
4.16 (defmethod funcall-test ((self test) &key declare)
4.17 (unless (functionp (test-fn self))
4.18 (trace! (setf (symbol-function (test-fn self))
4.19- (eval `(lambda ()
4.20- ,(when declare `(declare ,declare))
4.21- ,@(test-form self))))))
4.22+ (eval `(lambda ()
4.23+ ,(when declare `(declare ,declare))
4.24+ ,@(test-form self))))))
4.25 (funcall (test-fn self)))
4.26
4.27 (defmethod compile-test ((self test) &key declare &allow-other-keys)
4.28- (compile
4.29- (test-fn self)
4.30- `(lambda ()
4.31- ,(when declare `(declare ,declare))
4.32- ,@(test-form self))))
4.33+ (with-compilation-unit (:policy '(optimize debug))
4.34+ (compile
4.35+ (test-fn self)
4.36+ `(lambda ()
4.37+ ,(when declare `(declare ,declare))
4.38+ ,@(test-form self)))))
4.39
4.40 (defun fail! (form &optional fmt &rest args)
4.41 (let ((reason (and fmt (apply #'format nil fmt args))))
4.42@@ -422,7 +422,7 @@
4.43 (defmethod do-test ((self test) &optional fx)
4.44 (declare (ignorable fx))
4.45 (with-test-env self
4.46- (info! "running test: " *testing*)
4.47+ (trace! "running test: " *testing*)
4.48 (flet ((%do ()
4.49 (if-let ((opt *compile-tests*))
4.50 ;; RESEARCH 2023-08-31: with-compilation-unit?
4.51@@ -434,7 +434,7 @@
4.52 (funcall (compile-test self :declare opt))
4.53 (setf %test-result (make-test-result :pass (test-fn self))))
4.54 (progn
4.55- (funcall-test self)
4.56+ (funcall-test self :declare '(optimize (debug 3) (safety 0)))
4.57 (setf %test-result (make-test-result :pass (test-name self)))))))
4.58 (if *catch-test-errors*
4.59 (handler-bind
4.60@@ -446,6 +446,12 @@
4.61 (%do))
4.62 (%do)))))
4.63
4.64+(defmethod do-test ((self simple-string) &optional fixture)
4.65+ (do-test (find-test *test-suite* self) fixture))
4.66+
4.67+(defmethod do-test ((self symbol) &optional fixture)
4.68+ (do-test (find-test *test-suite* (symbol-name self)) fixture))
4.69+
4.70 ;;;; Fixtures
4.71
4.72 ;; Our fixtures are just closures - with a pandoric environment. You
4.73@@ -535,23 +541,20 @@
4.74 (do-test (pop-test self)))
4.75 self))
4.76
4.77-(defmethod do-test ((self simple-string) &optional test)
4.78- (let ((suite (find-suite self)))
4.79- (do-test suite test)))
4.80-
4.81-(defmethod do-test ((self symbol) &optional test)
4.82- (do-test (symbol-name self) test))
4.83-
4.84 ;; HACK 2023-09-01: find better method of declaring failures from
4.85 ;; within the body of `deftest'.
4.86 (defmethod do-suite ((self test-suite) &key stream force)
4.87 (when stream (setf (test-stream self) stream))
4.88 (with-slots (name stream) self
4.89- (format stream "in suite ~x with ~A/~A tests:~%"
4.90- name
4.91- (count t (tests self)
4.92- :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))
4.93- (length (tests self)))
4.94+ (format stream "in suite ~x:~%"
4.95+ name)
4.96+ (format stream "; with ~A~A tests~%"
4.97+ (if force
4.98+ ""
4.99+ (format nil "~A/"
4.100+ (count t (tests self)
4.101+ :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))))
4.102+ (length (tests self)))
4.103 ;; loop over each test, calling `do-test'. if locked or
4.104 ;; persistent, test is performed. if FORCE is non-nil all tests
4.105 ;; are performed.
4.106@@ -567,7 +570,7 @@
4.107 ;; collect if locked test not expected
4.108 (loop for r in (test-results self)
4.109 unless (test-pass-p r)
4.110- collect r)))
4.111+ collect r)))
4.112 (if (null locked)
4.113 (format stream "~&No tests failed.~%")
4.114 (progn
4.115@@ -600,15 +603,17 @@
4.116 (do-suite *test-suite* :stream stream))
4.117
4.118 ;;; Checks
4.119-(flet ((%test (val form)
4.120- (let ((r
4.121- (if val
4.122- (make-test-result :pass form)
4.123- (make-test-result :fail form))))
4.124- (info! r)
4.125- r)))
4.126- (defmacro is (test &rest args)
4.127- "The DWIM Check.
4.128+(eval-when (:compile-toplevel)
4.129+ (defun %test (val &optional form)
4.130+ (let ((r
4.131+ (if val
4.132+ (make-test-result :pass form)
4.133+ (make-test-result :fail form))))
4.134+ ;; (print r *standard-output*)
4.135+ r)))
4.136+
4.137+(defmacro is (test &rest args)
4.138+ "The DWIM Check.
4.139
4.140 (is (= 1 1)) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
4.141 If TEST returns a truthy value, return a PASS test-result, else return
4.142@@ -631,14 +636,14 @@
4.143 "
4.144 (with-gensyms (form)
4.145 `(if ,(null args)
4.146- (if *testing*
4.147- (push-result (funcall ,#'%test ,test ',test) *testing*)
4.148- (funcall ,#'%test ,test ',test))
4.149- (macrolet ((,form (test) `(let ,,(group args 2) ,,test)))
4.150+ (if *testing*
4.151+ (push-result (funcall 'rt::%test ,test ',test) *testing*)
4.152+ (funcall #'rt::%test ,test ',test))
4.153+ (macrolet ((,form (test) `(let ,,(group args 2) ,test)))
4.154 ;; TODO 2023-09-21: does this work...
4.155 (if *testing*
4.156- (push-result (funcall ,#'%test (,form ,test) ',test) *testing*)
4.157- (funcall ,#'%test (,form ,test) ',test)))))))
4.158+ (push-result (funcall #'rt::%test (,form ,test) ',test) *testing*)
4.159+ (funcall #'rt::%test (,form ,test) ',test))))))
4.160
4.161 (defmacro signals (condition-spec &body body)
4.162 "Generates a passing TEST-RESULT if body signals a condition of type
4.163@@ -677,23 +682,23 @@
4.164
4.165 :DISABLED - don't push this test to the current *TEST-SUITE*
4.166
4.167+:BENCH - enable benchmarking of this test
4.168+
4.169 BODY is parsed with SB-INT:PARSE-BODY and will fill in documentation
4.170 and declarations for the test body.
4.171 "
4.172 (destructuring-bind (pr doc dec fn)
4.173 (multiple-value-bind (forms dec doc)
4.174 ;; parse body with docstring allowed
4.175- (sb-int:parse-body (or body) t)
4.176- `(,props ',doc ',dec ',forms))
4.177+ (parse-body (or body) :documentation t :whole t)
4.178+ `(,props ,doc ,dec ',forms))
4.179 ;; TODO 2023-09-21: parse plist
4.180 `(let ((obj (make-test
4.181 :name ,(format nil "~A" name)
4.182- ;; note: we could leave these unbound if we want,
4.183- ;; personal preference
4.184 :form ,fn
4.185 ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
4.186 ,@(when-let ((v (getf pr :args))) `(:args ,v))
4.187- ;; ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
4.188+ ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
4.189 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
4.190 ,@(when doc `(:doc ,doc))
4.191 ,@(when dec `(:declaration ,dec)))))
