work

3 files changed, 131 insertions, 89 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 2a943496..913e905e 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -35,13 +35,18 @@
 
            cpp-environment
            cpp-environment?
-           cpp-if-status cpp-variables
+           cpp-if-status
+           ;; cpp-variables
+           cpp-file-stack
 
            make-environment in-environment?
            remove-identifier! add-identifier!
            get-identifier
            extend-environment
            disjoin-macro
+
+           pprint-environment
+           pprint-macro
            ))
 
 (define (macro-identifier x)
@@ -85,6 +90,7 @@
 (define-type (cpp-environment)
   (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
                  default: '(outside))
+  ;; not exported since type signatures don't hold inside the hash table
   (cpp-variables type: hash-table? default: (make-hash-table))
   (cpp-file-stack type: (and (not null?)
                              (list-of (pair-of string? exact-integer?)))
@@ -172,3 +178,29 @@
   (let ((env (clone-environment environment)))
     (remove-identifier! env name)
     env))
+
+
+
+(define* (pprint-environment environment optional: (port (current-error-port)))
+  (display "== Environment ==\n")
+  (hash-for-each (lambda (key macro)
+                   (pprint-macro macro port)
+                   (newline port))
+                 (cpp-variables environment)))
+
+(define* (pprint-macro x optional: (p (current-output-port)))
+  (cond ((internal-macro? x)
+         (format p "/* ~a INTERNAL MACRO */"
+                 (macro-identifier x)))
+        ((object-macro? x)
+         (format p "#define ~a ~a"
+                 (macro-identifier x)
+                 (unlex (macro-body x))))
+        ((function-macro? x)
+         (format p "#define ~a(~a) ~a"
+                 (macro-identifier x)
+                 (string-join (append (macro-identifier-list x)
+                                      (if (variadic? x)
+                                          '("...") '()))
+                              "," 'infix)
+                 (unlex (macro-body x))))))
diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm
index 1a7387f5..e5e73d32 100644
--- a/module/c/cpp-types.scm
+++ b/module/c/cpp-types.scm
@@ -52,3 +52,16 @@
        (match (lexeme-body token)
          (`(string-literal ,x) x)
          (_ #f))))
+
+
+(define (h-string-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(h-string ,x) x)
+         (_ #f))))
+
+(define (q-string-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(q-string ,x) x)
+         (_ #f))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 720a6ffc..71c2a09e 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -21,7 +21,7 @@
   :use-module (c cpp-util)
   :use-module ((c zipper) :select (list-zipper left focused right zip-find-right
                                                list->zipper zipper->list))
-  :export ())
+  :export (defined-macro))
 
 (define-syntax-rule (alist-of variable key-type value-type)
   (build-validator-body variable (list-of (pair-of key-type value-type))))
@@ -147,9 +147,11 @@
 
 
     (define parameter-map (build-parameter-map macro parameters))
-    (define stringify-resolved (expand# macro parameter-map))
     (remove placemaker-token?
-            (expand## (resolve-cpp-variables stringify-resolved parameter-map)))))
+            (-> macro
+                (expand# parameter-map)
+                (resolve-cpp-variables parameter-map)
+                expand##))))
 
 
 
@@ -322,20 +324,38 @@
                            "Invalid parameter list to `defined': ~s"
                            (list arguments) #f)))))
 
+;; (lex "STDC FP_CONTRACT ON")
+;; (#<<lexeme> type: preprocessing-token body: (identifier "STDC") noexpand: ()>
+;;  #<<lexeme> type: whitespace body: " " noexpand: ()>
+;;  #<<lexeme> type: preprocessing-token body: (identifier "FP_CONTRACT") noexpand: ()>
+;;  #<<lexeme> type: whitespace body: " " noexpand: ()>
+;;  #<<lexeme> type: preprocessing-token body: (identifier "ON") noexpand: ()>)
+
 ;; environment, tokens → environment
 (define (handle-pragma environment tokens)
-  ;; TODO rewrite without match
-  (match tokens
-    (`((preprocessing-token (identifier "STDC")) (whitespace ,_) ...
-       (preprocessing-token (identifier ,identifier)) (whitespace ,_) ...
-       (preprocessing-token (identifier ,on-off-switch)) (whitespace ,_) ...)
-     ;; TODO actually do something with the pragmas (probably just store them in the environment)
-     (format (current-error-port)
-             "#Pragma STDC ~a ~a" identifier on-off-switch)
-     environment)
-    (_ (format (current-error-port)
-               "Non-standard #Pragma: ~s~%" tokens)
-       environment)))
+  (typecheck environment cpp-environment?)
+  (typecheck tokens (list-of lexeme?))
+
+  (let ((err (lambda ()
+               (scm-error 'cpp-pragma-error "handle-pragma"
+                          "Invalid pragma directive: ~a"
+                          (list (unlex tokens)) #f))))
+
+    (cond ((null? tokens) (err))
+          ((equal? "STDC" (identifier-token? (car tokens)))
+           (call-with-values (lambda () (apply values (filter identifier-token? (cdr tokens))))
+             (case-lambda ((identifier on-off-switch)
+                           (format (current-output-port)
+                                   "#Pragma STDC ~a ~a"
+                                   (unlex (list identifier))
+                                   (unlex (list on-off-switch)))
+                           environment)
+                          (_ (err)))))
+          (else
+           (format (current-output-port)
+                   "Non-standard #Pragma: ~s~%"
+                   (unlex (list tokens)))
+           environment))))
 
 
 ;; TODO
@@ -345,35 +365,12 @@
 ;;    body: (lambda (environment tokens)
 ;;            )))
 
-;; TODO
 (define (resolve-constant-expression tokens)
   (typecheck tokens (list-of lexeme?))
   'TODO
   )
 
-(define* (pprint-macro x optional: (p (current-output-port)))
-  (cond ((internal-macro? x)
-         (format p "/* ~a INTERNAL MACRO */"
-                 (macro-identifier x)))
-        ((object-macro? x)
-         (format p "#define ~a ~a"
-                 (macro-identifier x)
-                 (unlex (macro-body x))))
-        ((function-macro? x)
-         (format p "#define ~a(~a) ~a"
-                 (macro-identifier x)
-                 (string-join (append (macro-identifier-list x)
-                                      (if (variadic? x)
-                                          '("...") '()))
-                              "," 'infix)
-                 (unlex (macro-body x))))))
-
-(define* (pprint-environment environment optional: (port (current-error-port)))
-  (display "== Environment ==\n")
-  (hash-for-each (lambda (key macro)
-                   (pprint-macro macro port)
-                   (newline port))
-                 (cpp-variables environment)))
+
 
 (define (mark-noexpand1 token name)
   (modify token lexeme-noexpand xcons name))
@@ -442,59 +439,57 @@
                          remaining-tokens)))))
 
 (define (resolve-and-include-header environment tokens)
-  (define (err msg . args)
-    (scm-error 'cpp-error "resolve-and-include-header"
-               (string-append msg ", tokens: ~s")
-               (append args (list (unlex tokens))) #f))
-
   (typecheck environment cpp-environment?)
   (typecheck tokens (list-of lexeme?))
 
-  (let loop ((%first-time #t) (tokens tokens))
-    (cond ((null? tokens) '())
-          ((h-string? (car tokens))
-           (unless (null? (remove-whitespace (cdr tokens)))
-             (err "Unexpected tokens after #include <>"))
-           (handle-preprocessing-tokens
-            environment
-            (-> str resolve-h-file read-file tokenize)))
-          ((q-string? (car tokens))
-           (unless (null? (remove-whitespace (cdr tokens)))
-             (err "Unexpected tokens after #include \"\""))
-           (handle-preprocessing-tokens
-            environment
-            (-> str resolve-q-file read-file tokenize)))
-          (else
-           (unless %first-time (err "Failed parsing tokens"))
-           (loop #f (resolve-token-stream environment tokens))))))
+  (let ((err (lambda (msg . args)
+               (scm-error 'cpp-error "resolve-and-include-header"
+                          (string-append msg ", tokens: ~s")
+                          (append args (list (unlex tokens))) #f))))
+    (let loop ((%first-time #t) (tokens tokens))
+      (cond ((null? tokens) '())
+            ((h-string-token? (car tokens))
+             => (lambda (str)
+                  (unless (null? (remove-whitespace (cdr tokens)))
+                    (err "Unexpected tokens after #include <>"))
+                  (handle-preprocessing-tokens
+                   environment
+                   (-> str resolve-h-file read-file tokenize))))
+            ((q-string-token? (car tokens))
+             => (lambda (str)
+                  (unless (null? (remove-whitespace (cdr tokens)))
+                    (err "Unexpected tokens after #include \"\""))
+                  (handle-preprocessing-tokens
+                   environment
+                   (-> str resolve-q-file read-file tokenize))))
+            (else
+             (unless %first-time (err "Failed parsing tokens"))
+             (loop #f (resolve-token-stream environment tokens)))))))
 
 ;; environment, tokens → environment
 (define (handle-line-directive environment tokens*)
   (typecheck environment cpp-environment?)
   (typecheck tokens* (list-of lexeme?))
 
-  (let loop ((%first-time #t) (tokens tokens*))
-    (cond ((null? tokens))
-          ((number-token? (car tokens))
-           => (lambda (line)
-                (let ((line (string->number line)))
-                 (let ((remaining (drop-whitespace (cdr tokens))))
-                   (cond ((null? remaining) (set environment current-line line))
-                         ((string-token? (car remaining))
-                          => (lambda (file)
-                               (-> environment
-                                   (set current-line line)
-                                   (set current-file file))))
-                         (%first-time
-                          (loop #f (resolve-token-stream environment tokens)))
-                         (else (scm-error 'cpp-error "handle-line-directive"
-                                          "Invalid line directive: ~s"
-                                          (list tokens*) #f)
-                               ))))))
-          (%first-time (loop #f (resolve-token-stream environment tokens)))
-          (else (scm-error 'cpp-error "handle-line-directive"
-                           "Invalid line directive: ~s"
-                           (list tokens*) #f)))))
+  (let ((err (lambda () (scm-error 'cpp-error "handle-line-directive"
+                              "Invalid line directive: ~s"
+                              (list tokens*) #f))))
+    (let loop ((%first-time #t) (tokens tokens*))
+      (cond ((null? tokens))
+            ((number-token? (car tokens))
+             => (lambda (line)
+                  (let ((line (string->number line)))
+                    (let ((remaining (drop-whitespace (cdr tokens))))
+                      (cond ((null? remaining) (set environment current-line (1- line)))
+                            ((string-token? (car remaining))
+                             => (lambda (file)
+                                  (-> environment
+                                      (set current-line (1- line))
+                                      (set current-file file))))
+                            (%first-time (loop #f (resolve-token-stream environment tokens)))
+                            (else (err)))))))
+            (%first-time (loop #f (resolve-token-stream environment tokens)))
+            (else (err))))))
 
 ;; environment, tokens → environment
 (define (resolve-define environment tokens)
@@ -545,11 +540,11 @@
                         args)
                  #f))
 
-    (cond ((null? tokens) '())
+    (cond ((null? tokens) (values environment '()))
           ((newline-token? (car tokens))
            (let ((environment (bump-line environment))
                  (tokens* (drop-whitespace (cdr tokens))))
-             (cond ((null? tokens*) '())
+             (cond ((null? tokens*) (values environment '()))
                    ((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
@@ -602,9 +597,11 @@
 
                    ;; Line is not a pre-processing directive
                    (else (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens))))
-                           (append (unless (in-comment-block? environment)
-                                     (resolve-token-stream environment line-tokens))
-                                   (loop environment remaining-tokens)))))))
+                           (let ((env* tokens* (loop environment remaining-tokens)))
+                             (values env*
+                                     (append (unless (in-comment-block? environment)
+                                               (resolve-token-stream environment line-tokens))
+                                             tokens*))))))))
 
           (else (err "Unexpected middle of line")))))