From ad0440b16d7e2694ae01df08710f24936b57ec99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 11 Jul 2022 20:31:58 +0200 Subject: work --- module/c/preprocessor2.scm | 173 ++++++++++++++++++++++----------------------- 1 file changed, 85 insertions(+), 88 deletions(-) (limited to 'module/c/preprocessor2.scm') 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") +;; (#< type: preprocessing-token body: (identifier "STDC") noexpand: ()> +;; #< type: whitespace body: " " noexpand: ()> +;; #< type: preprocessing-token body: (identifier "FP_CONTRACT") noexpand: ()> +;; #< type: whitespace body: " " noexpand: ()> +;; #< 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"))))) -- cgit v1.2.3