diff options
-rw-r--r-- | Makefile | 3 | ||||
-rwxr-xr-x | cpp | 2 | ||||
-rw-r--r-- | module/c/cpp-environment.scm | 87 | ||||
-rw-r--r-- | module/c/cpp-environment/function-like-macro.scm | 25 | ||||
-rw-r--r-- | module/c/cpp-environment/internal-macro.scm | 11 | ||||
-rw-r--r-- | module/c/cpp-environment/object-like-macro.scm | 18 | ||||
-rw-r--r-- | module/c/preprocessor2.scm | 16 | ||||
-rw-r--r-- | tests/test/cpp/cpp-environment.scm | 7 | ||||
-rw-r--r-- | tests/test/cpp/preprocessor2.scm | 62 |
9 files changed, 85 insertions, 146 deletions
@@ -19,9 +19,6 @@ scm_files = \ c/ast \ c/compiler \ c/cpp-environment \ - c/cpp-environment/function-like-macro \ - c/cpp-environment/internal-macro \ - c/cpp-environment/object-like-macro \ c/cpp-types \ c/cpp-util \ c/eval-basic \ @@ -18,7 +18,7 @@ exec $GUILE -e main -s "$0" "$@" (env tokens (preprocess-string content (make-default-environment)))) (pprint-environment env (current-output-port)) (newline) - (display "== tokens ==") + (display "/*** tokens ***/") (newline) (display (unlex tokens)) (newline) diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm index da8e4413..3bc94020 100644 --- a/module/c/cpp-environment.scm +++ b/module/c/cpp-environment.scm @@ -1,13 +1,10 @@ (define-module (c cpp-environment) :use-module (srfi srfi-1) :use-module (srfi srfi-88) - :use-module ((hnh util) :select (->>)) :use-module (hnh util object) :use-module (hnh util type) :use-module (hnh util lens) - :use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#) - :use-module ((c cpp-environment object-like-macro) :prefix #{obj:}#) - :use-module ((c cpp-environment internal-macro) :prefix #{int:}#) + :use-module ((c lex2) :select (lexeme?)) :use-module ((c unlex) :select (unlex)) :use-module ((rnrs enums)) :export ( @@ -18,6 +15,14 @@ macro-variadic? cpp-macro? + function-macro? + object-macro? + internal-macro? + + object-macro + function-macro + internal-macro + enter-into-if transition-to-if if-status @@ -33,29 +38,44 @@ current-line current-file - function-macro? - object-macro? - internal-macro? - cpp-environment? - cpp-if-status cpp-file-stack make-environment in-environment? remove-identifier add-identifier get-identifier extend-environment - disjoin-macro pprint-environment pprint-macro )) + +(define (%printer r p) + (format p "#<~a>" (pprint-macro r))) + +(define-type (function-macro printer: %printer) + (fun:identifier type: string? key: identifier) + (macro-identifier-list type: (list-of string?) + key: identifier-list) + (fun:body type: (list-of lexeme?) key: body) + (macro-variadic? type: boolean? default: #f + key: variadic?)) + + +(define-type (internal-macro printer: %printer) + (int:identifier type: string? key: identifier) + (int:body type: procedure? #| of arity 2 |# key: body)) + +(define-type (object-macro printer: %printer) + (obj:identifier type: string? key: identifier) + (obj:body type: (list-of lexeme?) key: body)) + (define (macro-identifier x) (define identifier - (cond ((obj:object-like-macro? x) obj:identifier) - ((fun:function-like-macro? x) fun:identifier) - ((int:internal-macro? x) int:identifier) + (cond ((object-macro? x) obj:identifier) + ((function-macro? x) fun:identifier) + ((internal-macro? x) int:identifier) (else (scm-error 'wrong-type-arg "macro-identifier" "Not a macro: ~s" (list x) #f)))) @@ -63,9 +83,9 @@ (define (macro-body-proc macro) - (cond ((obj:object-like-macro? macro) obj:body) - ((fun:function-like-macro? macro) fun:body) - ((int:internal-macro? macro) int:body) + (cond ((object-macro? macro) obj:body) + ((function-macro? macro) fun:body) + ((internal-macro? macro) int:body) (else (scm-error 'wrong-type-arg "macro-body" "Not a macro: ~s" (list macro) #f)))) @@ -74,17 +94,10 @@ (case-lambda ((macro) ((macro-body-proc macro) macro)) ((macro value) ((macro-body-proc macro) macro value)))) -(define macro-identifier-list fun:identifier-list) -(define macro-variadic? fun:variadic?) - -(define function-macro? fun:function-like-macro?) -(define object-macro? obj:object-like-macro?) -(define internal-macro? int:internal-macro?) - (define (cpp-macro? x) - (or (obj:object-like-macro? x) - (fun:function-like-macro? x) - (int:internal-macro? x))) + (or (object-macro? x) + (function-macro? x) + (internal-macro? x))) @@ -202,12 +215,6 @@ (define (make-environment) (cpp-environment)) -;; (define (clone-hash-table ht) -;; (alist->hash-table (hash-map->list cons ht))) - -;; (define (clone-environment environment) -;; (modify environment cpp-variables clone-hash-table)) - (define (in-environment? environment key) (assoc key (cpp-variables environment))) @@ -218,31 +225,25 @@ (lambda (vars) (remove (lambda (slot) (string=? key (car slot))) vars)))) -(define (add-identifier environment key value) - (typecheck key string?) - (typecheck value cpp-macro?) +(define (add-identifier environment macro) + (typecheck macro cpp-macro?) (modify environment cpp-variables - (lambda (vars) (acons key value vars)))) + (lambda (vars) (acons (macro-identifier macro) macro vars)))) (define (get-identifier environment key) (assoc-ref (cpp-variables environment) key)) - (define (extend-environment environment macros) (typecheck macros (list-of cpp-macro?)) - (fold (lambda (m env) (add-identifier env (macro-identifier m) m)) + (fold (lambda (m env) (add-identifier env m)) environment macros)) -(define (disjoin-macro environment name) - (typecheck name string?) - (remove-identifier environment name)) - (define* (pprint-environment environment optional: (port (current-error-port))) - (display "== Environment ==\n" port) + (display "/*** Environment ***/\n" port) (for-each (lambda (pair) (pprint-macro (cdr pair) port) (newline port)) diff --git a/module/c/cpp-environment/function-like-macro.scm b/module/c/cpp-environment/function-like-macro.scm deleted file mode 100644 index 59b47c9c..00000000 --- a/module/c/cpp-environment/function-like-macro.scm +++ /dev/null @@ -1,25 +0,0 @@ -(define-module (c cpp-environment function-like-macro) - :use-module (hnh util object) - :use-module (hnh util type) - :use-module ((c lex2) :select (lexeme?)) - :use-module ((c unlex) :select (unlex)) - :export (function-like-macro - function-like-macro? - identifier - identifier-list - body - variadic?)) - -(define-type (function-like-macro - printer: (lambda (r p) - (format p "#<#define ~a~a ~a>" - (identifier r) - (append (identifier-list r) - (if (variadic? r) - '("...") '())) - (unlex (body r))))) - (identifier type: string?) - (identifier-list type: (list-of string?)) - (body type: (list-of lexeme?)) - (variadic? type: boolean? - default: #f)) diff --git a/module/c/cpp-environment/internal-macro.scm b/module/c/cpp-environment/internal-macro.scm deleted file mode 100644 index 3c946738..00000000 --- a/module/c/cpp-environment/internal-macro.scm +++ /dev/null @@ -1,11 +0,0 @@ -(define-module (c cpp-environment internal-macro) - :use-module (hnh util object) - :export (internal-macro - internal-macro? - identifier body)) - -(define-type (internal-macro) - (identifier type: string?) - (body type: procedure? - ;; Arity 2 - )) diff --git a/module/c/cpp-environment/object-like-macro.scm b/module/c/cpp-environment/object-like-macro.scm deleted file mode 100644 index 90a3ad23..00000000 --- a/module/c/cpp-environment/object-like-macro.scm +++ /dev/null @@ -1,18 +0,0 @@ -(define-module (c cpp-environment object-like-macro) - :use-module (hnh util object) - :use-module (hnh util type) - :use-module ((c lex2) :select (lexeme?)) - :use-module ((c unlex) :select (unlex)) - :export (object-like-macro - object-like-macro? - identifier - body)) - - -(define-type (object-like-macro - printer: (lambda (r p) - (format p "#<#define ~a ~a>" - (identifier r) - (unlex (body r))))) - (identifier type: string?) - (body type: (list-of lexeme?))) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index d65a4ac9..229b1ae9 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -6,11 +6,6 @@ :use-module (c cpp-environment) :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?)) - :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 unless unval break/all)) :use-module ((hnh util lens) :select (set modify cdr*)) :use-module (hnh util path) @@ -110,7 +105,7 @@ (define (check-arity macro parameters) - (if (variadic? macro) + (if (macro-variadic? macro) (unless (>= (length parameters) (length (macro-identifier-list macro))) (scm-error 'cpp-arity-error "apply-macro" @@ -345,10 +340,10 @@ environment ;; 6.10.8 (list - (object-like-macro + (object-macro identifier: "__FILE__" body: (lex (format #f "~s" (current-file environment)))) - (object-like-macro + (object-macro identifier: "__LINE__" body: (lex (number->string (current-line environment))))))) @@ -619,20 +614,19 @@ (-> environment bump-line (add-identifier - identifier (cond ((and (not (null? tail)) (left-parenthesis-token? (car tail))) ;; function like macro (let ((variadic? identifiers replacement-list (parse-identifier-list tail))) - (function-like-macro + (function-macro identifier: identifier variadic?: variadic? identifier-list: identifiers ;; surrounding whitespace is not part of the replacement list ;; (6.10.3 p.7) body: (drop-whitespace-both replacement-list)))) - (else (object-like-macro + (else (object-macro identifier: identifier body: (drop-whitespace-both tail)))))))) diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm index e59940da..d38aafe3 100644 --- a/tests/test/cpp/cpp-environment.scm +++ b/tests/test/cpp/cpp-environment.scm @@ -3,9 +3,10 @@ :use-module (srfi srfi-88) :use-module (c cpp-environment) :use-module ((c lex2) :select (lex)) - :use-module (c cpp-environment object-like-macro) ) +(define cpp-if-status (@@ (c cpp-environment) cpp-if-status)) + (let ((e (make-environment))) (test-equal '(outside) (cpp-if-status e)) (let ((e* (enter-into-if e (if-status active)))) @@ -29,8 +30,8 @@ (let ((e (make-environment))) (let ((e* (add-identifier - e "key" - (object-like-macro + e + (object-macro identifier: "key" body: (lex "value"))))) (let ((result (get-identifier e* "key"))) diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index f79ece15..fd18ddce 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -18,9 +18,9 @@ in-environment? macro-identifier-list macro-body - cpp-file-stack)) - :use-module ((c cpp-environment function-like-macro) :select (function-like-macro)) - :use-module ((c cpp-environment object-like-macro) :select (object-like-macro)) + cpp-file-stack + function-macro + object-macro)) :use-module ((c cpp-util) :select (drop-whitespace-both tokens-until-eol @@ -232,11 +232,11 @@ (let ((e (join-file-line (make-environment)))) (test-equal "__FILE__ default value" - (object-like-macro identifier: "__FILE__" + (object-macro identifier: "__FILE__" body: (lex "\"*outside*\"")) (get-identifier e "__FILE__")) (test-equal "__LINE__ default value" - (object-like-macro identifier: "__LINE__" + (object-macro identifier: "__LINE__" body: (lex "1")) (get-identifier e "__LINE__"))) @@ -257,7 +257,7 @@ (lex "10") (-> (make-environment) (extend-environment - (list (object-like-macro + (list (object-macro identifier: "x" body: (lex "10")))) (resolve-token-stream (lex "x")) @@ -268,7 +268,7 @@ (lex "10 1") (-> (make-environment) (extend-environment - (list (object-like-macro + (list (object-macro identifier: "x" body: (lex "10")))) (resolve-token-stream (lex "x 1")) @@ -279,10 +279,10 @@ (lex "10 20") (-> (make-environment) (extend-environment - (list (object-like-macro + (list (object-macro identifier: "x" body: (lex "10")) - (object-like-macro + (object-macro identifier: "y" body: (lex "20")))) (resolve-token-stream (lex "x y")) @@ -298,7 +298,7 @@ (test-group "Object like macros" (call-with-values (lambda () (expand-macro (make-environment) - (object-like-macro + (object-macro identifier: "x" body: (lex "1 + 2")) '() '())) @@ -306,7 +306,7 @@ (call-with-values (lambda () (expand-macro (make-environment) - (object-like-macro + (object-macro identifier: "x" body: (lex "1+2")) '() (cdr (lex "x something else")))) @@ -337,7 +337,7 @@ (lex "1 + 2") (-> (make-environment) (extend-environment - (list (object-like-macro + (list (object-macro identifier: "x" body: (lex "1 + 2")))) (maybe-extend-identifier "x" '() '()) @@ -348,7 +348,7 @@ (append (lex "1 + 2") (lex "after")) (-> (make-environment) (extend-environment - (list (object-like-macro + (list (object-macro identifier: "x" body: (lex "1 + 2")))) (maybe-extend-identifier "x" '() (lex "after")) @@ -360,7 +360,7 @@ (lex "1") (remove-noexpand (apply-macro (make-environment) - (function-like-macro identifier: "f" + (function-macro identifier: "f" identifier-list: '() body: (lex "1")) '()))) @@ -371,7 +371,7 @@ parse-parameter-list (value-refx 0) (apply-macro (make-environment) - (function-like-macro identifier: "f" + (function-macro identifier: "f" identifier-list: '("x") body: (lex "x"))) remove-noexpand)) @@ -382,7 +382,7 @@ parse-parameter-list (value-refx 0) (apply-macro (make-environment) - (function-like-macro identifier: "f" + (function-macro identifier: "f" identifier-list: '("x" "y") body: (lex "x + y"))) remove-noexpand))) @@ -390,7 +390,7 @@ (test-group "Expand macro part 2" (test-group "Function like macros" (let ((e (make-environment))) - (let ((m (function-like-macro + (let ((m (function-macro identifier: "f" identifier-list: '() body: (lex "1")))) @@ -399,7 +399,7 @@ (test-error "Arity error for to many args" 'cpp-arity-error (expand-macro e m '() (lex "(10)")))) - (let ((m (function-like-macro + (let ((m (function-macro identifier: "f" identifier-list: '("x") variadic?: #t @@ -421,7 +421,7 @@ (lex "0") (-> e (extend-environment - (list (function-like-macro identifier: "f" + (list (function-macro identifier: "f" identifier-list: '("x") body: (lex "x")))) (resolve-token-stream (lex "f(0)")) @@ -432,7 +432,7 @@ (lex "(2) * (2)") (-> e (extend-environment - (list (function-like-macro identifier: "f" + (list (function-macro identifier: "f" identifier-list: '("x") body: (lex "(x) * (x)")))) (resolve-token-stream (lex "f(2)")) @@ -443,9 +443,9 @@ (lex "z") (-> e (extend-environment - (list (object-like-macro identifier: "x" + (list (object-macro identifier: "x" body: (lex "y")) - (object-like-macro identifier: "y" + (object-macro identifier: "y" body: (lex "z")))) (resolve-token-stream (lex "x")) (value-ref 1) @@ -455,10 +455,10 @@ (lex "10") (-> e (extend-environment - (list (function-like-macro identifier: "f" + (list (function-macro identifier: "f" identifier-list: '("x") body: (lex "g(x)")) - (function-like-macro identifier: "g" + (function-macro identifier: "g" identifier-list: '("y") body: (lex "y")))) (resolve-token-stream (lex "f(10)")) @@ -470,10 +470,10 @@ (lex "10") (-> e (extend-environment - (list (function-like-macro identifier: "f" + (list (function-macro identifier: "f" identifier-list: '("x") body: (lex "g(x)")) - (function-like-macro identifier: "g" + (function-macro identifier: "g" identifier-list: '("x") body: (lex "x")))) (resolve-token-stream (lex "f(10)")) @@ -486,10 +486,10 @@ (lex "10 * 2 + 20 * 2 + 30") (-> e (extend-environment - (list (function-like-macro identifier: "f" + (list (function-macro identifier: "f" identifier-list: '("x" "y") body: (lex "g(x) + g(y)")) - (function-like-macro identifier: "g" + (function-macro identifier: "g" identifier-list: '("x") body: (lex "x * 2")))) (resolve-token-stream (lex "f(10, 20) + 30")) @@ -865,12 +865,12 @@ f(g)(5)")) ;; (expand-macro ;; (extend-environment ;; (make-environment) -;; (list (object-like-macro identifier: "g" +;; (list (object-macro identifier: "g" ;; body: (lex "h")) -;; (function-like-macro identifier: "h" +;; (function-macro identifier: "h" ;; identifier:-list '("x") ;; body: (lex "(x + 10)")))) -;; (function-like-macro identifier: "f" +;; (function-macro identifier: "f" ;; identifier:-list '("a") ;; body: (lex "a")) ;; '() |