From f743e08220883eef86effdac8a5e7c94deddc302 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 11 Jul 2022 19:48:47 +0200 Subject: Cleanup + fix __LINE__. --- module/c/cpp-util.scm | 8 +- module/c/preprocessor2.scm | 179 ++++++++++++++++----------------------------- module/c/zipper.scm | 60 +++++++++++++++ 3 files changed, 130 insertions(+), 117 deletions(-) create mode 100644 module/c/zipper.scm (limited to 'module') diff --git a/module/c/cpp-util.scm b/module/c/cpp-util.scm index 420c8739..fff3cc9e 100644 --- a/module/c/cpp-util.scm +++ b/module/c/cpp-util.scm @@ -3,13 +3,15 @@ :use-module ((hnh util) :select (->)) :use-module (hnh util type) :use-module ((c lex2) :select (lex lexeme?)) + :use-module ((c unlex) :select (unlex)) :use-module (c cpp-types) :export (tokens-until-eol squeeze-whitespace drop-whitespace drop-whitespace-right drop-whitespace-both - cleanup-whitespace)) + cleanup-whitespace + concatenate-tokens)) ;; Returns two values: ;; - tokens until a newline token is met @@ -60,3 +62,7 @@ (define (cleanup-whitespace tokens) (typecheck tokens (list-of lexeme?)) (-> tokens drop-whitespace-both squeeze-whitespace)) + +(define (concatenate-tokens a b) + (car (lex (string-append (unlex (list a)) + (unlex (list b)))))) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 67ba4687..720a6ffc 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -2,24 +2,25 @@ :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (srfi srfi-88) - :use-module (ice-9 match) + :use-module (c cpp-environment) :use-module (c eval2) :use-module ((c cpp-environment function-like-macro) :select (function-like-macro variadic? identifier-list)) :use-module ((c cpp-environment object-like-macro) :select (object-like-macro)) :use-module ((c cpp-environment internal-macro) :select (internal-macro)) - :use-module ((hnh util) :select (-> intersperse aif swap)) + :use-module ((hnh util) :select (-> intersperse aif swap unless)) :use-module ((hnh util lens) :select (set modify cdr*)) :use-module (hnh util path) :use-module (hnh util type) - :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) :use-module (c cpp-types) :use-module (c cpp-util) + :use-module ((c zipper) :select (list-zipper left focused right zip-find-right + list->zipper zipper->list)) :export ()) (define-syntax-rule (alist-of variable key-type value-type) @@ -27,8 +28,6 @@ (define parameter-map? (of-type? (alist-of string? (list-of lexeme?)))) - - ;; parameters is a lexeme list, as returned by parse-parameter-list (define (build-parameter-map macro parameters) (typecheck macro macro?) @@ -44,7 +43,6 @@ (macro-identifier-list macro) parameters)))) - (define (expand# macro parameter-map) (typecheck macro macro?) (typecheck parameter-map parameter-map?) @@ -65,53 +63,6 @@ (loop (cdr tokens))))))) -(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?)) @@ -276,6 +227,8 @@ ;; - the remaining tokenstream ;; - how many newlines were encountered ;; The standard might call these "replacement lists" +;; Note that each returned token-list might have padding whitespace which should be trimmed. +;; It's kept to allow __VA_ARGS__ to "remember" its whitespace (define (parse-parameter-list tokens*) (typecheck tokens* (list-of lexeme?)) (let %loop ((depth 0) (newlines 0) (current '()) @@ -322,18 +275,16 @@ ;; Add __FILE__ and __LINE__ object macros to the environment (define (join-file-line environment) - (define file (current-file environment)) - (define line (current-line environment)) (extend-environment environment ;; 6.10.8 (list (object-like-macro identifier: "__FILE__" - body: (lex (format #f "~s" file))) + body: (lex (format #f "~s" (current-file environment)))) (object-like-macro identifier: "__LINE__" - body: (lex (number->string line)))))) + body: (lex (number->string (current-line environment))))))) (define (c-search-path) (make-parameter (list "." "/usr/include"))) @@ -478,11 +429,12 @@ (typecheck identifier string?) (typecheck remaining-tokens (list-of lexeme?)) (typecheck noexpand-list (list-of string?)) - (cond ((get-identifier environment identifier) - => (lambda (value) (expand-macro (join-file-line environment) - value - noexpand-list - remaining-tokens))) + (cond ((get-identifier (join-file-line environment) identifier) + => (lambda (value) + (expand-macro (join-file-line environment) + value + noexpand-list + remaining-tokens))) (else ; It wasn't an identifier, leave it as is (values environment (append (mark-noexpand (lex identifier) @@ -490,41 +442,31 @@ 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?)) - ;; TODO rewrite without match (let loop ((%first-time #t) (tokens tokens)) - (match (drop-whitespace tokens) - ((`(header-name (h-string ,str)) rest ...) - (cond ((remove whitespace-token? rest) - (negate null?) - => (lambda (tokens) - (scm-error 'cpp-error "resolve-and-include-header" - "Unexpected tokens after #include <>: ~s" - (list tokens) #f)))) - (handle-preprocessing-tokens - environment - (-> str resolve-h-file read-file tokenize))) - - ((`(header-name (q-string ,str)) rest ...) - (cond ((remove whitespace-token? rest) - (negate null?) - => (lambda (tokens) - (scm-error 'cpp-error "resolve-and-include-header" - "Unexpected tokens after #include <>: ~s" - (list tokens) - #f)))) - (handle-preprocessing-tokens - environment - (-> str resolve-q-file read-file tokenize))) - - (tokens - (unless %first-time - (scm-error 'cpp-error "resolve-and-include-header" - "Failed parsing tokens: ~s" - (list tokens) #f)) - (loop #f (resolve-token-stream environment 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)))))) ;; environment, tokens → environment (define (handle-line-directive environment tokens*) @@ -589,7 +531,12 @@ ;; environment, tokens -> environment, tokens (define (handle-preprocessing-tokens environment tokens) - (let loop ((environment environment) (tokens tokens)) + ;; Prepend a newline to ensure that the token stream always starts with a + ;; newline (otherwise guaranteed by how we loop). Decrement line-counter + ;; by one to compensate. + (let loop ((environment (bump-line environment -1)) + (tokens (append (lex "\n") tokens))) + (define (err fmt . args) (scm-error 'cpp-error "handle-preprocessing-tokens" (string-append "~a:~a " fmt) @@ -598,32 +545,26 @@ args) #f)) - (define (handle-regular-line environment tokens) - (let ((line-tokens remaining-tokens (tokens-until-eol tokens))) - (if (in-comment-block? environment) - (loop (bump-line environment) remaining-tokens) - (append (resolve-token-stream environment line-tokens) - (loop (bump-line environment) remaining-tokens))))) - - (cond ((null? tokens) '()) ((newline-token? (car tokens)) - (let ((tokens (drop-whitespace (cdr tokens)))) - (cond ((null? tokens) '()) - ((equal? '(punctuator "#") (lexeme-body (car tokens))) - (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens)))) + (let ((environment (bump-line environment)) + (tokens* (drop-whitespace (cdr tokens)))) + (cond ((null? tokens*) '()) + ((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 (let ((line-tokens (drop-whitespace line-tokens))) (cond ((null? line-tokens) - (loop (bump-line environment) remaining-tokens)) + ;; null directive + (loop environment remaining-tokens)) ((in-comment-block? environment) (case (string->symbol (identifier-token? (car line-tokens))) - ((else) (loop (bump-line (flip-flop-if environment)) remaining-tokens)) - ((endif) (loop (bump-line (leave-if environment)) remaining-tokens)) - ((elif) (loop (bump-line (resolve-for-if - (leave-if environment) - (drop-whitespace (cdr line-tokens)))) + ((else) (loop (flip-flop-if environment) remaining-tokens)) + ((endif) (loop (leave-if environment) remaining-tokens)) + ((elif) (loop (resolve-for-if + (leave-if environment) + (drop-whitespace (cdr line-tokens))) remaining-tokens)) (else (loop environment remaining-tokens)))) @@ -636,7 +577,7 @@ (call-with-values (lambda () (resolve-and-include-header environment body)) (lambda (environment tokens) - (loop (bump-line environment) + (loop environment (append tokens remaining-tokens)))) (let ((operation (case directive @@ -656,10 +597,16 @@ ((pragma) handle-pragma) (else (err "Unknown preprocessing directive: ~s" (list line-tokens)))))) - (loop (bump-line (operation environment body)) + (loop (operation environment body) remaining-tokens))))))))) - (else (handle-regular-line environment tokens))))) - (else (handle-regular-line environment tokens))))) + + ;; 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))))))) + + (else (err "Unexpected middle of line"))))) diff --git a/module/c/zipper.scm b/module/c/zipper.scm new file mode 100644 index 00000000..65cea211 --- /dev/null +++ b/module/c/zipper.scm @@ -0,0 +1,60 @@ +;;; Commentary: +;; Zipper data structure. Could be moved to (hnh util), but would then need to +;; be at least slightly more thorough. +;;; Code: + +(define-module (c zipper) + :use-module (srfi srfi-88) + :use-module (hnh util object) + :export (list-zipper + list-zipper? + left focused right + zip-left + zip-right + zip-find-right + list->zipper + zipper->list + rezip)) + +(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)))) -- cgit v1.2.3