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 ++++++++++------- tests/test/cpp/cpp-environment.scm | 4 +- tests/test/cpp/preprocessor2.scm | 207 ++++++++++++++++++++++++++++++------- 5 files changed, 311 insertions(+), 97 deletions(-) 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)))))) diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm index 684c0fb5..e59940da 100644 --- a/tests/test/cpp/cpp-environment.scm +++ b/tests/test/cpp/cpp-environment.scm @@ -8,8 +8,8 @@ (let ((e (make-environment))) (test-equal '(outside) (cpp-if-status e)) - (let ((e* (enter-active-if e))) - (test-equal "Enter works" '(active-if outside) (cpp-if-status e*)) + (let ((e* (enter-into-if e (if-status active)))) + (test-equal "Enter works" '(active outside) (cpp-if-status e*)) (test-equal "Original object remainins unmodified" '(outside) (cpp-if-status e)))) diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index 7fcaaccb..4e808b8b 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -1,12 +1,14 @@ (define-module (test cpp preprocessor2) + :use-module ((srfi srfi-1) :select (remove)) :use-module (srfi srfi-64) :use-module (srfi srfi-64 util) :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-71) :use-module (srfi srfi-88) - :use-module ((hnh util) :select (-> unval)) + :use-module ((hnh util) :select (-> ->> unval swap)) :use-module ((hnh util lens) :select (set)) :use-module ((hnh util io) :select (call-with-tmpfile)) + :use-module (hnh util values) :use-module (c preprocessor2) :use-module ((c cpp-environment) :select (extend-environment @@ -35,7 +37,7 @@ ) ) :use-module ((c cpp-types) - :select (punctuator-token? identifier-token?)) + :select (punctuator-token? identifier-token? whitespace-token?)) :use-module (c lex2) ) @@ -47,8 +49,6 @@ "6.10.3.5 Scope of macro definitions" "Example 3")) -;; TODO # if (and # elif) aren't yet implemented -;; (test-skip (test-match-group "Conditionals" "if")) (define apply-macro (@@ (c preprocessor2) apply-macro)) (define build-parameter-map (@@ (c preprocessor2) build-parameter-map)) @@ -82,13 +82,22 @@ (let ((env tokens (handle-preprocessing-tokens env (tokenize str)))) (drop-whitespace-both (remove-noexpand tokens)))) - (define (call-with-tmp-header string proc) - (proc - (call-with-tmpfile - (lambda (port filename) - (display string port) - filename) - tmpl: "/tmp/headerfile-XXXXXXX"))) +(define (make-runner string) + (lambda (rest) + (->> (tokenize string) + (append (tokenize rest)) + (handle-preprocessing-tokens (make-environment)) + (value-refx 1) + remove-noexpand + (remove whitespace-token?)))) + +(define (call-with-tmp-header string proc) + (proc + (call-with-tmpfile + (lambda (port filename) + (display string port) + filename) + tmpl: "/tmp/headerfile-XXXXXXX"))) @@ -666,7 +675,11 @@ X (call-with-tmp-header "__LINE__" (lambda (path) (test-equal "__LINE__ in other file" (lex "1") - (run (format #f "#include \"~a\"\n" path)))))) + (run (format #f "#include \"~a\"\n" path))))) + + + (test-error 'cpp-error (run "#include \n")) + ) @@ -1167,12 +1180,12 @@ c ")) (test-group "Unexpected if ends" - (test-error "#else outside if" - 'cpp-error (run "#else")) - (test-error "#endif outside if" - 'cpp-error (run "#endif")) - (test-error "#elif outside if" - 'cpp-error (run "#elif"))) + (test-error "#else outside if" + 'misc-error (run "#else")) + (test-error "#endif outside if" + 'misc-error (run "#endif")) + (test-error "#elif outside if" + 'misc-error (run "#elif"))) (test-group "if" (test-equal "Simple positive if" @@ -1205,25 +1218,48 @@ b a #elif 1 b +#else +c +#endif")) + + ;; undefined indentifiers expand to 0 + (test-equal "If with undefined identifier" + (lex "a") + (run " +#if X == 0 +a +#else +b +#endif +")) + + ;; null-defined identifiers expand to nothing, leaving an invalid equals form + (test-error "If with null-defined identifier" + 'cpp-error + (run " +#define X +#if X == 0 +a #endif")) + ;; Note that defined is automatically added to the environment when ;; evaluating #if. - (test-equal "#if with defined" - (lex "a") - (run " + (test-group "defined" + (test-equal "#if with defined" + (lex "a") + (run " #define X #if defined(X) a #else b -#endif") - ) +#endif")) - (test-equal "#if with negative defined" - (lex "b") - (run " + (test-equal "#if with negative defined" + (lex "b") + (run " #if defined(X) a #else @@ -1231,23 +1267,124 @@ b #endif")) - (test-group "defined without parenthesis" - (test-equal "negative" - (lex "b") - (run "#if defined X + (test-group "defined without parenthesis" + (test-equal "negative" + (lex "b") + (run "#if defined X a #else b #endif")) - (test-equal "positive" - (lex "a") - (run "#define X + (test-equal "positive" + (lex "a") + (run "#define X #if defined X a #else b -#endif"))) +#endif")))) + + + (test-group "Advanced if forms" + (let ((run (make-runner " +#if defined X + #if defined Y + #if defined Z + XYZ + #else + XYz + #endif + #elif defined Z + XyZ + #else + Xyz + #endif +#elif defined Y + #if defined Z + xYZ + #else + xYz + #endif +#elif defined Z + xyZ +#else + xyz +#endif +"))) + + ;; The above expression expands to "xyz", where the letter corresponding + ;; to the defined macros should be uppercase. + + (test-equal "xyz" + (lex "xyz") (run "")) + (test-equal "xyZ" + (lex "xyZ") (run "#define Z")) + (test-equal "xYz" + (lex "xYz") (run "#define Y")) + (test-equal "xYZ" + (lex "xYZ") (run "#define Y\n#define Z")) + (test-equal "Xyz" + (lex "Xyz") (run "#define X")) + (test-equal "XyZ" + (lex "XyZ") (run "#define X\n#define Z")) + (test-equal "XYz" + (lex "XYz") (run "#define X\n#define Y")) + (test-equal "XYZ" + (lex "XYZ") (run "#define X\n#define Y\n#define Z")))) + + (test-group "Needlesly complicated if tree" + ;; Structure borrowed from features-time64.h + (let ((run (make-runner " +#if defined X +# if X == 64 +# if ! defined (Z) || Z != 64 + a +# elif Y == 32 + b +# else + f +# endif +# elif X == 32 +# if Y > 32 + c +# endif +# else + d +# endif +#else +e +#endif +"))) - ;; TODO test advanced constant expression + (test-equal "No variables set" + (lex "e") (run "")) + ;; (test-equal "Just X" + ;; (lex "d") + ;; (run "#define X")) + (test-equal "Bad X" + (lex "d") (run "#define X 6")) + (test-equal "Good X and Y, no Z" + (lex "a") + (run " +#define X 64 +#define Y 32")) + (test-equal "Good X and Z != 64" + (lex "a") + (run " +#define X 64 +#define Z 63")) + (test-equal "Good X and Z == 64" + (lex "f") + (run " +#define X 64 +#define Z 64")) + (test-equal "Good (alt) X, and good Y" + (lex "c") + (run " +#define X 32 +#define Y 40")) + )) )) + + -- cgit v1.2.3