From b3f27f132f8ac405f8cdf7e201f03d157f366125 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 10 Jul 2022 20:24:01 +0200 Subject: work --- tests/test/cpp/preprocessor2.scm | 279 ++++++++++++++++++++++++++++----------- 1 file changed, 203 insertions(+), 76 deletions(-) (limited to 'tests/test/cpp/preprocessor2.scm') diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index 3d62e224..75e29834 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -4,29 +4,27 @@ :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-71) :use-module (srfi srfi-88) - :use-module ((hnh util) :select (unval)) + :use-module ((hnh util) :select (-> unval)) :use-module (c preprocessor2) :use-module (c cpp-environment) :use-module (c cpp-environment function-like-macro) :use-module (c cpp-environment object-like-macro) :use-module (c lex2)) -;; TODO Not yet implemented -;; (test-expect-fail (test-match-group "Stringify")) -;; (test-expect-fail -;; (test-match-all (test-match-group "Expand stringifiers") -;; (test-match-name "Correct stringification of one param"))) +;; arbitrary tokens useful in tests for checking that values are returned correctly +(define before (car (lex "before"))) +(define after (car (lex "after"))) (define tokens-until-eol (@@ (c preprocessor2) tokens-until-eol)) (test-group "Tokens until End Of Line" (call-with-values (lambda () (tokens-until-eol - '(before (whitespace "\n") after))) + (list before '(whitespace "\n") after))) (lambda (bef aft) - (test-equal '(before) bef) - (test-equal '((whitespace "\n") after) aft)))) + (test-equal (list before) bef) + (test-equal (list '(whitespace "\n") after) aft)))) @@ -178,7 +176,7 @@ (test-group "Rest arguments" (test-equal "Single simple" - `(("__VA_ARGS__" . ,(list (lex "x")))) + `(("__VA_ARGS__" . ,(lex "x"))) (let ((m (function-like-macro identifier: "str" identifier-list: '() @@ -187,18 +185,15 @@ (build-parameter-map m (list (lex "x"))))) - #; (test-equal "Two simple" - '() + `(("__VA_ARGS__" . ,(lex "x,y"))) (let ((m (function-like-macro identifier: "str" identifier-list: '() variadic?: #t body: '()))) (build-parameter-map - m (list (lex "x"))))) - )) - + m (list (lex "x,y"))))))) (test-group "Expand stringifiers" @@ -250,18 +245,20 @@ (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"))) + (lex "10") + (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"))) + (lex "10 1") + (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") @@ -272,8 +269,7 @@ (object-like-macro identifier: "y" body: (lex "20")))) - (lex "x y"))) - ) + (lex "x y")))) ;; TODO @@ -314,42 +310,40 @@ )) -(test-group "Maybe extend identifier" - (test-equal "Non-identifier returns remaining" - '() ((unval maybe-extend-identifier 1) - (make-environment) - "x" - '())) - - (test-equal "Non-identifiers remaining tokens are returned verbatim" - '(remaining) ((unval maybe-extend-identifier 1) - (make-environment) - "x" - '(remaining))) - - (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" - '())) - - (test-equal "Object like macro still returns remaining verbatim" - (append (lex "1 + 2") '(remaining)) - ((unval maybe-extend-identifier 1) - (extend-environment (make-environment) - (list - (object-like-macro - identifier: "x" - body: (lex "1 + 2")))) - "x" - '(remaining))) + (test-group "Maybe extend identifier" + (test-equal "Non-identifier returns remaining" + (lex "x") + ((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))) + + (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" + '())) - ) + (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))) + + ) (test-group "Apply macro" (test-equal "zero arg macro on nothing" @@ -368,23 +362,156 @@ (function-like-macro identifier: "f" identifier-list: '("x") body: (lex "x")) - (lex "10")))) + ((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)"))))) (test-group "Expand macro part 2" (test-group "Function like macros" - (let ((e (make-environment)) - (m (function-like-macro - identifier: "f" - identifier-list: '() - body: (lex "1")))) - (call-with-values (lambda () (expand-macro e m (lex "()"))) - (lambda (_ tokens*) (test-equal (lex "1") tokens*))) - ;; TODO this should raise an arity error - (call-with-values (lambda () (expand-macro e m (lex "(10)"))) - (lambda (_ tokens*) (test-equal '() tokens*))))))) + (let ((e (make-environment))) + (let ((m (function-like-macro + identifier: "f" + identifier-list: '() + body: (lex "1")))) + (call-with-values (lambda () (expand-macro e m (lex "()"))) + (lambda (_ tokens*) (test-equal (lex "1") tokens*))) + (test-error "Arity error for to many args" + '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*))) + (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*))) + ) + )))) + +(let ((e (make-environment))) + (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)"))) + + (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)")) + ) + + (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"))) + + (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)"))) + + " +#define f(x) g(x) +#define g(y) y +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)"))) + + + + (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"))))) + +(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)"))) + (test-equal "defined(DEFINED)" + (lex "1") (resolve-token-stream + (extend-environment + e (list (object-like-macro identifier: "X" + body: (lex "10")))) + (lex "defined(X)"))))) + + +(let ((env (resolve-define (make-environment) + (lex "f(x) x+1")))) + (test-assert "New binding added" (in-environment? env "f")) + (let ((m (get-identifier env "f"))) + (test-equal "Macro parameters" '("x") (macro-identifier-list m)) + (test-equal "Macro body" (lex "x+1") (macro-body m)))) + +;; This should issue a warning, since the standard requires a space after the ending parenthe here (6.10.3) +;; (resolve-define (make-environment) +;; (lex "f(x)x+1")) -(define apply-macro (@@ (c preprocessor2) apply-macro)) +;; (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)")))) -;; (resolve-define (make-environment) -;; (lex "f(x) x+1")) + + +;; resolve-h-file +;; resolve-q-file +;; handle-pragma -- cgit v1.2.3