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/cpp-types.scm | 4 ++ module/c/lex2.scm | 11 ++- module/c/preprocessor2.scm | 144 +++++++++++++++++++++++++++++++-------- module/hnh/util/type.scm | 1 - tests/test/cpp/preprocessor2.scm | 83 +++++++++++++++++++++- 5 files changed, 210 insertions(+), 33 deletions(-) diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm index e21a8f0c..1a7387f5 100644 --- a/module/c/cpp-types.scm +++ b/module/c/cpp-types.scm @@ -6,6 +6,7 @@ comment-token? preprocessing-token? newline-token? + placemaker-token? identifier-token? punctuator-token? number-token? @@ -21,6 +22,9 @@ (define (preprocessing-token? x) (eq? 'preprocessing-token (lexeme-type x))) +(define (placemaker-token? x) + (eq? 'placemaker (lexeme-type x))) + (define (newline-token? x) (and (whitespace-token? x) (string=? "\n" (lexeme-body x)))) diff --git a/module/c/lex2.scm b/module/c/lex2.scm index e1784541..c00a029c 100644 --- a/module/c/lex2.scm +++ b/module/c/lex2.scm @@ -6,6 +6,7 @@ :use-module (srfi srfi-88) :export (lex lexeme lexeme? + placemaker (type . lexeme-type) (body . lexeme-body) (noexpand . lexeme-noexpand))) @@ -268,8 +269,9 @@ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||" "?" ":" ";" "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|=" - "," "#" "##" - "<:" ":>" "<%" "%>" "%:" "%:%:")) + "," "##" "#" ; # and ## flipped + "<:" ":>" "<%" "%>" "%:%:" "%:" ; %: and %:%: flipped + )) ;;; A.1.8 Header names @@ -330,11 +332,14 @@ (define-type (lexeme) - (type type: (memv '(whitespace comment preprocessing-token))) + (type type: (memv '(whitespace comment preprocessing-token placemaker))) (body type: (or string? list?)) (noexpand type: (list-of string?) default: '())) +(define (placemaker) + (lexeme type: 'placemaker body: '())) + (define (lex-output->lexeme-object x) (match x (`(whitespace ,body) 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 diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm index 1ea09af5..50008a3a 100644 --- a/module/hnh/util/type.scm +++ b/module/hnh/util/type.scm @@ -52,4 +52,3 @@ "Invalid value for ~s. Expected ~s, got ~s" (list (quote variable) (quote type-clause) variable) #f))))) - diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index cbc62edd..9349d290 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -14,6 +14,11 @@ :use-module (c lex2)) +(test-skip "Stringify __VA_ARGS__") +(test-skip "__LINE__ through macro") +(test-skip "__LINE__ standalone") + + ;; arbitrary tokens useful in tests for checking that values are returned correctly (define before (car (lex "before"))) (define after (car (lex "after"))) @@ -214,7 +219,16 @@ 'macro-expand-error (expand# m (build-parameter-map - m (list (lex "x"))))))) + m (list (lex "x")))))) + + (let ((m (function-like-macro + identifier: "f" + identifier-list: '() + variadic?: #t + body: (lex "# __VA_ARGS__")))) + (test-equal "Stringify __VA_ARGS__" + (lex "\"10, 20\"") + (expand# m (build-parameter-map m (list (lex "10, 20"))))))) ;; TODO expand-join ;; token ## token2 @@ -594,7 +608,7 @@ f(10) #define x 1 x")))) -(test-equal "__LINE__" +(test-equal "__LINE__ through macro" (lex "5") (drop-whitespace-both (remove-noexpand @@ -606,6 +620,71 @@ x")))) x // 5")) ))) +(test-equal "__LINE__ standalone" + (lex "5") + (drop-whitespace-both + (remove-noexpand + (handle-preprocessing-tokens (make-environment) + (tokenize " // 1 +// 2 +// 3 +// 4 +__LINE__"))))) + + + +(define expand## (@@ (c preprocessor2) expand##)) + +(test-group "expand##" + (test-error 'cpp-error (expand## (lex "a ##"))) + (test-error 'cpp-error (expand## (lex "## a"))) + (test-error 'cpp-error (expand## (lex "##"))) + (test-equal (lex "ab") (expand## (lex "a ## b"))) + ) + +(test-equal "Token concatenation in function like macro" + (lex "ab") + (remove-noexpand + (handle-preprocessing-tokens + (make-environment) + (tokenize " +#define f() a ## b +f()")))) + +(test-equal "token concatentanion in object like macro" + (lex "ab") + (remove-noexpand + (handle-preprocessing-tokens + (make-environment) + (tokenize " +#define x a ## b +x")))) + +(test-equal "Token concatenation with parameter" + (lex "ab") + (remove-noexpand + (handle-preprocessing-tokens + (make-environment) + (tokenize " +#define f(x) x ## b +f(a)")))) + + +;; 6.10.3.3 p. 4 +(test-equal + (lex "\"x ## y\"") + (drop-whitespace-both + (remove-noexpand + (handle-preprocessing-tokens + (make-environment) + (tokenize " +#define hash_hash # ## # +#define mkstr(a) # a +#define in_between(a) mkstr(a) +#define join(c, d) in_between(c hash_hash d) + +join(x, y)"))))) + ;; __LINE__ ;; #line ;; #undef -- cgit v1.2.3