diff options
Diffstat (limited to 'module/c/preprocessor2.scm')
| -rw-r--r-- | module/c/preprocessor2.scm | 188 |
1 files changed, 126 insertions, 62 deletions
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 3f9552c5..b9b11d0a 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -4,17 +4,20 @@ :use-module (srfi srfi-88) :use-module (c cpp-environment) - :use-module (c eval2) + :use-module ((c eval2) :select (c-boolean->boolean)) + :use-module ((c eval-basic) :select (eval-basic-c)) :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 object-like-macro?)) + :select (function-like-macro variadic?)) + :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 break/all)) + :use-module ((hnh util) :select (-> ->> intersperse swap unless unval break/all)) :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 ((hnh util values) :select (abort* on-fst on-snd apply/values)) + :use-module ((hnh util io) :select (read-file)) :use-module ((c lex2) :select (lex placemaker @@ -27,15 +30,16 @@ :use-module (c unlex) :use-module (c cpp-types) :use-module (c cpp-util) + :use-module ((c ast) :select (build-ast)) :export (_Pragma-macro - defined-macro + ;; defined-macro c-search-path - handle-preprocessing-tokens)) + handle-preprocessing-tokens + preprocess-string + make-default-environment + )) -(define (read-file path) - (call-with-input-file path (@ (ice-9 rdelim) read-string))) - (define-syntax-rule (alist-of variable key-type value-type) @@ -55,12 +59,6 @@ (define (ellipsis-token? token) (equal? "..." (punctuator-token? token))) -;; TODO -;; > #if defined X -;; is equivalent to -;; > #if defined(X) - - ;; parameters is a lexeme list, as returned by parse-parameter-list (define (build-parameter-map macro parameters) (typecheck macro cpp-macro?) @@ -201,15 +199,6 @@ expand##)))) - -;; Expand object-like macro - -;; #define VALUE 10 -;; #define str(x) #x -;; #define OTHER str(VALUE) -;; OTHER -;; ⇒ "VALUE" - ;; remaining-tokens should be the token stream just after the name of the macro (define (expand-macro environment macro noexpand-list remaining-tokens) (typecheck environment cpp-environment?) @@ -378,19 +367,6 @@ body: (lex (number->string (current-line environment))))))) -(define defined-macro - (internal-macro - identifier: "defined" - body: (lambda (environment arguments) - (typecheck arguments (and (list-of (list-of lexeme?)) - (not null?))) - (aif (identifier-token? (car (list-ref arguments 0))) - (let ((in-env (boolean->c-boolean (in-environment? environment it)))) - (values environment (lex (number->string in-env)))) - (scm-error 'cpp-error "defined" - "Invalid parameter list to `defined': ~s" - (list arguments) #f))))) - (define _Pragma-macro (internal-macro identifier: "_Pragma" @@ -436,21 +412,65 @@ environment)))) -;; 6.10.1 p. 4 -(define (resolve-constant-expression cpp-tokens) - ;; (typecheck tokens (list-of lexeme?)) +;; (next-token-or-group (lex " x y") +;; => (car (lex "x")) +;; => (lex " y") +;; next-token-or-group (lex " (x) y") +;; => (lex "(x)") +;; => (lex " y") +(define (next-token-or-group tokens) + (let loop ((tokens (drop-whitespace tokens))) + (cond ((null? tokens) + ;; TODO error here? + '()) + ((left-parenthesis-token? (car tokens)) + (parse-group tokens)) + ((preprocessing-token? (car tokens)) + (car+cdr tokens)) + (else + (loop (cdr tokens)))))) + + + +(define (parse-if-line environment cpp-tokens) (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)))) + (define one (car (lex "1"))) + + (define (drop-identifiers tokens) + (map (lambda (x) (if (identifier-token? x) + zero x)) + tokens)) + + (drop-identifiers + (let ((environment (join-file-line environment))) + (let loop ((tokens cpp-tokens)) + (cond ((null? tokens) '()) + ((identifier-token? (car tokens)) + (lambda (s) (and s (string=? s "defined"))) + => (lambda _ + (let ((next rest (next-token-or-group (cdr tokens)))) + (cons (if (and=> (identifier-token? (if (parenthesis-group? next) + ;; TODO empty group + (car (drop-whitespace (parenthesis-group-tokens next))) + next)) + (lambda (it) (in-environment? environment it))) + one zero) + (loop rest))))) + + ((and (identifier-token? (car tokens)) + (not (marked-noexpand? (car tokens)))) + (let ((_ tokens + (maybe-extend-identifier environment + (identifier-token? (car tokens)) + (lexeme-noexpand (car tokens)) + (cdr tokens)))) + (loop tokens))) + + (else (cons (car tokens) + (loop (cdr tokens))))))))) + + - 'TODO - ;; eval as per 6.6 - ) @@ -498,13 +518,16 @@ (typecheck environment cpp-environment?) ;; (typecheck tokens (list-of lexeme?)) - (-> (extend-environment environment (list defined-macro)) - ;; no newlines in #if line - ((unval resolve-token-stream 1) tokens) - resolve-constant-expression - c-boolean->boolean - (if (enter-active-if environment) - (enter-inactive-if environment)))) + (if (->> tokens + (parse-if-line environment) + (remove whitespace-token?) + merge-string-literals + build-ast + ;; 6.10.1 p. 4 + eval-basic-c + c-boolean->boolean) + (enter-active-if environment) + (enter-inactive-if environment))) ;; environment, string, (list token) → environment, (list token) (define (maybe-extend-identifier environment identifier noexpand-list remaining-tokens) @@ -719,11 +742,10 @@ (unless (in-conditional? env) (err "#endif outside conditional")) (leave-if env))) - ((else) (lambda (env _) - (unless (in-conditional? env) - (err "#else outside conditional")) - (flip-flop-if env))) - ;; ((elif) (lambda )) + ((else elif) (lambda (env _) + (unless (in-conditional? env) + (err "#else outside conditional")) + (flip-flop-if env))) ((define) resolve-define) ((undef) (lambda (env body) (remove-identifier env (identifier-token? (car body))))) ((line) handle-line-directive) @@ -750,3 +772,45 @@ (else (err "Unexpected middle of line, (near ~s)" (unlex tokens)))))) + + + + +(define* (make-default-environment key: (now (localtime (current-time)))) + (call-with-values + (lambda () + (preprocess-string + (format + #f + " +#define __STDC__ 1 +#define __STDC_HOSTED__ 1 +#define __STDC_VERSION__ 201112L +#define __DATE__ \"~a\" +#define __TIME__ \"~a\" +" + ;; TODO format should always be in + ;; english, and not tranlated + (strftime "\"%b %_d %Y\"" now) + (strftime "\"%H:%M:%S\"" now)) + (make-environment))) + (lambda (env _) env))) + + +(define* (preprocess-string str optional: (environment (make-default-environment))) + (on-snd + (->> + (abort* + (->> str +;;; Phase 1-3 + tokenize +;;; 4. Execution of preprocessing directives, all preprocessing directives are then deleted + (handle-preprocessing-tokens environment))) + +;;; 5. (something with character sets) +;;; 7. Whitespace tokens are discarded, each preprocessing token is converted into a token + (remove whitespace-token?) +;;; 6. concatenation of string literals +;;; Should be done before removal of whitespace, but I don't understand why + merge-string-literals + ))) |