From 35b7888c9b5f217dd2911c0ba93519df36e97922 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 11 Jul 2022 01:10:19 +0200 Subject: Rewrite handel-preprocessing-tokens. --- module/c/cpp-environment.scm | 12 +++ module/c/preprocessor2.scm | 184 ++++++++++++++++++------------------------- 2 files changed, 87 insertions(+), 109 deletions(-) (limited to 'module') diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm index 2ad60b56..2a943496 100644 --- a/module/c/cpp-environment.scm +++ b/module/c/cpp-environment.scm @@ -19,7 +19,9 @@ enter-active-if enter-inactive-if + flip-flop-if leave-if + in-comment-block? enter-file leave-file @@ -97,9 +99,19 @@ (define (enter-inactive-if environment) (modify environment cpp-if-status xcons 'inactive-if)) +;; for #else +(define (flip-flop-if environment) + ((if (in-comment-block? environment) + enter-active-if + enter-inactive-if) + (leave-if environment))) + (define (leave-if environment) (modify environment cpp-if-status cdr)) +(define (in-comment-block? environment) + (eq? 'inactive-if (get environment cpp-if-status car*))) + (define (enter-file environment filename) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index a6710314..5adcd40c 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -50,18 +50,6 @@ parameters))) -;; TODO Deprecate? -(define (parameter-map->macro-list param-map) - (typecheck param-map parameter-map?) - (map (lambda (pair) - (let ((identifier (car pair)) - (body (cdr pair))) - (object-like-macro - identifier: identifier - body: body))) - param-map)) - - (define (expand# macro parameter-map) (typecheck macro macro?) (typecheck parameter-map parameter-map?) @@ -88,14 +76,19 @@ ;; Each element should be the lexeme list for that argument (typecheck parameters (list-of (list-of lexeme?))) (typecheck macro macro?) - (when (or (and (variadic? macro) - (> (length (macro-identifier-list macro)) - (length parameters))) - (and (not (variadic? macro)) - (not (= (length (macro-identifier-list macro)) - (length parameters))))) + (when (and (variadic? macro) + (> (length (macro-identifier-list macro)) + (length parameters))) + (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))) + (when (and (not (variadic? macro)) + (not (= (length (macro-identifier-list macro)) + (length parameters)))) (scm-error 'cpp-arity-error "apply-macro" - ;; TODO better error message for variadic macros "Wrong number of arguments to macro ~s, expected ~s, got ~s" (list (macro-identifier macro) (length (macro-identifier-list macro)) @@ -503,14 +496,13 @@ ;; function like macro (let ((identifier-list replacement-list - (break (lambda (token) (equal? '(punctuator ")") (lexeme-body token) )) + (break (lambda (token) (equal? '(punctuator ")") (lexeme-body token))) (cdr tail)))) (let ((variadic? identifiers (parse-identifier-list identifier-list))) (function-like-macro identifier: identifier variadic?: variadic? identifier-list: identifiers - ;; NOTE 6.10.3 states that there needs to be at least on whitespace here ;; cdr drops the end parenthesis of the definition ;; surrounding whitespace is not part of the replacement list (6.10.3 p.7) body: (drop-whitespace-both (cdr replacement-list)))))) @@ -532,94 +524,68 @@ args) #f)) - ;; TODO all of this needs to be surounded with a conditional for - ;; environmentns if status. However, ensure that each directive - ;; starts at start of line - - (match tokens - ('() '()) - ((`(whitespace "\n") `(whitespace ,_) '... '(preprocessing-token (puntuator "#")) rest ...) - ;; Line tokens are those in this line, - ;; while remaining tokens are the newline, follewed by the rest of the files tokens - (let ((line-tokens remaining-tokens (tokens-until-eol rest))) - ;; Actual tokens just removes all whitespace between "#" and "define" - (let ((actual-tokens (drop-whitespace line-tokens))) - (if (null? actual-tokens) - (loop (bump-line environment) remaining-tokens) - (match (car actual-tokens) - (`(preprocessing-token (identifier "if")) - (let ((environment (resolve-for-if environment actual-tokens))) - (loop environment remaining-tokens))) - - (`(preprocessing-token (identifier "ifdef")) - (match actual-tokens - ((`(preprocessing-token (identifier ,id)) _ ...) - (loop - ((if (in-environment? environment id) - enter-active-if enter-inactive-if) - environment) - remaining-tokens)) - (_ (err "Non identifier in ifdef: ~s" actual-tokens)))) - - (`(preprocessing-token (identifier "ifndef")) - (match actual-tokens - ((`(preprocessing-token (identifier ,id)) _ ...) - (loop - ((if (in-environment? environment id) - enter-inactive-if enter-active-if) - environment) - remaining-tokens)) - (_ (err "Non identifier in ifndef: ~s" actual-tokens)))) - - ('(preprocessing-token (identifier "else")) - ;; TODO - 'TODO - ) - - ('(preprocessing-token (identifier "elif")) - (-> environment leave-if - (resolve-for-if actual-tokens) - (loop remaining-tokens))) - - ('(preprocessing-token (identifier "endif")) - (loop (leave-if environment) remaining-tokens)) - - ('(preprocessing-token (identifier "include")) - (call-with-values - (lambda () (resolve-and-include-header environment (cdr actual-tokens))) - (lambda (environment tokens) - (loop environment (append tokens remaining-tokens))))) - - ('(preprocessing-token (identifier "define")) - (let ((env (resolve-define environment (cdr actual-tokens)))) - (loop env remaining-tokens)) - ) - - ('(preprocessing-token (identifier "undef")) - (loop (match actual-tokens - (`((preprocessing-token (identifier ,id))) - (-> environment bump-line (remove-identifier! id)))) - remaining-tokens)) - - ('(preprocessing-token (identifier "line")) - (loop (handle-line-directive environment actual-tokens) - remaining-tokens)) - - ('(preprocessing-token (identifier "error")) - ;; NOTE this is an "expected" error - (throw 'cpp-error actual-tokens)) - - ('(preprocessing-token (identifier "pragma")) - (loop (handle-pragma environment actual-tokens) - remaining-tokens))))))) - - ((`(preprocessing-token (identifier ,id)) rest ...) - (maybe-extend-identifier environment id rest loop)) - - (('(whitespace "\n") rest ...) - (cons '(whitespace "\n") (loop (bump-line environment) rest))) - - ((token rest ...) (cons token (loop environment rest)))))) + (define (handle-regular-line environment tokens) + (let ((line-tokens remaining-tokens (tokens-until-eol tokens))) + (if (in-comment-block? environment) + (loop (bump-line environment) remaining-tokens) + (append (resolve-token-stream environment line-tokens) + (loop (bump-line environment) remaining-tokens))))) + + + (cond ((null? tokens) '()) + ((newline-token? (car tokens)) + (let ((tokens (drop-whitespace (cdr tokens)))) + (cond ((null? tokens) '()) + ((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 + (let ((line-tokens (drop-whitespace line-tokens))) + (cond ((null? line-tokens) + (loop (bump-line environment) remaining-tokens)) + + ((in-comment-block? environment) + (case (string->symbol (identifier-token? (car line-tokens))) + ((else) (loop (bump-line (flip-flop-if environment)) remaining-tokens)) + ((endif) (loop (bump-line (leave-if environment)) remaining-tokens)) + ((elif) (loop (bump-line (resolve-for-if + (leave-if environment) + (drop-whitespace (cdr line-tokens)))) + remaining-tokens)) + (else (loop (environment remaining-tokens))))) + + ;; From here on we are not in a comment block + (else + (let ((directive (string->symbol (identifier-token? (car line-tokens)))) + (body (drop-whitespace (cdr line-tokens)))) + (if (eq? 'include directive) + ;; include is special since it returns a token stream + (call-with-values + (lambda () (resolve-and-include-header environment body)) + (lambda (environment tokens) + (loop (bump-line environment) + (append tokens remaining-tokens)))) + (let ((operation + (case directive + ((if) resolve-for-if) + ((ifdef) + (lambda (env body) + (if (in-environment? env (identifier-token? (car body))) + enter-active-if enter-inactive-if))) + ((ifndef) + (lambda (env body) + (if (in-environment? env (identifier-token? (car body))) + enter-inactive-if enter-active-if))) + ((define) resolve-define) + ((undef) (lambda (env body) (remove-identifier! env (car body)))) + ((line) handle-line-directive) + ((error) (lambda (_ body) (throw 'cpp-error body))) + ((pragma) handle-pragma) + (else (err "Unknown preprocessing directive: ~s" + (list line-tokens)))))) + (loop (bump-line (operation environment body)) + remaining-tokens))))))))) + (else (handle-regular-line environment tokens))))) + (else (handle-regular-line environment tokens))))) -- cgit v1.2.3