diff options
Diffstat (limited to 'module/c/cpp-environment.scm')
| -rw-r--r-- | module/c/cpp-environment.scm | 215 |
1 files changed, 215 insertions, 0 deletions
diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm new file mode 100644 index 00000000..a6401e71 --- /dev/null +++ b/module/c/cpp-environment.scm @@ -0,0 +1,215 @@ +(define-module (c cpp-environment) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module (ice-9 hash-table) + :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 unlex) :select (unlex)) + :export ( + + macro-identifier + macro-body + macro-identifier-list + macro-variadic? + cpp-macro? + ;; pprint-macro + + enter-active-if + enter-inactive-if + flip-flop-if + leave-if + in-conditional/active? + in-conditional/inactive? + in-conditional? + + enter-file + leave-file + bump-line + current-line + current-file + + function-macro? + object-macro? + internal-macro? + + cpp-environment + cpp-environment? + cpp-if-status + ;; cpp-variables + cpp-file-stack + + make-environment in-environment? + remove-identifier add-identifier + get-identifier + extend-environment + disjoin-macro + + pprint-environment + pprint-macro + )) + +(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) + (else (scm-error 'wrong-type-arg "macro-identifier" + "Not a macro: ~s" + (list x) #f)))) + (identifier x)) + + +(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) + (else (scm-error 'wrong-type-arg "macro-body" + "Not a macro: ~s" + (list macro) #f)))) + +(define macro-body + (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))) + + + + +(define-type (cpp-environment) + (cpp-if-status type: (list-of (memv '(outside active-if inactive-if))) + default: '(outside)) + ;; not exported since type signatures don't hold inside the hash table + ;; TODO replace hash table with something that doesn't require copying the + ;; entire structure every time + (cpp-variables type: hash-table? default: (make-hash-table)) + (cpp-file-stack type: (and (not null?) + (list-of (pair-of string? exact-integer?))) + default: '(("*outside*" . 1)))) + + + + +(define (enter-active-if environment) + (modify environment cpp-if-status xcons 'active-if)) + +(define (enter-inactive-if environment) + (modify environment cpp-if-status xcons 'inactive-if)) + +;; for #else +(define (flip-flop-if environment) + ((if (in-conditional/inactive? environment) + enter-active-if + enter-inactive-if) + (leave-if environment))) + +(define (leave-if environment) + (modify environment cpp-if-status cdr)) + +(define (in-conditional/inactive? environment) + (eq? 'inactive-if (get environment cpp-if-status car*))) + +(define (in-conditional/active? environment) + (eq? 'active-if (get environment cpp-if-status car*))) + +(define (in-conditional? environment) + (or (in-conditional/inactive? environment) + (in-conditional/active? environment))) + + + +(define (enter-file environment filename) + (modify environment cpp-file-stack xcons (cons filename 1))) + +(define (leave-file environment) + (modify environment cpp-file-stack cdr)) + +(define current-line (compose-lenses cpp-file-stack car* cdr*)) + +(define current-file (compose-lenses cpp-file-stack car* car*)) + +(define* (bump-line environment optional: (count 1)) + (modify environment current-line + count)) + + + + +(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) + (hash-get-handle (cpp-variables environment) key)) + +(define (remove-identifier environment key) + (typecheck key string?) + + (let ((environment (clone-environment environment))) + (hash-remove! (cpp-variables environment) key) + environment)) + +(define (add-identifier environment key value) + (typecheck key string?) + (typecheck value cpp-macro?) + + (let ((environment (clone-environment environment))) + (hash-set! (cpp-variables environment) key value) + environment)) + +(define (get-identifier environment key) + (hash-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)) + 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") + (hash-for-each (lambda (key macro) + (pprint-macro macro port) + (newline port)) + (cpp-variables environment))) + +(define* (pprint-macro x optional: (p (current-output-port))) + (cond ((internal-macro? x) + (format p "/* ~a INTERNAL MACRO */" + (macro-identifier x))) + ((object-macro? x) + (format p "#define ~a ~a" + (macro-identifier x) + (unlex (macro-body x)))) + ((function-macro? x) + (format p "#define ~a(~a) ~a" + (macro-identifier x) + (string-join (append (macro-identifier-list x) + (if (macro-variadic? x) + '("...") '())) + "," 'infix) + (unlex (macro-body x)))))) |