From 85bb810edc083b0bcc08f76e22d51d1555dc828d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 30 Jun 2022 07:07:59 +0200
Subject: Add basic c evaluator.

---
 tests/test/cpp.scm | 66 ++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 52 insertions(+), 14 deletions(-)

(limited to 'tests/test/cpp.scm')

diff --git a/tests/test/cpp.scm b/tests/test/cpp.scm
index fa767fe3..1294bc96 100644
--- a/tests/test/cpp.scm
+++ b/tests/test/cpp.scm
@@ -3,10 +3,15 @@
 ;;; 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.
@@ -31,6 +36,18 @@
 
 (define run (compose parse-lexeme-tree lex))
 
+(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 ...)
@@ -100,7 +117,8 @@
                             (operator "*")
                             (integer (base-10 "2"))))
    (lex form))
- (test-equal '(+ 2 (* 2 2)) (run form)))
+ (test-equal '(+ 2 (* 2 2)) (run form))
+ (test-equal 6 (exec form)))
 
 (let-group
  ((form "2 * 2 + 2"))
@@ -110,7 +128,8 @@
                             (operator "+")
                             (integer (base-10 "2"))))
    (lex form))
- (test-equal '(+ (* 2 2) 2) (run form)))
+ (test-equal '(+ (* 2 2) 2) (run form))
+ (test-equal 6 (exec form)))
 
 (let-group
  ((form "2+2+2"))
@@ -119,7 +138,8 @@
                      (infix (integer (base-10 "2"))
                             (operator "+")
                             (integer (base-10 "2")))) (lex form))
- (test-equal '(+ 2 2 2) (run form)))
+ (test-equal '(+ 2 2 2) (run form))
+ (test-equal 6 (exec form)))
 
 (test-group "Unary minus"
   (test-group "Without space"
@@ -127,21 +147,24 @@
       (test-equal '(prefix (prefix-operator "-")
                            (integer (base-10 "1")))
         (lex form))
-      (test-equal '(- 1) (run 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) (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 '(- x) (run form))
+      (test-equal -5 (exec form '(x 5)))))
 
   (test-group "Before infix"
     (let ((form "-x+3"))
@@ -150,8 +173,8 @@
                           (operator "+")
                           (integer (base-10 "3")))
         (lex form))
-      (test-equal '(+ (- x) 3)
-        (run form))))
+      (test-equal '(+ (- x) 3) (run form))
+      (test-equal -2 (exec form '(x 5)))))
 
   (test-group "Inside infix expression"
     (let ((form "x+-3"))
@@ -160,7 +183,8 @@
                           (prefix (prefix-operator "-")
                                   (integer (base-10 "3"))))
         (lex form))
-      (test-equal '(+ x (- 3)) (run form))))
+      (test-equal '(+ x (- 3)) (run form))
+      (test-equal 2 (exec form '(x 5)))))
   )
 
 
@@ -180,7 +204,8 @@
 
 (let ((form "1000000U"))
   (test-equal '(integer (base-10 "1000000") (integer-suffix "U")) (lex form))
-  (test-equal '(as-type (unsigned) 1000000) (run form)))
+  (test-equal '(as-type (unsigned) 1000000) (run form))
+  (test-equal 1000000 (exec form)))
 
 
 (let ((form "0x10c"))
@@ -197,17 +222,30 @@
                       (operator "!=")
                       (variable "b"))
     (lex form))
-  (test-equal '(not_eq a b) (run 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)))
+    (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 '(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))
-- 
cgit v1.2.3