aboutsummaryrefslogtreecommitdiff
path: root/tests/test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/test')
-rw-r--r--tests/test/c-parse.scm69
-rw-r--r--tests/test/cpp.scm603
-rw-r--r--tests/test/cpp/cpp-environment.scm45
-rw-r--r--tests/test/cpp/lex2.scm177
-rw-r--r--tests/test/cpp/preprocessor2.scm1247
-rw-r--r--tests/test/cpp/to-token.scm65
-rw-r--r--tests/test/cpp/util.scm14
-rw-r--r--tests/test/datetime.scm40
-rw-r--r--tests/test/lens.scm21
-rw-r--r--tests/test/object.scm80
-rw-r--r--tests/test/recurrence-advanced.scm1
-rw-r--r--tests/test/util.scm28
12 files changed, 2353 insertions, 37 deletions
diff --git a/tests/test/c-parse.scm b/tests/test/c-parse.scm
new file mode 100644
index 00000000..c16958de
--- /dev/null
+++ b/tests/test/c-parse.scm
@@ -0,0 +1,69 @@
+;;; Commentary
+;; Test implementation details of C parser
+;; TODO Should be ran before (test cpp)
+;;; Code
+
+(define-module (test cpp)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-88)
+ :use-module ((c lex) :select (lex))
+ :use-module (c parse))
+
+(define flatten-infix (@@ (c parse) flatten-infix))
+(define resolve-order-of-operations (@@ (c parse) resolve-order-of-operations))
+
+(test-group "Flatten infix"
+ (test-equal "Simple binary operator"
+ '(fixed-infix (integer (base-10 "1"))
+ +
+ (integer (base-10 "2")))
+ (flatten-infix (lex "1 + 2")))
+
+ (test-equal "Simple binary operator, with compound structure in on branch"
+ '(fixed-infix (integer (base-10 "1"))
+ +
+ (funcall (variable "f")
+ (group (integer (base-10 "2")))))
+ (flatten-infix (lex "1 + f(2)"))))
+
+(test-group "Order of operations"
+ (test-equal "Basic binary operator"
+ '((resolved-operator +)
+ (integer (base-10 "1"))
+ (integer (base-10 "2")))
+ (resolve-order-of-operations (flatten-infix (lex "1 + 2"))))
+
+ (test-equal "Multiple operators, with non-left-associative application"
+ '((resolved-operator +)
+ (integer (base-10 "1"))
+ ((resolved-operator *)
+ (integer (base-10 "2"))
+ (integer (base-10 "3"))))
+ (resolve-order-of-operations (flatten-infix (lex "1 + 2 * 3"))))
+
+ (test-equal "Multiple of the same operation gets clumed together"
+ '((resolved-operator +)
+ (integer (base-10 "1"))
+ (integer (base-10 "2"))
+ (integer (base-10 "3")))
+ (resolve-order-of-operations (flatten-infix (lex "1 + 2 + 3"))))
+
+ (test-equal "Simple Ternary"
+ '(ternary
+ (integer (base-10 "1"))
+ (integer (base-10 "2"))
+ (integer (base-10 "3")))
+ (resolve-order-of-operations (flatten-infix (lex "1 ? 2 : 3"))))
+
+ (test-equal "ternary with further infix operators"
+ '(ternary ((resolved-operator +)
+ (integer (base-10 "1"))
+ (integer (base-10 "2")))
+ ((resolved-operator %)
+ (integer (base-10 "3"))
+ (integer (base-10 "4")))
+ ((resolved-operator *)
+ (integer (base-10 "5"))
+ (integer (base-10 "6"))))
+ (resolve-order-of-operations (flatten-infix (lex "1 + 2? 3 % 4 : 5 * 6")))))
+
diff --git a/tests/test/cpp.scm b/tests/test/cpp.scm
index 9c720fde..1294bc96 100644
--- a/tests/test/cpp.scm
+++ b/tests/test/cpp.scm
@@ -3,37 +3,602 @@
;;; Code:
(define-module (test cpp)
+ :use-module (srfi srfi-1)
:use-module (srfi srfi-64)
:use-module (srfi srfi-88)
:use-module ((c lex) :select (lex))
- :use-module ((c parse) :select (parse-lexeme-tree)))
+ :use-module ((c parse) :select (parse-lexeme-tree))
+ :use-module ((c eval) :select (c-eval))
+ :use-module ((c eval environment) :select (make-environment env-set!))
+ :use-module ((rnrs arithmetic bitwise)
+ :select (bitwise-xor)))
+
+;; Note that the lexer's output isn't stable.
+;; The tests here are more to see where the lexer succeeds but the parser fails.
+;; So changing the lexer test cases isn't a problem
+;; but don't change the parser test cases
+
+;; __asm__ always has strings as arguments
+(test-skip "__asm__")
+
+;; Lexer produces garbage when attempted. Fixing this would also fix cast
+;; operations.
+(test-skip "Float in infix expression")
+;; order of operation is wrong, leading to an incorrect result
+(test-skip "Cast with operation")
+
+;; not implemented
+(test-skip "Token concatenation")
+
+;; A string follewed by a macro (which expands to a string)
+;; should be concatenated. This is however not yet implemented
+(test-skip "Implicit concatenation of string and macro")
(define run (compose parse-lexeme-tree lex))
-(test-equal
- '(+ (post-increment (dereference C)) 3)
- (run "(*C)++ + 3"))
+(define (alist->environment alist)
+ (fold (lambda (pair env)
+ (apply env-set! env pair))
+ (make-environment)
+ alist))
+
+(define (exec form . base-bindings)
+ (call-with-values
+ (lambda () (c-eval (alist->environment base-bindings)
+ (run form)))
+ (lambda (env value) value)))
+
+(define-syntax let-group
+ (syntax-rules ()
+ ((let ((form name) rest ...) body ...)
+ (test-group name
+ (let ((form name)
+ rest ...)
+ body ...)))))
+
+(let-group
+ ((form "(*C)++ + 3"))
+ (test-equal '(infix (postfix (group (prefix (prefix-operator "*")
+ (variable "C")))
+ (postfix-operator "++"))
+ (operator "+")
+ (integer (base-10 "3")))
+ (lex form))
+ (test-equal '(+ (post-increment (dereference C)) 3)
+ (run form)))
+
+(let-group
+ ((form "*C++ + 3"))
+ (test-equal '(infix (postfix (prefix (prefix-operator "*")
+ (variable "C"))
+ (postfix-operator "++"))
+ (operator "+")
+ (integer (base-10 "3")))
+ (lex form))
+ (test-equal '(+ (post-increment (dereference C)) 3)
+ (run form)))
+
+(let-group
+ ((form "*C++"))
+ (test-equal '(postfix (prefix (prefix-operator "*")
+ (variable "C"))
+ (postfix-operator "++"))
+ (lex form))
+ (test-equal '(post-increment (dereference C))
+ (run form)))
+
+(let-group
+ ((form "C++ + C++"))
+ (test-equal '(infix (postfix (variable "C")
+ (postfix-operator "++"))
+ (operator "+")
+ (postfix (variable "C")
+ (postfix-operator "++")))
+ (lex form))
+ (test-equal '(+ (post-increment C) (post-increment C))
+ (run form)))
+
+(let-group
+ ((form "++C + ++C"))
+ (test-equal '(infix (prefix (prefix-operator "++")
+ (variable "C"))
+ (operator "+")
+ (prefix (prefix-operator "++")
+ (variable "C")))
+ (lex form))
+ (test-equal '(+ (pre-increment C) (pre-increment C))
+ (run form)))
+
+(let-group
+ ((form "2 + 2 * 2"))
+ (test-equal '(infix (integer (base-10 "2"))
+ (operator "+")
+ (infix (integer (base-10 "2"))
+ (operator "*")
+ (integer (base-10 "2"))))
+ (lex form))
+ (test-equal '(+ 2 (* 2 2)) (run form))
+ (test-equal 6 (exec form)))
+
+(let-group
+ ((form "2 * 2 + 2"))
+ (test-equal '(infix (integer (base-10 "2"))
+ (operator "*")
+ (infix (integer (base-10 "2"))
+ (operator "+")
+ (integer (base-10 "2"))))
+ (lex form))
+ (test-equal '(+ (* 2 2) 2) (run form))
+ (test-equal 6 (exec form)))
+
+(let-group
+ ((form "2+2+2"))
+ (test-equal '(infix (integer (base-10 "2"))
+ (operator "+")
+ (infix (integer (base-10 "2"))
+ (operator "+")
+ (integer (base-10 "2")))) (lex form))
+ (test-equal '(+ 2 2 2) (run form))
+ (test-equal 6 (exec form)))
+
+(test-group "Unary minus"
+ (test-group "Without space"
+ (let ((form "-1"))
+ (test-equal '(prefix (prefix-operator "-")
+ (integer (base-10 "1")))
+ (lex form))
+ (test-equal '(- 1) (run form))
+ (test-equal -1 (exec form))))
+
+ (test-group "With space"
+ (let ((form "- 1"))
+ (test-equal '(prefix (prefix-operator "-")
+ (integer (base-10 "1")))
+ (lex form))
+ (test-equal '(- 1) (run form))
+ (test-equal -1 (exec form))))
+
+ (test-group "Before variable"
+ (let ((form "-x"))
+ (test-equal '(prefix (prefix-operator "-")
+ (variable "x"))
+ (lex form))
+ (test-equal '(- x) (run form))
+ (test-equal -5 (exec form '(x 5)))))
+
+ (test-group "Before infix"
+ (let ((form "-x+3"))
+ (test-equal '(infix (prefix (prefix-operator "-")
+ (variable "x"))
+ (operator "+")
+ (integer (base-10 "3")))
+ (lex form))
+ (test-equal '(+ (- x) 3) (run form))
+ (test-equal -2 (exec form '(x 5)))))
+
+ (test-group "Inside infix expression"
+ (let ((form "x+-3"))
+ (test-equal '(infix (variable "x")
+ (operator "+")
+ (prefix (prefix-operator "-")
+ (integer (base-10 "3"))))
+ (lex form))
+ (test-equal '(+ x (- 3)) (run form))
+ (test-equal 2 (exec form '(x 5)))))
+ )
+
+
+
+
+;; Hand picked forms from output of `cpp -dM /usr/include/termios.h` on
+;; FreeBSD 13.1-RELEASE releng/13.1-n250148-fc952ac2212 GENERIC amd64
+;; 2022-06-28
+
+(let ((form "00000200"))
+ (test-equal '(integer (base-8 "0000200")) (lex form))
+ (test-equal 128 (run form)))
+
+(let ((form "0"))
+ (test-equal '(integer (base-10 "0")) (lex form))
+ (test-equal 0 (run form)))
+
+(let ((form "1000000U"))
+ (test-equal '(integer (base-10 "1000000") (integer-suffix "U")) (lex form))
+ (test-equal '(as-type (unsigned) 1000000) (run form))
+ (test-equal 1000000 (exec form)))
+
+
+(let ((form "0x10c"))
+ (test-equal '(integer (base-16 "10c")) (lex form))
+ (test-equal 268 (run form)))
+
+;; Lexer keeps original case, handled later by parser
+(let ((form "0X10C"))
+ (test-equal '(integer (base-16 "10C")) (lex form))
+ (test-equal 268 (run form)))
+
+(let ((form "a != b"))
+ (test-equal '(infix (variable "a")
+ (operator "!=")
+ (variable "b"))
+ (lex form))
+ (test-equal '(not_eq a b) (run form))
+ (test-equal 1 (exec form '(a 1) '(b 2)))
+ (test-equal 0 (exec form '(a 1) '(b 1)))
+ )
+
+(let ((form "((c) == (val) && (val) != _POSIX_VDISABLE)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(and (== c val)
+ (not_eq val _POSIX_VDISABLE))
+ (run form))
+ (test-equal 0 (exec form '(c 1) '(val 2) '(_POSIX_VDISABLE 3)))
+ )
+
+(let ((form "CTRL('O')"))
+ (test-equal '(funcall (variable "CTRL") (group (char "O"))) (lex form))
+ (test-equal '(funcall CTRL 79) (run form))
+ (test-equal (bitwise-xor #x40 (char->integer #\O))
+ (exec form
+ ;; Definition copied from our parsers output of
+ ;; preprocessing output as defined above
+ '(CTRL (lambda (x)
+ (ternary (and (>= x 97) (<= x 122))
+ (+ (- x 97) 1)
+ (bitand (+ (- x 65) 1) 127)))))))
+
+(let ((form "CREPRINT"))
+ (test-equal '(variable "CREPRINT") (lex form))
+ (test-equal 'CREPRINT (run form)))
+
+(let ((form "(CCTS_OFLOW | CRTS_IFLOW)"))
+ (test-equal '(group (infix (variable "CCTS_OFLOW")
+ (operator "|")
+ (variable "CRTS_IFLOW")))
+ (lex form))
+ (test-equal '(bitor CCTS_OFLOW CRTS_IFLOW) (run form)))
+
+;; ((x) >= 'a' && (x) <= 'z'
+;; ? ((x) - 'a' + 1)
+;; : (((x) - 'a' + 1) & 0x7f))
+(let ((form "((x) >= 'a' && (x) <= 'z' ? ((x) - 'a' + 1) : (((x) - 'a' + 1) & 0x7f))"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(ternary
+ (and (>= x #x61)
+ (<= x #x7A))
+ (+ (- x #x61) 1)
+ (bitand (+ (- x #x61) 1) 127))
+ (run form)))
+
+(let ((form "((x) & ~(IOCPARM_MASK << 16))"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(bitand x (compl (<< IOCPARM_MASK 16))) (run form)))
+
+(let ((form "(((x) >> 8) & 0xff)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(bitand (>> x 8) 255) (run form)))
+
+(let ((form "(((x) >> 16) & IOCPARM_MASK)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(bitand (>> x 16) IOCPARM_MASK) (run form)))
+
+(let ((form "((1 << IOCPARM_SHIFT) - 1)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(- (<< 1 IOCPARM_SHIFT) 1) (run form)))
+
+(let ((form "_IO('t', 120)"))
+ (test-equal '(funcall
+ (variable "_IO")
+ (group (infix (char "t")
+ (operator ",")
+ (integer (base-10 "120")))))
+ (lex form))
+ (test-equal '(funcall _IO (#{,}# 116 120)) (run form)))
+
+;; note the lone type
+(let ((form "_IOW('t', 98, int)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(funcall _IOW (#{,}# 116 98 int))
+ (run form)))
+
+;; note the multi-word type
+(let ((form "_IOR('t', 19, struct termios)"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(funcall _IOR (#{,}# 116 19 (struct-type termios))) (run form)))
+
+
+;; TODO concatenation rules
+;; #define __CONCAT(x,y) __CONCAT1(x,y)
+;; #define __CONCAT1(x,y) x ## y
+;; #define __CONSTANT_CFSTRINGS__ 1
+;; #define __COPYRIGHT(s) __IDSTRING(__CONCAT(__copyright_,__LINE__),s)
+
+(test-group "Token concatenation"
+ (let ((form "x ## y"))
+ (test-equal '() (lex form))
+ (test-equal '0 (run form))))
+
+(test-group "Floating point numbers"
+
+ (test-group "Diffent forms"
+ (test-group "No decimal point, exponent, no suffix"
+ (let ((form "10e10"))
+ (test-equal '(float (float-integer (base-10 "10"))
+ (exponent (base-10 "10")))
+ (lex form))
+ (test-equal 10e10 (run form))))
+
+ (test-group "No decimal point, negative exponent"
+ (let ((form "10e-10"))
+ (test-equal '(float (float-integer (base-10 "10"))
+ (exponent "-" (base-10 "10")))
+ (lex form))
+ (test-equal 10e-10 (run form))))
+
+ (test-group "No decimal point, exponent and suffix"
+ (let ((form "10e10L"))
+ (test-equal '(float (float-integer (base-10 "10"))
+ (exponent (base-10 "10"))
+ (float-suffix "L"))
+ (lex form))
+ (test-equal '(as-type (long double) 10e10)
+ (run form))))
+
+ (test-group "Leading period, no exponent or suffix"
+ (let ((form ".1"))
+ (test-equal '(float (float-decimal (base-10 "1"))) (lex form))
+ (test-equal 0.1 (run form))))
+
+ (test-group "Trailing period, no exponent or suffix"
+ (let ((form "1."))
+ (test-equal '(float (float-integer (base-10 "1"))) (lex form))
+ (test-equal 1.0 (run form)))))
+
+
+ (test-group "Negative float"
+ (let ((form "-1.0"))
+ (test-equal '(prefix (prefix-operator "-")
+ (float (float-integer (base-10 "1"))
+ (float-decimal (base-10 "0"))))
+ (lex form))
+ (test-equal '(- 1.0) (run form))))
+
+
+
+ (test-group "Real world examples"
+ (let ((form "4.9406564584124654e-324"))
+ (test-equal '(float (float-integer (base-10 "4"))
+ (float-decimal (base-10 "9406564584124654"))
+ (exponent "-" (base-10 "324")))
+ (lex form))
+ (test-equal 4.9406564584124654e-324 (run form)))
+
+ (let ((form "1.7976931348623157e+308"))
+ (test-equal '(float (float-integer (base-10 "1"))
+ (float-decimal (base-10 "7976931348623157"))
+ (exponent "+" (base-10 "308")))
+ (lex form))
+ (test-equal 1.7976931348623157e+308 (run form))))
+
+ (test-group "Float in infix expression"
+ (test-group "Simple case"
+ (let ((form "1. + .1"))
+ (test-equal '(infix (float (float-integer (base-10 "1")))
+ (operator "+")
+ (float (float-decimal (base-10 "1"))))
+ (lex form))
+ (test-equal '(+ 1.0 0.1) (run form))))
+ ;; (test-group "Complicated case")
+ ))
+
+(test-group "Typecasts"
+
+ (let ((form "(unsigned) 5"))
+ (test-equal '((group (variable "unsigned"))
+ (integer (base-10 "5")))
+ (lex form))
+ (test-equal '(as-type (unsigned) 5)
+ (run form)))
+
+ (let ((form "(unsigned integer) 5"))
+ (test-equal '((group (variable "unsigned")
+ (variable "integer"))
+ (integer (base-10 "5")))
+ (lex form))
+ (test-equal '(as-type (unsigned integer) 5) (run form)))
+
+ (test-group "Pointer with space"
+ (let ((form "(int *) 5"))
+ (test-equal '((group (postfix (variable "int")
+ (postfix-operator "*")))
+ (integer (base-10 "5")))
+ (lex form))
+ (test-equal '(as-type (int *) 5)
+ (run form))))
+
+ (test-group "Pointer without space"
+ (let ((form "(int*) 5"))
+ (test-equal '((group (postfix (variable "int")
+ (postfix-operator "*")))
+ (integer (base-10 "5")))
+ (lex form))
+ (test-equal '(as-type (int *) 5)
+ (run form))))
+
+ (test-group "Multi word type pointer"
+ (let ((form "(unsigned int*) 5"))
+ (test-equal '((group (variable "unsigned")
+ (postfix (variable "int")
+ (postfix-operator "*")))
+ (integer (base-10 "5")))
+ (lex form))
+ (test-equal '(as-type (unsigned int *) 5)
+ (run form))))
+
+ (test-group "Double cast"
+ (let ((form "(int)(unsigned) 5"))
+ (test-equal '((group (variable "int"))
+ (group (variable "unsigned"))
+ (integer (base-10 "5"))) (lex form))
+ (test-equal '(as-type (int) (as-type (unsigned) 5))
+ (run form))))
+
+ (test-group "Cast with operation"
+ (let ((form "(int) 5 + 7"))
+ (test-equal '((group (variable "int"))
+ (infix (integer (base-10 "5"))
+ (operator "+")
+ (integer (base-10 "7"))))
+ (lex form))
+
+ (test-equal '(+ (as-type (int) 5) 7)
+ (run form))))
+
+
+
+ (test-group "Tripple cast, with value inside paranthesis"
+ (let ((form "(type)(__uintptr_t)(const void *)(var)"))
+ (test-equal '((group (variable "type"))
+ (group (variable "__uintptr_t"))
+ (group (variable "const")
+ (postfix (variable "void")
+ (postfix-operator "*")))
+ (group (variable "var")))
+ (lex form))
+ (test-equal '(as-type (type)
+ (as-type (__uintptr_t)
+ (as-type (const void *)
+ var)))
+ (run form))))
+
+ (test-group "Same as above, but whole thing inside parenthesis"
+ (let ((form "((type)(__uintptr_t)(const void *)(var))"))
+ (test-equal '(group (group (variable "type"))
+ (group (variable "__uintptr_t"))
+ (group (variable "const")
+ (postfix (variable "void")
+ (postfix-operator "*")))
+ (group (variable "var")))
+ (lex form))
+ (test-equal '(as-type (type)
+ (as-type (__uintptr_t)
+ (as-type (const void *)
+ var)))
+ (run form))))
+
+ (let ((form "((type)(__uintptr_t)(const volatile void *)(var))"))
+ ;; (test-equal '() (lex form))
+ (test-equal '(as-type (type)
+ (as-type (__uintptr_t)
+ (as-type (const volatile void *)
+ var)))
+ (run form)))
+
+ (let ((form "((unsigned long) ((inout) | (((len) & IOCPARM_MASK) << 16) | ((group) << 8) | (num)))"))
+ (test-equal '(group (group (variable "unsigned") (variable "long"))
+ (group (infix (group (variable "inout"))
+ (operator "|")
+ (infix (group (infix (group (infix (group (variable "len"))
+ (operator "&")
+ (variable "IOCPARM_MASK")))
+ (operator "<<")
+ (integer (base-10 "16"))))
+ (operator "|")
+ (infix (group (infix (group (variable "group"))
+ (operator "<<")
+ (integer (base-10 "8"))))
+ (operator "|")
+ (group (variable "num")))))))
+ (lex form))
+ (test-equal '(as-type (unsigned long)
+ (bitor inout
+ (<< (bitand len IOCPARM_MASK) 16)
+ (<< group 8)
+ num))
+ (run form))))
+
+(test-group "Characters"
+ (let ((form "'c'"))
+ (test-equal '(char "c") (lex form))
+ (test-equal #x63 (run form)))
+
+ (let ((form "'\\n'"))
+ (test-equal '(char (escaped-char "n")) (lex form))
+ (test-equal (char->integer #\newline) (run form))))
+
+(test-group "Strings"
+ (test-group "Empty string"
+ (let ((form "\"\""))
+ (test-equal 'string (lex form))
+ (test-equal #vu8(0) (run form))))
+
+ (test-group "Simple string"
+ (let ((form "\"li\""))
+ (test-equal '(string "li") (lex form))
+ (test-equal #vu8(#x6C #x69 0) (run form))))
+
+ (test-group "Implicit concatenation of strings"
+ (let ((form "\"a\" \"b\""))
+ (test-equal '((string "a")
+ (string "b"))
+ (lex form))
+ (test-equal #vu8(#x61 #x62 0)
+ (run form))))
-(test-equal
- '(+ (post-increment (dereference C)) 3)
- (run "*C++ + 3"))
+ (test-group "Implicit concatenation of string and macro"
+ (let ((form "\"a\" MACRO"))
+ (test-equal '((string "a") (variable "MACRO")) (lex form))
+ (test-equal '() (run form))))
-(test-equal
- '(post-increment (dereference C))
- (run "*C++"))
+ (test-group "String with only escape"
+ (let ((form (string #\" #\\ #\" #\")))
+ (test-equal `(string (escaped-char "\"")) (lex form))
+ (test-equal #vu8(34 0) (run form))))
-(test-equal
- '(+ (post-increment C) (post-increment C))
- (run "C++ + C++"))
+ (test-group "String with escape at start"
+ (let ((form (string #\" #\\ #\" #\a #\")))
+ (test-equal `(string (escaped-char "\"") "a") (lex form))
+ (test-equal #vu8(34 #x61 0) (run form))))
-(test-equal
- '(+ (pre-increment C) (pre-increment C))
- (run "++C + ++C"))
+ (test-group "String with escape at end"
+ (let ((form (string #\" #\a #\\ #\" #\")))
+ (test-equal `(string "a" (escaped-char "\"")) (lex form))
+ (test-equal #vu8(#x61 34 0) (run form))))
-(test-equal '(+ 2 (* 2 2)) (run "2 + 2 * 2"))
+ (test-group "String with escape in middle"
+ (let ((form (string #\" #\a #\\ #\" #\b #\")))
+ (test-equal `(string "a" (escaped-char "\"") "b") (lex form))
+ (test-equal #vu8(#x61 34 #x62 0) (run form))))
-(test-equal '(+ (* 2 2) 2) (run "2 * 2 + 2"))
+ ;; \e is semi non-standard
+ (test-group "String with bakslash-e esacpe"
+ (let ((form "\"\\e\""))
+ (test-equal '(string (escaped-char "e")) (lex form))
+ (test-equal #vu8(#x1b 0) (run form))))
-(test-equal '(+ 2 2 2) (run "2+2+2"))
+ (test-group "String with byte secquence escape"
+ (let ((form "\"\\xf0\\x9f\\x92\\xa9\""))
+ (test-equal '(string (escaped-char (base-16-char "f0"))
+ (escaped-char (base-16-char "9f"))
+ (escaped-char (base-16-char "92"))
+ (escaped-char (base-16-char "a9")))
+ (lex form))
+ (test-equal #vu8(#xf0 #x9f #x92 #xa9 0) (run form)))))
+(test-group "__asm__"
+ (let ((form "__asm__(\".globl \" __XSTRING(sym))"))
+ (test-equal '() (lex form))
+ ;; TODO implicit string concatenation
+ (test-equal '(funcall __asm__
+ (string ".globl ")
+ (funcall __XSTRING sym)) (run form))))
+(let ((form "__attribute__((__aligned__(x)))"))
+ (test-equal '(funcall (variable "__attribute__")
+ (group (group (funcall (variable "__aligned__")
+ (group (variable "x"))))))
+ (lex form))
+ ;; This drops the extra set of parenthesis. Do we care?
+ (test-equal '(funcall __attribute__
+ (funcall __aligned__ x))
+ (run form)))
diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm
new file mode 100644
index 00000000..684c0fb5
--- /dev/null
+++ b/tests/test/cpp/cpp-environment.scm
@@ -0,0 +1,45 @@
+(define-module (test cpp cpp-environmunt)
+ :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)
+ )
+
+(let ((e (make-environment)))
+ (test-equal '(outside) (cpp-if-status e))
+ (let ((e* (enter-active-if e)))
+ (test-equal "Enter works" '(active-if outside) (cpp-if-status e*))
+ (test-equal "Original object remainins unmodified"
+ '(outside) (cpp-if-status e))))
+
+(define cpp-file-stack (@@ (c cpp-environment) cpp-file-stack))
+
+(let ((e (make-environment)))
+ (test-equal "Default file stack"
+ '(("*outside*" . 1))
+ (cpp-file-stack e))
+ (let ((e* (enter-file e "test.c")))
+ (test-equal "File stack after entering file"
+ '(("test.c" . 1) ("*outside*" . 1)) (cpp-file-stack e*))
+ (let ((e** (bump-line e*)))
+ (test-equal 2 (current-line e**)))))
+
+
+
+(let ((e (make-environment)))
+ (let ((e* (add-identifier
+ e "key"
+ (object-like-macro
+ identifier: "key"
+ body: (lex "value")))))
+ (let ((result (get-identifier e* "key")))
+ (test-assert (cpp-macro? result))
+ (test-equal (lex "value")
+ (macro-body result)))))
+
+(let ((e (make-environment)))
+ (let ((result (get-identifier e "key")))
+ (test-assert "Missing identifier returns #f"
+ (not result)))
+ )
diff --git a/tests/test/cpp/lex2.scm b/tests/test/cpp/lex2.scm
new file mode 100644
index 00000000..f4f9b857
--- /dev/null
+++ b/tests/test/cpp/lex2.scm
@@ -0,0 +1,177 @@
+(define-module (test cpp lex2)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-88)
+ :use-module (ice-9 peg)
+ :use-module (c lex2))
+
+(define (l s) (lexeme type: 'preprocessing-token body: s))
+
+(define (ls . xs)
+ (map l xs))
+
+(test-equal "Integer literal"
+ (ls '(pp-number "10"))
+ (lex "10"))
+
+(test-equal "String literal"
+ (ls `(string-literal (encoding-prefix) "Hello"))
+ (lex "\"Hello\""))
+
+
+(test-equal "Mulitple tokens, including whitespace"
+ (list (lexeme type: 'whitespace body: " ")
+ (l '(pp-number "10"))
+ (lexeme type: 'whitespace body: " "))
+ (lex " 10 "))
+
+(test-equal "Char literal"
+ (ls `(character-constant (character-prefix) "a"))
+ (lex "'a'"))
+
+
+
+(test-equal "Comment inside string"
+ (ls `(string-literal (encoding-prefix) "Hel/*lo"))
+ (lex "\"Hel/*lo\""))
+
+(test-equal "#define line"
+ (list
+ (l '(punctuator "#"))
+ (l '(identifier "define"))
+ (lexeme type: 'whitespace body: " ")
+ (l '(identifier "f"))
+ (l '(punctuator "("))
+ (l '(identifier "x"))
+ (l '(punctuator ")"))
+ (lexeme type: 'whitespace body: " ")
+ (l '(pp-number "10")))
+ (lex "#define f(x) 10"))
+
+
+
+(test-equal "Nested parenthesis"
+ (list
+ (l '(identifier "f"))
+ (l '(punctuator "("))
+ (l '(pp-number "1"))
+ (l '(punctuator ","))
+ (lexeme type: 'whitespace body: " ")
+ (l '(punctuator "("))
+ (l '(pp-number "2"))
+ (l '(punctuator ","))
+ (lexeme type: 'whitespace body: " ")
+ (l '(pp-number "3"))
+ (l '(punctuator ")"))
+ (l '(punctuator ","))
+ (lexeme type: 'whitespace body: " ")
+ (l '(pp-number "4"))
+ (l '(punctuator ")")))
+ (lex "f(1, (2, 3), 4)"))
+
+
+
+;; Generating a single lexeme
+;; (whitespace " ")
+;; would also be ok
+(test-equal "Grouped whitespace"
+ (list (lexeme type: 'whitespace body: " ")
+ (lexeme type: 'whitespace body: " "))
+ (lex " "))
+
+(test-equal "Newlines get sepparate whitespace tokens"
+ (list (lexeme type: 'whitespace body: " ")
+ (lexeme type: 'whitespace body: " ")
+ (lexeme type: 'whitespace body: "\n")
+ (lexeme type: 'whitespace body: " "))
+ (lex " \n "))
+
+
+;; Refer to 6.4 p.1 for the syntax requirement
+;; 6.10.9 p. 2 for the sample string
+(test-equal "each non-white-space character that cannot be one of the above"
+ (list (l '(punctuator "."))
+ (l '(punctuator "."))
+ (lexeme type: 'other body: "\\") ; <- Interesting part
+ (l '(identifier "listing"))
+ (l '(punctuator "."))
+ (l '(identifier "dir")))
+ (lex "..\\listing.dir"))
+
+
+(test-equal "Propper H-string"
+ (ls '(header-name (h-string "a")))
+ (lex "<a>"))
+
+(test-equal "Unexpected h-string"
+ (list (l '(pp-number "1"))
+ (lexeme type: 'whitespace body: " ")
+ (l '(header-name (h-string " 2 ")))
+ (lexeme type: 'whitespace body: " ")
+ (l '(pp-number "3")))
+ (lex "1 < 2 > 3"))
+
+(test-equal "Quotation mark inside h-string"
+ (ls '(header-name (h-string "a\"b")))
+ (lex "<a\"b>"))
+
+(test-equal "Interaction of h-strings and regular strings"
+ (test-equal "Less than string, not h-string"
+ (ls '(pp-number "1")
+ '(string-literal (encoding-prefix) "<")
+ '(punctuator ">"))
+ (lex "1\"<\">"))
+
+ (test-equal "H-string, not string"
+ (list (lexeme type: 'preprocessing-token body: '(pp-number "1"))
+ (lexeme type: 'preprocessing-token body: '(header-name (h-string "\"")))
+ (lexeme type: 'other body: "\""))
+ (lex "1<\">\"")))
+
+(test-equal "Q-strings are lexed as regular strings"
+ (list (l '(punctuator "#"))
+ (l '(identifier "include"))
+ (lexeme type: 'whitespace body: " ")
+ (l '(string-literal (encoding-prefix) "test")))
+ ;; # include here, since generated tokens could possible depend on that context,
+ ;; and the reason regular strings are returned is since the lexer doesn't check
+ ;; that context
+ (lex "#include \"test\"")
+ )
+
+
+
+(test-group "Unicode"
+ (test-equal "In string literals"
+ (ls '(string-literal (encoding-prefix) "åäö"))
+ (lex "\"åäö\""))
+
+ (test-equal "Outside string literals"
+ (list (lexeme type: 'other body: "å")
+ (lexeme type: 'other body: "ä")
+ (lexeme type: 'other body: "ö"))
+ (lex "åäö")))
+
+
+
+
+(test-group "Characters with prefixes"
+ (test-equal (ls '(character-constant (character-prefix . "u")
+ "a"))
+ (lex "u'a'"))
+ (test-equal (ls '(character-constant (character-prefix . "U")
+ "a"))
+ (lex "U'a'"))
+ (test-equal (ls '(character-constant (character-prefix . "L")
+ "a"))
+ (lex "L'a'")))
+
+;; Note that these strings have 0 "data" components
+(test-group "Strings with prefixes"
+ (test-equal (ls '(string-literal (encoding-prefix . "u8")))
+ (lex "u8\"\""))
+ (test-equal (ls '(string-literal (encoding-prefix . "u")))
+ (lex "u\"\""))
+ (test-equal (ls '(string-literal (encoding-prefix . "U")))
+ (lex "U\"\""))
+ (test-equal (ls '(string-literal (encoding-prefix . "L")))
+ (lex "L\"\"")))
diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
new file mode 100644
index 00000000..1df1a621
--- /dev/null
+++ b/tests/test/cpp/preprocessor2.scm
@@ -0,0 +1,1247 @@
+(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 ((hnh util lens) :select (set))
+ :use-module (c preprocessor2)
+ :use-module ((c cpp-environment)
+ :select (extend-environment
+ make-environment
+ get-identifier
+ enter-file
+ in-environment?
+ macro-identifier-list
+ macro-body
+ cpp-file-stack))
+ :use-module ((c cpp-environment function-like-macro) :select (function-like-macro))
+ :use-module ((c cpp-environment object-like-macro) :select (object-like-macro))
+ :use-module ((c cpp-util)
+ :select (drop-whitespace-both
+ tokens-until-eol
+ squeeze-whitespace
+ cleanup-whitespace
+ next-token-matches?
+ ))
+ :use-module ((c unlex)
+ :select (
+ unlex
+ unlex-aggressive
+ stringify-token
+ stringify-tokens
+ )
+ )
+ :use-module ((c cpp-types)
+ :select (punctuator-token? identifier-token?))
+ :use-module (c lex2)
+ )
+
+;; TODO Redefinition checking code isn't yet written
+(test-skip "Example 6")
+
+;; See (c preprocessor2) TODO#1
+(test-expect-fail (test-match-group
+ "6.10.3.5 Scope of macro definitions"
+ "Example 3"))
+
+;; TODO # if (and # elif) aren't yet implemented
+(test-skip (test-match-group "Conditionals" "if"))
+
+(define apply-macro (@@ (c preprocessor2) apply-macro))
+(define build-parameter-map (@@ (c preprocessor2) build-parameter-map))
+(define expand# (@@ (c preprocessor2) expand#))
+(define expand## (@@ (c preprocessor2) expand##))
+(define expand-macro (@@ (c preprocessor2) expand-macro))
+(define handle-line-directive (@@ (c preprocessor2) handle-line-directive))
+(define handle-preprocessing-tokens (@@ (c preprocessor2) handle-preprocessing-tokens))
+(define join-file-line (@@ (c preprocessor2) join-file-line))
+(define mark-noexpand (@@ (c preprocessor2) mark-noexpand))
+(define maybe-extend-identifier (@@ (c preprocessor2) maybe-extend-identifier))
+(define parse-identifier-list (@@ (c preprocessor2) parse-identifier-list))
+(define parse-parameter-list (@@ (c preprocessor2) parse-parameter-list))
+(define resolve-define (@@ (c preprocessor2) resolve-define))
+(define resolve-token-stream (@@ (c preprocessor2) resolve-token-stream))
+;; (define tokenize (@@ (c preprocessor2) tokenize))
+(define resolve-h-file (@@ (c preprocessor2) resolve-h-file))
+(define resolve-q-file (@@ (c preprocessor2) resolve-q-file))
+(define resolve-header (@@ (c preprocessor2) resolve-header))
+;; (define include-header (@@ (c preprocessor2) include-header))
+
+;; Remove the noexpand list from each token.
+
+;; Allows equal? with fresh tokens
+(define (remove-noexpand tokens)
+ ;; (typecheck tokens (list-of token?))
+ (map (lambda (token) (set token lexeme-noexpand '()))
+ tokens))
+
+(define* (run str optional: (env (make-environment)))
+ (let ((env tokens (handle-preprocessing-tokens env (tokenize str))))
+ (drop-whitespace-both (remove-noexpand tokens))))
+
+ (define (call-with-tmp-header string proc)
+ (let* ((filename (string-copy "/tmp/headerfile-XXXXXXX"))
+ (port (mkstemp! filename)))
+ (with-output-to-port port
+ (lambda () (display string)
+ ))
+ (close-port port)
+ (proc filename)))
+
+
+
+(test-group "Tokens until End Of Line"
+ (call-with-values
+ (lambda () (tokens-until-eol (lex "before\nafter")))
+ (lambda (bef aft)
+ (test-equal (lex "before") bef)
+ (test-equal (lex "\nafter") aft))))
+
+
+
+(test-equal "Squeeze whitespace"
+ (lex "bef aft")
+ (squeeze-whitespace
+ (append (lex "bef ")
+ (lex " aft"))))
+
+
+(test-group "Stringify"
+ (test-equal "("
+ (stringify-token (car (lex "("))))
+ ;; TODO more cases
+
+ (test-equal (car (lex "\"(a, b)\""))
+ (stringify-tokens (lex "(a, b)"))))
+
+
+(test-group "Parse identifier list"
+ (test-group "Single argument"
+ (let ((rest args remaining (parse-identifier-list (lex "(x)"))))
+ (test-assert (not rest))
+ (test-equal '("x") args)
+ (test-equal '() remaining)))
+
+ (test-group "Multiple parameters"
+ (let ((rest args remaining (parse-identifier-list (lex "(x, y)"))))
+ (test-assert (not rest))
+ (test-equal '("x" "y") args)
+ (test-equal '() remaining)))
+
+ (test-group "Zero parameters"
+ (let ((rest args remaining (parse-identifier-list (lex "()"))))
+ (test-assert (not rest))
+ (test-equal '() args)
+ (test-equal '() remaining)))
+
+ (test-group "Rest args after regular"
+ (let ((rest args remaining (parse-identifier-list (lex "(x, ...)"))))
+ (test-assert rest)
+ (test-equal '("x") args)
+ (test-equal '() remaining)))
+
+ (test-group "Only rest args"
+ (let ((rest args remaining (parse-identifier-list (lex "(...)"))))
+ (test-assert rest)
+ (test-equal '() args)
+ (test-equal '() remaining)))
+
+ (test-group "Errors"
+ (test-error "Compound forms are invalid"
+ 'wrong-type-arg (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)")))))
+
+
+
+
+(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 "Two empty parameters"
+ (let ((containing remaining nls (parse-parameter-list (lex "(,)"))))
+ (test-equal (list (lex "") (lex "")) 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 "Newline in parameters"
+ (let ((containing remaining nls (parse-parameter-list (lex "(\n1\n)"))))
+ (test-equal (list (lex "\n1\n")) containing)
+ (test-equal '() remaining)
+ (test-equal 2 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 '())))
+
+ (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#
+ 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#
+ m (build-parameter-map
+ m (list (lex "x"))))))
+
+ (let ((m (function-like-macro
+ identifier: "f"
+ identifier-list: '()
+ variadic?: #t
+ body: (lex "# __VA_ARGS__"))))
+ (test-equal "Stringify __VA_ARGS__"
+ (lex "\"10, 20\"")
+ (expand# m (build-parameter-map m (list (lex "10, 20")))))))
+
+
+(let ((e (join-file-line (make-environment))))
+ (test-equal "__FILE__ default value"
+ (object-like-macro identifier: "__FILE__"
+ body: (lex "\"*outside*\""))
+ (get-identifier e "__FILE__"))
+ (test-equal "__LINE__ default value"
+ (object-like-macro identifier: "__LINE__"
+ body: (lex "1"))
+ (get-identifier e "__LINE__")))
+
+
+(test-group "Token streams"
+ (test-group "Non-expanding"
+ (test-equal "Null stream"
+ '() ((unval resolve-token-stream 1) (make-environment) '()))
+ (test-equal "Constant resolve to themselves"
+ (lex "1") ((unval resolve-token-stream 1) (make-environment) (lex "1")))
+ (test-equal "Identifier-likes not in environment stay put"
+ (lex "x") (remove-noexpand ((unval resolve-token-stream 1) (make-environment) (lex "x"))))
+ (test-equal "Identifier-likes with stuff after keep stuff after"
+ (lex "x 1") (remove-noexpand ((unval resolve-token-stream 1) (make-environment) (lex "x 1")))))
+
+ (test-group "Object likes"
+ (test-equal "Expansion of single token"
+ (lex "10")
+ (remove-noexpand
+ ((unval resolve-token-stream 1)
+ (extend-environment (make-environment)
+ (list (object-like-macro
+ identifier: "x"
+ body: (lex "10"))))
+ (lex "x"))))
+
+ (test-equal "Expansion keeps stuff after"
+ (lex "10 1")
+ (remove-noexpand
+ ((unval resolve-token-stream 1)
+ (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")
+ (remove-noexpand
+ ((unval resolve-token-stream 1)
+ (extend-environment (make-environment)
+ (list (object-like-macro
+ identifier: "x"
+ body: (lex "10"))
+ (object-like-macro
+ identifier: "y"
+ body: (lex "20"))))
+ (lex "x y"))))))
+
+
+(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") (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") (remove-noexpand tokens))))
+
+ ;; (call-with-values (expand-macro (make-environment)))
+
+ ))
+
+
+ (test-group "Maybe extend identifier"
+ (test-equal "Non-identifier returns remaining"
+ (lex "x")
+ (remove-noexpand ((unval maybe-extend-identifier 1)
+ (make-environment) "x" '()'())))
+
+ (test-equal "Non-identifiers remaining tokens are returned verbatim"
+ (append (lex "x") (lex "after"))
+ (remove-noexpand ((unval maybe-extend-identifier 1)
+ (make-environment) "x" '() (lex "after"))))
+
+ (test-equal "Object like identifier expands"
+ (lex "1 + 2")
+ (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") (lex "after"))
+ (remove-noexpand ((unval maybe-extend-identifier 1)
+ (extend-environment (make-environment)
+ (list
+ (object-like-macro
+ identifier: "x"
+ body: (lex "1 + 2"))))
+ "x"
+ '()
+ (lex "after"))))
+
+ )
+
+ (test-group "Apply macro"
+ (test-equal "zero arg macro on nothing"
+ (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")
+ (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")
+ (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"
+ (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") (remove-noexpand 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") (remove-noexpand tokens*))))
+ ;; This doesn't fail, since a single required argument is satisfied by the default nothing
+ #;
+ (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") (remove-noexpand tokens*))))
+ )
+ ))))
+
+(let ((e (make-environment)))
+ (test-group "Resolve token stream with function likes"
+ (test-equal "Macro expanding to its parameter"
+ (lex "0")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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)")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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)"))))
+
+
+ (test-equal "function like containing another macro using the same parameter name"
+ (lex "10")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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")
+ (remove-noexpand ((unval resolve-token-stream 1)
+ (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") (remove-noexpand ((unval resolve-token-stream 1) e (lex "defined(X)"))))
+ (test-equal "defined(DEFINED)"
+ (lex "1") (remove-noexpand ((unval resolve-token-stream 1)
+ (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"))
+
+(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")
+ ((unval resolve-token-stream 1) 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 ((unval resolve-token-stream 1) 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 ((unval resolve-token-stream 1) 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 ((unval resolve-token-stream 1) env (lex "x"))))))
+
+
+
+
+(test-group "Line directive"
+ (let ((e (make-environment)))
+ (test-equal "#line <number>"
+ '(("*outside*" . 9))
+ (cpp-file-stack (handle-line-directive e (lex "10"))))
+ (test-equal "#line <line> <file>"
+ '(("file" . 9))
+ (cpp-file-stack (handle-line-directive e (lex "10 \"file\""))))
+
+ (test-equal "#line <macro>"
+ '(("*outside*" . 9))
+ (cpp-file-stack
+ (handle-line-directive
+ (resolve-define e (lex "x 10"))
+ (lex "x"))))))
+
+
+;; NOTE these tests assume a "regular" Unix system
+(test-group "#include"
+ (test-group "Resolve header paths"
+ (test-equal "Find in path"
+ "/usr/include/stdio.h"
+ (resolve-h-file "stdio.h"))
+
+ (test-error "Fail if not in path"
+ 'cpp-error
+ (resolve-h-file "This file doesn't exist"))
+
+ (test-equal "Q-string with absolute path"
+ "/dev/null"
+ (resolve-q-file "/dev/null"))
+ (test-error "Q-File fails for missing file"
+ 'cpp-error (resolve-q-file "This file doesn't exists"))
+
+ (test-equal "Q-strings also look in path"
+ "/usr/include/stdio.h"
+ (resolve-q-file "stdio.h")))
+
+ (test-group "resolve-header returns paths from pp tokens (from #include directive)"
+ (test-equal "H-string"
+ "/usr/include/stdio.h"
+ (resolve-header (make-environment)
+ (lex "<stdio.h>")))
+ (test-equal "Q-string"
+ "/usr/include/stdio.h"
+ (resolve-header (make-environment)
+ (lex "\"stdio.h\""))))
+
+ ;; TODO #include is subject to macro expansion
+
+ (test-group "Actually including stuff"
+ (call-with-tmp-header "
+#define X 10
+int x;
+" (lambda (filename)
+ (test-equal "Include through #include"
+ (lex "int x;\n\n10")
+ (run (format #f "
+#include \"~a\"
+X
+" filename))))))
+
+ ;; NOTE should really be below "regular" __LINE__ tests
+ (call-with-tmp-header "__LINE__" (lambda (path)
+ (test-equal "__LINE__ in other file"
+ (lex "1")
+ (run (format #f "#include \"~a\"\n" path))))))
+
+
+
+
+
+(call-with-values (lambda ()
+ (handle-preprocessing-tokens (make-environment)
+ (lex "1")))
+ (lambda (env tokens)
+ (test-equal "Simplest case" (lex "1") tokens)))
+
+
+
+(test-equal "Define"
+ (lex "1")
+ (run "
+#define x 1
+x"))
+
+(test-group "__LINE__ and __FILE__"
+ (test-group "__LINE__"
+ (test-equal "only __LINE__"
+ (lex "1")
+ (run "__LINE__"))
+
+ (test-equal "__LINE__ after linebreak"
+ (lex "2")
+ (run "\n__LINE__"))
+
+
+ (test-equal "__LINE__ through macro"
+ (lex "5")
+ (drop-whitespace-both (run " // 1
+#define x __LINE__ // 2
+// 3
+// 4
+x // 5"))
+ )
+
+ (test-equal "__LINE__ standalone"
+ (lex "5")
+ (drop-whitespace-both
+ (run " // 1
+// 2
+// 3
+// 4
+__LINE__"))))
+
+ (test-equal "__FILE__"
+ (lex "\"sample-file.c\"")
+ (run "__FILE__" (enter-file (make-environment) "sample-file.c")))
+
+ (test-group "#line"
+ (test-equal "Updating line"
+ (lex "10")
+ (run "#line 10\n__LINE__"))
+
+ (test-equal "Updating line and file"
+ (lex "10 \"file.c\"")
+ (run "#line 10 \"file.c\"\n__LINE__ __FILE__"))
+ )
+ )
+
+
+
+(test-group "expand##"
+ (test-error 'cpp-error (expand## (lex "a ##")))
+ (test-error 'cpp-error (expand## (lex "## a")))
+ (test-error 'cpp-error (expand## (lex "##")))
+ (test-equal (lex "ab") (expand## (lex "a ## b")))
+ )
+
+(test-group "Token concatenation"
+
+
+ (test-equal "Token concatenation in function like macro"
+ (lex "ab")
+ (run "
+#define f() a ## b
+f()"))
+
+ (test-equal "token concatentanion in object like macro"
+ (lex "ab")
+ (run "
+#define x a ## b
+x"))
+
+ (test-equal "Token concatenation with parameter"
+ (lex "ab")
+ (run "
+#define f(x) x ## b
+f(a)"))
+
+
+ ;; 6.10.3.3 p. 4
+ (test-equal "x ## y"
+ (lex "char p[] = \"x ## y\"")
+ (run "
+#define hash_hash # ## #
+#define mkstr(a) # a
+#define in_between(a) mkstr(a)
+#define join(c, d) in_between(c hash_hash d)
+
+char p[] = join(x, y)")))
+
+(test-group "__VA_ARGS__"
+ (test-equal "__VA_ARGS__ split its arguments"
+ (lex "1")
+ (run "
+#define fst(x, y) x
+#define f(...) fst(__VA_ARGS__)
+f(1,2)
+"))
+
+ (test-equal
+ "Stringify __VA_ARGS__"
+ (lex "\"1,2\"")
+ (run "
+#define g(...) #__VA_ARGS__
+g(1,2)
+"))
+
+ (test-equal "__VA_ARGS__ keep whitespace"
+ (lex "x, y")
+ (run "
+#define args(...) __VA_ARGS__
+args(x, y)
+"))
+
+ (test-equal "Concat with __VA_ARGS__"
+ (lex "fx,y")
+ (run "
+#define wf(...) f ## __VA_ARGS__
+wf(x,y)
+"))
+
+ (test-equal
+ "Concat with __VA_ARGS__ (keeping whitespace)"
+ (lex "fx, y")
+ (run "
+#define wf(...) f ## __VA_ARGS__
+wf(x, y)
+")))
+
+
+(test-equal "Usage before #define"
+ (lex "X")
+ (run "X
+
+#define X 100"))
+
+(test-equal "#undef"
+ (lex "X\n10\nX")
+ (run "
+X
+#define X 10
+X
+#undef X
+X
+")
+ )
+
+(test-error "#error directive"
+ 'cpp-error-directive
+ (run "#error anything goes here"))
+
+(test-error "#error without body"
+ 'cpp-error-directive
+ (run "#error"))
+
+(test-group "Pragma"
+ (test-group "#pragma"
+ (test-equal "#Pragma STDC FP_CONTRACT ON"
+ (with-output-to-string (lambda () (run "#pragma STDC FP_CONTRACT ON")))))
+
+ (test-group "_Pragma"
+ (let ((e (extend-environment (make-environment)
+ (list
+ (@ (c preprocessor2) _Pragma-macro)))))
+ (test-equal "#Pragma STDC FP_CONTRACT ON"
+ (with-output-to-string
+ (lambda () (run "_Pragma(\"STDC FP_CONTRACT ON\")" e))))
+
+ ;; 6.10.9 example
+ (test-group "Non-standard #Pragma: listing on \"..\\\\listing.dir\""
+ ;; source: LISTING( ..\listing.dir )
+ ;; dest: _Pragma( "listing on \"..\\listing.dir\"")
+
+ (test-equal "Dry-run"
+ "pragma(\"listing on \\\"..\\\\\\\\listing.dir\\\"\")"
+ (unlex (run "
+#define LISTING(x) PRAGMA(listing on #x)
+#define PRAGMA(x) pragma(#x)
+LISTING(..\\listing.dir)"))
+ )
+
+ (test-equal "With _Pragma"
+ "Non-standard #Pragma: listing on \"..\\\\listing.dir\""
+ (with-output-to-string
+ (lambda ()
+ (run "
+#define LISTING(x) PRAGMA(listing on #x)
+#define PRAGMA(x) _Pragma(#x)
+LISTING(..\\listing.dir)
+" e))))))
+ ))
+
+(test-group "Next token matches?"
+ (test-assert "Zero tokens never match" (not (next-token-matches? (const #t) '())))
+
+ (test-assert "Non-matching token"
+ (not (next-token-matches? punctuator-token? (lex "x+y"))))
+
+ (test-assert "Maching token"
+ (next-token-matches? identifier-token? (lex "x+y")))
+
+ (test-assert "Matching token, after whitespace"
+ (next-token-matches? identifier-token? (lex " \n x + y"))))
+
+
+(test-equal "Function likes aren't expanded if not followed by a left parenthese"
+ (lex "f")
+ (run "
+#define f(x)
+f"))
+
+(test-equal "Parameter expansion times"
+ (lex "fx fy") (run "
+#define fw(x) f ## x
+#define ffw(x) fw(x)
+#define x y
+fw(x) ffw(x)
+"))
+
+(test-equal (lex "(5 + 10)") (run "
+#define x 10
+#define f(a) a
+#define g h
+#define h(x) (x + 10)
+f(g)(5)"))
+
+
+;; (expand-macro
+;; (extend-environment
+;; (make-environment)
+;; (list (object-like-macro identifier: "g"
+;; body: (lex "h"))
+;; (function-like-macro identifier: "h"
+;; identifier:-list '("x")
+;; body: (lex "(x + 10)"))))
+;; (function-like-macro identifier: "f"
+;; identifier:-list '("a")
+;; body: (lex "a"))
+;; '()
+;; (lex "(g)(5)"))
+
+;; ;; ⇒ #<<cpp-environment> cpp-if-status: (outside) cpp-variables: #<hash-table 7f6f5974d6a0 2/31> cpp-file-stack: (("*outside*" . 1))>
+;; ⇒ (#<<lexeme> type: preprocessing-token body: (identifier "h") noexpand: ("f" "h")>
+;; #<<lexeme> type: preprocessing-token body: (punctuator "(") noexpand: ()>
+;; #<<lexeme> type: preprocessing-token body: (pp-number "5") noexpand: ()>
+;; #<<lexeme> type: preprocessing-token body: (punctuator ")") noexpand: ()>)
+
+(test-equal "non-adjacent parameter list"
+ (lex "2*10")
+ (run "
+#define f(x) 2*x
+f (10)"))
+
+(test-equal "parameter-list on own line"
+ (lex "2*10")
+ (run "
+#define f(x) 2*x
+f
+
+
+(10)"))
+
+
+(test-group "6.10.3.5 Scope of macro definitions"
+
+ (test-equal "Example 3, except part below"
+ (unlex-aggressive (lex "f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & ^m(0,1);
+int i[] = { 1, 23, 4, 5, };
+char c[2][6] = { \"hello\", \"\" };"))
+ (unlex-aggressive (run "
+#define x 3
+#define f(a) f(x * (a))
+#undef x
+#define x 2
+#define g f
+#define z z[0]
+#define h g(~
+#define m(a) a(w)
+#define w 0,1
+#define t(a) a
+#define p() int
+#define q(x) x
+#define r(x,y) x ## y
+#define str(x) # x
+
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
+g(x+(3,4)-w) | h 5) &
+ ^m(m);
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
+char c[2][6] = { str(hello), str() };"))
+ )
+
+ (test-group "Example 3"
+ (test-equal "Subtest 1, is result of function application further macro expanded?"
+ (unlex-aggressive (lex "f(2 * (0,1))"))
+ ((unval handle-preprocessing-tokens 1) (make-environment) (tokenize "
+#define m(a) a(0,1)
+#define f(a) f(2 * (a))
+m(f)")))
+
+
+ (test-equal "True test"
+ (unlex-aggressive (lex "f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
+int i[] = { 1, 23, 4, 5, };
+char c[2][6] = { \"hello\", \"\" };"))
+ (unlex-aggressive (run "
+#define x 3
+#define f(a) f(x * (a))
+#undef x
+#define x 2
+#define g f
+#define z z[0]
+#define h g(~
+#define m(a) a(w)
+#define w 0,1
+#define t(a) a
+#define p() int
+#define q(x) x
+#define r(x,y) x ## y
+#define str(x) # x
+
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
+g(x+(3,4)-w) | h 5) & m
+ (f)^m(m);
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
+char c[2][6] = { str(hello), str() };"))))
+
+ ;; TODO Example 4 skipped due to #include in output
+
+ (test-equal "Example 5"
+ (unlex-aggressive (lex "int j[] = { 123, 45, 67, 89, 10, 11, 12, };"))
+ (unlex-aggressive (run "
+#define t(x,y,z) x ## y ## z
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), t(10,,), t(,11,), t(,,12), t(,,) };")))
+
+ (test-group "Example 6"
+ (test-assert "Valid redefinitions"
+ (run "
+#define OBJ_LIKE (1-1)
+#define OBJ_LIKE /* */ (1+1) /* */
+#define FUNC_LIKE(a) ( a )
+#define FUNC_LIKE( a )( /* */ \\
+ a /*
+ */ )"))
+
+ (test-error "Invalid redefinitions"
+ 'misc-error
+ (run "
+#define OBJ_LIKE (0)
+#define OBJ_LIKE (1 - 1)
+#define FUNC_LIKE(b) ( a )
+#define FUNC_LIKE(b) ( b )
+")))
+
+ (test-equal "Example 7"
+ (unlex-aggressive (lex "fprintf(stderr, \"Flag\");
+fprintf(stderr, \"X = %d\\n\", x);
+puts(\"The first, second, and third items.\");
+((x>y)?puts(\"x>y\"):
+ printf(\"x is %d but y is %d\", x, y));"))
+ (unlex-aggressive (run "
+#define debug(...) fprintf(stderr, __VA_ARGS__)
+#define showlist(...) puts(#__VA_ARGS__)
+#define report(test, ...) ((test)?puts(#test):\\
+ printf(__VA_ARGS__))
+debug(\"Flag\");
+debug(\"X = %d\\n\", x);
+showlist(The first, second, and third items.);
+report(x>y, \"x is %d but y is %d\", x, y);
+"))))
+
+
+(test-group "Misc"
+ (test-equal "Null directive"
+ (lex "1\n2")
+ (run "
+1
+#
+2"))
+
+ (test-error "Invalid directive"
+ 'cpp-error
+ (run "# invalid"))
+ )
+
+
+(test-group "Conditionals"
+ (test-group "ifdef"
+ (test-equal "#ifdef on non-defined"
+ (lex "")
+ (run "
+#ifdef X
+x
+#endif"))
+
+ (test-equal "#ifdef on defined"
+ (lex "x")
+ (run "
+#define X
+#ifdef X
+x
+#endif")))
+
+ (test-group "ifndef"
+ (test-equal "#ifndef on non-defined"
+ (lex "x")
+ (run "
+#ifndef X
+x
+#endif"))
+
+ (test-equal "#ifndef on defined"
+ (lex "")
+ (run "
+#define X
+#ifndef X
+x
+#endif
+")))
+
+ (test-group "else"
+ (test-equal "else from active to inactive"
+ (lex "1")
+ (run "
+#ifndef X
+1
+#else
+2
+#endif"))
+
+ (test-equal "else from inactive to active"
+ (lex "2")
+ (run "
+#ifdef X
+1
+#else
+2
+#endif")))
+
+ (test-assert "Pre-processing directives are ignored in non-active paths"
+ (run "
+#ifdef X
+#error
+#endif"))
+
+ ;; Should hold for all tokens, but _Pragma is the only one with observable
+ ;; side effects
+ (test-equal "Tokens aren't expanded in non-active paths"
+ ""
+ (with-output-to-string
+ (lambda ()
+ (run "
+#ifdef X
+_Pragma(\"not-called\")
+#endif"))))
+
+
+ (test-equal "Nested conditions"
+ (lex "a\n\nc")
+ (run "
+#define X
+#ifdef X
+a
+#ifdef Y
+b
+#endif
+c
+#endif
+"))
+
+ (test-equal
+ (lex "")
+ (run "
+#ifdef X
+a
+#ifdef Y
+b
+#endif /* Y */
+c
+#endif /* X */
+"))
+
+ (test-group "Unexpected if ends"
+ (test-error "#else outside if"
+ 'cpp-error (run "#else"))
+ (test-error "#endif outside if"
+ 'cpp-error (run "#endif"))
+ (test-error "#elif outside if"
+ 'cpp-error (run "#elif")))
+
+ (test-group "if"
+ (test-equal "Simple positive if"
+ (lex "x")
+ (run "
+#if 1
+x
+#endif"))
+
+ (test-equal "Simple negative if"
+ (lex "")
+ (run "
+#if 0
+x
+#endif"))
+
+ (test-equal "Elif isn't run when if is true"
+ (lex "a")
+ (run "
+#if 1
+a
+#elif 1
+b
+#endif"))
+
+ (test-equal "elif is run when if is false"
+ (lex "b")
+ (run "
+#if 0
+a
+#elif 1
+b
+#endif"))
+
+ ;; Note that defined is automatically added to the environment when
+ ;; evaluating #if.
+
+ (test-equal "#if with defined"
+ (lex "a")
+ (run "
+#define X
+#if defined(X)
+a
+#else
+b
+#endif")
+ )
+
+ (test-equal "#if with negative defined"
+ (lex "b")
+ (run "
+#if defined(X)
+a
+#else
+b
+#endif"))
+
+ ;; TODO test advanced constant expression
+ ))
diff --git a/tests/test/cpp/to-token.scm b/tests/test/cpp/to-token.scm
new file mode 100644
index 00000000..b633ce12
--- /dev/null
+++ b/tests/test/cpp/to-token.scm
@@ -0,0 +1,65 @@
+(define-module (test cpp to-token)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (c to-token)
+ :use-module ((system base lalr)
+ :select (lexical-token-category
+ lexical-token-value))
+ :use-module ((c lex2) :select (lex))
+ )
+
+(test-group "string tokens"
+ (let ((v (preprocessing-token->token (car (lex "\"Hello\"")))))
+ (test-equal 'string-literal (lexical-token-category v))
+ (test-equal #vu8(#x48 #x65 #x6C #x6C #x6F 0) (lexical-token-value v))
+ ;; TODO prefixes
+ ))
+
+(test-group "identifier tokens"
+ (let ((v (preprocessing-token->token (car (lex "hello")))))
+ (test-equal 'identifier (lexical-token-category v))
+ (test-equal 'hello (lexical-token-value v))))
+
+(test-group "keywords"
+ (test-equal 'auto (preprocessing-token->token (car (lex "auto")))))
+
+(test-group "numbers"
+ (test-group "Integers"
+ (test-group "Base-10"
+ (let ((v (preprocessing-token->token (car (lex "1")))))
+ (test-equal 'constant (lexical-token-category v))
+ (test-equal 1 (lexical-token-value v))))
+
+ (test-equal "Base-16"
+ 16 (lexical-token-value (preprocessing-token->token (car (lex "0x10")))))
+ (test-equal "Base-8"
+ 8 (lexical-token-value (preprocessing-token->token (car (lex "010")))))
+ (test-group "Suffixes"
+ 'TODO
+ ))
+
+ ;; TODO floats
+ )
+
+(test-group "character constants"
+ (let ((v (preprocessing-token->token (car (lex "'a'")))))
+ (test-equal 'constant (lexical-token-category v))
+ (test-equal (char->integer #\a) (lexical-token-value v)) )
+ (let ((v (preprocessing-token->token (car (lex "'ab'")))))
+ (test-equal 'constant (lexical-token-category v))
+ (test-equal (char->integer #\b) (lexical-token-value v)))
+ (let ((v (preprocessing-token->token (car (lex "'\\x41'")))))
+ (test-equal 'constant (lexical-token-category v))
+ (test-equal #x41 (lexical-token-value v)))
+ ;; (lex "'\\x4142'")
+ ;; (lex "'L\\x4142'")
+ )
+
+(test-group "punctuators"
+ (test-equal '+ (preprocessing-token->token (car (lex "+"))))
+ (test-equal 'lbrace (preprocessing-token->token (car (lex "{")))))
+
+(test-group "other"
+ (test-error 'cpp-error (preprocessing-token->token (car (lex " ")))))
+
diff --git a/tests/test/cpp/util.scm b/tests/test/cpp/util.scm
new file mode 100644
index 00000000..8329294a
--- /dev/null
+++ b/tests/test/cpp/util.scm
@@ -0,0 +1,14 @@
+(define-module (test cpp util)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-88)
+ :use-module (c cpp-util)
+ :use-module ((c lex2) :select (lex lexeme)))
+
+(test-group "Merge string literals"
+ (test-equal "To simple strings"
+ (list (lexeme type: 'preprocessing-token
+ body: '(string-literal (encoding-prefix) "Hello" "World")))
+ (merge-string-literals (lex "\"Hello\"\"World\"")))
+
+ ;; TODO tests with prefixes
+ )
diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm
index 2a5ac141..f73a0ad2 100644
--- a/tests/test/datetime.scm
+++ b/tests/test/datetime.scm
@@ -70,45 +70,44 @@
(test-error "Invalid second" 'wrong-type-arg (time second: #f))))
(test-group "Datetime"
- (let ((get-time% (@@ (datetime) get-time%)))
+ (let ()
(test-group "Empty datetime"
(let ((dt (datetime)))
- ;; TODO figure out propper export of get-time%
- (test-assert "Datetime date is date" (date? (get-date dt)))
- (test-assert "Datetime date is zero" (date-zero? (get-date dt)))
- (test-assert "Datetime time is time" (time? (get-time% dt)))
- (test-assert "Datetime time is zero" (time-zero? (get-time% dt)))
- (test-eqv "Defalut timezone is #f" #f (get-timezone dt))))
+ (test-assert "Datetime date is date" (date? (datetime-date dt)))
+ (test-assert "Datetime date is zero" (date-zero? (datetime-date dt)))
+ (test-assert "Datetime time is time" (time? (datetime-time dt)))
+ (test-assert "Datetime time is zero" (time-zero? (datetime-time dt)))
+ (test-eqv "Defalut timezone is #f" #f (tz dt))))
(test-group "Datetime with keys"
(let ((dt (datetime date: (date day: 10)
time: (time minute: 20))))
(test-equal "Given date is stored"
- 10 (day (get-date dt)))
+ 10 (day (datetime-date dt)))
(test-equal "Given time is stored"
- 20 (minute (get-time% dt))))
+ 20 (minute (datetime-time dt))))
(test-error "Date must be a date" 'wrong-type-arg (datetime date: 1))
(test-error "Date must be a date" 'wrong-type-arg (datetime date: (time)))
- (test-assert "Date: #f gives still constructs a date" (date? (get-date (datetime date: #f))))
+ (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f))))
(test-error "Time must be a time" 'wrong-type-arg (datetime time: 1))
(test-error "Time must be a time" 'wrong-type-arg (datetime time: (date)))
- (test-assert "Time: #f gives still constructs a time" (time? (get-time% (datetime time: #f))))
+ (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f))))
(let ((dt (datetime hour: 20 day: 30)))
- (test-equal "Time objects can be implicitly created" 20 (hour (get-time% dt)))
- (test-equal "Date objects can be implicitly created" 30 (day (get-date dt))))
+ (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt)))
+ (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt))))
(let ((dt (datetime day: 30 time: (time hour: 20))))
(test-equal "\"Upper\" and \"lower\" keys can be mixed"
- 20 (hour (get-time% dt)))
+ 20 (hour (datetime-time dt)))
(test-equal "\"Upper\" and \"lower\" keys can be mixed"
- 30 (day (get-date dt))))
+ 30 (day (datetime-date dt))))
(let ((dt (datetime hour: 30 time: (time hour: 20))))
(test-equal "time: has priority over hour: (and the like)"
- 20 (hour (get-time% dt)))))
+ 20 (hour (datetime-time dt)))))
(let ((dt (datetime day: 30 date: (date day: 20))))
(test-equal "date: has priority over day: (and the like)"
- 20 (day (get-date dt)))))))
+ 20 (day (datetime-date dt)))))))
;; Before the general parser, since it's a dependency string->datetime.
(test-group "Parse Month"
@@ -384,7 +383,7 @@
(test-assert "Current datetime returns a datetime"
(datetime? (current-datetime)))
(test-equal "Current datetime returns with tz: UTC"
- "UTC" (get-timezone (current-datetime)))
+ "UTC" (tz (current-datetime)))
(test-assert "Current-date returns a date"
(date? (current-date)))
@@ -707,6 +706,11 @@ date-range
(not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1)))))))
;; TODO
+date<=
+time<=
+datetime<=
+
+;; TODO
date/-time< date/-time<? date/-time<= date/-time<=?
date/-time> date/-time>? date/-time>= date/-time>=?
diff --git a/tests/test/lens.scm b/tests/test/lens.scm
new file mode 100644
index 00000000..0797e3aa
--- /dev/null
+++ b/tests/test/lens.scm
@@ -0,0 +1,21 @@
+(define-module (test lens)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util lens))
+
+
+(define first (ref 0))
+
+(test-equal '((1)) (first '(((1)))))
+(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2))
+(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2))
+
+
+;; (list-change (iota 10) 5 'Hello)
+;; => (0 1 2 3 4 Hello 6 7 8 9)
+
+(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
+
+;; (set (list (iota 10)) first first 11)
diff --git a/tests/test/object.scm b/tests/test/object.scm
new file mode 100644
index 00000000..701c45c0
--- /dev/null
+++ b/tests/test/object.scm
@@ -0,0 +1,80 @@
+(define-module (test object)
+ :use-module (srfi srfi-64)
+ :use-module (srfi srfi-64 test-error)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util object)
+ :use-module ((hnh util) :select (->)))
+
+(define-type (f) x)
+
+(test-group "Created procedures"
+ (test-assert "Constructor" (procedure? f))
+ (test-assert "Predicate" (procedure? f?))
+ (test-assert "Field access" (procedure? x)))
+
+;; (f)
+;; (f x: 10)
+;; (f? (f))
+
+(test-equal "Accessors are getters"
+ 10 (x (f x: 10)))
+(test-assert "Accessors update, returning a object of the original type"
+ (f? (x (f x: 10) 20)))
+(test-equal "A get after an update returns the new value"
+ 20 (-> (f x: 10)
+ (x 20)
+ x))
+
+
+(define-type (g) x)
+
+(test-assert "Second type can be created"
+ (g x: 10))
+
+(test-assert "Second type isn't first type"
+ (not (f? (g x: 10))))
+
+(test-assert "First type isn't second type"
+ (not (g? (f x: 10))))
+
+;; Tests that the old x gets shadowed
+;; (test-equal 10 (x (f x: 10)))
+;; (test-equal 10 (x (g x: 10)))
+
+;; field-level arguments
+;; - init:
+(define-type (f2) (f2-x default: 0 type: integer?))
+(test-equal 0 (f2-x (f2)))
+
+;; - type:
+
+(test-error "Giving an invalid type to the constructor throws an error"
+ 'wrong-type-arg (f2 f2-x: 'hello))
+(test-error "Giving an invalid type to a setter throws an error"
+ 'wrong-type-arg (f2-x (f2) 'hello))
+(test-equal "The error includes the name of the field, the expected type, and the given value"
+ '(f2-x integer? hello)
+ (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello))
+ (lambda (err proc fmt args data) args)))
+
+(test-equal "Typed setter updates the value"
+ (f2 f2-x: 10) (f2-x (f2) 10))
+
+;; type-level arguments
+;; - constructor:
+(define-type (f3 constructor: (lambda (make check)
+ (lambda* (#:key f3-x f3-y)
+ (check f3-x f3-y)
+ (make f3-x f3-y))))
+ (f3-x type: integer?)
+ (f3-y type: string?))
+
+(test-assert "Custom constructors create objcets"
+ (f3? (f3 f3-x: 10 f3-y: "Hello")))
+
+(test-error "Bad arguments to custom constructor"
+ 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world))
+
+;; - printer:
+(define-type (f4 printer: (lambda (r p) (display "something" p))))
+(test-equal "something" (with-output-to-string (lambda () (write (f4)))))
diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm
index a291cc17..56f4cda6 100644
--- a/tests/test/recurrence-advanced.scm
+++ b/tests/test/recurrence-advanced.scm
@@ -27,6 +27,7 @@
:use-module ((datetime)
:select (parse-ics-datetime
datetime
+ datetime-date
time
date
datetime->string))
diff --git a/tests/test/util.scm b/tests/test/util.scm
index 1de96a37..5e2aab4e 100644
--- a/tests/test/util.scm
+++ b/tests/test/util.scm
@@ -187,6 +187,34 @@
(test-error 'wrong-type-arg (find-extreme '()))
+;; TODO group-by
+;; TODO split-by
+
+(test-group "Split-by-one-of"
+
+ (test-equal "Empty input"
+ '(()) (split-by-one-of '() '(+)))
+
+ (test-equal "No matching tokens"
+ '((1 + 2)) (split-by-one-of '(1 + 2) '(/)))
+
+ (test-equal "Matching tokens"
+ '((1) (+ 2) (- 3))
+ (split-by-one-of '(1 + 2 - 3) '(+ -)))
+
+ (test-equal "Maching tokens, multiple values in each group"
+ '((1 + 2) (* 3 + 4))
+ (split-by-one-of '(1 + 2 * 3 + 4) '(*))))
+
+
+(test-group "break/all"
+ (test-equal '((a b c)) (break/all (const #f) '(a b c)))
+ (test-equal '(()) (break/all (const #t) '()))
+ (test-equal '(() () () ()) (break/all (const #t) '(a b c)))
+ (test-equal '((a b) (c d)) (break/all number? '(a b 1 c d)))
+ (test-equal '(() ()) (break/all number? '(1))))
+
+
(call-with-values
(lambda ()
(span-upto
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-25 08:36:29 +0200