;;; The type database.
;;;
;;; Every named aggregate, typedef and define the semantic engine
;;; walks past is recorded here, so that macros (or other forms) can
;;; ask what a type is made of. That is what lets a macro generate
;;; code from a struct's fields given nothing but its name.
;;;
;;; Entries are filled in as toplevel forms are processed, in order, so
;;; a type has to be declared before the macro that asks about it.

(import
  scheme
  (scheme base)
  (chicken base)
  srfi-1
  srfi-69)

;;; Two namespaces: `struct point' and a `point' typedef are separate
;;; declarations. Tags -- struct, union and enum alike -- share the
;;; second table between them
(define +type-db+ (make-hash-table))    ; typedefs and defines
(define +tag-db+ (make-hash-table))     ; struct, union and enums

;;; What type a *name* has, which neither of the two above records:
;;;
;;;   (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int)
;;;   (var origin (struct point) ...)    -> (struct point)
(define +name-db+ (make-hash-table))

(define (strip-pub form)
  (if (eq? (car form) 'pub) (cdr form) form))

(define (comment-form? f)
  (and (pair? f) (eq? (car f) 'comment)))

;;; Fields are written with the type last and one or more names before
;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that
;;; into one (name type) per field, which is what a caller wants.
(define (normalize-fields fields)
  (append-map
   (lambda (field)
     (if (comment-form? field)
         (list)
         (let ((type (last field))
               (names (drop-right field 1)))
           (map (lambda (name) (list name type)) names))))
   (remove comment-form? fields)))

;;; ([pub] struct name (fields ...) . attrs)
(define (aggregate-fields form)
  (let ((f (strip-pub form)))
    (if (and (pair? (cddr f)) (list? (caddr f)))
        (caddr f)
        (list))))

(define (add-struct name form)
  (hash-table-set! +tag-db+ name
                   (list 'struct name (normalize-fields (aggregate-fields form)))))

(define (add-union name form)
  (hash-table-set! +tag-db+ name
                   (list 'union name (normalize-fields (aggregate-fields form)))))

;;; ([pub] enum name (value ...))
(define (add-enum name form)
  (let ((f (strip-pub form)))
    (hash-table-set! +tag-db+ name
                     (list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
                                          (caddr f)
                                          (list))))))

;;; ([pub] typedef new-name target)
(define (add-typedef name form)
  (hash-table-set! +type-db+ name
                   (list 'typedef name (last (strip-pub form)))))

;;; (define name value ...) -- a C #define, kept so a macro can read a
;;; compile-time constant rather than re-parse the source.
(define (add-define name form)
  (hash-table-set! +type-db+ name
                   (list 'define name (cddr (strip-pub form)))))

;;; `(type-of x)' inside a macro body: the type of the expression the
;;; macro was handed, where `get-name-type' only answers for a name.
;;; The walker that can answer it lives in `semen', which is compiled
;;; after this, so it installs itself here for the length of one
;;; expansion. Outside one there is no scope to ask about, and the
;;; answer is #f.
(define current-type-of (make-parameter (lambda (form) #f)))

(define (type-of form) ((current-type-of) form))

(define (add-name-type! name type)
  (hash-table-set! +name-db+ name type))

;;; #f for a name never declared, which is what `printf' looks like
;;; until something parses stdio.h. Not an error here; the caller
;;; decides.
(define (get-name-type name)
  (hash-table-ref/default +name-db+ name #f))

;;; What `(make-adder 10)' has for a type: `make-adder's return type,
;;; or #f when NAME is not a function with a signature on record
(define (get-return-type name)
  (let ((type (get-name-type name)))
    (and (pair? type)
         (eq? 'fn (car type))
         (= 3 (length type))
         (third type))))

(define (get-tag-info name)
  (hash-table-ref/default +tag-db+ name #f))

;;; First look up the ordinary identifier, then tag of that id when
;;; no ordinary one was declared, as C does
(define (get-type-info name)
  (or (hash-table-ref/default +type-db+ name #f)
      (get-tag-info name)))

;;; ((name type) ...) for a struct or union, #f for anything else --
;;; including a name that was never declared. Callers give the better
;;; error, since they know what they wanted it for.
;;;
;;; A typedef is followed to what it stands for, so reflection over an
;;; alias works exactly as it does over the name it aliases.
(define (get-fields name)
  (let ((info (resolve-type-info name)))
    (and info
         (memq (car info) '(struct union))
         (caddr info))))

;;; Follow a typedef chain to the name it stands for. #f if NAME is
;;; not a typedef. A typedef that leads back to itself stops rather
;;; than spinning: nothing prevents one from being written.
(define (get-underlying-type name)
  (let follow ((name name) (seen (list)))
    (and (not (member name seen))
         (let ((info (get-type-info name)))
           (and info
                (eq? (car info) 'typedef)
                (let ((target (caddr info)))
                  (or (and (symbol? target) (follow target (cons name seen)))
                      target)))))))

;;; The declaration NAME ultimately names. For a typedef that is the
;;; entry of whatever it stands for, and for anything else it is
;;; NAME's own info
(define (target-tag target)
  (cond
   ((symbol? target) target)
   ((and (pair? target)
         (memq (car target) '(struct union enum))
         (pair? (cdr target))
         (symbol? (cadr target)))
    (cadr target))
   (else #f)))

(define (resolve-type-info name)
  (let ((info (resolve-ordinary-type-info name)))
    (if (and info (memq (car info) '(struct union enum)))
        info
        (or (get-tag-info name) info))))

(define (resolve-ordinary-type-info name)
  (let ((info (get-type-info name)))
    (and info
         (if (eq? (car info) 'typedef)
             (let ((tag (target-tag (get-underlying-type name))))
               ;; A typedef target is written in type position, where
               ;; `struct point' means the tag
               (and tag (or (get-tag-info tag) (get-type-info tag))))
             info))))

;;; Type matcher macro
;;; (type-match type
;;;   (int ...)
;;;   ((* const char) ...)
;;;   ([int 10] ...)
;;;   ((* _) ...)                     ; a pointer to anything
;;;   ((¤ _ _) ...)                   ; an array of anything, any length
;;;   (else ...))
;;;
;;; A type is a form, not an atom, so patterns are matched structurally
;;; rather than dispatched on like `case'. They are literal types and
;;; are not evaluated; `else' is optional and the whole thing is #f when
;;; nothing matches and there is no else.
;;;
;;; `_' in a pattern matches anything in that position, the same thing
;;; it means in a type. Without it every spelling has to be enumerated:
;;; `(closure ((int)) int)' and `(closure ((float)) int)' are separate
;;; clauses for what is one case.
;;;
;;; A `_' written last takes everything that remains, because a type's
;;; words are spread rather than nested -- `(* const char)' is three
;;; elements, so `(* _)' has to cover two of them to mean "a pointer to
;;; anything".
;;;
;;; Nothing destructures: a macro body is ordinary Scheme and a type is
;;; a list, so `(caddr (type-of x))' already reads the length out of
;;; `(¤ int 4)'.
(define-syntax type-match
  (syntax-rules (else)
    ((_ type) #f)
    ((_ type (else body ...)) (begin body ...))
    ((_ type (pattern body ...) clause ...)
     (if (type-pattern-matches? 'pattern type)
         (begin body ...)
         (type-match type clause ...)))))

(define (type-pattern-matches? pattern type)
  (cond
   ((eq? pattern '_) #t)
   ((and (pair? pattern) (pair? type))
    (if (and (eq? (car pattern) '_) (null? (cdr pattern)))
        #t                              ; a trailing `_' takes the rest
        (and (type-pattern-matches? (car pattern) (car type))
             (type-pattern-matches? (cdr pattern) (cdr type)))))
   (else (equal? pattern type))))

;;; Map function to each field/value of a structure/union/enum
;;; For enums, field-type is the type of the enum (since C 23)
;;; (map-fields type-name
;;;     (lambda (field-name field-type) ...))
;;;
;;; Returns #f if nothing of that name was declared
(define (map-fields struct-union-enum fn)
  (let ((info (resolve-type-info struct-union-enum)))
    (and info
         (case (car info)
           ((struct union)
            (map (lambda (field) (fn (car field) (cadr field)))
                 (caddr info)))
           ;; An enumerator's type is the enum itself -- named as it was
           ;; declared, since `enum some-typedef' is not a C type.
           ((enum)
            (let ((type (list 'enum (cadr info))))
              (map (lambda (value) (fn value type))
                   (caddr info))))
           (else #f)))))

;;; The shape of a written type
;;;
;;; Three places have to tell a type from something that merely
;;; contains one: an arglist entry is either `(name type)' or a bare
;;; type, and an array's last element is either a bound or the last
;;; word of its element type. They used to answer it separately, and
;;; disagreed.

;;; A qualifier can never end a type, which is what tells `(¤ const t)'
;;; -- an unsized array of `t' -- from `(¤ int 4)'.
(define +c-qualifiers+ '(const volatile restrict _Atomic))

(define +c-specifiers+
  '(void char short int long float double signed unsigned
    bool _Bool complex _Complex))

;;; Does this list start a type rather than name one? `(const char)'
;;; and `(unsigned int)' are types; `(f1 float)' is a named parameter.
(define (type-head? form)
  (and (pair? form)
       (symbol? (car form))
       (or (memq (car form) '(* ¤ struct union enum))
           (memq (car form) +c-qualifiers+)
           (memq (car form) +c-specifiers+))))

;;; Does the parameter name itself?
;;; (f1 float) does
;;; (float), (const char), (unsigned int) and (¤ float 4) do not
(define (named-arg? arg)
  (and (pair? arg)
       (pair? (cdr arg))                ; 1 element args are always type
       (not (type-head? arg))))

;;; Is NAME a typedef, as opposed to a `define'd constant? Both live in
;;; the same table, and only the first is part of a type.
(define (typedef-name? name)
  (let ((info (and (symbol? name) (get-type-info name))))
    (and info (memq (car info) '(typedef struct union enum)) #t)))

;;; `(¤ int N)' is N of int
;;; `(¤ unsigned int)' is an unsized array of unsigned int
;;;
;;; The last element is a bound only if what precedes it is already a
;;; complete type, so `(¤ const mytype)' and `(¤ * size-t)' end in the
;;; last word of their element type and not in a bound. A type is
;;; complete when it ends in a specifier, in a tag following its
;;; keyword, or in a typedef we have seen declared.
;;;
;;; TYPE is the whole `(¤ ...)' form.
(define (array-bound? type)
  (and (> (length type) 2)
       (let ((bound (last type))
             (preceding (last (drop-right type 1))))
         (cond
          ((not (symbol? bound)) #t)
          ((or (memq bound +c-specifiers+) (memq bound +c-qualifiers+)) #f)
          ((memq preceding +c-specifiers+) #t)
          ;; a tag always follows its keyword, so `(¤ * struct tt)' ends
          ;; in a name belonging to the type
          ((memq preceding '(struct union enum)) #f)
          (else (typedef-name? preceding))))))

;;; What one element of a written array type is:
;;; (¤ struct point 2) -> (struct point), (¤ * const char 2) -> (* const char)
(define (array-element-type type)
  (and (pair? type)
       (eq? '¤ (car type))
       (pair? (cdr type))
       (let ((words (if (array-bound? type)
                        (drop-right (cdr type) 1)
                        (cdr type))))
         (and (pair? words)
              (if (null? (cdr words)) (car words) words)))))