path: root/module/c/preprocessor2.scm

(define-module (c preprocessor2)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-71)
  :use-module (srfi srfi-88)

  :use-module (ice-9 format)
  :use-module (c cpp-environment)
  :use-module ((c eval2) :select (c-boolean->boolean))
  :use-module ((c eval-basic) :select (eval-basic-c))
  :use-module ((hnh util) :select (-> ->> intersperse unless unval break/all))
  :use-module ((hnh util lens) :select (set modify cdr*))
  :use-module (hnh util path)
  :use-module (hnh util type)
  :use-module (hnh util object)
  :use-module ((hnh util values) :select (abort* on-snd value-ref apply/values))
  :use-module ((hnh util io) :select (read-file))
  :use-module ((c lex2)
               :select (lex
                        placemaker
                        lexeme?
                        lexeme-noexpand
                        tokenize
                        ))
  :use-module (c unlex)
  :use-module (c cpp-types)
  :use-module (c cpp-util)
  :use-module ((c ast) :select (build-ast))
  :export (_Pragma-macro
           ;; defined-macro
           c-search-path
           handle-preprocessing-tokens
           cpp
           preprocess-string
           make-default-environment
           ))




(define parameter-map? (of-type? (alist-of string? (list-of lexeme?))))

(define (concat-token? token)            (and (equal? "##"  (punctuator-token? token))
                                              (not (member "##" (lexeme-noexpand token)))))
(define (stringify-token? token)         (equal? "#"   (punctuator-token? token)))
(define (left-parenthesis-token? token)  (equal? "("   (punctuator-token? token)))
(define (right-parenthesis-token? token) (equal? ")"   (punctuator-token? token)))
(define (comma-token? token)             (equal? ","   (punctuator-token? token)))
(define (ellipsis-token? token)          (equal? "..." (punctuator-token? token)))




(define (expand# macro parameter-map)
  (typecheck macro cpp-macro?)
  (typecheck parameter-map parameter-map?)
  (let loop ((tokens (macro-body macro)))
    (cond ((null? tokens) '())
          ((stringify-token? (car tokens))
           (let* ((head rest (car+cdr (drop-whitespace (cdr tokens))))
                  (x (identifier-token? head)))
             (cond ((assoc-ref parameter-map x)
                    => (lambda (tokens)
                         (cons (stringify-tokens tokens)
                               (loop rest))))
                   (else
                    (scm-error 'macro-expand-error "expand#"
                               "'#' is not followed by a macro parameter: ~s"
                               (list x) #f)))))
          (else (cons (car tokens)
                      (loop (cdr tokens)))))))


;; 6.10.3.3
(define (expand## tokens)
  ;; (typecheck tokens (list-of lexeme?))

  (let loop ((left '())
             (right tokens))
    (cond ((null? right)
           (reverse left))
          ((concat-token? (car right))
           (let ((l (drop-whitespace left))
                 (r (drop-whitespace (cdr right))))
             (cond ((or (null? l) (null? r))
                    (scm-error 'cpp-error "expand##"
                               "## can't be first or last token: ~s"
                               (list (unlex tokens)) #f))
                   ((and (placemaker-token? (car l))
                         (placemaker-token? (car r)))
                    (loop (cdr l) (cons (placemaker) (cdr r))))
                   ((placemaker-token? (car l))
                    (loop (cdr l) r))
                   ((placemaker-token? (car r))
                    (loop (cdr l) (cons (car l) (cdr r))))
                   (else
                    ;; 6.10.3.3 p. 3
                    ;; I believe that ## is the only special case where the
                    ;; result of concatenation is differente from the token directly.
                    (let ((token (concatenate-tokens (car l) (car r))))
                      (let ((token (if (concat-token? token)
                                       (modify token lexeme-noexpand xcons "##")
                                       token)))
                        (loop (cdr l) (cons token (cdr r)))))))))
          (else
           (let ((pre post (break concat-token? right)))
             (loop (append left (reverse pre)) post))))))


(define (check-arity macro parameters)
  (if (macro-variadic? macro)
      (unless (>= (length parameters)
                 (length (macro-identifier-list macro)))
        (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)))
      (unless (or (and (= 0 (length (macro-identifier-list macro)))
                       (= 1 (length parameters))
                       (null? (car parameters)))
                  (= (length (macro-identifier-list macro))
                     (length parameters)))
        (scm-error 'cpp-arity-error "apply-macro"
                   "Wrong number of arguments to macro ~s, expected ~s, got ~s"
                   (list (macro-identifier macro)
                         (length (macro-identifier-list macro))
                         (length parameters))
                   (list macro)))))

;; expand function like macro
;; parameter is a list of lexeme-lists, each "top level" element matching one
;; argument to the macro
(define (apply-macro environment macro parameters)
  (typecheck environment cpp-environment?)
  ;; Each element should be the lexeme list for that argument
  (typecheck parameters (list-of (list-of lexeme?)))
  (typecheck macro cpp-macro?)
  (check-arity macro parameters)

  (let ()

    (define (resolve-cpp-variables tokens parameter-map)
      (define (bound-identifier? id)
        (assoc-ref parameter-map id))

      ;; expand parameters, and place placemaker tokens
      (let loop ((tokens tokens) (last #f))
        (cond ((null? tokens) '())
              ((identifier-token? (car tokens))
               bound-identifier?
               => (lambda (id)
                    (let ((replacement (assoc-ref parameter-map id)))
                      (if (null? replacement)
                          (cons (placemaker) (loop (cdr tokens) #f))
                          ;; macroexpand replacement here! But only if the token isn't used with ## (or #)
                          (append
                           (if (or (concat-token? last)
                                   (next-token-matches? concat-token? tokens))
                               replacement
                               ;; resolve-token-stream only modifies environment by updating current line
                               ;; that can't happen in a macro body
                               ((unval resolve-token-stream 1) environment replacement once?: #t))
                           (loop (cdr tokens) #f))))))
              ((whitespace-token? (car tokens))
               (cons (car tokens) (loop (cdr tokens) last)))
              (else (cons (car tokens) (loop (cdr tokens) (car tokens)))))))


    ;; parameters is a lexeme list, as returned by parse-parameter-list
    (define parameter-map
      (map (lambda (pair) (modify pair cdr* drop-whitespace-both))
           (if (macro-variadic? macro)
               (let ((head rest (split-at parameters (length (macro-identifier-list macro)))))
                 (cons (cons "__VA_ARGS__" (concatenate (intersperse (lex ",") rest)))
                       (map cons
                            (macro-identifier-list macro)
                            head)))
               (map cons
                    (macro-identifier-list macro)
                    parameters))))

    (remove placemaker-token?
            (-> macro
                (expand# parameter-map)
                (resolve-cpp-variables parameter-map)
                expand##))))


;; remaining-tokens should be the token stream just after the name of the macro
(define (expand-macro environment macro noexpand-list remaining-tokens)
  (typecheck environment cpp-environment?)
  (typecheck macro cpp-macro?)
  ;; (typecheck remaining-tokens (list-of lexeme?))
  (typecheck noexpand-list (list-of string?))

  (let ((name (macro-identifier macro)))
    (cond ((object-macro? macro)
           (values environment
                   (append (fold mark-noexpand
                                 (expand## (macro-body macro))
                                 (cons name noexpand-list))
                           remaining-tokens)))

          ((or (function-macro? macro)
               (internal-macro? macro))
           (if (next-token-matches? left-parenthesis-token? remaining-tokens)
               (let* ((containing remaining newlines (parse-parameter-list remaining-tokens))
                      (environment tokens*
                                   (if (function-macro? macro)
                                       (values environment (apply-macro environment macro containing))
                                       ((macro-body macro) environment containing))))
                 (values (bump-line environment newlines)
                         (append (fold mark-noexpand
                                       tokens*
                                       (cons name noexpand-list))
                                 remaining)))

               (values environment
                       ;; TODO#1 the token shouldn't be expanded here, but it should neither be marked no-expand?
                       ;; Consider the case
                       ;; #define m(a) a(0,1)
                       ;; #define f(a) f(2 * (a))
                       ;; m(f)
                       (append (mark-noexpand (macro-identifier macro)
                                              (lex (macro-identifier macro)))
                               remaining-tokens))))


          (else
           (scm-error 'wrong-type-arg "expand-macro"
                      "Macro isn't a macro: ~s"
                      (list macro) #f)))))



(define-type (parenthesis-group)
  (parenthesis-group-tokens
   type: (list-of (or lexeme? parenthesis-group?))))

(define (make-parenthesis-group tokens)
  (parenthesis-group parenthesis-group-tokens: tokens))


(define (flatten-group tokens)
  (cond ((null? tokens) '())
        ((lexeme? (car tokens))
         (cons (car tokens) (flatten-group (cdr tokens))))
        ((parenthesis-group? (car tokens))
         (append (lex "(")
                 (flatten-group (parenthesis-group-tokens (car tokens)))
                 (lex ")")
                 (flatten-group (cdr tokens))))))


;; Takes a list of preprocessing tokens, and returns three values
;; - if the last token was '...'
;; - a list of strings of all token names
;; - the remaining tokens
;; Note that this is ONLY #define f(x) forms
;; not usage forms
(define (parse-identifier-list tokens)
  ;; (typecheck tokens (list-of lexeme?))
  (let* ((group remaining (parse-group (drop-whitespace tokens)))
         (groups (reverse (map drop-whitespace-both
                               (break/all comma-token? (parenthesis-group-tokens group))))))
    ;; Checks that there where no nested parenthesis
    (cond ((equal? '(()) groups)
           (values #f '() remaining))
          (else
           (typecheck groups (list-of (and (list-of-length 1)
                                           (list-of lexeme?))))

           (let ((variadic? groups (if (ellipsis-token? (caar groups))
                                       (values #t (cdr groups))
                                       (values #f groups))))
             (values
              variadic?
              (map (lambda (x) (or (identifier-token? x)
                              (scm-error 'cpp-error "parse-identifier-list"
                                         "Unexpected preprocessing-token in identifier list: ~s"
                                         (list x) #f)))
                   (map car (reverse groups)))
              remaining))))))



(define (newline-count group)
  (count newline-token? (flatten-group (parenthesis-group-tokens group))))


;; tokens ⇒ parenthesis-group, remaining-tokens
(define (parse-group tokens)
  (typecheck tokens (not null?))
  (typecheck (car tokens) left-parenthesis-token?)

  ;; Push each found symbol onto a stack.
  ;; If the given symbol is a right parenthesis, pop elements from the stack
  ;; until a left parenthesis is found, construct a group of these elements,
  ;; and push it back onto the stack

  (let loop ((stack '()) (remaining tokens))
    (cond ((and (of-type? stack (list-of-length 1))
                (car stack))
           parenthesis-group?
           => (lambda (item) (values item remaining)))
          ((null? remaining)
           (scm-error 'misc-error "parse-group"
                      "Ran out of tokens while parsing: ~s (stack: ~s)"
                      (list (unlex tokens) stack) #f))
          (else
           (loop (cond ((right-parenthesis-token? (car remaining))
                        (let ((group rest (break left-parenthesis-token? stack)))
                          (cons (make-parenthesis-group (reverse group))
                                ;; Remove left-parenthesis
                                (cdr rest))))
                       (else (cons (car remaining) stack)))
                 (cdr remaining))))))



;; returns three values:
;; - a list of tokens where each is a parameter to the function like macro
;; - the remaining tokenstream
;; - how many newlines were encountered
;; The standard might call these "replacement lists"
;; Note that each returned token-list might have padding whitespace which should be trimmed.
;; It's kept to allow __VA_ARGS__ to "remember" its whitespace
(define (parse-parameter-list tokens)
  (let ((group remaining (parse-group (drop-whitespace tokens))))
    ;; Checks that no inner groups where here
    ;; (typecheck tokens (list-of lexeme?))
    (values (map flatten-group
                 (break/all comma-token? (parenthesis-group-tokens group)))
            remaining
            (newline-count group))))


;; Add __FILE__ and __LINE__ object macros to the environment
(define (join-file-line environment)
  (extend-environment
   environment
   ;; 6.10.8
   (list
    (object-macro
     identifier: "__FILE__"
     body: (lex (format #f "~s" (current-file environment))))
    (object-macro
     identifier: "__LINE__"
     body: (lex (number->string (current-line environment)))))))


(define _Pragma-macro
  (internal-macro
   identifier: "_Pragma"
   body: (lambda (environment arguments)
           (typecheck arguments (and (list-of (list-of lexeme?))
                                     (not null?)))
           (cond ((string-token? (caar arguments))
                  (lambda (a . _) a)
                  ;; TODO handle rest
                  => (lambda (encoding it . rest)
                       (values (handle-pragma environment (lex it))
                               '())))
                 (else (scm-error 'cpp-pragma-error "_Pragma"
                                  "Invalid argument to _Pragma: ~s"
                                  (list (car arguments)) #f))))))



;; environment, tokens → environment
(define (handle-pragma environment tokens)
  (define (err)
   (scm-error 'cpp-pragma-error "handle-pragma"
              "Invalid pragma directive: ~a"
              (list (unlex tokens)) #f))

  (typecheck environment cpp-environment?)
  ;; (typecheck tokens (list-of lexeme?))

  (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: ~a"
                 (unlex tokens))
         environment)))


;; (next-token-or-group (lex "  x y")
;; => (car (lex "x"))
;; => (lex " y")
;; next-token-or-group (lex "  (x) y")
;; => (lex "(x)")
;; => (lex " y")
(define (next-token-or-group tokens)
  (let loop ((tokens (drop-whitespace tokens)))
    (cond ((null? tokens)
           (scm-error 'misc-error "next-token-or-group" "Out of tokens" '() #f))
          ((left-parenthesis-token? (car tokens))
           (parse-group tokens))
          ((preprocessing-token? (car tokens))
           (car+cdr tokens))
          (else (scm-error 'misc-error "next-token-or-group"
                           "This should be impossible" '() #f)))))


(define (parse-if-line environment cpp-tokens)
  (define zero (car (lex "0")))
  (define one  (car (lex "1")))

  (define (drop-identifiers tokens)
    (map (lambda (x) (if (identifier-token? x)
                    zero x))
         tokens))

  (drop-identifiers
   (let ((environment (join-file-line environment)))
     (let loop ((tokens cpp-tokens))
       (cond ((null? tokens) '())
             ((identifier-token? (car tokens))
              (lambda (s) (and s (string=? s "defined")))
              => (lambda _
                   (let ((next rest (next-token-or-group (cdr tokens))))
                     (cons (if (and=> (identifier-token? (if (parenthesis-group? next)
                                                             ;; TODO empty group
                                                             (car (drop-whitespace (parenthesis-group-tokens next)))
                                                             next))
                                      (lambda (it) (in-environment? environment it)))
                               one zero)
                           (loop rest)))))

             ((and (identifier-token? (car tokens))
                   (not (marked-noexpand? (car tokens))))
              (-> (maybe-extend-identifier environment
                                           (identifier-token? (car tokens))
                                           (lexeme-noexpand (car tokens))
                                           (cdr tokens))
                  (value-ref 1)
                  loop))

             (else (cons (car tokens)
                         (loop (cdr tokens)))))))))


(define (mark-noexpand1 token name)
  (modify token lexeme-noexpand xcons name))

(define (mark-noexpand name tokens)
  ;; (typecheck tokens (list-of lexeme?))
  ;; (typecheck name string?)
  (map (lambda (token) (mark-noexpand1 token name)) tokens))

(define (marked-noexpand? token)
  (and=> (identifier-token? token)
         (lambda (id) (member id (lexeme-noexpand token)))))

;; Expands a token-stream which contains no pre-processing directives (#if:s, ...)
;; If @var{once?} is true then the resulting body won't be scanned again for tokens to expand
;; environment, tokens, [boolean] → environment, tokens
(define* (resolve-token-stream environment tokens key: once?)
  (typecheck environment cpp-environment?)
  ;; (typecheck tokens (list-of lexeme?))

  (let loop ((environment environment) (tokens tokens))
    (cond ((null? tokens) (values environment '()))
          ((newline-token? (car tokens))
           (on-snd (cons (car tokens) (abort* (loop (bump-line environment) (cdr tokens))))))
          ((and (identifier-token? (car tokens))
                (not (marked-noexpand? (car tokens))))
           ;; Here is the loop after expansion
           (apply/values (if once? values loop)
                         (maybe-extend-identifier environment
                                                  (identifier-token? (car tokens))
                                                  (lexeme-noexpand (car tokens))
                                                  (cdr tokens))))
          (else (on-snd (cons (car tokens) (abort* (loop environment (cdr tokens)))))))))



;; returns a new environment
;; handle body of #if
;; environment, (list token) → environment
(define (handle-if-directive environment tokens)
  (typecheck environment cpp-environment?)
  ;; (typecheck tokens (list-of lexeme?))
  (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)
  (typecheck environment cpp-environment?)
  (typecheck identifier string?)
  ;; (typecheck remaining-tokens (list-of lexeme?))
  (typecheck noexpand-list (list-of string?))

  (cond ((get-identifier (join-file-line environment) identifier)
         => (lambda (value)
              (expand-macro (join-file-line environment)
                            value
                            noexpand-list
                            remaining-tokens)))
        (else ; It wasn't an identifier, leave it as is
         (values environment
                 (append (mark-noexpand identifier (lex identifier))
                         remaining-tokens)))))

;; 'gcc -xc -E -v /dev/null' prints GCC:s search path
(define c-search-path
  (make-parameter (list "/usr/include"
                        "/usr/local/include")))

;; #include <stdio.h>
(define (resolve-h-file string)
  (typecheck string string?)
  (cond ((path-absolute? string) string)
        (else (or (find file-exists?
                        (map (lambda (path-prefix) (path-append path-prefix string))
                             (c-search-path)))
                  (scm-error 'cpp-error "resolve-h-file"
                             "Can't find file: <~a>"
                             (list string) #f)))))

;; #include "myheader.h"
(define (resolve-q-file string)
  (typecheck string string?)

  (cond ((file-exists? string) string)
        ;; This should always be a fallback (6.10.2, p. 3)
        (else (resolve-h-file string))))


(define (resolve-header environment tokens)
  (typecheck environment cpp-environment?)
  ;; (typecheck tokens (list-of lexeme?))

  (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 retry% ((%first-time #t) (tokens tokens))
      (let ((retry (lambda () (retry% #f ((unval resolve-token-stream 1) environment tokens)))))
        (cond ((null? tokens) (err "Invalid #include line"))
              ((h-string-token? (car tokens))
               => (lambda (str)
                    (unless (null? (drop-whitespace (cdr tokens)))
                      (err "Unexpected tokens after #include <>"))
                    (resolve-h-file str)))
              ((q-string-token? (car tokens))
               => (lambda (str)
                    (unless (null? (drop-whitespace (cdr tokens)))
                      (err "Unexpected tokens after #include \"\""))
                    (resolve-q-file str)))
              (else
               (unless %first-time (err "Failed parsing tokens"))
               (retry)))))))



;; environment, tokens → environment
(define (handle-line-directive environment tokens*)
  (typecheck environment cpp-environment?)
  ;; (typecheck tokens* (list-of lexeme?))

  (let ((err (lambda () (scm-error 'cpp-error "handle-line-directive"
                              "Invalid line directive: ~s"
                              (list tokens*) #f))))
    (let retry% ((%first-time #t) (tokens tokens*))
      (let ((retry (lambda () (retry% #f ((unval resolve-token-stream 1) environment tokens)))))
        (cond ((null? tokens))
              ((pp-number? (car tokens))
               => (lambda (line)
                    (let ((line (string->number line))
                          (remaining (drop-whitespace (cdr tokens))))
                      (cond ((null? remaining) (set environment current-line (1- line)))
                            ((string-token? (car remaining))
                             (lambda (a . _) a)
                             => (lambda (encoding . fragments)
                                  (-> environment
                                      (set current-line (1- line))
                                      ;; TODO properly join string
                                      (set current-file (car fragments)))))
                            ;; no newlines in #line
                            (%first-time (retry))
                            (else (err))))))
              ;; no newlines in #line
              (%first-time (retry))
              (else (err)))))))


;; environment, tokens → environment
(define (handle-define-directive environment tokens)
  (typecheck environment cpp-environment?)
  ;; (typecheck tokens (list-of lexeme?))

  (let ((identifier (identifier-token? (car tokens)))
        (tail (cdr tokens)))
    (-> environment
        bump-line
        (add-identifier
         (cond ((and (not (null? tail))
                     (left-parenthesis-token? (car tail)))
                ;; function like macro
                (let ((variadic? identifiers replacement-list
                                 (parse-identifier-list tail)))
                  (function-macro
                   identifier: identifier
                   variadic?: variadic?
                   identifier-list: identifiers
                   ;; surrounding whitespace is not part of the replacement list
                   ;; (6.10.3 p.7)
                   body: (drop-whitespace-both replacement-list))))
               (else (object-macro
                      identifier: identifier
                      body: (drop-whitespace-both tail))))))))


(define (handle-include-directive environment body)
  ;; TODO change to store source location in lexemes
  ;; and rewrite the following to
  ;; (loop environment
  ;;       (append (-> path read-file tokenize) remaining-tokens))
  ;; TODO and then transfer these source locations when we move
  ;; to "real" tokens (c to-token)
  (let ((path (resolve-header environment body)))
    (values
     ;; same hack as at start of loop
     (-> environment (enter-file path) (bump-line -1))
     (->> path read-file tokenize (append (lex "\n"))))) )


;; enter if depending on the status of thunk
(define (enter-depending env thunk)
  (enter-into-if env
                 (if (thunk)
                     (if-status active)
                     (if-status inactive))))

;; is the next token defined in the environment?
(define (next-in-environment env body)
  (in-environment? env (identifier-token? (car body))))

(define (handle-ifdef-directive env body)
  (enter-depending env (lambda () (next-in-environment env body))))

(define (handle-ifndef-directive env body)
  (enter-depending env (lambda () (not (next-in-environment env body)))))

(define (handle-error-directive environment body)
  (throw 'cpp-error-directive
         (format #f "#error ~a" (unlex body))
         (format #f "at ~s:~a"
                 (current-file environment)
                 (current-line environment))
         (format #f "included as ~s"
                 (cpp-file-stack environment))))



;; handles a line starting with a hash (#)
;; line-tokens are the cpp-tokens between hash and EOL
;; remaining tokens are the remaining tokens in the stream
;; loop is (almost) a continuation
(define (handle-preprocessing-directive environment line-tokens remaining-tokens loop)
  (if  (null? line-tokens)
       ;; null directive
       (loop environment remaining-tokens)

       (let ((directive (string->symbol (identifier-token? (car line-tokens)))))
         (cond
          ((in-conditional/inactive-inactive? environment)
           (-> environment
               ((case directive
                  ((ifdef ifndef if)  (lambda (e) (enter-into-if e (if-status inactive-inactive))))
                  ((endif)            leave-if)
                  ((elif else)        identity)
                  (else identity)))
               (loop remaining-tokens)))

          ((in-conditional/inactive? environment)
           (-> environment
               ((case directive
                  ((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
                                 (handle-if-directive (drop-whitespace (cdr line-tokens))))))
                  (else identity)))
               (loop remaining-tokens)))

          ;; From here on we are not in a comment block
          (else
           (let ((body (drop-whitespace (cdr line-tokens))))
             (if (eq? 'include directive)
                 ;; include is special since it returns a token stream
                 (let ((environment included-tokens
                                    (call-with-values
                                        (lambda () (handle-include-directive environment body))
                                      loop)))
                   (on-snd (append included-tokens
                                   (abort* (loop (leave-file environment)
                                                 remaining-tokens)))))

                 (let ((op (case directive   ; (environment, list token) → environment
                             ((if) handle-if-directive)
                             ((ifdef) handle-ifdef-directive)
                             ((ifndef) handle-ifndef-directive)
                             ;; NOTE possibly validate that body is empty for endif and else
                             ((endif)      (lambda (env _) (leave-if env)))
                             ((else elif)  (lambda (env _) (transition-to-if env (if-status inactive-inactive))))
                             ((define) handle-define-directive)
                             ((undef) (lambda (env body) (remove-identifier env (identifier-token? (car body)))))
                             ((line) handle-line-directive)
                             ((error) handle-error-directive)
                             ((pragma) handle-pragma)
                             (else (throw 'propagate
                                          "Unknown preprocessing directive: ~s"
                                          (list (unlex line-tokens)))))))
                   (-> environment
                       (op body)
                       (loop remaining-tokens))))))))))



;; Handles an entire stream (a whole file) of cpp-tokens
;; environment, tokens -> environment, tokens
(define (handle-preprocessing-tokens environment tokens)
  ;; Prepend a newline to ensure that the token stream always starts with a
  ;; newline (otherwise guaranteed by how we loop). Decrement line-counter
  ;; by one to compensate.
  (let loop ((environment (bump-line environment -1))
             (tokens (append (lex "\n") tokens)))

    (define (err fmt . args)
      (scm-error 'cpp-error "handle-preprocessing-tokens"
                 (string-append "~a:~a " fmt)
                 (cons* (current-file environment)
                        (current-line environment)
                        args)
                 #f))

    (catch 'cpp-error
      (lambda ()
       (cond ((null? tokens) (values environment '()))
             ((newline-token? (car tokens))
              (let ((environment (bump-line environment))
                    (tokens* (drop-whitespace (cdr tokens))))
                (cond ((null? tokens*) (values environment '()))
                      ((equal? "#" (punctuator-token? (car tokens*)))
                       (let* ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens*)))
                              ;; drop whitespace after newline check to not "eat" the next newline token
                              (line-tokens (drop-whitespace line-tokens)))
                         (catch 'propagate
                           (lambda () (handle-preprocessing-directive environment line-tokens remaining-tokens loop))
                           (lambda (_ . args) (apply err args)))))

                      ;; Line is not a pre-processing directive
                      (else (let* ((preceding-tokens remaining-tokens (tokens-until-cpp-directive (cdr tokens)))
                                   (env* resolved-tokens (if (in-conditional/inactive? environment)
                                                             (values environment '())
                                                             (resolve-token-stream environment preceding-tokens))))
                              (on-snd (append resolved-tokens
                                              ;; The initial newline is presreved here, for better output,
                                              ;; and to keep at least one whitespace token when there was one previously.
                                              ;; possibly also keep a newline for line-directives.
                                              (unless (null? remaining-tokens) (lex "\n"))
                                              (abort* (loop env* remaining-tokens)))))))))

             (else (err "Unexpected middle of line, (near ~s)"
                        (unlex tokens)))))
      (lambda (_ proc fmt args rest)
        (with-output-to-port (current-error-port)
          (lambda ()
            (format #t "cpp error in ~a~%" proc)
            (format #t "~a:~a: error: ~?~%"
                    (current-file environment)
                    (current-line environment)
                    fmt args)
            (let ((trace (drop-right ((@@ (c cpp-environment) cpp-file-stack) environment) 1)))
              (unless (null? trace)
                (for-each (lambda (file)
                            (format #t "Included from ~a:~a~%"
                                    (car file) (cdr file)))
                          (cdr trace))))
            ;; re-throw
            (scm-error 'cpp-error proc fmt args rest)
            ))))))





(define* (make-default-environment key: (now (localtime (current-time))))
  (-> (string-append
       "#define __STDC__ 1\n"
       "#define __STDC_HOSTED__ 1\n"
       "#define __STDC_VERSION__ 201112L\n"
       ;; TODO format should always be in
       ;; english, and not tranlated
       (format #f "#define __DATE__ \"~a\"~%" (strftime "%b %_d %Y" now))
       (format #f "#define __TIME__ \"~a\"~%" (strftime "%H:%M:%S"  now)))
      (preprocess-string (make-environment))
      (value-ref 0)))


;; partial pre-process, useful for running just the preprocessor interactivly
(define* (cpp str optional: (environment (make-default-environment)))
  (->> str
;;; Phase 1-3
       tokenize
;;; 4. Execution of preprocessing directives, all preprocessing directives are then deleted
       (handle-preprocessing-tokens environment)))

(define* (preprocess-string str optional: (environment (make-default-environment)))
  (->> (cpp str environment)
       abort*
;;; 5. (something with character sets)
;;; 7. Whitespace tokens are discarded, each preprocessing token is converted into a token
       (remove whitespace-token?)
;;; 6. concatenation of string literals
;;; Should be done before removal of whitespace, but I don't understand why
       merge-string-literals
       on-snd))