work.

1 files changed, 372 insertions, 11 deletions

diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index 117b7e49..3d62e224 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -1,22 +1,38 @@
 (define-module (test cpp preprocessor2)
   :use-module (srfi srfi-64)
-  :use-module (srfi srfi-88))
+  :use-module (srfi srfi-64 util)
+  :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 (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")))
 
 
+(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)))
-   (lambda (bef aft)
-     (test-equal '(before) bef)
-     (test-equal '((whitespace "\n") after) aft))))
+  (call-with-values
+      (lambda ()
+        (tokens-until-eol
+         '(before (whitespace "\n") after)))
+    (lambda (bef aft)
+      (test-equal '(before) bef)
+      (test-equal '((whitespace "\n") after) aft))))
 
 
 
+(define squeeze-whitespace (@@ (c preprocessor2) squeeze-whitespace))
 (test-equal "Squeeze whitespace"
-    '(bef (whitespace " ") aft)
+  '(bef (whitespace " ") aft)
   (squeeze-whitespace
    '(bef
      (whitespace a)
@@ -25,5 +41,350 @@
 
 
 
-(test-equal "("
-  (stringify-token '(preprocessor-token (operator "("))))
+(define stringify-token (@@ (c preprocessor2) stringify-token))
+(define stringify-tokens (@@ (c preprocessor2) stringify-tokens))
+
+(test-group "Stringify"
+  (test-equal "("
+    (stringify-token '(punctuator "(")))
+  ;; TODO more cases
+
+  (test-equal (car (lex "\"(a, b)\""))
+    (stringify-tokens (lex "(a,    b)")))
+  )
+
+
+(define parse-identifier-list (@@ (c preprocessor2) parse-identifier-list))
+
+(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)))
+
+  (test-group "Multiple parameters"
+    (let ((rest args (parse-identifier-list (lex "x, y"))))
+      (test-assert (not rest))
+      (test-equal '("x" "y") args)))
+
+
+  (test-group "Rest args after regular"
+    (let ((rest args (parse-identifier-list (lex "x, ..."))))
+      (test-assert rest)
+      (test-equal '("x") args)))
+
+  (test-group "Only rest args"
+    (let ((rest args (parse-identifier-list (lex "..."))))
+      (test-assert rest)
+      (test-equal '() args)))
+
+  (test-group "Errors"
+    (test-error "Compound forms are invalid"
+      'cpp-error (parse-identifier-list (lex "(y)")))
+
+    (test-error "Non-identifier atoms are invalid"
+      'cpp-error (parse-identifier-list (lex "1")))
+
+    (test-error "Rest args not at end is invalid"
+      'cpp-error (parse-identifier-list (lex "..., y")))))
+
+
+
+(define expand-stringifiers (@@ (c preprocessor2) expand-stringifiers))
+(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))
+
+(test-equal "Clean up whitespace"
+  (lex "( 2 , 4 )")
+  (cleanup-whitespace (lex "  \n (   2   , \n 4    )  \t   ")))
+
+
+;; Parameter lists (the callsite arguments to the macro)
+(test-group "Parameter list"
+  (test-group "Empty parameter list"
+    (let ((containing remaining nls (parse-parameter-list (lex "()"))))
+      (test-equal '() containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls)))
+
+  (test-group "Single value in parameter list"
+    (let ((containing remaining nls (parse-parameter-list (lex "(x)"))))
+      (test-equal (list (lex "x")) containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls)))
+
+  (test-group "Two values in parameter list"
+    (let ((containing remaining nls (parse-parameter-list (lex "(x, y)"))))
+      (test-equal (list (lex "x")
+                        (lex "y"))
+        containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls)))
+
+  (test-group "Three values in parameter list"
+    (let ((containing remaining nls (parse-parameter-list (lex "(x, y, z)"))))
+      (test-equal (list (lex "x")
+                        (lex "y")
+                        (lex "z"))
+        containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls)))
+
+  (test-group "Numeric parameter"
+    (let ((containing remaining nls (parse-parameter-list (lex "(1)"))))
+      (test-equal (list (lex "1")) containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls))
+    )
+
+  (test-group "Two values, one of which is a paretheseed pair"
+    (let ((containing remaining nls
+                      (parse-parameter-list (lex "(x, (y, z))"))))
+      (test-equal (list (lex "x") (lex "(y, z)"))
+        containing)
+      (test-equal '() remaining)
+      (test-equal 0 nls))))
+
+(test-group "Build parameter map"
+  (test-equal "Simplest case, zero arguments"
+    '()
+    (let ((m (function-like-macro
+              identifier: "str"
+              identifier-list: '()
+              body: (lex "#x"))))
+      (build-parameter-map
+       m '() #; (list (lex "x"))
+       )))
+
+  (test-equal "Single (simple) argument"
+    `(("x" . ,(lex "x")))
+    (let ((m (function-like-macro
+              identifier: "str"
+              identifier-list: '("x")
+              body: '())))
+      (build-parameter-map
+       m
+       (list (lex "x")))))
+
+  (test-equal "Single advanced argument"
+    `(("x" . ,(lex "(x)")))
+    (let ((m (function-like-macro
+              identifier: "str"
+              identifier-list: '("x")
+              body: '())))
+      (build-parameter-map
+       m (list (lex "(x)")))))
+
+  (test-group "Rest arguments"
+    (test-equal "Single simple"
+      `(("__VA_ARGS__" . ,(list (lex "x"))))
+      (let ((m (function-like-macro
+                identifier: "str"
+                identifier-list: '()
+                variadic?: #t
+                body: '())))
+        (build-parameter-map
+         m (list (lex "x")))))
+
+    #;
+    (test-equal "Two simple"
+      '()
+      (let ((m (function-like-macro
+                identifier: "str"
+                identifier-list: '()
+                variadic?: #t
+                body: '())))
+        (build-parameter-map
+         m (list (lex "x")))))
+    ))
+
+
+
+(test-group "Expand stringifiers"
+  (let ((m (function-like-macro
+            identifier: "str"
+            identifier-list: '("x")
+            body: (lex "#x"))))
+    (test-equal "Correct stringification of one param"
+      (lex "\"10\"")
+      (expand-stringifiers
+       m (build-parameter-map
+          m (list (lex "10"))))))
+
+  (let ((m (function-like-macro
+            identifier: "str"
+            identifier-list: '()
+            body: (lex "#x"))))
+    (test-error "Stringification fails for non-parameters"
+      'macro-expand-error
+      (expand-stringifiers
+       m (build-parameter-map
+          m (list (lex "x")))))))
+
+;; TODO expand-join
+;; token ## token2
+
+(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*"))))
+    (get-identifier e "__FILE__"))
+  (test-equal (object-like-macro identifier: "__LINE__"
+                                 body: '((preprocessing-token (pp-number "1"))))
+    (get-identifier e "__LINE__")))
+
+(define resolve-token-stream (@@ (c preprocessor2) resolve-token-stream))
+
+(test-group "Token streams"
+  (test-group "Non-expanding"
+    (test-equal "Null stream"
+      '() (resolve-token-stream (make-environment) '()))
+    (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")))
+    (test-equal "Identifier-likes with stuff after keep stuff after"
+      (lex "x 1") (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")))
+
+    (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")))
+
+    (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")))
+    )
+
+  ;; TODO
+
+  ;; (test-group "Function likes")
+
+  ;; (test-group "Mix of object and function likes")
+
+  )
+
+(define expand-macro (@@ (c preprocessor2) expand-macro))
+(define resolve-define (@@ (c preprocessor2) resolve-define))
+(define apply-macro (@@ (c preprocessor2) apply-macro))
+(define maybe-extend-identifier (@@ (c preprocessor2) maybe-extend-identifier))
+
+(test-group "Macro expansion"
+  (test-group "Expand macro part 1"
+    ;; Expand object like macros
+    ;; apply-macro depends on this, but expand macro with function like macros
+    ;; depend on apply-macro, thereby the two parter
+    (test-group "Object like macros"
+      (call-with-values
+          (lambda () (expand-macro (make-environment)
+                              (object-like-macro
+                               identifier: "x" body: (lex "1 + 2"))
+                              '()))
+        (lambda (_ tokens) (test-equal "Simplest case" (lex "1 + 2") 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)))
+
+      ;; (call-with-values (expand-macro (make-environment)))
+
+      ))
+
+
+(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 "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"))
+       '()))
+
+    (test-equal "Single arg macro"
+      (lex "10")
+      (apply-macro
+       (make-environment)
+       (function-like-macro identifier: "f"
+                            identifier-list: '("x")
+                            body: (lex "x"))
+       (lex "10"))))
+
+  (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*)))))))
+
+(define apply-macro (@@ (c preprocessor2) apply-macro))
+
+
+;; (resolve-define (make-environment)
+;;                 (lex "f(x) x+1"))