Rewrite handel-preprocessing-tokens.

2 files changed, 87 insertions, 109 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 2ad60b56..2a943496 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -19,7 +19,9 @@
 
            enter-active-if
            enter-inactive-if
+           flip-flop-if
            leave-if
+           in-comment-block?
 
            enter-file
            leave-file
@@ -97,9 +99,19 @@
 (define (enter-inactive-if environment)
   (modify environment cpp-if-status xcons 'inactive-if))
 
+;; for #else
+(define (flip-flop-if environment)
+  ((if (in-comment-block? environment)
+       enter-active-if
+       enter-inactive-if)
+   (leave-if environment)))
+
 (define (leave-if environment)
   (modify environment cpp-if-status cdr))
 
+(define (in-comment-block? environment)
+  (eq? 'inactive-if (get environment cpp-if-status car*)))
+
 
 
 (define (enter-file environment filename)
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index a6710314..5adcd40c 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -50,18 +50,6 @@
            parameters)))
 
 
-;; TODO Deprecate?
-(define (parameter-map->macro-list param-map)
-  (typecheck param-map parameter-map?)
-  (map (lambda (pair)
-         (let ((identifier (car pair))
-               (body (cdr pair)))
-           (object-like-macro
-            identifier: identifier
-            body: body)))
-       param-map))
-
-
 (define (expand# macro parameter-map)
   (typecheck macro macro?)
   (typecheck parameter-map parameter-map?)
@@ -88,14 +76,19 @@
   ;; Each element should be the lexeme list for that argument
   (typecheck parameters (list-of (list-of lexeme?)))
   (typecheck macro macro?)
-  (when (or (and (variadic? macro)
-                 (> (length (macro-identifier-list macro))
-                    (length parameters)))
-            (and (not (variadic? macro))
-                 (not (= (length (macro-identifier-list macro))
-                         (length parameters)))))
+  (when (and (variadic? macro)
+             (> (length (macro-identifier-list macro))
+                (length parameters)))
+    (scm-error 'cpp-arity-error "apply-macro"
+               "Too few arguments to variadic macro ~s, expected at least ~s, got ~s"
+               (list (macro-identifier macro)
+                     (length (macro-identifier-list macro))
+                     (length parameters))
+               (list macro)))
+  (when (and (not (variadic? macro))
+             (not (= (length (macro-identifier-list macro))
+                     (length parameters))))
     (scm-error 'cpp-arity-error "apply-macro"
-               ;; TODO better error message for variadic macros
                "Wrong number of arguments to macro ~s, expected ~s, got ~s"
                (list (macro-identifier macro)
                      (length (macro-identifier-list macro))
@@ -503,14 +496,13 @@
                 ;; function like macro
                 (let ((identifier-list
                        replacement-list
-                       (break (lambda (token) (equal? '(punctuator ")") (lexeme-body token) ))
+                       (break (lambda (token) (equal? '(punctuator ")") (lexeme-body token)))
                               (cdr tail))))
                   (let ((variadic? identifiers (parse-identifier-list identifier-list)))
                     (function-like-macro
                      identifier: identifier
                      variadic?: variadic?
                      identifier-list: identifiers
-                     ;; NOTE 6.10.3 states that there needs to be at least on whitespace here
                      ;; cdr drops the end parenthesis of the definition
                      ;; surrounding whitespace is not part of the replacement list (6.10.3 p.7)
                      body: (drop-whitespace-both (cdr replacement-list))))))
@@ -532,94 +524,68 @@
                         args)
                  #f))
 
-    ;; TODO all of this needs to be surounded with a conditional for
-    ;; environmentns if status. However, ensure that each directive
-    ;; starts at start of line
-
-    (match tokens
-      ('() '())
-      ((`(whitespace "\n") `(whitespace ,_) '... '(preprocessing-token (puntuator "#")) rest ...)
-       ;; Line tokens are those in this line,
-       ;; while remaining tokens are the newline, follewed by the rest of the files tokens
-       (let ((line-tokens remaining-tokens (tokens-until-eol rest)))
-         ;; Actual tokens just removes all whitespace between "#" and "define"
-         (let ((actual-tokens (drop-whitespace line-tokens)))
-           (if (null? actual-tokens)
-               (loop (bump-line environment) remaining-tokens)
-               (match (car actual-tokens)
-                 (`(preprocessing-token (identifier "if"))
-                  (let ((environment (resolve-for-if environment actual-tokens)))
-                    (loop environment remaining-tokens)))
-
-                 (`(preprocessing-token (identifier "ifdef"))
-                  (match actual-tokens
-                    ((`(preprocessing-token (identifier ,id)) _ ...)
-                     (loop
-                      ((if (in-environment? environment id)
-                           enter-active-if enter-inactive-if)
-                       environment)
-                      remaining-tokens))
-                    (_ (err "Non identifier in ifdef: ~s" actual-tokens))))
-
-                 (`(preprocessing-token (identifier "ifndef"))
-                  (match actual-tokens
-                    ((`(preprocessing-token (identifier ,id)) _ ...)
-                     (loop
-                      ((if (in-environment? environment id)
-                           enter-inactive-if enter-active-if)
-                       environment)
-                      remaining-tokens))
-                    (_ (err "Non identifier in ifndef: ~s" actual-tokens))))
-
-                 ('(preprocessing-token (identifier "else"))
-                  ;; TODO
-                  'TODO
-                  )
-
-                 ('(preprocessing-token (identifier "elif"))
-                  (-> environment leave-if
-                      (resolve-for-if actual-tokens)
-                      (loop remaining-tokens)))
-
-                 ('(preprocessing-token (identifier "endif"))
-                  (loop (leave-if environment) remaining-tokens))
-
-                 ('(preprocessing-token (identifier "include"))
-                  (call-with-values
-                      (lambda () (resolve-and-include-header environment (cdr actual-tokens)))
-                    (lambda (environment tokens)
-                     (loop environment (append tokens remaining-tokens)))))
-
-                 ('(preprocessing-token (identifier "define"))
-                  (let ((env (resolve-define environment (cdr actual-tokens))))
-                    (loop env remaining-tokens))
-                  )
-
-                 ('(preprocessing-token (identifier "undef"))
-                  (loop (match actual-tokens
-                          (`((preprocessing-token (identifier ,id)))
-                           (-> environment bump-line (remove-identifier! id))))
-                        remaining-tokens))
-
-                 ('(preprocessing-token (identifier "line"))
-                  (loop (handle-line-directive environment actual-tokens)
-                        remaining-tokens))
-
-                 ('(preprocessing-token (identifier "error"))
-                  ;; NOTE this is an "expected" error
-                  (throw 'cpp-error actual-tokens))
-
-                 ('(preprocessing-token (identifier "pragma"))
-                  (loop (handle-pragma environment actual-tokens)
-                        remaining-tokens)))))))
-
-      ((`(preprocessing-token (identifier ,id)) rest ...)
-       (maybe-extend-identifier environment id rest loop))
-
-      (('(whitespace "\n") rest ...)
-       (cons '(whitespace "\n") (loop (bump-line environment) rest)))
-
-      ((token rest ...) (cons token (loop environment rest))))))
+    (define (handle-regular-line environment tokens)
+      (let ((line-tokens remaining-tokens (tokens-until-eol tokens)))
+        (if (in-comment-block? environment)
+            (loop (bump-line environment) remaining-tokens)
+            (append (resolve-token-stream environment line-tokens)
+                    (loop (bump-line environment) remaining-tokens)))))
+
+
+    (cond ((null? tokens) '())
+          ((newline-token? (car tokens))
+           (let ((tokens (drop-whitespace (cdr tokens))))
+             (cond ((null? tokens) '())
+                   ((equal? '(punctuator "#") (lexeme-body (car tokens)))
+                    (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens))))
+                      ;; drop whitespace after to not "eat" the next newline token
+                      (let ((line-tokens (drop-whitespace line-tokens)))
+                        (cond ((null? line-tokens)
+                               (loop (bump-line environment) remaining-tokens))
+
+                              ((in-comment-block? environment)
+                               (case (string->symbol (identifier-token? (car line-tokens)))
+                                 ((else)  (loop (bump-line (flip-flop-if environment)) remaining-tokens))
+                                 ((endif) (loop (bump-line (leave-if environment)) remaining-tokens))
+                                 ((elif)  (loop (bump-line (resolve-for-if
+                                                            (leave-if environment)
+                                                            (drop-whitespace (cdr line-tokens))))
+                                                remaining-tokens))
+                                 (else (loop (environment remaining-tokens)))))
+
+                              ;; From here on we are not in a comment block
+                              (else
+                               (let ((directive (string->symbol (identifier-token? (car line-tokens))))
+                                     (body (drop-whitespace (cdr line-tokens))))
+                                 (if (eq? 'include directive)
+                                     ;; include is special since it returns a token stream
+                                     (call-with-values
+                                         (lambda () (resolve-and-include-header environment body))
+                                       (lambda (environment tokens)
+                                         (loop (bump-line environment)
+                                               (append tokens remaining-tokens))))
+                                     (let ((operation
+                                            (case directive
+                                              ((if) resolve-for-if)
+                                              ((ifdef)
+                                               (lambda (env body)
+                                                 (if (in-environment? env (identifier-token? (car body)))
+                                                     enter-active-if enter-inactive-if)))
+                                              ((ifndef)
+                                               (lambda (env body)
+                                                 (if (in-environment? env (identifier-token? (car body)))
+                                                     enter-inactive-if enter-active-if)))
+                                              ((define) resolve-define)
+                                              ((undef) (lambda (env body) (remove-identifier! env (car body))))
+                                              ((line) handle-line-directive)
+                                              ((error) (lambda (_ body) (throw 'cpp-error body)))
+                                              ((pragma) handle-pragma)
+                                              (else (err "Unknown preprocessing directive: ~s"
+                                                         (list line-tokens))))))
+                                       (loop (bump-line (operation environment body))
+                                             remaining-tokens)))))))))
+                   (else (handle-regular-line environment tokens)))))
+          (else (handle-regular-line environment tokens)))))