From d1b87ade120f8d01d86ed6e5c9661f36f78751b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 11 Jul 2022 18:34:48 +0200 Subject: Fix most of expand##. --- module/c/preprocessor2.scm | 144 ++++++++++++++++++++++++++++++++++++--------- 1 file changed, 117 insertions(+), 27 deletions(-) (limited to 'module/c/preprocessor2.scm') diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 5adcd40c..c6410ca3 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -13,7 +13,8 @@ :use-module ((hnh util lens) :select (set modify)) :use-module (hnh util path) :use-module (hnh util type) - :use-module ((c lex2) :select (lex #|lexeme|# lexeme? lexeme-body lexeme-type lexeme-noexpand)) + :use-module (hnh util object) + :use-module ((c lex2) :select (lex placemaker lexeme? lexeme-body lexeme-noexpand)) :use-module ((c trigraph) :select (replace-trigraphs)) :use-module ((c line-fold) :select (fold-lines)) :use-module (c unlex) @@ -27,13 +28,6 @@ (define parameter-map? (of-type? (alist-of string? (list-of lexeme?)))) -;; Expand ## tokens -;; TODO -;; Tokens is the body of the macro -(define (expand## macro tokens) - (typecheck macro macro?) - (typecheck tokens (list-of lexeme?)) - tokens) ;; parameters is a lexeme list, as returned by parse-parameter-list (define (build-parameter-map macro parameters) @@ -68,6 +62,96 @@ (loop rest))))) (else (cons (car tokens) (loop (cdr tokens))))))) + +;; Tokens is the body of the macro + + + +(define-type (list-zipper) + (left type: list?) + focused + (right type: list?)) + +;; Move zipper one step to the left +(define (zip-left zipper) + (if (null? (left zipper)) + zipper + (list-zipper left: (cdr (left zipper)) + right: (cons (focused zipper) (right zipper)) + focused: (car (left zipper))))) + +;; Move zipper one step to the right +(define (zip-right zipper) + (if (null? (right zipper)) + zipper + (list-zipper left: (cons (focused zipper) (left zipper)) + right: (cdr (right zipper)) + focused: (car (right zipper))))) + +;; find first element matching predicate, going right +(define (zip-find-right predicate zipper) + (cond ((null? (right zipper)) zipper) + ((predicate (focused zipper)) zipper) + (else (zip-find-right predicate (zip-right zipper))))) + +(define (list->zipper list) + (list-zipper left: '() + focused: (car list) + right: (cdr list))) + + +(define (rezip zipper) + (if (null? (left zipper)) + zipper + (rezip (zip-left zipper)))) + +(define (zipper->list zipper) + (let ((z (rezip zipper))) + (cons (focused z) + (right z)))) + +(define (concatenate-tokens a b) + (car (lex (string-append (unlex (list a)) + (unlex (list b)))))) + +;; 6.10.3.3 +(define (expand## tokens) + (typecheck tokens (list-of lexeme?)) + + (let loop ((zipper (list->zipper tokens))) + (cond ((equal? "##" (punctuator-token? (focused zipper))) + (let ((l (drop-whitespace (left zipper))) + (r (drop-whitespace (right zipper)))) + (cond ((or (null? l) (null? r)) + (scm-error 'cpp-error "expand##" + "## can't be first or last token: ~s" + (list (unlex tokens)) #f)) + ((and (placemaker-token? (car l)) + (placemaker-token? (car r))) + (loop (list-zipper left: (cdr l) + right: (cdr r) + focused: (placemaker)))) + ((placemaker-token? (car l)) + (loop (list-zipper left: (cdr l) + right: (cdr r) + focused: (car r)))) + ((placemaker-token? (car r)) + (loop (list-zipper left: (cdr l) + right: (cdr r) + focused: (car l)))) + (else + (loop (list-zipper left: (cdr l) + right: (cdr r) + focused: (concatenate-tokens + (car l) (car r)))))))) + ((null? (right zipper)) + (zipper->list zipper)) + (else + (loop (zip-find-right + (lambda (token) (equal? "##" (punctuator-token? token))) + zipper)))))) + + ;; expand function like macro ;; parameter is a list of lexeme-lists, each "top level" element matching one ;; argument to the macro @@ -95,24 +179,29 @@ (length parameters)) (list macro))) (let () - (define parameter-map (build-parameter-map macro parameters)) - (define stringify-resolved (expand# macro parameter-map)) - ;; TODO resolve ## - (define resulting-body stringify-resolved #; (expand## macro stringify-resolved)) - (define (bound-identifier? id) - (and (string? id) - (or (and (variadic? macro) (string=? id "__VA_ARGS__")) - (member id (macro-identifier-list macro))))) + (define (resolve-cpp-variables tokens) + (define (bound-identifier? id) + (and (string? id) + (or (and (variadic? macro) (string=? id "__VA_ARGS__")) + (member id (macro-identifier-list macro))))) + ;; expand parameters, and place placemaker tokens + (let loop ((tokens tokens)) + (cond ((null? tokens) '()) + ((identifier-token? (car tokens)) + bound-identifier? + => (lambda (id) (let ((replacement (assoc-ref parameter-map id))) + (if (null? replacement) + (cons (placemaker) (loop (cdr tokens))) + ;; TODO macroexpand replacement here? + (append replacement (loop (cdr tokens))))))) + (else (cons (car tokens) (loop (cdr tokens))))))) - (let loop ((tokens resulting-body)) - (cond ((null? tokens) '()) - ;; TODO the parameters should be macro-expanded before being inserted - ((identifier-token? (car tokens)) - bound-identifier? - => (lambda (id) (append (assoc-ref parameter-map id) - (loop (cdr tokens))))) - (else (cons (car tokens) (loop (cdr tokens)))))))) + + (define parameter-map (build-parameter-map macro parameters)) + (define stringify-resolved (expand# macro parameter-map)) + (remove placemaker-token? + (expand## (resolve-cpp-variables stringify-resolved))))) @@ -134,7 +223,7 @@ (let ((name (macro-identifier macro))) (cond ((object-macro? macro) (values environment (append (fold (swap mark-noexpand) - (macro-body macro) + (expand## (macro-body macro)) (cons name noexpand-list)) remaining-tokens))) @@ -296,10 +385,11 @@ (lex (number->string in-env))) (scm-error 'cpp-error "defined" "Invalid parameter list to `defined': ~s" - (list tokens) #f))))) + (list arguments) #f))))) ;; environment, tokens → environment (define (handle-pragma environment tokens) + ;; TODO rewrite without match (match tokens (`((preprocessing-token (identifier "STDC")) (whitespace ,_) ... (preprocessing-token (identifier ,identifier)) (whitespace ,_) ... @@ -551,7 +641,7 @@ (leave-if environment) (drop-whitespace (cdr line-tokens)))) remaining-tokens)) - (else (loop (environment remaining-tokens))))) + (else (loop environment remaining-tokens)))) ;; From here on we are not in a comment block (else -- cgit v1.2.3