diff options
Diffstat (limited to 'module/c/preprocessor2.scm')
| -rw-r--r-- | module/c/preprocessor2.scm | 185 |
1 files changed, 96 insertions, 89 deletions
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index c1db3f08..f18ca748 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -9,18 +9,33 @@ :select (function-like-macro variadic? identifier-list)) :use-module ((c cpp-environment object-like-macro) :select (object-like-macro object-like-macro?)) :use-module ((c cpp-environment internal-macro) :select (internal-macro)) - :use-module ((hnh util) :select (-> intersperse aif swap unless unval)) + :use-module ((hnh util) :select (-> ->> intersperse aif swap unless unval)) :use-module ((hnh util lens) :select (set modify cdr*)) :use-module (hnh util path) :use-module (hnh util type) - :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 ((hnh util values) :select (abort* on-fst on-snd apply/values)) + :use-module ((c lex2) + :select (lex + placemaker + lexeme? + lexeme-body + lexeme-noexpand + + tokenize + )) :use-module (c unlex) :use-module (c cpp-types) :use-module (c cpp-util) - :use-module (ice-9 control) - :export (defined-macro _Pragma-macro)) + :export (_Pragma-macro + defined-macro + c-search-path + handle-preprocessing-tokens)) + + +(define (read-file path) + (call-with-input-file path (@ (ice-9 rdelim) read-string))) + + (define-syntax-rule (alist-of variable key-type value-type) (build-validator-body variable (list-of (pair-of key-type value-type)))) @@ -36,18 +51,10 @@ (define (ellipsis-token? token) (equal? "..." (punctuator-token? token))) -(define-syntax-rule (abort* form) - (call-with-values (lambda () form) abort)) - -(define-syntax-rule (on-fst form) - (% form - (lambda (prompt fst . rest) - (apply values (prompt fst) rest)))) - -(define-syntax-rule (on-snd form) - (% form - (lambda (prompt fst snd . rest) - (apply values fst (prompt snd) rest)))) +;; TODO +;; > #if defined X +;; is equivalent to +;; > #if defined(X) ;; parameters is a lexeme list, as returned by parse-parameter-list @@ -335,28 +342,6 @@ identifier: "__LINE__" body: (lex (number->string (current-line environment))))))) -(define (c-search-path) (make-parameter (list "." "/usr/include"))) - -;; #include <stdio.h> -(define (resolve-h-file string) - (typecheck string string?) - (cond ((path-absolute? string) string) - (else - (let ((filename - (find file-exists? - (map (lambda (path-prefix) - (path-append path-prefix string)) - (c-search-path))))) - (if filename filename - (scm-error 'cpp-error "resolve-h-file" - "Can't resolve file: ~s" - (list string) #f)))))) - -;; #include "myheader.h" -(define (resolve-q-file string) - (typecheck string string?) - ;; This should always be a fallback (6.10.2, p. 3) - (cond (else (resolve-h-file string)))) (define defined-macro (internal-macro @@ -412,9 +397,20 @@ environment)))) -(define (resolve-constant-expression tokens) +;; 6.10.1 p. 4 +(define (resolve-constant-expression cpp-tokens) ;; (typecheck tokens (list-of lexeme?)) + (define zero (car (lex "0"))) + #; + (define tokens + (map preprocessing-token->token + (map (lambda (token) + (cond ((identifier-token? token) zero) + (else token))) + (remove whitespace-token? tokens)))) + 'TODO + ;; eval as per 6.6 ) @@ -446,13 +442,12 @@ (on-snd (cons (car tokens) (abort* (loop (bump-line environment) (cdr tokens)))))) ((and (identifier-token? (car tokens)) (not (marked-noexpand? (car tokens)))) - (call-with-values - (lambda () (maybe-extend-identifier environment - (identifier-token? (car tokens)) - (lexeme-noexpand (car tokens)) - (cdr tokens))) - ;; Here is the after expansion - (if once? values loop))) + ;; Here is the loop after expansion + (apply/values (if once? values loop) + (maybe-extend-identifier environment + (identifier-token? (car tokens)) + (lexeme-noexpand (car tokens)) + (cdr tokens)))) (else (on-snd (cons (car tokens) (abort* (loop environment (cdr tokens))))))))) @@ -490,7 +485,37 @@ identifier) remaining-tokens))))) -(define (resolve-and-include-header environment tokens) +;; 'gcc -xc -E -v /dev/null' prints GCC:s search path +(define c-search-path + (make-parameter (list "/usr/include" + "/usr/local/include"))) + +;; #include <stdio.h> +(define (resolve-h-file string) + (typecheck string string?) + (cond + ;; NOTE do I want this case? + ;; GCC has it + ((path-absolute? string) string) + (else + (or + (find file-exists? + (map (lambda (path-prefix) + (path-append path-prefix string)) + (c-search-path))) + (scm-error 'cpp-error "resolve-h-file" + "Can't resolve file: ~s" + (list string) #f))))) + +;; #include "myheader.h" +(define (resolve-q-file string) + (typecheck string string?) + (cond ((file-exists? string) string) + ;; This should always be a fallback (6.10.2, p. 3) + (else (resolve-h-file string)))) + + +(define (resolve-header environment tokens) (typecheck environment cpp-environment?) ;; (typecheck tokens (list-of lexeme?)) @@ -499,21 +524,17 @@ (string-append msg ", tokens: ~s") (append args (list (unlex tokens))) #f)))) (let loop ((%first-time #t) (tokens tokens)) - (cond ((null? tokens) '()) + (cond ((null? tokens) (err "Invalid #include line")) ((h-string-token? (car tokens)) => (lambda (str) (unless (null? (drop-whitespace (cdr tokens))) (err "Unexpected tokens after #include <>")) - (handle-preprocessing-tokens - environment - (-> str resolve-h-file read-file tokenize)))) + (resolve-h-file str))) ((q-string-token? (car tokens)) => (lambda (str) (unless (null? (drop-whitespace (cdr tokens))) (err "Unexpected tokens after #include \"\"")) - (handle-preprocessing-tokens - environment - (-> str resolve-q-file read-file tokenize)))) + (resolve-q-file str))) (else (unless %first-time (err "Failed parsing tokens")) ;; No newlines in #include @@ -623,11 +644,23 @@ (body (drop-whitespace (cdr line-tokens)))) (if (eq? 'include directive) ;; include is special since it returns a token stream - (call-with-values - (lambda () (resolve-and-include-header environment body)) - (lambda (environment tokens) - (loop environment - (append tokens remaining-tokens)))) + (let ((path (resolve-header environment body))) + ;; TODO change to store source location in lexemes + ;; and rewrite the following to + ;; (loop environment + ;; (append (-> path read-file tokenize) remaining-tokens)) + ;; TODO and then transfer these source locations when we move + ;; to "real" tokens (c to-token) + (let ((env* tokens* + (loop + ;; same hack as at start of loop + (-> environment + (enter-file path) + (bump-line -1)) + (append (lex "\n") + (-> path read-file tokenize))))) + (on-snd (append tokens* (abort* (loop (leave-file env*) remaining-tokens)))))) + (let ((operation ; (environment, list token) → environment (case directive ((if) resolve-for-if) @@ -674,32 +707,6 @@ (unless (null? remaining-tokens) (lex "\n")) (abort* (loop env* remaining-tokens)))))))))) - (else (err "Unexpected middle of line"))))) - - - -(define (read-file path) - (call-with-input-file path (@ (ice-9 rdelim) read-string))) + (else (err "Unexpected middle of line, (near ~s)" + (unlex tokens)))))) -(define (comment->whitespace token) - (if (comment-token? token) - (car (lex " ")) - token)) - -(define (comments->whitespace tokens) - (map comment->whitespace tokens)) - -;;; 5.1.11.2 Translation phases - -(define (tokenize string) - (-> string -;;; 1. trigraph replacement - replace-trigraphs -;;; 2. Line folding - fold-lines -;;; 3. Decomposition into preprocenning tokens, whitespaces, and comments - lex -;;; 4. Execution of preprocessing directives, all preprocessing directives are then deleted - comments->whitespace - ;; squeeze-whitespace-blocks - )) |