diff options
Diffstat (limited to 'module/c/preprocessor2.scm')
| -rw-r--r-- | module/c/preprocessor2.scm | 155 |
1 files changed, 86 insertions, 69 deletions
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 4678ded7..d7bf3b64 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -9,7 +9,7 @@ :select (function-like-macro variadic? identifier-list)) :use-module ((c cpp-environment object-like-macro) :select (object-like-macro object-like-macro?)) :use-module ((c cpp-environment internal-macro) :select (internal-macro)) - :use-module ((hnh util) :select (-> intersperse aif swap unless)) + :use-module ((hnh util) :select (-> intersperse aif swap unless unval)) :use-module ((hnh util lens) :select (set modify cdr*)) :use-module (hnh util path) :use-module (hnh util type) @@ -19,7 +19,8 @@ :use-module (c unlex) :use-module (c cpp-types) :use-module (c cpp-util) - :export (defined-macro)) + :use-module (ice-9 control) + :export (defined-macro _Pragma-macro)) (define-syntax-rule (alist-of variable key-type value-type) (build-validator-body variable (list-of (pair-of key-type value-type)))) @@ -34,6 +35,21 @@ (define (comma-token? token) (equal? "," (punctuator-token? token))) (define (ellipsis-token? token) (equal? "..." (punctuator-token? token))) + +(define-syntax-rule (abort* form) + (call-with-values (lambda () form) abort)) + +(define-syntax-rule (on-fst form) + (% form + (lambda (prompt fst . rest) + (apply values (prompt fst) rest)))) + +(define-syntax-rule (on-snd form) + (% form + (lambda (prompt fst snd . rest) + (apply values fst (prompt snd) rest)))) + + ;; parameters is a lexeme list, as returned by parse-parameter-list (define (build-parameter-map macro parameters) (typecheck macro cpp-macro?) @@ -157,7 +173,9 @@ (if (or (concat-token? last) (next-token-matches? concat-token? tokens)) replacement - (resolve-token-stream environment replacement once?: #t)) + ;; 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))) @@ -190,13 +208,6 @@ (let ((name (macro-identifier macro))) (cond ((object-macro? macro) - ;; #define f(a) f(x * (a)) - ;; #define w 0,1 - ;; #define m(a) a(w) - ;; m(f) - ;; ⇒ f(0,1) - ;; instead of expected - ;; f(2 * (0,1)) (values environment (append (fold (swap mark-noexpand) (expand## (macro-body macro)) (cons name noexpand-list)) @@ -211,17 +222,23 @@ (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 (lex (macro-identifier macro)) (macro-identifier macro)) remaining-tokens)))) ((internal-macro? macro) (if (next-token-matches? left-parenthesis-token? remaining-tokens) (let ((containing remaining newlines (parse-parameter-list remaining-tokens))) - (values (bump-line environment newlines) - (append (fold (swap mark-noexpand) - ((macro-body macro) environment containing) - (cons name noexpand-list)) - remaining))) + (let ((env* tokens* ((macro-body macro) environment containing))) + (values (bump-line env* newlines) + (append (fold (swap mark-noexpand) + tokens* + (cons name noexpand-list)) + remaining)))) (values environment (append (mark-noexpand (lex (macro-identifier macro)) (macro-identifier macro)) remaining-tokens)))) @@ -256,13 +273,6 @@ -(define (next-token-matches? predicate tokens) - (let ((tokens (drop-whitespace tokens))) - (if (null? tokens) - #f - (predicate (car tokens))))) - - ;; returns three values: ;; - a list of tokens where each is a parameter to the function like macro ;; - the remaining tokenstream @@ -356,17 +366,24 @@ (not null?))) (aif (identifier-token? (car (list-ref arguments 0))) (let ((in-env (boolean->c-boolean (in-environment? environment it)))) - (lex (number->string in-env))) + (values environment (lex (number->string in-env)))) (scm-error 'cpp-error "defined" "Invalid parameter list to `defined': ~s" (list arguments) #f))))) -;; (lex "STDC FP_CONTRACT ON") -;; (#<<lexeme> type: preprocessing-token body: (identifier "STDC") noexpand: ()> -;; #<<lexeme> type: whitespace body: " " noexpand: ()> -;; #<<lexeme> type: preprocessing-token body: (identifier "FP_CONTRACT") noexpand: ()> -;; #<<lexeme> type: whitespace body: " " noexpand: ()> -;; #<<lexeme> type: preprocessing-token body: (identifier "ON") noexpand: ()>) +(define _Pragma-macro + (internal-macro + identifier: "_Pragma" + body: (lambda (environment arguments) + (typecheck arguments (and (list-of (list-of lexeme?)) + (not null?))) + (aif (string-token? (caar arguments)) + (values (handle-pragma environment (lex it)) '()) + (scm-error 'cpp-pragma-error "_Pragma" + "Invalid argument to _Pragma: ~s" + (list (car arguments)) #f))))) + + ;; environment, tokens → environment (define (handle-pragma environment tokens) @@ -395,13 +412,6 @@ environment)))) -;; TODO -;; (define _Pragma-macro -;; (internal-macro -;; identifier: "_Pragma" -;; body: (lambda (environment tokens) -;; ))) - (define (resolve-constant-expression tokens) (typecheck tokens (list-of lexeme?)) 'TODO @@ -424,26 +434,28 @@ ;; 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?)) ;; (pprint-environment environment) ;; (format (current-error-port) "~a~%~%" (unlex tokens)) (let loop ((environment environment) (tokens tokens)) - (cond ((null? tokens) '()) - ((car tokens) - (lambda (x) (and (identifier-token? x) - (not (marked-noexpand? x)))) - => (lambda (token) - (call-with-values - (lambda () (maybe-extend-identifier environment - (identifier-token? token) - (lexeme-noexpand token) - (cdr tokens))) - ;; Here is the after expansion - (if once? (lambda (_ t) t) loop)))) - (else (cons (car tokens) - (loop environment (cdr 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)))) + (call-with-values + (lambda () (maybe-extend-identifier environment + (identifier-token? (car tokens)) + (lexeme-noexpand (car tokens)) + (cdr tokens))) + ;; Here is the after expansion + (if once? values loop))) + (else (on-snd (cons (car tokens) (abort* (loop environment (cdr tokens))))))))) + + ;; returns a new environment ;; handle body of #if @@ -453,7 +465,8 @@ (typecheck tokens (list-of lexeme?)) (-> (extend-environment environment defined-macro) - (resolve-token-stream tokens) + ;; no newlines in #if line + ((unval resolve-token-stream 1) tokens) resolve-constant-expression c-boolean->boolean (if (enter-active-if environment) @@ -503,7 +516,8 @@ (-> str resolve-q-file read-file tokenize)))) (else (unless %first-time (err "Failed parsing tokens")) - (loop #f (resolve-token-stream environment tokens))))))) + ;; No newlines in #include + (loop #f ((unval resolve-token-stream 1) environment tokens))))))) ;; environment, tokens → environment (define (handle-line-directive environment tokens*) @@ -517,17 +531,19 @@ (cond ((null? tokens)) ((number-token? (car tokens)) => (lambda (line) - (let ((line (string->number line))) - (let ((remaining (drop-whitespace (cdr tokens)))) - (cond ((null? remaining) (set environment current-line (1- line))) - ((string-token? (car remaining)) - => (lambda (file) - (-> environment - (set current-line (1- line)) - (set current-file file)))) - (%first-time (loop #f (resolve-token-stream environment tokens))) - (else (err))))))) - (%first-time (loop #f (resolve-token-stream environment tokens))) + (let ((line (string->number line)) + (remaining (drop-whitespace (cdr tokens)))) + (cond ((null? remaining) (set environment current-line (1- line))) + ((string-token? (car remaining)) + => (lambda (file) + (-> environment + (set current-line (1- line)) + (set current-file file)))) + ;; no newlines in #line + (%first-time (loop #f ((unval resolve-token-stream 1) environment tokens))) + (else (err)))))) + ;; no newlines in #line + (%first-time (loop #f ((unval resolve-token-stream 1) environment tokens))) (else (err)))))) ;; environment, tokens → environment @@ -634,15 +650,16 @@ remaining-tokens))))))))) ;; Line is not a pre-processing directive - (else (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens)))) - (let ((env* tokens* (loop environment remaining-tokens))) - (values env* - (append (unless (in-comment-block? environment) - (resolve-token-stream environment line-tokens)) + (else (let ((preceding-tokens remaining-tokens (tokens-until-cpp-directive (cdr tokens)))) + (let* ((env* resolved-tokens (if (in-comment-block? 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. - (append (unless (null? remaining-tokens) (lex "\n")) tokens*))))))))) + (unless (null? remaining-tokens) (lex "\n")) + (abort* (loop env* remaining-tokens)))))))))) (else (err "Unexpected middle of line"))))) |