;;; -*- Mode: Scheme; scheme48-package: fasl-tests -*-

;;;; Fasloader & Fasdumper
;;;; Tests

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (call-with-string-fasdump-port recipient)
  (let ((fasdump-port (make-block-fasdump-port usual-fasl-encoder)))
    (recipient fasdump-port)
    (call-with-string-output-port
      (lambda (output-port)
        (write-block-fasdump fasdump-port output-port)))))

(define *fasl-tests* '())

(define (make-test name dump load)
  (let ((test (list name dump load)))
    (set! *fasl-tests* (cons test *fasl-tests*))
    test))

(define (run-fasl-tests)
  ((lambda (do-test)
     (for-each do-test (reverse *fasl-tests*)))
   (lambda (test)
     (receive (ok? condition) (run-test test)
       (cond (ok?
              (display ";Passed: ")
              (write (car test))
              (newline))
             (else
              (display ";** Failed: ")
              (write (car test))
              (newline)
              (if condition
                  (display-condition condition
                                     (current-output-port)))))))))

(define (run-test test)
  (with-fasl-condition-handlers
    (lambda ()
      (let ((dump (cadr test))
            (load (caddr test)))
        (let* ((string (call-with-string-fasdump-port dump))
               (string-port (make-string-input-port string))
               (fasload-port
                (open-block-fasload-port string-port
                                         usual-fasl-decoder)))
          (if (and (load fasload-port)
                   (maybe-fasload fasload-port
                                  (lambda (obj) obj #f)
                                  (lambda () #t)))
              (values #t #t)
              (values #f #f)))))))

(define (with-fasl-condition-handlers thunk)
  (call-with-current-continuation
    (lambda (k)
      (with-fasdump-condition-handler
          (lambda (condition)
            (k #f condition))
        (lambda ()
          (with-fasload-condition-handler
              (lambda (condition)
                (k #f condition))
            thunk))))))

(define (check-header fasload-port header)
  (let ((char (peek-char fasload-port)))
    (and (not (eof-object? char))
         (= (char->ascii char)
            header))))

(define test-immediates
  (make-test 'immediates
             (lambda (fasdump-port)
               (define (dump x) (fasdump x fasdump-port))
               (dump '())
               (dump #t)
               (dump #f)
               (dump #\x)
               (dump (eof-object))
               (dump (unspecific)))
             (lambda (fasload-port)
               (define (check expected)
                 (and (check-header fasload-port
                                    (enum fasl-header IMMEDIATE))
                      (eqv? (fasload fasload-port) expected)))
               (and (check '())
                    (check #t)
                    (check #f)
                    (check #\x)
                    (check (eof-object))
                    (check (unspecific))))))

(define test-integers
  (make-test 'integers
             (lambda (fasdump-port)
               (fasdump 123 fasdump-port)
               (fasdump 1234 fasdump-port)
               (fasdump -123 fasdump-port)
               (fasdump -1234 fasdump-port)
               (fasdump #x10101 fasdump-port))
             (lambda (fasload-port)
               (define (check expected)
                 (and (check-header fasload-port
                                    (enum fasl-header IMMEDIATE))
                      (eqv? (fasload fasload-port)
                            expected)))
               (and (check 123)
                    (check 1234)
                    (check -123)
                    (check -1234)
                    (check #x10101)))))

(define test-pair
  (make-test 'pair
             (lambda (fasdump-port)
               (fasdump '(0 . 1) fasdump-port))
             (lambda (fasload-port)
               (equal? (fasload fasload-port) '(0 . 1)))))

(define test-pairs
  (make-test
   'pairs
   (lambda (fasdump-port)
     (define (dump x) (fasdump x fasdump-port))
     (let* ((p '(2 . 3))
            (q (cons 1 p))
            (r (cons 0 (cons 1 #f))))
       (set-cdr! (cdr r) r)
       (dump p)
       (dump q)
       (dump r)))
   (lambda (fasload-port)
     (and (check-header fasload-port
                        (enum fasl-header SHARED-OBJECT))
          (let ((p (fasload fasload-port)))
            (and (equal? p '(2 . 3))
                 (check-header fasload-port
                               (enum fasl-header UNSHARED-OBJECT))
                 (let ((q (fasload fasload-port)))
                   (and (equal? q (cons 1 p))
                        (check-header fasload-port
                                      (enum fasl-header SHARED-OBJECT))
                        (let ((r (fasload fasload-port)))
                          (and (pair? r)
                               (eqv? (car r) 0)
                               (pair? (cdr r))
                               (eqv? (cadr r) 1)
                               (eq? (cddr r) r)))))))))))

(define test-pairs&integers
  (make-test 'pairs&integers
             (lambda (fasdump-port)
               (fasdump 123 fasdump-port)
               (let ((x (cons 12 (cons #x34 #x56))))
                 (fasdump (cdr x) fasdump-port)
                 (fasdump #x34 fasdump-port)
                 (fasdump x fasdump-port)
                 (fasdump (cdr x) fasdump-port))
               (fasdump #x100 fasdump-port))
             (lambda (fasload-port)
               (and (check-header fasload-port
                                  (enum fasl-header IMMEDIATE))
                    (eqv? (fasload fasload-port)
                          123)
                    (check-header fasload-port
                                  (enum fasl-header SHARED-OBJECT))
                    (let ((xd (fasload fasload-port)))
                      (and (pair? xd)
                           (eqv? (car xd) #x34)
                           (eqv? (cdr xd) #x56)
                           (check-header fasload-port
                                         (enum fasl-header IMMEDIATE))
                           (eqv? (fasload fasload-port) #x34)
                           (check-header fasload-port
                                         (enum fasl-header
                                               UNSHARED-OBJECT))
                           (let ((x (fasload fasload-port)))
                             (and (pair? x)
                                  (eqv? (car x) 12)
                                  (eq? (cdr x) xd)))
                           (check-header fasload-port
                                         (enum fasl-header REFERENCE))
                           (eq? (fasload fasload-port) xd)))
                    (check-header fasload-port
                                  (enum fasl-header IMMEDIATE))
                    (eqv? (fasload fasload-port) #x100)))))

(define test-many-pairs
  (make-test 'many-pairs
             (lambda (fasdump-port)
               (let ((tail (cons 2 3)))
                 (fasdump tail fasdump-port)
                 (do ((i 0 (+ i 1)))
                     ((= i 1000))
                   (fasdump (cons i tail) fasdump-port))))
             (lambda (fasload-port)
               (let ((tail (fasload fasload-port)))
                 (and (pair? tail)
                      (eqv? (car tail) 2)
                      (eqv? (cdr tail) 3)
                      (let loop ((i 0))
                        (or (= i 1000)
                            (let ((obj (fasload fasload-port)))
                              (and (pair? obj)
                                   (eqv? (car obj) i)
                                   (eq? (cdr obj) tail)
                                   (loop (+ i 1)))))))))))

(define test-vector
  (make-test 'vector
             (lambda (fasdump-port)
               (fasdump '#(0 1 2) fasdump-port))
             (lambda (fasload-port)
               (equal? (fasload fasload-port)
                       '#(0 1 2)))))

(define test-vectors
  (make-test 'vectors
             (lambda (fasdump-port)
               (let* ((v1 '#(0 3 (5 . 7)))
                      (v0 (make-vector #x1000 v1)))
                 (vector-set! v0 0 v0)
                 (fasdump v0 fasdump-port)
                 (fasdump v1 fasdump-port)))
             (lambda (fasload-port)
               (let* ((v0 (fasload fasload-port))
                      (v1 (fasload fasload-port)))
                 (and (equal? v1 '#(0 3 (5 . 7)))
                      (vector? v1)
                      (= (vector-length v0) #x1000)
                      (eq? (vector-ref v0 0) v0)
                      (let loop ((i 1))
                        (or (= i #x1000)
                            (and (eq? (vector-ref v0 i) v1)
                                 (loop (+ i 1))))))))))

(define test-big-vector
  (make-test 'big-vector
             (lambda (fasdump-port)
               (fasdump (make-vector 1000 (cons 1 2))
                        fasdump-port))
             (lambda (fasload-port)
               (let ((vector (fasload fasload-port)))
                 (and (vector? vector)
                      (= (vector-length vector) 1000)
                      (let ((item (vector-ref vector 0)))
                        (let loop ((i 1))
                          (or (= i 1000)
                              (and (eq? (vector-ref vector i) item)
                                   (loop (+ i 1)))))))))))

(define test-numbers
  (let ((list '(#x100000
                123 1234 -123 -1234
                1.0 1.1 1/2
                1+2i 1.0+2.0i
                1/2+3i 1+2/3i)))
    (make-test 'numbers
               (lambda (fasdump-port)
                 (fasdump list fasdump-port))
               (lambda (fasload-port)
                 (equal? (fasload fasload-port)
                         list)))))

(define test-byte-vectors
  (make-test 'byte-vectors
             (lambda (fasdump-port)
               (let ((bv0 (make-byte-vector 3 0))
                     ;; 4096 is chosen to overflow the buffer.
                     (bv1 (make-byte-vector 4096 #x7C)))
                 (byte-vector-set! bv0 1 #x18)
                 (byte-vector-set! bv0 2 #x8F)
                 (fasdump bv0 fasdump-port)
                 (fasdump bv1 fasdump-port)))
             (lambda (fasload-port)
               (let* ((bv0 (and (check-header fasload-port
                                              (enum fasl-header
                                                    UNSHARED-OBJECT))
                                (fasload fasload-port)))
                      (bv1 (and (check-header fasload-port
                                              (enum fasl-header
                                                    UNSHARED-OBJECT))
                                (fasload fasload-port))))
                 (and (byte-vector? bv0)
                      (= (byte-vector-length bv0) 3)
                      (= (byte-vector-ref bv0 0) 0)
                      (= (byte-vector-ref bv0 1) #x18)
                      (= (byte-vector-ref bv0 2) #x8F)
                      (byte-vector? bv1)
                      (= (byte-vector-length bv1) 4096)
                      (let loop ((i 0))
                        (or (= i 4096)
                            (and (= (byte-vector-ref bv1 i) #x7C)
                                 (loop (+ i 1))))))))))

(define test-cell
  (make-test 'cell
             (lambda (fasdump-port)
               (fasdump (make-cell 0) fasdump-port))
             (lambda (fasload-port)
               (and (check-header fasload-port
                                  (enum fasl-header UNSHARED-OBJECT))
                    (let ((cell (fasload fasload-port)))
                      (and (cell? cell)
                           (eqv? (cell-ref cell) 0)))))))

(define test-cells
  (make-test 'cells
             (lambda (fasdump-port)
               (let* ((c0 (make-cell 'FOO))
                      (c1 (make-cell c0))
                      (c2 (make-cell #f)))
                 (cell-set! c2 c2)
                 (fasdump c0 fasdump-port)
                 (fasdump c1 fasdump-port)
                 (fasdump c2 fasdump-port)))
             (lambda (fasload-port)
               (and (check-header fasload-port
                                  (enum fasl-header SHARED-OBJECT))
                    (let ((c0 (fasload fasload-port)))
                      (and (cell? c0)
                           (eq? (cell-ref c0) 'FOO)
                           (check-header fasload-port
                                         (enum fasl-header
                                               UNSHARED-OBJECT))
                           (let ((c1 (fasload fasload-port)))
                             (and (cell? c1)
                                  (eq? (cell-ref c1) c0)
                                  (let ((c2 (fasload fasload-port)))
                                    (and (cell? c2)
                                         (eq? (cell-ref c2)
                                              c2)))))))))))

(define test-weak-pointer
  (make-test 'weak-pointer
             (lambda (fasdump-port)
               (let ((p '(5 . 3)))
                 (fasdump p fasdump-port)
                 (fasdump (make-weak-pointer p) fasdump-port)))
             (lambda (fasload-port)
               (let* ((p (and (check-header fasload-port
                                            (enum fasl-header
                                                  SHARED-OBJECT))
                              (fasload fasload-port)))
                      (wp (and (check-header fasload-port
                                             (enum fasl-header
                                                   UNSHARED-OBJECT))
                               (fasload fasload-port))))
                 (and (equal? p '(5 . 3))
                      (weak-pointer? wp)
                      (eq? (weak-pointer-ref wp) p))))))

(define test-zot
  (make-test
   'zot
   (lambda (fasdump-port)
     (let* ((bv (make-byte-vector 3 0))
            (v (make-vector 3 bv))
            (c (make-cell v))
            (l (list 123 1234 -123 -1234
                     'FOO
                     "frob" #\f
                     1.0 1/2
                     1+2i 1.0+2.0i
                     1/2+3i 1+2/3i
                     v
                     c
                     (make-weak-pointer c)
                     bv)))
       (byte-vector-set! bv 0 #x12)
       (byte-vector-set! bv 1 #xEF)
       (byte-vector-set! bv 2 #x76)
       (vector-set! v 0 c)
       (vector-set! v 1 l)
       (fasdump bv fasdump-port)
       (fasdump l fasdump-port)
       (fasdump v fasdump-port)
       (fasdump c fasdump-port)))
   (lambda (fasload-port)
     (let ((bv (and (check-header fasload-port
                                  (enum fasl-header SHARED-OBJECT))
                    (fasload fasload-port))))
       (and (byte-vector? bv)
            (= (byte-vector-length bv) 3)
            (= (byte-vector-ref bv 0) #x12)
            (= (byte-vector-ref bv 1) #xEF)
            (= (byte-vector-ref bv 2) #x76)
            (let* ((l (fasload fasload-port))
                   (ref (lambda (i) (list-ref l i)))
                   (test (lambda (i datum) (eqv? (ref i) datum))))
              (and (list? l)
                   (= (length l) 17)
                   (test 0 123)
                   (test 1 1234)
                   (test 2 -123)
                   (test 3 -1234)
                   (test 4 'FOO)
                   (equal? (ref 5) "frob")
                   (test 6 #\f)
                   (test 7 1.0)
                   (test 8 1/2)
                   (test 9 1+2i)
                   (test 10 1.0+2.0i)
                   (test 11 1/2+3i)
                   (test 12 1+2/3i)
                   (let ((v (ref 13)))
                     (and (vector? v)
                          (= (vector-length v) 3)
                          (eq? (vector-ref v 1) l)
                          (eq? (vector-ref v 2) bv)
                          (let ((c (vector-ref v 0)))
                            (and (cell? c)
                                 (eq? (cell-ref c) v)
                                 (eq? (ref 14) c)
                                 (let ((wp (ref 15)))
                                   (and (weak-pointer? wp)
                                        (eq? (weak-pointer-ref wp)
                                             c)))
                                 (eq? (ref 16) bv)
                                 (eq? (fasload fasload-port)
                                      v)
                                 (eq? (fasload fasload-port)
                                      c))))))))))))