(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (foreign c)) ;; util (define header-count 1) (define print-header (lambda (title) (set-tag title) (display "=========================================") (newline) (display header-count) (display " ") (display title) (newline) (display "=========================================") (newline) (set! header-count (+ header-count 1)))) (define count 0) (define assert-tag 'none) (define set-tag (lambda (tag) (set! assert-tag tag) (set! count 0))) (cond-expand (gambit (define assert (lambda (check value-a value-b) (let ((result (apply check (list value-a value-b)))) (set! count (+ count 1)) (if (not result) (display "FAIL ") (display "PASS ")) (display "[") (display assert-tag) (display " - ") (display count) (display "]") (display ": ") (write (list 'check 'value-a 'value-b)) (newline) (when (not result) (exit 1)))))) (else (define-syntax assert (syntax-rules () ((_ check value-a value-b) (let ((result (apply check (list value-a value-b)))) (set! count (+ count 1)) (if (not result) (display "FAIL ") (display "PASS ")) (display "[") (display assert-tag) (display " - ") (display count) (display "]") (display ": ") (write (list 'check 'value-a 'value-b)) (newline) (when (not result) (exit 1)))))))) (define-syntax debug (syntax-rules () ((_ value) (begin (display 'value) (display ": ") (write value) (newline))))) (let* ((pointer-size (c-type-size 'long)) (pointer (make-c-bytevector (c-type-size 'long)))) (c-bytevector-sint-set! pointer 0 42 (native-endianness) pointer-size) (let ((value (c-bytevector-sint-ref pointer 0 (native-endianness) pointer-size))) (c-free pointer) (display "Code: ") (display value) (newline) (assert = value 42)))