alex-eg
a860da6d7e
All checks were successful
Sex CI / build-linux (pull_request) Successful in 5m18s
316 lines
12 KiB
Scheme
316 lines
12 KiB
Scheme
;;; 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
|
|
;;;
|
|
;;; Where a type ends, asked by an arglist and by an array bound:
|
|
;;;
|
|
;;; (f1 float) a name and a type (unsigned int) a type
|
|
;;; (¤ int 4) four of int (¤ const t) unsized, of const t
|
|
;;; (¤ mytype N) N of mytype (¤ * size-t) unsized, of (* size-t)
|
|
|
|
;;; A qualifier cannot end a type: `(¤ const t)' is unsized, `(¤ int 4)'
|
|
;;; is four of int.
|
|
(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))))
|
|
|
|
;;; A typedef and a `define' share +type-db+; only the typedef is part
|
|
;;; of a type:
|
|
;;;
|
|
;;; (typedef small int) -> (¤ small N) is N of small
|
|
;;; (define CAP 4) -> (¤ int CAP) is CAP of int
|
|
(define (typedef-name? name)
|
|
(let ((info (and (symbol? name) (get-type-info name))))
|
|
(and info (memq (car info) '(typedef struct union enum)) #t)))
|
|
|
|
;;; The last element is a bound only where what precedes it already
|
|
;;; spells a whole type -- a specifier, a tag after its keyword, or a
|
|
;;; typedef we have seen declared:
|
|
;;;
|
|
;;; (¤ int 4) four of int (¤ unsigned int) unsized
|
|
;;; (¤ mytype CAP) CAP of mytype (¤ struct point) unsized
|
|
;;; (¤ const mytype) unsized (¤ * size-t) unsized
|
|
;;;
|
|
;;; 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)))))
|