path: root/module/c/cpp-environment.scm

(define-module (c cpp-environment)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-88)
  :use-module (hnh util object)
  :use-module (hnh util type)
  :use-module (hnh util lens)
  :use-module ((c lex2) :select (lexeme?))
  :use-module ((c unlex) :select (unlex))
  :use-module ((rnrs enums))
  :export (

           macro-identifier
           macro-body
           macro-identifier-list
           macro-variadic?
           cpp-macro?

           function-macro?
           object-macro?
           internal-macro?

           object-macro
           function-macro
           internal-macro

           enter-into-if
           transition-to-if
           if-status
           leave-if
           in-conditional/active?
           in-conditional/inactive-inactive?
           in-conditional/inactive?
           in-conditional?

           enter-file
           leave-file
           bump-line
           current-line
           current-file

           cpp-environment?
           cpp-file-stack

           make-environment in-environment?
           remove-identifier add-identifier
           get-identifier
           extend-environment

           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 ((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))))
  (identifier x))


(define (macro-body-proc macro)
  (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))))

(define macro-body
  (case-lambda ((macro)       ((macro-body-proc macro) macro))
               ((macro value) ((macro-body-proc macro) macro value))))

(define (cpp-macro? x)
  (or (object-macro? x)
      (function-macro? x)
      (internal-macro? x)))





(define-enumeration if-status
  (active                               ; We are in the "executing" branch of an if
   inactive                             ; We are in a non-"executing" branch, which may be followed by an "executing" branch
   inactive-inactive                    ; We are in a branch which will never execute, and neither will its children or further siblings
   outside)                             ; We aren't in an if-condition
  if-status-set)

(define (if-status? x)
  (enum-set-member? x (enum-set-universe (if-status-set))))

(define-type (cpp-environment)
  (cpp-if-status type: (and (list-of if-status?)
                            (not null?))
                 default: (list (if-status outside)))
  (cpp-variables type: (alist-of string? cpp-macro?)
                 default: '())
  (cpp-file-stack type: (and (not null?)
                             (list-of (pair-of string? exact-integer?)))
                  default: '(("*outside*" . 1))))




;; Morph the current if status into another
;; non-allowed transitions throws
(define (transition-to-if env next)
  (define valid-next
    (case (car (cpp-if-status env))
      ;; After an active if or elif no further elif's or else's can ever be active
      ((active)            (if-status-set inactive-inactive))
      ;; We can from an inactive if or elif move into an active elif or else
      ((inactive)          (if-status-set active inactive))
      ;; once nothing more can be active, nothing more can be active
      ((inactive-inactive) (if-status-set inactive-inactive))
      ;; outside can never be moved away from
      ((outside)           (if-status-set))
      (else => (lambda (x) (scm-error 'misc-error "transition-to-if"
                                 "Unknown enum: ~s" (list x) #f)))))
  (unless (enum-set-member? next valid-next)
    (scm-error 'misc-error "transition-to-if"
               "Invalid transition, ~a → ~a (valid next: ~s)"
               (list (car (cpp-if-status env))
                     next
                     (enum-set->list valid-next))
               #f))
  (set env cpp-if-status car* next))

;; enter into a nested if statement
;; An exception is thrown if the resulting if-stack is invalid
(define (enter-into-if env next)
  (define valid-next
    (case (car (cpp-if-status env))
      ;; from an active if statement, both positive and negative if's are possible
      ((active outside)              (if-status-set active inactive))
      ;; from an inactive if clause nothing can ever be active
      ((inactive inactive-inactive) (if-status-set inactive-inactive))
      (else => (lambda (x) (scm-error 'misc-error "enter-into-if"
                                 "Unknown enum: ~s" (list x) #f)))))

  (unless (enum-set-member? next valid-next)
    (scm-error 'misc-error "enter-into-if"
               "Can't enter ~a from ~a (valid: ~s)"
               (list next
                     (car (cpp-if-status env))
                     (enum-set->list valid-next))
               #f))

  (modify env cpp-if-status xcons next))

;; Leaves the current if statement
(define (leave-if environment)
  (when (eq? (if-status outside) (car (cpp-if-status environment)))
    (scm-error 'misc-error "leave-if"
               "Can't leave 'outside'"
               '() #f))
  (modify environment cpp-if-status cdr))

(define (in-conditional/inactive-inactive? environment)
  (eq? (if-status inactive-inactive) (get environment cpp-if-status car*)))

(define (in-conditional/inactive? environment)
  (enum-set-member?
   (get environment cpp-if-status car*)
   (if-status-set inactive inactive-inactive)))

(define (in-conditional/active? environment)
  (eq? (if-status active) (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 (in-environment? environment key)
  (assoc key (cpp-variables environment)))

(define (remove-identifier environment key)
  (typecheck key string?)

  (modify environment cpp-variables
          (lambda (vars) (remove (lambda (slot) (string=? key (car slot)))
                            vars))))

(define (add-identifier environment macro)
  (typecheck macro cpp-macro?)

  (modify environment cpp-variables
          (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 m))
        environment macros))




(define* (pprint-environment environment optional: (port (current-error-port)))
  (display "/*** Environment ***/\n" port)
  (for-each (lambda (pair)
              (pprint-macro (cdr pair) 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))))))