diff options
Diffstat (limited to '')
-rwxr-xr-x | tests/run-tests.scm | 11 | ||||
-rw-r--r-- | tests/test/cpp/cpp-environment.scm | 5 | ||||
-rw-r--r-- | tests/test/cpp/lex2.scm | 76 | ||||
-rw-r--r-- | tests/test/cpp/preprocessor2.scm | 335 |
4 files changed, 236 insertions, 191 deletions
diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 3955a6a2..7f7ccfcd 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -79,6 +79,8 @@ fi ;; end of individual test case (test-runner-on-test-begin! runner (lambda (runner) + #; + (set-current-error-port (open-output-string)) (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) (test-runner-on-test-end! runner (lambda (runner) @@ -97,7 +99,14 @@ fi => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) - (truncated-print p width: 60)))))))) + (truncated-print p width: 60))))) + (else (bold "[UNNAMED ASSERTION]"))))) + #; + (when verbose? + (display + (map (lambda (line) (string-append (make-indent (1+ depth)) "> " line "\n")) + (string-split (get-output-string (current-error-port)) #\n))) + (newline)) (when (eq? 'fail (test-result-kind)) (cond ((test-result-ref runner 'actual-error) => (lambda (err) diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm index 8600c731..d31ec208 100644 --- a/tests/test/cpp/cpp-environment.scm +++ b/tests/test/cpp/cpp-environment.scm @@ -2,6 +2,7 @@ :use-module (srfi srfi-64) :use-module (srfi srfi-88) :use-module (c cpp-environment) + :use-module ((c lex2) :select (lex)) :use-module (c cpp-environment object-like-macro) ) @@ -29,10 +30,10 @@ e "key" (object-like-macro identifier: "key" - body: '((preprocessing-token (identifier "value"))))))) + body: (lex "value"))))) (let ((result (get-identifier e* "key"))) (test-assert (macro? result)) - (test-equal '((preprocessing-token (identifier "value"))) + (test-equal (lex "value") (macro-body result)))) ;; (get-identifier e "key") here is undefined ) diff --git a/tests/test/cpp/lex2.scm b/tests/test/cpp/lex2.scm index 762ff176..b80bcf37 100644 --- a/tests/test/cpp/lex2.scm +++ b/tests/test/cpp/lex2.scm @@ -6,60 +6,62 @@ (test-equal "Integer literal" - '((preprocessing-token (pp-number "10"))) + (list (lexeme type: 'preprocessing-token body: '(pp-number "10"))) (lex "10")) (test-equal "String literal" - '((preprocessing-token (string-literal "Hello"))) + (list (lexeme type: 'preprocessing-token body: '(string-literal "Hello"))) (lex "\"Hello\"")) (test-equal "Mulitple tokens, including whitespace" - '((whitespace " ") - (preprocessing-token (pp-number "10")) - (whitespace " ")) + (list (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(pp-number "10")) + (lexeme type: 'whitespace body: " ")) (lex " 10 ")) (test-equal "Char literal" - '((preprocessing-token (character-constant "a"))) + (list (lexeme type: 'preprocessing-token body: '(character-constant "a"))) (lex "'a'")) (test-equal "Comment inside string" - '((preprocessing-token (string-literal "Hel/*lo"))) + (list (lexeme type: 'preprocessing-token body: '(string-literal "Hel/*lo"))) (lex "\"Hel/*lo\"")) (test-equal "#define line" - '((preprocessing-token (punctuator "#")) - (preprocessing-token (identifier "define")) - (whitespace " ") - (preprocessing-token (identifier "f")) - (preprocessing-token (punctuator "(")) - (preprocessing-token (identifier "x")) - (preprocessing-token (punctuator ")")) - (whitespace " ") - (preprocessing-token (pp-number "10"))) + (list + (lexeme type: 'preprocessing-token body: '(punctuator "#")) + (lexeme type: 'preprocessing-token body: '(identifier "define")) + (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(identifier "f")) + (lexeme type: 'preprocessing-token body: '(punctuator "(")) + (lexeme type: 'preprocessing-token body: '(identifier "x")) + (lexeme type: 'preprocessing-token body: '(punctuator ")")) + (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(pp-number "10"))) (lex "#define f(x) 10")) (test-equal "Nested parenthesis" - '((preprocessing-token (identifier "f")) - (preprocessing-token (punctuator "(")) - (preprocessing-token (pp-number "1")) - (preprocessing-token (punctuator ",")) - (whitespace " ") - (preprocessing-token (punctuator "(")) - (preprocessing-token (pp-number "2")) - (preprocessing-token (punctuator ",")) - (whitespace " ") - (preprocessing-token (pp-number "3")) - (preprocessing-token (punctuator ")")) - (preprocessing-token (punctuator ",")) - (whitespace " ") - (preprocessing-token (pp-number "4")) - (preprocessing-token (punctuator ")"))) + (list + (lexeme type: 'preprocessing-token body: '(identifier "f")) + (lexeme type: 'preprocessing-token body: '(punctuator "(")) + (lexeme type: 'preprocessing-token body: '(pp-number "1")) + (lexeme type: 'preprocessing-token body: '(punctuator ",")) + (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(punctuator "(")) + (lexeme type: 'preprocessing-token body: '(pp-number "2")) + (lexeme type: 'preprocessing-token body: '(punctuator ",")) + (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(pp-number "3")) + (lexeme type: 'preprocessing-token body: '(punctuator ")")) + (lexeme type: 'preprocessing-token body: '(punctuator ",")) + (lexeme type: 'whitespace body: " ") + (lexeme type: 'preprocessing-token body: '(pp-number "4")) + (lexeme type: 'preprocessing-token body: '(punctuator ")"))) (lex "f(1, (2, 3), 4)")) @@ -68,13 +70,13 @@ ;; (whitespace " ") ;; would also be ok (test-equal "Grouped whitespace" - '((whitespace " ") - (whitespace " ")) + (list (lexeme type: 'whitespace body: " ") + (lexeme type: 'whitespace body: " ")) (lex " ")) (test-equal "Newlines get sepparate whitespace tokens" - '((whitespace " ") - (whitespace " ") - (whitespace "\n") - (whitespace " ")) + (list (lexeme type: 'whitespace body: " ") + (lexeme type: 'whitespace body: " ") + (lexeme type: 'whitespace body: "\n") + (lexeme type: 'whitespace body: " ")) (lex " \n ")) diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index 75e29834..e2ff0a17 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -5,6 +5,7 @@ :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module ((hnh util) :select (-> unval)) + :use-module ((hnh util lens) :select (set)) :use-module (c preprocessor2) :use-module (c cpp-environment) :use-module (c cpp-environment function-like-macro) @@ -21,21 +22,19 @@ (call-with-values (lambda () (tokens-until-eol - (list before '(whitespace "\n") after))) + (list before (car (lex "\n")) after))) (lambda (bef aft) (test-equal (list before) bef) - (test-equal (list '(whitespace "\n") after) aft)))) + (test-equal (list (car (lex "\n")) after) aft)))) (define squeeze-whitespace (@@ (c preprocessor2) squeeze-whitespace)) (test-equal "Squeeze whitespace" - '(bef (whitespace " ") aft) + (lex "bef aft") (squeeze-whitespace - '(bef - (whitespace a) - (whitespace b) - aft))) + (append (lex "bef ") + (lex " aft")))) @@ -44,7 +43,7 @@ (test-group "Stringify" (test-equal "(" - (stringify-token '(punctuator "("))) + (stringify-token (car (lex "(")))) ;; TODO more cases (test-equal (car (lex "\"(a, b)\"")) @@ -56,9 +55,9 @@ (test-group "Parse identifier list" (test-group "Single argument" - (let ((rest args (parse-identifier-list (lex "x")))) - (test-assert (not rest)) - (test-equal '("x") args))) + (let ((rest args (parse-identifier-list (lex "x")))) + (test-assert (not rest)) + (test-equal '("x") args))) (test-group "Multiple parameters" (let ((rest args (parse-identifier-list (lex "x, y")))) @@ -88,7 +87,7 @@ -(define expand-stringifiers (@@ (c preprocessor2) expand-stringifiers)) +(define expand# (@@ (c preprocessor2) expand#)) (define build-parameter-map (@@ (c preprocessor2) build-parameter-map)) (define parse-parameter-list (@@ (c preprocessor2) parse-parameter-list)) (define cleanup-whitespace (@@ (c preprocessor2) cleanup-whitespace)) @@ -152,8 +151,7 @@ identifier-list: '() body: (lex "#x")))) (build-parameter-map - m '() #; (list (lex "x")) - ))) + m '()))) (test-equal "Single (simple) argument" `(("x" . ,(lex "x"))) @@ -203,7 +201,7 @@ body: (lex "#x")))) (test-equal "Correct stringification of one param" (lex "\"10\"") - (expand-stringifiers + (expand# m (build-parameter-map m (list (lex "10")))))) @@ -213,7 +211,7 @@ body: (lex "#x")))) (test-error "Stringification fails for non-parameters" 'macro-expand-error - (expand-stringifiers + (expand# m (build-parameter-map m (list (lex "x"))))))) @@ -223,15 +221,22 @@ (define join-file-line (@@ (c preprocessor2) join-file-line)) (let ((e (join-file-line (make-environment)))) - (test-equal (object-like-macro identifier: "__FILE__" - body: '((preprocessing-token (string-literal "*outside*")))) + (test-equal "__FILE__ default value" + (object-like-macro identifier: "__FILE__" + body: (lex "\"*outside*\"")) (get-identifier e "__FILE__")) - (test-equal (object-like-macro identifier: "__LINE__" - body: '((preprocessing-token (pp-number "1")))) + (test-equal "__LINE__ default value" + (object-like-macro identifier: "__LINE__" + body: (lex "1")) (get-identifier e "__LINE__"))) (define resolve-token-stream (@@ (c preprocessor2) resolve-token-stream)) +(define (remove-noexpand tokens) + ;; (typecheck tokens (list-of token?)) + (map (lambda (token) (set token lexeme-noexpand '())) + tokens)) + (test-group "Token streams" (test-group "Non-expanding" (test-equal "Null stream" @@ -239,37 +244,40 @@ (test-equal "Constant resolve to themselves" (lex "1") (resolve-token-stream (make-environment) (lex "1"))) (test-equal "Identifier-likes not in environment stay put" - (lex "x") (resolve-token-stream (make-environment) (lex "x"))) + (lex "x") (remove-noexpand (resolve-token-stream (make-environment) (lex "x")))) (test-equal "Identifier-likes with stuff after keep stuff after" - (lex "x 1") (resolve-token-stream (make-environment) (lex "x 1")))) + (lex "x 1") (remove-noexpand (resolve-token-stream (make-environment) (lex "x 1"))))) (test-group "Object likes" (test-equal "Expansion of single token" (lex "10") - (resolve-token-stream (extend-environment (make-environment) - (list (object-like-macro - identifier: "x" - body: (lex "10")))) - (lex "x"))) + (remove-noexpand + (resolve-token-stream (extend-environment (make-environment) + (list (object-like-macro + identifier: "x" + body: (lex "10")))) + (lex "x")))) (test-equal "Expansion keeps stuff after" (lex "10 1") - (resolve-token-stream (extend-environment (make-environment) - (list (object-like-macro - identifier: "x" - body: (lex "10")))) - (lex "x 1"))) + (remove-noexpand + (resolve-token-stream (extend-environment (make-environment) + (list (object-like-macro + identifier: "x" + body: (lex "10")))) + (lex "x 1")))) (test-equal "Multiple object like macros in one stream" (lex "10 20") - (resolve-token-stream (extend-environment (make-environment) - (list (object-like-macro - identifier: "x" - body: (lex "10")) - (object-like-macro - identifier: "y" - body: (lex "20")))) - (lex "x y")))) + (remove-noexpand + (resolve-token-stream (extend-environment (make-environment) + (list (object-like-macro + identifier: "x" + body: (lex "10")) + (object-like-macro + identifier: "y" + body: (lex "20")))) + (lex "x y"))))) ;; TODO @@ -294,16 +302,18 @@ (lambda () (expand-macro (make-environment) (object-like-macro identifier: "x" body: (lex "1 + 2")) + '() '())) - (lambda (_ tokens) (test-equal "Simplest case" (lex "1 + 2") tokens))) + (lambda (_ tokens) (test-equal "Simplest case" (lex "1 + 2") (remove-noexpand tokens)))) (call-with-values (lambda () (expand-macro (make-environment) (object-like-macro identifier: "x" body: (lex "1+2")) + '() (cdr (lex "x something else")))) (lambda (_ tokens) (test-equal "Expansion with stuff after" - (lex "1+2 something else") tokens))) + (lex "1+2 something else") (remove-noexpand tokens)))) ;; (call-with-values (expand-macro (make-environment))) @@ -313,65 +323,67 @@ (test-group "Maybe extend identifier" (test-equal "Non-identifier returns remaining" (lex "x") - ((unval maybe-extend-identifier 1) - (make-environment) "x" '())) + (remove-noexpand ((unval maybe-extend-identifier 1) + (make-environment) "x" '()'()))) (test-equal "Non-identifiers remaining tokens are returned verbatim" (append (lex "x") (list after)) - ((unval maybe-extend-identifier 1) - (make-environment) "x" (list after))) + (remove-noexpand ((unval maybe-extend-identifier 1) + (make-environment) "x" '() (list after)))) (test-equal "Object like identifier expands" (lex "1 + 2") - ((unval maybe-extend-identifier 1) - (extend-environment (make-environment) - (list - (object-like-macro - identifier: "x" - body: (lex "1 + 2")))) - "x" - '())) + (remove-noexpand ((unval maybe-extend-identifier 1) + (extend-environment (make-environment) + (list + (object-like-macro + identifier: "x" + body: (lex "1 + 2")))) + "x" + '() + '()))) (test-equal "Object like macro still returns remaining verbatim" (append (lex "1 + 2") (list after)) - ((unval maybe-extend-identifier 1) - (extend-environment (make-environment) - (list - (object-like-macro - identifier: "x" - body: (lex "1 + 2")))) - "x" - (list after))) + (remove-noexpand ((unval maybe-extend-identifier 1) + (extend-environment (make-environment) + (list + (object-like-macro + identifier: "x" + body: (lex "1 + 2")))) + "x" + '() + (list after)))) ) (test-group "Apply macro" (test-equal "zero arg macro on nothing" (lex "1") - (apply-macro - (make-environment) - (function-like-macro identifier: "f" - identifier-list: '() - body: (lex "1")) - '())) + (remove-noexpand (apply-macro + (make-environment) + (function-like-macro identifier: "f" + identifier-list: '() + body: (lex "1")) + '()))) (test-equal "Single arg macro" (lex "10") - (apply-macro - (make-environment) - (function-like-macro identifier: "f" - identifier-list: '("x") - body: (lex "x")) - ((unval parse-parameter-list) (lex "(10)")))) + (remove-noexpand (apply-macro + (make-environment) + (function-like-macro identifier: "f" + identifier-list: '("x") + body: (lex "x")) + ((unval parse-parameter-list) (lex "(10)"))))) (test-equal "Two arg macro" (lex "10 + 20") - (apply-macro - (make-environment) - (function-like-macro identifier: "f" - identifier-list: '("x" "y") - body: (lex "x + y")) - ((unval parse-parameter-list) (lex "(10, 20)"))))) + (remove-noexpand (apply-macro + (make-environment) + (function-like-macro identifier: "f" + identifier-list: '("x" "y") + body: (lex "x + y")) + ((unval parse-parameter-list) (lex "(10, 20)")))))) (test-group "Expand macro part 2" (test-group "Function like macros" @@ -380,21 +392,21 @@ identifier: "f" identifier-list: '() body: (lex "1")))) - (call-with-values (lambda () (expand-macro e m (lex "()"))) - (lambda (_ tokens*) (test-equal (lex "1") tokens*))) + (call-with-values (lambda () (expand-macro e m '() (lex "()"))) + (lambda (_ tokens*) (test-equal (lex "1") (remove-noexpand tokens*)))) (test-error "Arity error for to many args" - 'cpp-arity-error (expand-macro e m (lex "(10)")))) + 'cpp-arity-error (expand-macro e m '() (lex "(10)")))) (let ((m (function-like-macro identifier: "f" identifier-list: '("x") variadic?: #t body: (lex "__VA_ARGS__ x")))) - (call-with-values (lambda () (expand-macro e m (lex "(1)"))) - (lambda (_ tokens*) (test-equal (lex " 1") tokens*))) + (call-with-values (lambda () (expand-macro e m '() (lex "(1)"))) + (lambda (_ tokens*) (test-equal (lex " 1") (remove-noexpand tokens*)))) (test-error "Arity error on too few args (with variadic)" - 'cpp-arity-error (expand-macro e m (lex "()"))) - (call-with-values (lambda () (expand-macro e m (lex "(1,2,3)"))) - (lambda (_ tokens*) (test-equal (lex "2,3 1") tokens*))) + 'cpp-arity-error (expand-macro e m '() (lex "()"))) + (call-with-values (lambda () (expand-macro e m '() (lex "(1,2,3)"))) + (lambda (_ tokens*) (test-equal (lex "2,3 1") (remove-noexpand tokens*)))) ) )))) @@ -402,44 +414,44 @@ (test-group "Resolve token stream with function likes" (test-equal "Macro expanding to its parameter" (lex "0") - (resolve-token-stream - (extend-environment - e (list (function-like-macro identifier: "f" - identifier-list: '("x") - body: (lex "x")))) - (lex "f(0)"))) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (function-like-macro identifier: "f" + identifier-list: '("x") + body: (lex "x")))) + (lex "f(0)")))) (test-equal "Macro expanding parameter multiple times" (lex "(2) * (2)") - (resolve-token-stream - (extend-environment - e (list (function-like-macro identifier: "f" - identifier-list: '("x") - body: (lex "(x) * (x)")))) - (lex "f(2)")) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (function-like-macro identifier: "f" + identifier-list: '("x") + body: (lex "(x) * (x)")))) + (lex "f(2)"))) ) (test-equal "Object like contains another object like" (lex "z") - (resolve-token-stream - (extend-environment - e (list (object-like-macro identifier: "x" - body: (lex "y")) - (object-like-macro identifier: "y" - body: (lex "z")))) - (lex "x"))) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (object-like-macro identifier: "x" + body: (lex "y")) + (object-like-macro identifier: "y" + body: (lex "z")))) + (lex "x")))) (test-equal "function like contains another macro" (lex "10") - (resolve-token-stream - (extend-environment - e (list (function-like-macro identifier: "f" - identifier-list: '("x") - body: (lex "g(x)")) - (function-like-macro identifier: "g" - identifier-list: '("y") - body: (lex "y")))) - (lex "f(10)"))) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (function-like-macro identifier: "f" + identifier-list: '("x") + body: (lex "g(x)")) + (function-like-macro identifier: "g" + identifier-list: '("y") + body: (lex "y")))) + (lex "f(10)")))) " #define f(x) g(x) @@ -449,42 +461,42 @@ f(10) (test-equal "function like containing another macro using the same parameter name" (lex "10") - (resolve-token-stream - (extend-environment - e (list (function-like-macro identifier: "f" - identifier-list: '("x") - body: (lex "g(x)")) - (function-like-macro identifier: "g" - identifier-list: '("x") - body: (lex "x")))) - (lex "f(10)"))) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (function-like-macro identifier: "f" + identifier-list: '("x") + body: (lex "g(x)")) + (function-like-macro identifier: "g" + identifier-list: '("x") + body: (lex "x")))) + (lex "f(10)")))) (test-equal "function like contains another macro" (lex "10 * 2 + 20 * 2 + 30") - (resolve-token-stream - (extend-environment - e (list (function-like-macro identifier: "f" - identifier-list: '("x" "y") - body: (lex "g(x) + g(y)")) - (function-like-macro identifier: "g" - identifier-list: '("x") - body: (lex "x * 2")))) - (lex "f(10, 20) + 30"))))) + (remove-noexpand (resolve-token-stream + (extend-environment + e (list (function-like-macro identifier: "f" + identifier-list: '("x" "y") + body: (lex "g(x) + g(y)")) + (function-like-macro identifier: "g" + identifier-list: '("x") + body: (lex "x * 2")))) + (lex "f(10, 20) + 30")))))) (let ((e (extend-environment (make-environment) (list (@@ (c preprocessor2) defined-macro))))) (test-group "defined() macro" (test-equal "defined(NOT_DEFINED)" - (lex "0") (resolve-token-stream e (lex "defined(X)"))) + (lex "0") (remove-noexpand (resolve-token-stream e (lex "defined(X)")))) (test-equal "defined(DEFINED)" - (lex "1") (resolve-token-stream - (extend-environment - e (list (object-like-macro identifier: "X" - body: (lex "10")))) - (lex "defined(X)"))))) + (lex "1") (remove-noexpand (resolve-token-stream + (extend-environment + e (list (object-like-macro identifier: "X" + body: (lex "10")))) + (lex "defined(X)")))))) (let ((env (resolve-define (make-environment) @@ -498,17 +510,38 @@ f(10) ;; (resolve-define (make-environment) ;; (lex "f(x)x+1")) -;; (let ((env (resolve-define (make-environment) -;; (lex "x x")))) -;; (test-equal "Macro expanding to itself leaves the token" -;; (lex "x") -;; (resolve-token-stream env (lex "x")))) - -(let ((env (-> (make-environment) - (resolve-define (lex "f(a) a*g")) - (resolve-define (lex "g(a) f(a)"))))) - (test-equal '() - (resolve-token-stream env (lex "f(2)(9)")))) +(define mark-noexpand (@@ (c preprocessor2) mark-noexpand)) + +(test-group "Recursive macros" + (let ((env (resolve-define (make-environment) + (lex "x x")))) + (test-equal "Macro expanding to itself leaves the token" + (mark-noexpand (lex "x") "x") + (resolve-token-stream env (lex "x")))) + + ;; Test from C standard 6.10.3.4 p. 4 + ;; Both the expansion "2*f(9)" and "2*9*g" are valid. + ;; The case chosen here is mostly a consequence of how the code works + (let ((env (-> (make-environment) + (resolve-define (lex "f(a) a*g")) + (resolve-define (lex "g(a) f(a)"))))) + (test-equal "Mutual recursion with two function like macros" + (lex "2*f(9)") + (remove-noexpand (resolve-token-stream env (lex "f(2)(9)"))))) + + (let ((env (-> (make-environment) + (resolve-define (lex "f 2 * g")) + (resolve-define (lex "g(x) x + f"))))) + (test-equal "Mutual recursion with object and function like macro" + (lex "2 * 10 + f") + (remove-noexpand (resolve-token-stream env (lex "f(10)"))))) + + (let ((env (-> (make-environment) + (resolve-define (lex "x 2*y")) + (resolve-define (lex "y 3*x"))))) + (test-equal "Mutual recursion with two object likes" + (lex "2*3*x") + (remove-noexpand (resolve-token-stream env (lex "x")))))) |