test_pure.ss

#! /usr/bin/env -S chez-scheme --script

;; Test script to help verify the correctness of the pure scheme implementation
;; against the installed libev shared lib.

;; It uses our FFI wrapper lib to see if the pure scheme implementation idea of libev
;; matches that of the real one.

;; Currently that's pretty broad, only struct size and public member offsets are checked.

(import
  (chezscheme)
  (ev ftypes-util))

;; #t show both success and error messages.
;; #f show only error messages.
(define verbose? #f)

(define load-lib
  (load-shared-object "ev/libchez-ffi.so"))

(define mem=?
  (let ([f (foreign-procedure "memcmp" (void* void* size_t) int)])
    (lambda (mem-a mem-b sz)
      (and (= (f (ftype-pointer-address mem-a) (ftype-pointer-address mem-b) sz) 0) #t))))

(define return-code 0)

(define-syntax ev-simple-function
  (syntax-rules ()
    [(_ (name rest ...) ...)
     (ev-function (name () rest ...) ...)]))

;; pure.scm is autogenerated, see GNUmakefile.
(include "pure.scm")

(ev-simple-function
  (Make-ev-io		(int int (* ev-io-cb-t))	(* ev-io-t))
  (Make-ev-timer	(ev-tstamp ev-tstamp (* ev-timer-cb-t))	(* ev-timer-t))
  (Make-ev-periodic	(ev-tstamp ev-tstamp (* ev-periodic-reschedule-cb-t) (* ev-periodic-cb-t))	(* ev-periodic-t))
  (Make-ev-signal	(int (* ev-signal-cb-t))	(* ev-signal-t))
  (Make-ev-child	(int int (* ev-child-cb-t))	(* ev-child-t))
  (Make-ev-stat	(string ev-tstamp (* ev-stat-cb-t))	(* ev-stat-t))
  (Make-ev-idle	((* ev-idle-cb-t))	(* ev-idle-t))
  (Make-ev-prepare	((* ev-prepare-cb-t))	(* ev-prepare-t))
  (Make-ev-check	((* ev-check-cb-t))	(* ev-check-t))
  (Make-ev-embed	((* ev-loop) (* ev-embed-cb-t))	(* ev-embed-t))
  (Make-ev-fork	((* ev-fork-cb-t))	(* ev-fork-t))
  (Make-ev-cleanup	((* ev-cleanup-cb-t))	(* ev-cleanup-t))
  (Make-ev-async	((* ev-async-cb-t))	(* ev-async-t))
  (ev-version-major	()	int)
  (ev-version-minor	()	int)
  (ev-default-loop	(int)			(* ev-loop))
  (ev-io-start		((* ev-loop) (* ev-io-t))		void)
  (Ev-io-modify		((* ev-io-t) int)	void)
  (Ev-is-active		((* ev-watcher))	boolean)
  (Ev-periodic-at	((* ev-periodic-t))	ev-tstamp)
  (Ev-async-pending	((* ev-async-t))	boolean)
  )

(ffi-wrapper-function
  [ev-statdata-sizeof			()	size_t]
  )

(ffi-wrapper-function
  [ev-io-sizeof				()	size_t]
  [ev-io-fd-offsetof			()	size_t]
  [ev-io-events-offsetof		()	size_t]
  [ev-timer-sizeof			()	size_t]
  [ev-timer-after-offsetof		()	size_t]
  [ev-timer-repeat-offsetof		()	size_t]
  [ev-periodic-sizeof			()	size_t]
  [ev-periodic-offset-offsetof		()	size_t]
  [ev-periodic-interval-offsetof	()	size_t]
  [ev-periodic-reschedule-cb-offsetof	()	size_t]
  [ev-signal-sizeof			()	size_t]
  [ev-signal-signum-offsetof		()	size_t]
  [ev-child-sizeof			()	size_t]
  [ev-child-trace-offsetof		()	size_t]
  [ev-child-pid-offsetof		()	size_t]
  [ev-child-rpid-offsetof		()	size_t]
  [ev-child-rstatus-offsetof		()	size_t]
  [ev-stat-sizeof			()	size_t]
  [ev-stat-attr-offsetof		()	size_t]
  [ev-stat-interval-offsetof		()	size_t]
  [ev-stat-path-offsetof		()	size_t]
  [ev-stat-prev-offsetof		()	size_t]
  [ev-stat-timer-offsetof		()	size_t]
  [ev-stat-wd-offsetof			()	size_t]
  [ev-idle-sizeof			()	size_t]
  [ev-prepare-sizeof			()	size_t]
  [ev-check-sizeof			()	size_t]
  [ev-fork-sizeof			()	size_t]
  [ev-cleanup-sizeof			()	size_t]
  [ev-embed-sizeof			()	size_t]
  [ev-embed-other-offsetof		()	size_t]
  [ev-async-sizeof			()	size_t]
  )

(define-syntax say
  (syntax-rules ()
    [(_ fmt-str args ...)
     (format verbose? fmt-str args ...)]))

(define-syntax doh!
  (syntax-rules ()
    [(_ fmt-str args ...)
     (begin
       (format (current-error-port) fmt-str args ...)
       (set! return-code 1))]))

(define-syntax test-ftype-sizeof
  (syntax-rules ()
    [(_ ev-t c-sizeof)
     (let ([lhs (ftype-sizeof ev-t)]
           [rhs (c-sizeof)])
       (if (= lhs rhs)
         (say "sizeof ~a scheme ~d == c ~d~n" 'ev-t lhs rhs)
         (doh! "sizeof ~a scheme ~d != c ~d~n" 'ev-t lhs rhs)))]))

(define-syntax test-offset
  (syntax-rules ()
    [(_ ev-t field c-offset)
     (let ([lhs (ftype-offsetof ev-t field)]
           [rhs (c-offset)])
       (if (= lhs rhs)
         (say "~a.~a scheme ~d == c ~d~n" 'ev-t 'field lhs rhs)
         (doh! "~a.~a scheme ~d != c ~d~n" 'ev-t 'field lhs rhs)))]))

;; TODO test return-type? predicate.
;; TODO test free watcher. I'm not sure how, maybe define my own mem alloc?
(define-syntax test-make-memory
  (lambda (x)
    (syntax-case x ()
      [(_ type (args ...) ...)
       (identifier? #'type)
       (with-syntax ([ffi-func (make-id-syntax #'type "Make-" #'type)]
                     [pure-func (make-id-syntax #'type "make-" #'type)]
                     [cb-t (make-id-syntax #'type #'type "-cb-t")]
                     [sizeof (make-id-syntax #'type #'type "-sizeof")])
         #'(begin
             (let* ([cb (make-ftype-pointer cb-t (lambda (loop w rev) (void)))]
                    [mem-ffi (ffi-func args ... cb)]
                    [mem-pure (pure-func args ... cb)])
               (if (mem=? mem-ffi mem-pure (sizeof))
                 (say "make-mem= ~a bytes ~a args ~s~n" 'type (sizeof) '(args ...))
                 (doh! "make-mem<> ~a bytes ~a args ~s~n" 'type (sizeof) '(args ...))))
             ...
             ))]
      [(_ (x ...) ...)
       #'(begin
           (test-make-memory x ...) ...)])))

;; Keep this synced to major/minor version of libev that these bindings have been tested against.
(if (not (= (ev-version-major) 4))
  (say "Warning: ev-version-major != 4 (value: ~a)~n" (ev-version-major))
  (if (> (ev-version-minor) 33)
    (say "Warning: ev-version-minor > 33 (value: ~a)~n" (ev-version-minor))))

(test-ftype-sizeof ev-statdata ev-statdata-sizeof)
(test-ftype-sizeof ev-io-t ev-io-sizeof)
(test-ftype-sizeof ev-timer-t ev-timer-sizeof)
(test-ftype-sizeof ev-periodic-t ev-periodic-sizeof)
(test-ftype-sizeof ev-signal-t ev-signal-sizeof)
(test-ftype-sizeof ev-child-t ev-child-sizeof)
(test-ftype-sizeof ev-stat-t ev-stat-sizeof)
(test-ftype-sizeof ev-idle-t ev-idle-sizeof)
(test-ftype-sizeof ev-prepare-t ev-prepare-sizeof)
(test-ftype-sizeof ev-check-t ev-check-sizeof)
(test-ftype-sizeof ev-fork-t ev-fork-sizeof)
(test-ftype-sizeof ev-cleanup-t ev-cleanup-sizeof)
(test-ftype-sizeof ev-embed-t ev-embed-sizeof)
(test-ftype-sizeof ev-async-t ev-async-sizeof)

(test-offset ev-io-t fd ev-io-fd-offsetof)
(test-offset ev-io-t events ev-io-events-offsetof)
(test-offset ev-timer-t at ev-timer-after-offsetof)
(test-offset ev-timer-t repeat ev-timer-repeat-offsetof)
(test-offset ev-periodic-t offset ev-periodic-offset-offsetof)
(test-offset ev-periodic-t interval ev-periodic-interval-offsetof)
(test-offset ev-periodic-t reschedule-cb ev-periodic-reschedule-cb-offsetof)
(test-offset ev-signal-t signum ev-signal-signum-offsetof)
(test-offset ev-child-t flags ev-child-trace-offsetof)
(test-offset ev-child-t pid ev-child-pid-offsetof)
(test-offset ev-child-t rpid ev-child-rpid-offsetof)
(test-offset ev-child-t rstatus ev-child-rstatus-offsetof)
(test-offset ev-stat-t timer ev-stat-timer-offsetof)
(test-offset ev-stat-t interval ev-stat-interval-offsetof)
(test-offset ev-stat-t path ev-stat-path-offsetof)
(test-offset ev-stat-t prev ev-stat-prev-offsetof)
(test-offset ev-stat-t attr ev-stat-attr-offsetof)
(test-offset ev-stat-t wd ev-stat-wd-offsetof)
(test-offset ev-embed-t other ev-embed-other-offsetof)

;; Test make-ev-TYPE constructors. ie, compare pure scheme init vs C libev init.
;; The actual arg values aren't important, only that ev structs are initialised the same.
;; Bytes in memory created by pure scheme will be compared to that made by libev.
(define rcb
  (make-ftype-pointer
    ev-periodic-reschedule-cb-t
    (lambda (w now)
      (+ now 22))))
(define loop-null (make-ftype-pointer ev-loop 0))
(define loop-deadbeef (make-ftype-pointer ev-loop #xdeadbeef))
(test-make-memory
  (ev-io	; (fd events)
    (1 2)
    (2 1)
    (#xdead #xbeef))
  (ev-timer	; (after repeat)
    (4 8)	; mix both fixnum and flonum inputs
    (2.0 6.5)
    (77 8.0)
    (9.5 33))
  (ev-periodic	; (offset interval reschedule-cb)
    (10 5 rcb)
    (2 4.5 rcb)
    (1.0 7 rcb)
    (3.5 9.9 rcb))
  (ev-signal	; (signum)
    (0)
    (1)
    (15))
  (ev-child	; (pid trace)
    (777 0)
    (124445 1)
    ;; trace must be 0 or 1, libev will quietly cast non-zero to 1.
    ;; These bindings don't, but maybe they should?
    #;(444 2))
  (ev-idle
    ())
  (ev-prepare
    ())
  (ev-check
    ())
  (ev-fork
    ())
  (ev-cleanup
    ())
  (ev-embed	; (other)
    (loop-null)
    (loop-deadbeef))
  (ev-async
    ())
  )

;; Constructors for ev-stat will allocate foreign memory for strings (ala strdup)
;; so we can't compare those. Instead, test the accessors.
#;(ev-stat	; (path interval)
  ("/bin/sh" 5)
  ("/tmp" 4.0))

(let ([st (make-ev-stat "/bin/sh" 5 (make-ftype-pointer ev-stat-cb-t (lambda (loop w rev) (void))))])
  (if (string=? "/bin/sh" (ev-stat-path-get* st))
    (say "string= ev-stat-path-get* ~s~n" (ev-stat-path-get* st))
    (doh! "string<> ev-stat-path-get* scheme ~s expected ~s~n" (ev-stat-path-get* st) "/bin/sh"))
  (if (= (ev-stat-interval-get st) 5)
    (say "interval= ev-stat-interval-get ~s~n" (ev-stat-interval-get st))
    (doh! "interval<> ev-stat-interval-get scheme ~s expected ~s~n" (ev-stat-interval-get st) 5)))

;;;; Test extra macro redefinitions.

;; ev-io-modify
(let* ([cb (make-ftype-pointer ev-io-cb-t (lambda (w rev) (void)))]
       [pure-mem (make-ev-io 2 (evmask 'READ 'WRITE) cb)]
       [ffi-mem (Make-ev-io 2 (evmask 'READ 'WRITE) cb)])
  (ev-io-modify pure-mem (evmask 'WRITE))
  (Ev-io-modify ffi-mem (evmask 'WRITE))
  (if (mem=? pure-mem ffi-mem (ev-io-sizeof))
    (say "mem= ev-io-modify (2 2)~n")
    (doh! "mem<> ev-io-modify (2 2)~n")))

;; ev-is-active
(let ([pure-mem (make-ev-io 0 (evmask 'READ) (make-ftype-pointer ev-io-cb-t (lambda (w rev) (void))))]
      [ffi-mem (Make-ev-io 0 (evmask 'READ) (make-ftype-pointer ev-io-cb-t (lambda (w rev) (void))))])
  (if (and (not (ev-is-active pure-mem))	; must start inactive
           (eq? (ev-is-active pure-mem) (ev-is-active ffi-mem)))
    (say "= ev-is-active ~a~n" (ev-is-active pure-mem))
    (doh! "!= ev-is-active scheme ~a ffi ~a~n" (ev-is-active pure-mem) (ev-is-active ffi-mem)))
  ;; Test the ffi wrapper too.
  (if (and (not (Ev-is-active pure-mem))	; must start inactive
           (eq? (Ev-is-active pure-mem) (Ev-is-active ffi-mem)))
    (say "= Ev-is-active ~a~n" (Ev-is-active pure-mem))
    (doh! "!= Ev-is-active scheme ~a ffi ~a~n" (Ev-is-active pure-mem) (Ev-is-active ffi-mem)))
  ;; Assume ev-multiplicity? is #t...
  ;; `ev-io-start` is locally defined and needs the loop arg.
  (ev-io-start (ev-default-loop 0) pure-mem)
  (ev-io-start (ev-default-loop 0) ffi-mem)
  (if (and (ev-is-active pure-mem)
           (eq? (ev-is-active pure-mem) (ev-is-active ffi-mem)))
    (say "= ev-is-active #t~n")
    (doh! "!= ev-is-active scheme ~a ffi ~a~n" (ev-is-active pure-mem) (ev-is-active ffi-mem)))
  ;; Test the ffi wrapper too.
  (if (and (Ev-is-active pure-mem)
           (eq? (Ev-is-active pure-mem) (Ev-is-active ffi-mem)))
    (say "= Ev-is-active #t~n")
    (doh! "!= Ev-is-active scheme ~a ffi ~a~n" (Ev-is-active pure-mem) (Ev-is-active ffi-mem))))

;; ev-periodic-at
(let ([pure-mem (make-ev-periodic 10 5 rcb (make-ftype-pointer ev-periodic-cb-t (lambda (loop w rev) (void))))])
  (if (= (ev-periodic-at pure-mem) (Ev-periodic-at pure-mem))
    (say "= ev-periodic-at ~a~n" (ev-periodic-at pure-mem))
    (doh! "!= ev-periodic-at scheme ~a ffi ~a~n" (ev-periodic-at pure-mem) (Ev-periodic-at pure-mem))))

;; ev-async-pending
(let ([pure-mem (make-ev-async (make-ftype-pointer ev-async-cb-t (lambda (loop w rev) (void))))])
  (if (eq? (ev-async-pending pure-mem) (Ev-async-pending pure-mem))
    (say "= ev-async-pending ~a~n" (ev-async-pending pure-mem))
    (doh! "!= ev-async-pending scheme ~a ffi ~a~n" (ev-async-pending pure-mem) (Ev-async-pending pure-mem))))

(exit return-code)