diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-11 20:31:58 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-11 20:31:58 +0200 |
commit | ad0440b16d7e2694ae01df08710f24936b57ec99 (patch) | |
tree | e21b066e4b7d6dca9efe57ac01d6e083a87b7737 /module/c | |
parent | Cleanup + fix __LINE__. (diff) | |
download | calp-ad0440b16d7e2694ae01df08710f24936b57ec99.tar.gz calp-ad0440b16d7e2694ae01df08710f24936b57ec99.tar.xz |
work
Diffstat (limited to '')
-rw-r--r-- | module/c/cpp-environment.scm | 34 | ||||
-rw-r--r-- | module/c/cpp-types.scm | 13 | ||||
-rw-r--r-- | module/c/preprocessor2.scm | 173 |
3 files changed, 131 insertions, 89 deletions
diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm index 2a943496..913e905e 100644 --- a/module/c/cpp-environment.scm +++ b/module/c/cpp-environment.scm @@ -35,13 +35,18 @@ cpp-environment cpp-environment? - cpp-if-status cpp-variables + cpp-if-status + ;; cpp-variables + cpp-file-stack make-environment in-environment? remove-identifier! add-identifier! get-identifier extend-environment disjoin-macro + + pprint-environment + pprint-macro )) (define (macro-identifier x) @@ -85,6 +90,7 @@ (define-type (cpp-environment) (cpp-if-status type: (list-of (memv '(outside active-if inactive-if))) default: '(outside)) + ;; not exported since type signatures don't hold inside the hash table (cpp-variables type: hash-table? default: (make-hash-table)) (cpp-file-stack type: (and (not null?) (list-of (pair-of string? exact-integer?))) @@ -172,3 +178,29 @@ (let ((env (clone-environment environment))) (remove-identifier! env name) env)) + + + +(define* (pprint-environment environment optional: (port (current-error-port))) + (display "== Environment ==\n") + (hash-for-each (lambda (key macro) + (pprint-macro macro port) + (newline port)) + (cpp-variables environment))) + +(define* (pprint-macro x optional: (p (current-output-port))) + (cond ((internal-macro? x) + (format p "/* ~a INTERNAL MACRO */" + (macro-identifier x))) + ((object-macro? x) + (format p "#define ~a ~a" + (macro-identifier x) + (unlex (macro-body x)))) + ((function-macro? x) + (format p "#define ~a(~a) ~a" + (macro-identifier x) + (string-join (append (macro-identifier-list x) + (if (variadic? x) + '("...") '())) + "," 'infix) + (unlex (macro-body x)))))) diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm index 1a7387f5..e5e73d32 100644 --- a/module/c/cpp-types.scm +++ b/module/c/cpp-types.scm @@ -52,3 +52,16 @@ (match (lexeme-body token) (`(string-literal ,x) x) (_ #f)))) + + +(define (h-string-token? token) + (and (preprocessing-token? token) + (match (lexeme-body token) + (`(h-string ,x) x) + (_ #f)))) + +(define (q-string-token? token) + (and (preprocessing-token? token) + (match (lexeme-body token) + (`(q-string ,x) x) + (_ #f)))) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 720a6ffc..71c2a09e 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -21,7 +21,7 @@ :use-module (c cpp-util) :use-module ((c zipper) :select (list-zipper left focused right zip-find-right list->zipper zipper->list)) - :export ()) + :export (defined-macro)) (define-syntax-rule (alist-of variable key-type value-type) (build-validator-body variable (list-of (pair-of key-type value-type)))) @@ -147,9 +147,11 @@ (define parameter-map (build-parameter-map macro parameters)) - (define stringify-resolved (expand# macro parameter-map)) (remove placemaker-token? - (expand## (resolve-cpp-variables stringify-resolved parameter-map))))) + (-> macro + (expand# parameter-map) + (resolve-cpp-variables parameter-map) + expand##)))) @@ -322,20 +324,38 @@ "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: ()>) + ;; environment, tokens → environment (define (handle-pragma environment tokens) - ;; TODO rewrite without match - (match tokens - (`((preprocessing-token (identifier "STDC")) (whitespace ,_) ... - (preprocessing-token (identifier ,identifier)) (whitespace ,_) ... - (preprocessing-token (identifier ,on-off-switch)) (whitespace ,_) ...) - ;; TODO actually do something with the pragmas (probably just store them in the environment) - (format (current-error-port) - "#Pragma STDC ~a ~a" identifier on-off-switch) - environment) - (_ (format (current-error-port) - "Non-standard #Pragma: ~s~%" tokens) - environment))) + (typecheck environment cpp-environment?) + (typecheck tokens (list-of lexeme?)) + + (let ((err (lambda () + (scm-error 'cpp-pragma-error "handle-pragma" + "Invalid pragma directive: ~a" + (list (unlex tokens)) #f)))) + + (cond ((null? tokens) (err)) + ((equal? "STDC" (identifier-token? (car tokens))) + (call-with-values (lambda () (apply values (filter identifier-token? (cdr tokens)))) + (case-lambda ((identifier on-off-switch) + (format (current-output-port) + "#Pragma STDC ~a ~a" + (unlex (list identifier)) + (unlex (list on-off-switch))) + environment) + (_ (err))))) + (else + (format (current-output-port) + "Non-standard #Pragma: ~s~%" + (unlex (list tokens))) + environment)))) ;; TODO @@ -345,35 +365,12 @@ ;; body: (lambda (environment tokens) ;; ))) -;; TODO (define (resolve-constant-expression tokens) (typecheck tokens (list-of lexeme?)) 'TODO ) -(define* (pprint-macro x optional: (p (current-output-port))) - (cond ((internal-macro? x) - (format p "/* ~a INTERNAL MACRO */" - (macro-identifier x))) - ((object-macro? x) - (format p "#define ~a ~a" - (macro-identifier x) - (unlex (macro-body x)))) - ((function-macro? x) - (format p "#define ~a(~a) ~a" - (macro-identifier x) - (string-join (append (macro-identifier-list x) - (if (variadic? x) - '("...") '())) - "," 'infix) - (unlex (macro-body x)))))) - -(define* (pprint-environment environment optional: (port (current-error-port))) - (display "== Environment ==\n") - (hash-for-each (lambda (key macro) - (pprint-macro macro port) - (newline port)) - (cpp-variables environment))) + (define (mark-noexpand1 token name) (modify token lexeme-noexpand xcons name)) @@ -442,59 +439,57 @@ remaining-tokens))))) (define (resolve-and-include-header environment tokens) - (define (err msg . args) - (scm-error 'cpp-error "resolve-and-include-header" - (string-append msg ", tokens: ~s") - (append args (list (unlex tokens))) #f)) - (typecheck environment cpp-environment?) (typecheck tokens (list-of lexeme?)) - (let loop ((%first-time #t) (tokens tokens)) - (cond ((null? tokens) '()) - ((h-string? (car tokens)) - (unless (null? (remove-whitespace (cdr tokens))) - (err "Unexpected tokens after #include <>")) - (handle-preprocessing-tokens - environment - (-> str resolve-h-file read-file tokenize))) - ((q-string? (car tokens)) - (unless (null? (remove-whitespace (cdr tokens))) - (err "Unexpected tokens after #include \"\"")) - (handle-preprocessing-tokens - environment - (-> str resolve-q-file read-file tokenize))) - (else - (unless %first-time (err "Failed parsing tokens")) - (loop #f (resolve-token-stream environment tokens)))))) + (let ((err (lambda (msg . args) + (scm-error 'cpp-error "resolve-and-include-header" + (string-append msg ", tokens: ~s") + (append args (list (unlex tokens))) #f)))) + (let loop ((%first-time #t) (tokens tokens)) + (cond ((null? tokens) '()) + ((h-string-token? (car tokens)) + => (lambda (str) + (unless (null? (remove-whitespace (cdr tokens))) + (err "Unexpected tokens after #include <>")) + (handle-preprocessing-tokens + environment + (-> str resolve-h-file read-file tokenize)))) + ((q-string-token? (car tokens)) + => (lambda (str) + (unless (null? (remove-whitespace (cdr tokens))) + (err "Unexpected tokens after #include \"\"")) + (handle-preprocessing-tokens + environment + (-> str resolve-q-file read-file tokenize)))) + (else + (unless %first-time (err "Failed parsing tokens")) + (loop #f (resolve-token-stream environment tokens))))))) ;; environment, tokens → environment (define (handle-line-directive environment tokens*) (typecheck environment cpp-environment?) (typecheck tokens* (list-of lexeme?)) - (let loop ((%first-time #t) (tokens 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))))) + (let ((err (lambda () (scm-error 'cpp-error "handle-line-directive" + "Invalid line directive: ~s" + (list tokens*) #f)))) + (let loop ((%first-time #t) (tokens 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 (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))) + (else (err)))))) ;; environment, tokens → environment (define (resolve-define environment tokens) @@ -545,11 +540,11 @@ args) #f)) - (cond ((null? tokens) '()) + (cond ((null? tokens) (values environment '())) ((newline-token? (car tokens)) (let ((environment (bump-line environment)) (tokens* (drop-whitespace (cdr tokens)))) - (cond ((null? tokens*) '()) + (cond ((null? tokens*) (values environment '())) ((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 @@ -602,9 +597,11 @@ ;; Line is not a pre-processing directive (else (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens)))) - (append (unless (in-comment-block? environment) - (resolve-token-stream environment line-tokens)) - (loop environment remaining-tokens))))))) + (let ((env* tokens* (loop environment remaining-tokens))) + (values env* + (append (unless (in-comment-block? environment) + (resolve-token-stream environment line-tokens)) + tokens*)))))))) (else (err "Unexpected middle of line"))))) |