From a66525db9c4c07c8cff6f927bd930f62f7d1ccdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 22 Jul 2022 17:21:23 +0200 Subject: Handle nested #if trees. --- module/c/cpp-environment.scm | 100 ++++++++++++++++++++++++++++++++++--------- module/c/eval-basic.scm | 4 +- module/c/preprocessor2.scm | 93 ++++++++++++++++++++++++---------------- 3 files changed, 137 insertions(+), 60 deletions(-) (limited to 'module/c') 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)))))) -- cgit v1.2.3