Handle nested #if trees.

5 files changed, 311 insertions, 97 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index a6401e71..39e596d1 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -2,6 +2,7 @@
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-88)
   :use-module (ice-9 hash-table)
+  :use-module ((hnh util) :select (->>))
   :use-module (hnh util object)
   :use-module (hnh util type)
   :use-module (hnh util lens)
@@ -9,6 +10,7 @@
   :use-module ((c cpp-environment object-like-macro)   :prefix #{obj:}#)
   :use-module ((c cpp-environment internal-macro)      :prefix #{int:}#)
   :use-module ((c unlex) :select (unlex))
+  :use-module ((rnrs enums))
   :export (
 
            macro-identifier
@@ -18,11 +20,12 @@
            cpp-macro?
            ;; pprint-macro
 
-           enter-active-if
-           enter-inactive-if
-           flip-flop-if
+           enter-into-if
+           transition-to-if
+           if-status
            leave-if
            in-conditional/active?
+           in-conditional/inactive-inactive?
            in-conditional/inactive?
            in-conditional?
 
@@ -90,9 +93,21 @@
 
 
 
+
+(define-enumeration if-status
+  (active                               ; We are in the "executing" branch of an if
+   inactive                             ; We are in a non-"executing" branch, which may be followed by an "executing" branch
+   inactive-inactive                    ; We are in a branch which will never execute, and neither will its children or further siblings
+   outside)                             ; We aren't in an if-condition
+  if-status-set)
+
+(define (if-status? x)
+  (enum-set-member? x (enum-set-universe (if-status-set))))
+
 (define-type (cpp-environment)
-  (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
-                 default: '(outside))
+  (cpp-if-status type: (and (list-of if-status?)
+                            (not null?))
+                 default: (list (if-status outside)))
   ;; not exported since type signatures don't hold inside the hash table
   ;; TODO replace hash table with something that doesn't require copying the
   ;; entire structure every time
@@ -104,27 +119,70 @@
 
 
 
-(define (enter-active-if environment)
-  (modify environment cpp-if-status xcons 'active-if))
-
-(define (enter-inactive-if environment)
-  (modify environment cpp-if-status xcons 'inactive-if))
-
-;; for #else
-(define (flip-flop-if environment)
-  ((if (in-conditional/inactive? environment)
-       enter-active-if
-       enter-inactive-if)
-   (leave-if environment)))
-
+;; Morph the current if status into another
+;; non-allowed transitions throws
+(define (transition-to-if env next)
+  (define valid-next
+    (case (car (cpp-if-status env))
+      ;; After an active if or elif no further elif's or else's can ever be active
+      ((active)            (if-status-set inactive-inactive))
+      ;; We can from an inactive if or elif move into an active elif or else
+      ((inactive)          (if-status-set active inactive))
+      ;; once nothing more can be active, nothing more can be active
+      ((inactive-inactive) (if-status-set inactive-inactive))
+      ;; outside can never be moved away from
+      ((outside)           (if-status-set))
+      (else => (lambda (x) (scm-error 'misc-error "transition-to-if"
+                                 "Unknown enum: ~s" (list x) #f)))))
+  (unless (enum-set-member? next valid-next)
+    (scm-error 'misc-error "transition-to-if"
+               "Invalid transition, ~a → ~a (valid next: ~s)"
+               (list (car (cpp-if-status env))
+                     next
+                     (enum-set->list valid-next))
+               #f))
+  (set env cpp-if-status car* next))
+
+;; enter into a nested if statement
+;; An exception is thrown if the resulting if-stack is invalid
+(define (enter-into-if env next)
+  (define valid-next
+    (case (car (cpp-if-status env))
+      ;; from an active if statement, both positive and negative if's are possible
+      ((active outside)              (if-status-set active inactive))
+      ;; from an inactive if clause nothing can ever be active
+      ((inactive inactive-inactive) (if-status-set inactive-inactive))
+      (else => (lambda (x) (scm-error 'misc-error "enter-into-if"
+                                 "Unknown enum: ~s" (list x) #f)))))
+
+  (unless (enum-set-member? next valid-next)
+    (scm-error 'misc-error "enter-into-if"
+               "Can't enter ~a from ~a (valid: ~s)"
+               (list next
+                     (car (cpp-if-status env))
+                     (enum-set->list valid-next))
+               #f))
+
+  (modify env cpp-if-status xcons next))
+
+;; Leaves the current if statement
 (define (leave-if environment)
+  (when (eq? (if-status outside) (car (cpp-if-status environment)))
+    (scm-error 'misc-error "leave-if"
+               "Can't leave 'outside'"
+               '() #f))
   (modify environment cpp-if-status cdr))
 
+(define (in-conditional/inactive-inactive? environment)
+  (eq? (if-status inactive-inactive) (get environment cpp-if-status car*)))
+
 (define (in-conditional/inactive? environment)
-  (eq? 'inactive-if (get environment cpp-if-status car*)))
+  (enum-set-member?
+   (get environment cpp-if-status car*)
+   (if-status-set inactive inactive-inactive)))
 
 (define (in-conditional/active? environment)
-  (eq? 'active-if (get environment cpp-if-status car*)))
+  (eq? (if-status active) (get environment cpp-if-status car*)))
 
 (define (in-conditional? environment)
   (or (in-conditional/inactive? environment)
@@ -191,7 +249,7 @@
 
 
 (define* (pprint-environment environment optional: (port (current-error-port)))
-  (display "== Environment ==\n")
+  (display "== Environment ==\n" port)
   (hash-for-each (lambda (key macro)
                    (pprint-macro macro port)
                    (newline port))
diff --git a/module/c/eval-basic.scm b/module/c/eval-basic.scm
index 9a16a095..7335e3ea 100644
--- a/module/c/eval-basic.scm
+++ b/module/c/eval-basic.scm
@@ -60,4 +60,6 @@
                  => (lambda (op)
                       (apply op (map loop args))))
                 (else
-                 (err "Unknown operator ~s" f)))))))))
+                 (err "Unknown operator ~s" f))))
+         (_ (err "Invalid (inner) form for basic eval: ~s" ast)))))
+    (_ (err "Invalid (outer) form for basic eval: ~s" ast))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index b9b11d0a..a34fd2dd 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -517,17 +517,18 @@
 (define (resolve-for-if environment tokens)
   (typecheck environment cpp-environment?)
   ;; (typecheck tokens (list-of lexeme?))
-
-  (if (->> tokens
-           (parse-if-line environment)
-           (remove whitespace-token?)
-           merge-string-literals
-           build-ast
-           ;; 6.10.1 p. 4
-           eval-basic-c
-           c-boolean->boolean)
-      (enter-active-if environment)
-      (enter-inactive-if environment)))
+  (enter-into-if
+   environment
+   (if (->> tokens
+            (parse-if-line environment)
+            (remove whitespace-token?)
+            merge-string-literals
+            build-ast
+            ;; 6.10.1 p. 4
+            eval-basic-c
+            c-boolean->boolean)
+       (if-status active)
+       (if-status inactive))))
 
 ;; environment, string, (list token) → environment, (list token)
 (define (maybe-extend-identifier environment identifier noexpand-list remaining-tokens)
@@ -684,22 +685,31 @@
              (cond ((null? tokens*) (values environment '()))
                    ((equal? "#" (punctuator-token? (car tokens*)))
                     (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens*))))
-                      ;; drop whitespace after to not "eat" the next newline token
+                      ;; drop whitespace after newline check to not "eat" the next newline token
                       (let ((line-tokens (drop-whitespace line-tokens)))
                         (cond ((null? line-tokens)
                                ;; null directive
                                (loop environment remaining-tokens))
 
+                              ((in-conditional/inactive-inactive? environment)
+                               (let ((op (case (string->symbol (identifier-token? (car line-tokens)))
+                                           ((ifdef ifndef if)  (lambda (e) (enter-into-if e (if-status inactive-inactive))))
+                                           ((endif)            leave-if)
+                                           ((elif else)        identity)
+                                           (else identity))))
+                                 (loop (op environment) remaining-tokens)))
+
                               ((in-conditional/inactive? environment)
-                               (case (string->symbol (identifier-token? (car line-tokens)))
-                                 ((ifdef if) (loop (enter-inactive-if environment) remaining-tokens))
-                                 ((else)  (loop (flip-flop-if environment) remaining-tokens))
-                                 ((endif) (loop (leave-if environment) remaining-tokens))
-                                 ((elif)  (loop (resolve-for-if
-                                                 (leave-if environment)
-                                                 (drop-whitespace (cdr line-tokens)))
-                                                remaining-tokens))
-                                 (else (loop environment remaining-tokens))))
+                               (let ((op (case (string->symbol (identifier-token? (car line-tokens)))
+                                           ((ifdef ifndef if) (lambda (e) (enter-into-if e (if-status inactive-inactive))))
+                                           ((endif)           leave-if)
+                                           ((else)            (lambda (e) (transition-to-if e (if-status active))))
+                                           ((elif)            (lambda (environment)
+                                                                (-> environment
+                                                                    leave-if
+                                                                    (resolve-for-if (drop-whitespace (cdr line-tokens))))))
+                                           (else identity))))
+                                 (loop (op environment) remaining-tokens)))
 
                               ;; From here on we are not in a comment block
                               (else
@@ -722,35 +732,42 @@
                                                         (bump-line -1))
                                                     (append (lex "\n")
                                                             (-> path read-file tokenize)))))
-                                         (on-snd (append tokens* (abort* (loop (leave-file env*) remaining-tokens))))))
+                                         (on-snd (append tokens* (abort* (loop (leave-file env*)
+                                                                               remaining-tokens))))))
 
                                      (let ((operation ; (environment, list token) → environment
                                             (case directive
                                               ((if) resolve-for-if)
                                               ((ifdef)
                                                (lambda (env body)
-                                                 ((if (in-environment? env (identifier-token? (car body)))
-                                                      enter-active-if enter-inactive-if)
-                                                  env)))
+                                                 (enter-into-if env
+                                                                (if (in-environment? env (identifier-token? (car body)))
+                                                                    (if-status active)
+                                                                    (if-status inactive)))))
                                               ((ifndef)
                                                (lambda (env body)
-                                                 ((if (in-environment? env (identifier-token? (car body)))
-                                                      enter-inactive-if enter-active-if)
-                                                  env)))
+                                                 (enter-into-if env
+                                                                (if (in-environment? env (identifier-token? (car body)))
+                                                                    (if-status inactive)
+                                                                    (if-status active)))))
                                               ;; NOTE possibly validate that body is empty for endif and else
-                                              ((endif) (lambda (env _)
-                                                         (unless (in-conditional? env)
-                                                           (err "#endif outside conditional"))
-                                                         (leave-if env)))
-                                              ((else elif)  (lambda (env _)
-                                                              (unless (in-conditional? env)
-                                                                (err "#else outside conditional"))
-                                                              (flip-flop-if env)))
+                                              ;; checks that these aren't outside #if is handled internally
+                                              ((endif)      (lambda (env _) (leave-if env)))
+                                              ((else elif)  (lambda (env _) (transition-to-if env (if-status inactive-inactive))))
                                               ((define) resolve-define)
-                                              ((undef) (lambda (env body) (remove-identifier env (identifier-token? (car body)))))
+                                              ((undef) (lambda (env body)
+                                                         (remove-identifier
+                                                          env (identifier-token? (car body)))))
                                               ((line) handle-line-directive)
                                               ((error) (lambda (_ tokens)
-                                                          (throw 'cpp-error-directive (unlex tokens))))
+                                                         (throw 'cpp-error-directive
+                                                                (format #f "#error ~a" (unlex tokens))
+                                                                (format #f "at ~s:~a"
+                                                                        (current-file environment)
+                                                                        (current-line environment))
+                                                                (format #f "included as ~s"
+                                                                        (cpp-file-stack environment))
+                                                                )))
                                               ((pragma) handle-pragma)
                                               (else (err "Unknown preprocessing directive: ~s"
                                                          (list line-tokens))))))
diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm
index 684c0fb5..e59940da 100644
--- a/tests/test/cpp/cpp-environment.scm
+++ b/tests/test/cpp/cpp-environment.scm
@@ -8,8 +8,8 @@
 
 (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*))
+  (let ((e* (enter-into-if e (if-status active))))
+    (test-equal "Enter works" '(active outside) (cpp-if-status e*))
     (test-equal "Original object remainins unmodified"
       '(outside) (cpp-if-status e))))
 
diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index 7fcaaccb..4e808b8b 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -1,12 +1,14 @@
 (define-module (test cpp preprocessor2)
+  :use-module ((srfi srfi-1) :select (remove))
   :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) :select (-> ->> unval swap))
   :use-module ((hnh util lens) :select (set))
   :use-module ((hnh util io) :select (call-with-tmpfile))
+  :use-module (hnh util values)
   :use-module (c preprocessor2)
   :use-module ((c cpp-environment)
                :select (extend-environment
@@ -35,7 +37,7 @@
                         )
                )
   :use-module ((c cpp-types)
-               :select (punctuator-token? identifier-token?))
+               :select (punctuator-token? identifier-token? whitespace-token?))
   :use-module (c lex2)
   )
 
@@ -47,8 +49,6 @@
                    "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))
@@ -82,13 +82,22 @@
   (let ((env tokens (handle-preprocessing-tokens env (tokenize str))))
     (drop-whitespace-both (remove-noexpand tokens))))
 
- (define (call-with-tmp-header string proc)
-   (proc
-    (call-with-tmpfile
-     (lambda (port filename)
-       (display string port)
-       filename)
-     tmpl: "/tmp/headerfile-XXXXXXX")))
+(define (make-runner string)
+  (lambda (rest)
+   (->> (tokenize string)
+        (append (tokenize rest))
+        (handle-preprocessing-tokens (make-environment))
+        (value-refx 1)
+        remove-noexpand
+        (remove whitespace-token?))))
+
+(define (call-with-tmp-header string proc)
+  (proc
+   (call-with-tmpfile
+    (lambda (port filename)
+      (display string port)
+      filename)
+    tmpl: "/tmp/headerfile-XXXXXXX")))
 
 
 
@@ -666,7 +675,11 @@ X
  (call-with-tmp-header "__LINE__" (lambda (path)
     (test-equal "__LINE__ in other file"
       (lex "1")
-      (run (format #f "#include \"~a\"\n" path))))))
+      (run (format #f "#include \"~a\"\n" path)))))
+
+
+ (test-error 'cpp-error (run "#include <no-such-file>\n"))
+ )
 
 
 
@@ -1167,12 +1180,12 @@ c
 "))
 
   (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-error "#else outside if"
+      'misc-error (run "#else"))
+    (test-error "#endif outside if"
+      'misc-error (run "#endif"))
+    (test-error "#elif outside if"
+      'misc-error (run "#elif")))
 
   (test-group "if"
     (test-equal "Simple positive if"
@@ -1205,25 +1218,48 @@ b
 a
 #elif 1
 b
+#else
+c
+#endif"))
+
+    ;; undefined indentifiers expand to 0
+    (test-equal "If with undefined identifier"
+      (lex "a")
+      (run "
+#if X == 0
+a
+#else
+b
+#endif
+"))
+
+    ;; null-defined identifiers expand to nothing, leaving an invalid equals form
+    (test-error "If with null-defined identifier"
+      'cpp-error
+      (run "
+#define X
+#if X == 0
+a
 #endif"))
 
+
     ;; Note that defined is automatically added to the environment when
     ;; evaluating #if.
 
-    (test-equal "#if with defined"
-      (lex "a")
-      (run "
+    (test-group "defined"
+     (test-equal "#if with defined"
+       (lex "a")
+       (run "
 #define X
 #if defined(X)
 a
 #else
 b
-#endif")
-      )
+#endif"))
 
-    (test-equal "#if with negative defined"
-      (lex "b")
-      (run "
+     (test-equal "#if with negative defined"
+       (lex "b")
+       (run "
 #if defined(X)
 a
 #else
@@ -1231,23 +1267,124 @@ b
 #endif"))
 
 
-    (test-group "defined without parenthesis"
-      (test-equal "negative"
-          (lex "b")
-        (run "#if defined X
+     (test-group "defined without parenthesis"
+       (test-equal "negative"
+         (lex "b")
+         (run "#if defined X
 a
 #else
 b
 #endif"))
 
-      (test-equal "positive"
-        (lex "a")
-        (run "#define X
+       (test-equal "positive"
+         (lex "a")
+         (run "#define X
 #if defined X
 a
 #else
 b
-#endif")))
+#endif"))))
+
+
+    (test-group "Advanced if forms"
+      (let ((run (make-runner "
+#if defined X
+  #if defined Y
+    #if defined Z
+      XYZ
+    #else
+      XYz
+    #endif
+  #elif defined Z
+    XyZ
+  #else
+    Xyz
+  #endif
+#elif defined Y
+  #if defined Z
+    xYZ
+  #else
+    xYz
+  #endif
+#elif defined Z
+  xyZ
+#else
+  xyz
+#endif
+")))
+
+        ;; The above expression expands to "xyz", where the letter corresponding
+        ;; to the defined macros should be uppercase.
+
+        (test-equal "xyz"
+          (lex "xyz") (run ""))
+        (test-equal "xyZ"
+          (lex "xyZ") (run "#define Z"))
+        (test-equal "xYz"
+          (lex "xYz") (run "#define Y"))
+        (test-equal "xYZ"
+          (lex "xYZ") (run "#define Y\n#define Z"))
+        (test-equal "Xyz"
+          (lex "Xyz") (run "#define X"))
+        (test-equal "XyZ"
+          (lex "XyZ") (run "#define X\n#define Z"))
+        (test-equal "XYz"
+          (lex "XYz") (run "#define X\n#define Y"))
+        (test-equal "XYZ"
+          (lex "XYZ") (run "#define X\n#define Y\n#define Z"))))
+
+    (test-group "Needlesly complicated if tree"
+      ;; Structure borrowed from features-time64.h
+      (let ((run (make-runner "
+#if defined X
+# if X == 64
+#  if ! defined (Z) || Z != 64
+     a
+#  elif Y == 32
+     b
+#  else
+     f
+#  endif
+# elif X == 32
+#  if Y > 32
+     c
+#  endif
+# else
+     d
+# endif
+#else
+e
+#endif
+")))
 
-    ;; TODO test advanced constant expression
+        (test-equal "No variables set"
+          (lex "e") (run ""))
+        ;; (test-equal "Just X"
+        ;;   (lex "d")
+        ;;   (run "#define X"))
+        (test-equal "Bad X"
+          (lex "d") (run "#define X 6"))
+        (test-equal "Good X and Y, no Z"
+          (lex "a")
+          (run "
+#define X 64
+#define Y 32"))
+        (test-equal "Good X and Z != 64"
+          (lex "a")
+          (run "
+#define X 64
+#define Z 63"))
+        (test-equal "Good X and Z == 64"
+          (lex "f")
+          (run "
+#define X 64
+#define Z 64"))
+        (test-equal "Good (alt) X, and good Y"
+          (lex "c")
+          (run "
+#define X 32
+#define Y 40"))
+        ))
     ))
+
+