diff options
Diffstat (limited to 'module/c/preprocessor2.scm')
| -rw-r--r-- | module/c/preprocessor2.scm | 93 |
1 files changed, 55 insertions, 38 deletions
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)))))) |