path: root/tests/test/cpp/preprocessor2.scm

(define-module (test cpp preprocessor2)
  :use-module (srfi srfi-64)
  :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))


;; 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
         (list before '(whitespace "\n") after)))
    (lambda (bef aft)
      (test-equal (list before) bef)
      (test-equal (list '(whitespace "\n") after) aft))))



(define squeeze-whitespace (@@ (c preprocessor2) squeeze-whitespace))
(test-equal "Squeeze whitespace"
  '(bef (whitespace " ") aft)
  (squeeze-whitespace
   '(bef
     (whitespace a)
     (whitespace b)
     aft)))



(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__" . ,(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"
      `(("__VA_ARGS__" . ,(lex "x,y")))
      (let ((m (function-like-macro
                identifier: "str"
                identifier-list: '()
                variadic?: #t
                body: '())))
        (build-parameter-map
         m (list (lex "x,y")))))))


(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"
      (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"
      (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"))
       ((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)))
        (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"))

;; (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-h-file
;; resolve-q-file
;; handle-pragma