alex-eg
48a3d06925
Types, fns and vars are now written in another, better, more intuitive and readable way. Types: "pointer to const char" is "* const char" "array of pointers to volatile int" is "[* volatile int]" Read left to right Vars (as well as fn args, struct fields): (var name type) (struct vec3 ((x float) (y float) (z float)) (fn vec3-add ((v1 vec3) (v2 vec3)) vec3 ...) Also fns are now have return types after arg list. * is now must not be attached to any type name (or variable for that matter)
258 lines
7.6 KiB
Scheme
258 lines
7.6 KiB
Scheme
;;; Sex fmt-c output writer
|
|
|
|
(declare (unit fmt-c-writer)
|
|
(uses fmt-c
|
|
semen
|
|
utils))
|
|
|
|
(import (chicken string)
|
|
brev-separate
|
|
fmt
|
|
matchable
|
|
regex
|
|
srfi-1 ; lists
|
|
srfi-13 ; strings
|
|
tree
|
|
)
|
|
|
|
(define (unkebabify sym)
|
|
(case sym
|
|
((-) sym)
|
|
((--) sym)
|
|
((->) sym)
|
|
((-=) sym)
|
|
(else
|
|
(string->symbol
|
|
(string-substitute "-(?!>)" "_"
|
|
(symbol->string sym) #t)))))
|
|
|
|
(define (atom-to-fmt-c atom)
|
|
(case atom
|
|
((fn) '%fun)
|
|
((prototype) '%prototype)
|
|
((begin) '%block-begin)
|
|
((define) '%define)
|
|
((pointer) '%pointer)
|
|
((array) '%array)
|
|
((attribute) '%attribute)
|
|
((¤) 'vector-ref)
|
|
((include) '%include)
|
|
;; uh things we do for c89 compatibility
|
|
((bool) 'int)
|
|
((true) 1)
|
|
((false) 0)
|
|
(else
|
|
(if (symbol? atom)
|
|
(unkebabify atom)
|
|
atom))))
|
|
|
|
(define (make-field-access form)
|
|
(assert
|
|
(= 2 (length form)) "Wrong field access format")
|
|
(unkebabify
|
|
(string->symbol
|
|
(fmt #f (cadr form) (car form)))))
|
|
|
|
(define (walk-generic form acc)
|
|
(cond
|
|
((null? form) (cons '() acc))
|
|
|
|
;; vector, e.g. {}-initializer
|
|
((vector? form)
|
|
(cons
|
|
(list->vector
|
|
(car (walk-generic (vector->list form) (list))))
|
|
acc))
|
|
|
|
;; atom (hopefully)
|
|
((not (list? form)) (cons (atom-to-fmt-c form) acc))
|
|
|
|
;; another special case - field access
|
|
((and (symbol? (car form))
|
|
(char=? #\. (string-ref (symbol->string (car form)) 0)))
|
|
(cons (make-field-access form) acc))
|
|
|
|
;; variable declaration inside function
|
|
((eq? (car form) 'var)
|
|
(cons (walk-var form) acc))
|
|
|
|
;; (cast expr type) -> (%cast type expr)
|
|
((eq? (car form) 'cast)
|
|
(cons (list '%cast
|
|
(walk-type (drop form 2))
|
|
(car (walk-generic (second form) (list))))
|
|
acc))
|
|
|
|
;; toplevel, or a start of a regular list form
|
|
(else
|
|
(cons (fold-right
|
|
walk-generic
|
|
(list)
|
|
form)
|
|
acc))))
|
|
|
|
(define (walk-var form)
|
|
;; (var a int) -> (%var int a)
|
|
;; (var a (const int) 32) -> (%var (const int) a 32)
|
|
;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
|
|
;; note: [...] is actually (¤ ...) after reading
|
|
;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
|
|
(append
|
|
(list '%var)
|
|
(list (walk-type (flatten (third form))))
|
|
(list (atom-to-fmt-c (second form)))
|
|
|
|
(if (null? (drop form 3))
|
|
(list)
|
|
(car (walk-generic (drop form 3) (list)))) ; optional init expression
|
|
))
|
|
|
|
(define (walk-type form)
|
|
;; int -> int
|
|
;; (const int) -> const int
|
|
;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
|
|
;; [float 8] -> (%array float 8)
|
|
;; (* const char) -> (const char *)
|
|
;; (const * const * const char) -> (const char * const * const)
|
|
;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
|
|
(match form
|
|
(('¤ . array-type)
|
|
(if (integer? (last array-type))
|
|
;; sized array
|
|
(let ((type (drop-right array-type 1))
|
|
(size (last array-type)))
|
|
`(%array ,(walk-type (flatten type))
|
|
,size))
|
|
;; sugar for pointer... Do we really need it? Guess why not,
|
|
;; it's a strong semantic cue
|
|
`(%array ,(walk-type (flatten array-type)))))
|
|
(('fn arglist ret-type)
|
|
`(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
|
|
|
|
;; Special case: nested structs/unions
|
|
(('struct ((field-names field-types) ...) . attrs)
|
|
(append `(struct ,(process-struct-fields field-names field-types))
|
|
(if (null? attrs)
|
|
(list)
|
|
(list (map atom-to-fmt-c attrs)))))
|
|
(('union ((field-names field-types) ...) . attrs)
|
|
(append `(union ,(process-struct-fields field-names field-types))
|
|
(if (null? attrs)
|
|
(list)
|
|
(list (map atom-to-fmt-c attrs)))))
|
|
|
|
(else
|
|
(type-convert-to-c form))))
|
|
|
|
(define (type-convert-to-c type)
|
|
;; Our pointers to C pointers
|
|
;; int -> int
|
|
;; * const char -> const char *
|
|
;; const * const char -> const char * const
|
|
(if (atom? type) (atom-to-fmt-c type)
|
|
(tree-map atom-to-fmt-c
|
|
(fold-right append (list)
|
|
(list-join (reverse (list-split type '*))
|
|
'(*))))))
|
|
|
|
(define (walk-fn-def form)
|
|
(match form
|
|
(('fn name args ret-type . maybe-body)
|
|
`(%fun
|
|
,(walk-type ret-type)
|
|
,(car (walk-generic name (list)))
|
|
,(walk-arglist args)
|
|
.
|
|
,maybe-body))))
|
|
|
|
;;; Todo: isn't there a better way?
|
|
(define (is-probably-type form)
|
|
(case (car form)
|
|
((¤ * const volatile struct union) #t)
|
|
(else #f)))
|
|
|
|
(define (walk-arglist form)
|
|
;; E.g.:
|
|
;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
|
|
;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
|
|
(map (fn
|
|
(match x
|
|
(('¤ . _) (walk-type x))
|
|
|
|
;; yeah shitty, but I don't know yet how to determine if the
|
|
;; first entry is part of the type and not an argument name
|
|
;; :(
|
|
((? is-probably-type) (walk-type x))
|
|
|
|
;; 1 element args are always type
|
|
((_) (walk-type x))
|
|
|
|
((var . type) (append (list (walk-type (if (= 1 (length type))
|
|
(car type)
|
|
type)))
|
|
(list (walk-type var))))))
|
|
form))
|
|
|
|
(define (normalize-fn-form form)
|
|
;; (fn ret-type name arglist body) -> normal function
|
|
;; (fn ret-type name arglist) -> prototype
|
|
(if (>= (length form) 5)
|
|
(walk-fn-def form)
|
|
(cons 'prototype (cdr (walk-fn-def form)))))
|
|
|
|
(define (walk-function form static)
|
|
(if static
|
|
(walk-generic (list 'static (normalize-fn-form form))
|
|
(list))
|
|
(walk-generic (normalize-fn-form (cdr form))
|
|
(list))))
|
|
|
|
(define (process-struct-fields names types)
|
|
(zip (map walk-type types) (map atom-to-fmt-c names)))
|
|
|
|
(define (walk-struct form)
|
|
(match form
|
|
((type name ((field-names field-types) ...) . attrs)
|
|
(list (append `(,type ,(atom-to-fmt-c name)
|
|
,(process-struct-fields field-names field-types))
|
|
(if (null? attrs)
|
|
(list)
|
|
(list (map atom-to-fmt-c attrs))))))
|
|
(else (error "Malformed aggregate definition " form))))
|
|
|
|
(define (walk-extern form)
|
|
(case (cadr form)
|
|
((fn)
|
|
(list (cons 'extern (walk-function form #f))))
|
|
((var)
|
|
(list (cons 'extern (walk-generic (cdr form) (list)))))
|
|
(else (error "Extern what?"))))
|
|
|
|
(define (walk-public form)
|
|
(case (cadr form)
|
|
((fn)
|
|
(walk-function form #f))
|
|
((var)
|
|
(walk-generic (walk-var (cdr form)) (list)))
|
|
((define defmacro import include struct typedef union var)
|
|
;; ignore here, used in generating public interface
|
|
(process-toplevel-form (cdr form)))
|
|
(else
|
|
(error "Pub what?" (cadr form)))))
|
|
|
|
(define (process-toplevel-form form)
|
|
;; todo: rewrite to match
|
|
;; for some reason should return list in a list; TODO: rewrite
|
|
(case (car form)
|
|
((fn) (walk-function form #t))
|
|
((var) (walk-generic (list 'static (walk-var form)) (list)))
|
|
((extern) (walk-extern form))
|
|
((pub) (walk-public form))
|
|
((struct union) (walk-struct form))
|
|
(else (walk-generic form (list)))))
|
|
|
|
(define (emit-c sex-forms)
|
|
(for-each (lambda (form)
|
|
(fmt #t (c-expr (car (process-toplevel-form form))) nl))
|
|
sex-forms))
|