Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Eliminate double eval from xtmtest and xtmtest-compile #386

Merged
merged 7 commits into from
May 18, 2020
Merged

Eliminate double eval from xtmtest and xtmtest-compile #386

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
f7a994e
Add an xtmtest-with-fixture test and exercise it
pdcawley May 16, 2020
ae931ed
Fail a sanity check
pdcawley May 16, 2020
478fd64
squash! Fail a sanity check
pdcawley May 17, 2020
e8290a4
Passing my sanity check now!
pdcawley May 17, 2020
0d97ddd
Remove last double evaluation from xtmtest
pdcawley May 17, 2020
25e31c4
Eliminate the unnecessary quoting of xtmtest-* forms
pdcawley May 17, 2020
a3e2325
Remove the optional unquote code from xtmtest-*
pdcawley May 17, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
60 changes: 45 additions & 15 deletions libs/core/test.xtm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -83,33 +83,38 @@
(equal? exp-res 'compile-should-fail))
(xtmtest-update-test-result func-sym 'correct ',call #f #f)
(xtmtest-update-test-result func-sym 'no-compile ',call #f #f))
(eval ,form (interaction-environment))
(eval ',form (interaction-environment))
(catch (xtmtest-update-test-result func-sym 'compile ',call #f #f)
(let ((result (eval ,call (interaction-environment))))
(let ((result (eval ',call (interaction-environment))))
(if (or (not exp-res) (equal? exp-res result))
(xtmtest-update-test-result func-sym 'correct ',call exp-res result)
(xtmtest-update-test-result func-sym 'incorrect ',call exp-res result)))))))

(define-macro (xtmtest-compile form)
`(let ((func-sym (quote ,(cadadr form))))
`(let ((func-sym (quote ,(cadr form))))
(print-with-colors 'cyan 'default #t (print "xtmtest "))
(print-with-colors 'black 'cyan #t (print "" func-sym ""))
(println)
(catch (xtmtest-update-test-result func-sym 'no-compile 'compile-only #f #f)
(eval ,form (interaction-environment))
(eval ',form (interaction-environment))
(xtmtest-update-test-result func-sym 'correct 'compile-only #t #t))))

(define-macro (xtmtest-result call expected-result)
`(let ((evaluation-environment (current-environment))
(func-sym (quote ,(car call))))
(print-with-colors 'cyan 'default #t (print "xtmtest "))
(print-with-colors 'black 'cyan #t (print "" func-sym ""))
(println)
(catch (xtmtest-update-test-result func-sym ',call 'compile #f #f)
(let ((result (eval ',call evaluation-environment)))
(if (equal? ,expected-result result)
(xtmtest-update-test-result func-sym 'correct ',call ,expected-result result)
(xtmtest-update-test-result func-sym 'incorrect ',call ,expected-result result))))))
(define (xtmtest-result-body call expected-result extra)
(let ((prefix (if (null? extra) "" (format "~a: " (car extra)))))
`(let ((evaluation-environment (current-environment))
(test-name (format "~a ~a" ,prefix ',(if (pair? call) (car call) call))))
(print-with-colors 'cyan 'default #t (print "xtmtest "))
(print-with-colors 'black 'cyan #t (print "" test-name ))
(println)
(catch (xtmtest-update-test-result test-name ',call 'compile #f #f)
(let ((result (eval ',call evaluation-environment)))
(if (equal? ,expected-result result)
(xtmtest-update-test-result ',prefix 'correct ',call ,expected-result result)
(xtmtest-update-test-result ',prefix 'incorrect ',call ,expected-result result)))))) )

(define-macro (xtmtest-result call expected-result . extra)
(xtmtest-result-body call expected-result extra))


(define xtmtest-print-results
(lambda ()
Expand Down Expand Up @@ -179,3 +184,28 @@
0)))
;; if not quitting, set the timeout back
(sys:set-default-timeout timeout)))))

;;; xmttest-with-fixture

(define (xtmtest-with-fixture-body name fixture tests)
`(let ((fixture-environment ((lambda () (current-environment)))))
(let ((suite-name ',name))
(print-with-colors 'cyan 'default #t (print "xtmtest "))
(print-with-colors 'black 'cyan #t (print "" suite-name))
(println)
(eval `(begin
(define-macro (is? call expected-result . args)
(xtmtest-result-body call
expected-result
(list (if (not (null? args))
(format "~a.~a" ',suite-name (car args))
(format "~a.is?" ',suite-name))))))
fixture-environment)
(catch (xtmtest-update-test-result suite-name 'no-compile ',fixture #f #f)
(eval ',fixture fixture-environment)
(eval '(begin ,@tests) fixture-environment)))))


(define-macro (xtmtest-with-fixture name fixture . tests)
(xtmtest-with-fixture-body name fixture tests))

2 changes: 1 addition & 1 deletion tests/all-core.xtm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,6 @@

;;; Code:

(xtmtest-run-tests (append '("tests/core/system.xtm" "tests/core/adt.xtm" "tests/core/math.xtm" "tests/core/std.xtm" "tests/core/xtlang.xtm" "tests/core/constraints.xtm" "tests/core/expr_problem.xtm" "tests/core/algebraic_data_types.xtm")
(xtmtest-run-tests (append '("tests/core/system.xtm" "tests/core/test.xtm" "tests/core/adt.xtm" "tests/core/math.xtm" "tests/core/std.xtm" "tests/core/xtlang.xtm" "tests/core/constraints.xtm" "tests/core/expr_problem.xtm" "tests/core/algebraic_data_types.xtm")
(unix-or-Windows '("tests/core/generics.xtm") '()))
#t #t)
Loading