diff options
Diffstat (limited to '')
-rw-r--r-- | module/c/cpp-types.scm | 24 | ||||
-rw-r--r-- | module/c/preprocessor2.scm | 41 | ||||
-rw-r--r-- | tests/test/cpp/preprocessor2.scm | 20 |
3 files changed, 64 insertions, 21 deletions
diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm index 64bf6a7b..e21a8f0c 100644 --- a/module/c/cpp-types.scm +++ b/module/c/cpp-types.scm @@ -6,7 +6,11 @@ comment-token? preprocessing-token? newline-token? - identifier-token?)) + identifier-token? + punctuator-token? + number-token? + string-token? + )) (define (whitespace-token? x) (eq? 'whitespace (lexeme-type x))) @@ -26,3 +30,21 @@ (match (lexeme-body token) (`(identifier ,id) id) (_ #f)))) + +(define (punctuator-token? token) + (and (preprocessing-token? token) + (match (lexeme-body token) + (`(punctuator ,x) x) + (_ #f)))) + +(define (number-token? token) + (and (preprocessing-token? token) + (match (lexeme-body token) + (`(pp-number ,x) x) + (_ #f)))) + +(define (string-token? token) + (and (preprocessing-token? token) + (match (lexeme-body token) + (`(string-literal ,x) x) + (_ #f)))) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 2d2a9530..a6710314 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -464,27 +464,28 @@ (typecheck environment cpp-environment?) (typecheck tokens* (list-of lexeme?)) - ;; TODO rewrite without match (let loop ((%first-time #t) (tokens tokens*)) - (match tokens - (`((preprocessing-token (pp-number ,line)) (whitespace ,_) ... rest ...) - (match rest - (`((preprocessing-token (string-literal ,file)) (whitespace ,_) ...) - (-> environment - (set current-line line) - (set current-file file))) - (`((whitespace ,_) ...) - (set environment current-line line)) - (_ (unless %first-time - (scm-error 'cpp-error "handle-line-directive" - "Invalid line directive: ~s" - (list tokens*) #f)) - (loop #f (resolve-token-stream environment tokens))))) - (_ (unless %first-time - (scm-error 'cpp-error "handle-line-directive" - "Invalid line directive: ~s" - (list tokens*) #f)) - (loop #f (resolve-token-stream environment tokens)))))) + (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 line)) + ((string-token? (car remaining)) + => (lambda (file) + (-> environment + (set current-line line) + (set current-file file)))) + (%first-time + (loop #f (resolve-token-stream environment tokens))) + (else (scm-error 'cpp-error "handle-line-directive" + "Invalid line directive: ~s" + (list tokens*) #f) + )))))) + (%first-time (loop #f (resolve-token-stream environment tokens))) + (else (scm-error 'cpp-error "handle-line-directive" + "Invalid line directive: ~s" + (list tokens*) #f))))) ;; environment, tokens → environment (define (resolve-define environment tokens) diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index e2ff0a17..9e11bb04 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -545,6 +545,26 @@ f(10) +(define cpp-file-stack (@@ (c cpp-environment) cpp-file-stack)) +(define handle-line-directive (@@ (c preprocessor2) handle-line-directive)) + +(test-group "Line directive" + (let ((e (make-environment))) + (test-equal "#line <number>" + '(("*outside*" . 10)) + (cpp-file-stack (handle-line-directive e (lex "10")))) + (test-equal "#line <line> <file>" + '(("file" . 10)) + (cpp-file-stack (handle-line-directive e (lex "10 \"file\"")))) + + (test-equal "#line <macro>" + '(("*outside*" . 10)) + (cpp-file-stack + (handle-line-directive + (resolve-define e (lex "x 10")) + (lex "x")))))) + + ;; resolve-h-file ;; resolve-q-file ;; handle-pragma |