367 lines
14 KiB
Scheme
367 lines
14 KiB
Scheme
(define c-output #f)
|
|
(define sch-output #f)
|
|
|
|
(define (select-functions)
|
|
(do ((functions functions (cdr functions)))
|
|
((null? functions))
|
|
(referenced! (car functions))))
|
|
|
|
(define (generate-translation)
|
|
(delete-file "C-OUTPUT")
|
|
(delete-file "SCH-OUTPUT")
|
|
(set! c-output (open-output-file "C-OUTPUT"))
|
|
(set! sch-output (open-output-file "SCH-OUTPUT"))
|
|
(display "#include \"chez-stdlib.h\"" c-output) (newline c-output)
|
|
(display "#include \"stdlib.h\"" c-output) (newline c-output)
|
|
|
|
(dump-structs)
|
|
(dump-unions)
|
|
(dump-functions)
|
|
(dump-variables)
|
|
(dump-enums)
|
|
(dump-macros)
|
|
|
|
(close-output-port c-output)
|
|
(close-output-port sch-output)
|
|
|
|
#t)
|
|
|
|
(define (chez-type type)
|
|
(case (record-tag type)
|
|
((pointer) 'unsigned-32)
|
|
((int long enum) 'integer-32)
|
|
((unsigned unsigned-long) 'unsigned-32)
|
|
((char unsigned-char signed-char) 'char)
|
|
((void) 'void)
|
|
((double) 'double-float)
|
|
((float) 'single-float)
|
|
((***invalid***) '***invalid***)
|
|
(else
|
|
(warn "Cannot translate this type: " type)
|
|
(string->symbol (string-append (symbol->string '***invalid:)
|
|
(symbol->string (record-tag type))
|
|
"***")))))
|
|
|
|
(define (dump-structs)
|
|
(dump-struct/union structs struct-names "struct"))
|
|
|
|
(define (dump-unions)
|
|
(dump-struct/union unions union-names "union"))
|
|
(define (dump-struct/union records typedef-name-getter qualifier)
|
|
(for-each
|
|
(lambda (structure)
|
|
(if (referenced? structure)
|
|
(begin
|
|
(if (user-defined-tag? (tag structure))
|
|
(dump-struct/union-def structure qualifier (tag structure)))
|
|
(for-each (lambda (n)
|
|
(if (user-defined-tag? (tag structure))
|
|
(generate-reference-to-structure structure n qualifier)
|
|
(dump-struct/union-def structure "" n)))
|
|
(typedef-name-getter structure)))))
|
|
records))
|
|
(define (generate-reference-to-structure structure typedef-name qualifier)
|
|
(for-each (lambda (n)
|
|
(let ((newname (compute-newname n typedef-name (tag structure) qualifier)))
|
|
(display `(define ,newname ,n) sch-output)
|
|
(newline sch-output)))
|
|
(cached-names structure)))
|
|
(define (compute-newname oldname typedef-name tag qualifier)
|
|
(let ((q (string-append qualifier "_" tag)))
|
|
(let ((get (string-append "_get_" q))
|
|
(set (string-append "_set_" q))
|
|
(alloc (string-append "_alloc_" q))
|
|
(free (string-append "_free_" q)))
|
|
(cond ((string-prefix=? oldname get)
|
|
(string-append "_get_" typedef-name (substring oldname (string-length get)
|
|
(string-length oldname))))
|
|
((string-prefix=? oldname set)
|
|
(string-append "_set_" typedef-name (substring oldname (string-length set)
|
|
(string-length oldname))))
|
|
((string-prefix=? oldname alloc) (string-append "_alloc_" typedef-name))
|
|
((string-prefix=? oldname free) (string-append "_free_" typedef-name))
|
|
(else (error "compute-newname: can't handle: " oldname))))))
|
|
(define (dump-struct/union-def structure qualifier name)
|
|
(if (not (null? (fields structure)))
|
|
(let* ((funcname (if (string=? qualifier "")
|
|
name
|
|
(string-append qualifier "_" name)))
|
|
(cast (if (string=? qualifier "")
|
|
name
|
|
(string-append qualifier " " name))))
|
|
(generate-constructor-and-destructor structure funcname cast)
|
|
(generate-accessors-and-mutators structure funcname cast ""))))
|
|
(define (generate-constructor-and-destructor structure funcname cast)
|
|
(function-pair constructor-template
|
|
(vector funcname cast)
|
|
(string-append "_alloc_" funcname)
|
|
'((void ()))
|
|
`(pointer ,(struct/union-ref structure)))
|
|
(function-pair destructor-template
|
|
(vector funcname cast)
|
|
(string-append "_free_" funcname)
|
|
`((pointer ,(struct/union-ref structure)))
|
|
'(void ()))
|
|
(cache-name structure (string-append "_alloc_" funcname))
|
|
(cache-name structure (string-append "_free_" funcname)))
|
|
(define constructor-template
|
|
"unsigned _alloc_@0(void) {
|
|
@1 *_p = (@1 *)malloc(sizeof(@1)); return (_p == 0 ? 0 : (unsigned)_p);
|
|
}")
|
|
|
|
(define destructor-template
|
|
"void _free_@0(unsigned _p) { if (_p == 0) abort(); free((@1 *)_p); }")
|
|
(define (generate-accessors-and-mutators structure funcname cast selector)
|
|
(for-each
|
|
(lambda (field)
|
|
(let ((funcname (string-append funcname "_" (canonical-name (name field))))
|
|
(selector (string-append selector (if (string=? selector "") "" ".") (name field))))
|
|
(cond ((basic-type? (type field))
|
|
(getset-basic-type structure funcname cast selector field))
|
|
((array-type? (type field))
|
|
(getset-array-type structure funcname cast selector field))
|
|
((structured-type? (type field))
|
|
(getset-structured-type structure funcname cast selector field))
|
|
(else (error 'generate-accessors-and-mutators "Unknown: " field)))))
|
|
(fields structure)))
|
|
(define (getset-basic-type struct funcname cast selector field)
|
|
(let* ((typename (basic-type-name (type field)))
|
|
(fieldtype (c-cast-expression (type field))))
|
|
(function-pair accessor-template
|
|
(vector typename funcname cast selector)
|
|
(string-append "_get_" funcname)
|
|
`((pointer ,(struct/union-ref struct)))
|
|
(type field))
|
|
(function-pair mutator-template
|
|
(vector typename funcname cast selector fieldtype)
|
|
(string-append "_set_" funcname)
|
|
`((pointer ,(struct/union-ref struct)) ,(type field))
|
|
`(void ()))
|
|
(cache-name struct (string-append "_get_" funcname))
|
|
(cache-name struct (string-append "_set_" funcname))))
|
|
(define accessor-template
|
|
"@0 _get_@1( unsigned _p ) { return (@0)((@2*)_p)->@3; }")
|
|
|
|
(define mutator-template
|
|
"void _set_@1( unsigned _p, @0 _v ) { ((@2*)_p)->@3 = (@4)_v; }")
|
|
(define (getset-array-type structure funcname cast selector field)
|
|
(function-pair array-accessor-template
|
|
(vector funcname cast selector)
|
|
(string-append "_get_" funcname)
|
|
`((pointer ,(struct/union-ref structure)))
|
|
'(unsigned))
|
|
(cache-name structure (string-append "_get_" funcname)))
|
|
|
|
(define array-accessor-template
|
|
"unsigned _get_@0( unsigned _p ) { return (unsigned)(((@1*)_p)->@2); }")
|
|
(define (getset-structured-type structure funcname cast selector field)
|
|
(let (;(selector (string-append selector "." (name field)))
|
|
;(funcname (string-append funcname "_" (canonical-name (name field))))
|
|
(struct (if (eq? (record-tag (type field)) 'struct-ref)
|
|
(lookup (tag (type field)) structs)
|
|
(lookup (tag (type field)) unions))))
|
|
(generate-accessors-and-mutators struct funcname cast selector)))
|
|
|
|
(define (dump-variables)
|
|
(for-each (lambda (v)
|
|
(let ((n (canonical-name (name v))))
|
|
(function-pair global-template
|
|
(vector n (name v))
|
|
(string-append "_glob_" n)
|
|
'((void ()))
|
|
`(pointer ,(type v)))))
|
|
vars))
|
|
|
|
(define global-template
|
|
"unsigned _glob_@0( void ) { return (unsigned)&@1; }")
|
|
|
|
(define (dump-functions)
|
|
(for-each (lambda (f) (define-foreign (name f) (type f)))
|
|
functions))
|
|
(define (define-foreign name type)
|
|
(let ((argtypes (arglist type))
|
|
(returntype (rett type)))
|
|
(let loop ((l argtypes))
|
|
(cond ((null? l) #t)
|
|
((structured-type? (car l))
|
|
(warn "Cannot pass structured value of type"
|
|
(rational-typename (car l))
|
|
"to function"
|
|
name)
|
|
(set-car! l '(***invalid***))
|
|
(loop (cdr l)))
|
|
(else
|
|
(loop (cdr l)))))
|
|
(if (structured-type? returntype)
|
|
(begin (warn "Cannot receive structured value of type"
|
|
(rational-typename returntype)
|
|
"from function"
|
|
name)
|
|
(set! returntype '(***invalid***))))
|
|
|
|
(write
|
|
`(define ,(string->symbol (canonical-name name))
|
|
(foreign-function ,name
|
|
,(chez-map-args argtypes name)
|
|
,(chez-type returntype)))
|
|
sch-output)
|
|
(newline sch-output)))
|
|
(define (chez-map-args args name)
|
|
(cond ((and (= (length args) 1)
|
|
(eq? (caar args) 'void))
|
|
'())
|
|
((= (length args) 0)
|
|
(warn "Function without prototype assumed to take no arguments:"
|
|
name)
|
|
'())
|
|
(else
|
|
(map (lambda (x)
|
|
(if (eq? (record-tag x) 'void)
|
|
(begin (warn "Varargs *cannot* be handled for" name)
|
|
'***invalid***)
|
|
(chez-type x)))
|
|
args))))
|
|
|
|
(define (dump-enums)
|
|
(for-each (lambda (x)
|
|
(display (instantiate "(define @0 @1)"
|
|
(vector (canonical-name (name x))
|
|
(number->string (value x))))
|
|
sch-output)
|
|
(newline sch-output))
|
|
enum-idents))
|
|
|
|
(define (dump-macros)
|
|
(for-each (lambda (m)
|
|
(if (and (valid-ident? (name m))
|
|
(valid-number? (value m)))
|
|
(begin
|
|
(display `(define ,(canonical-name (name m))
|
|
,(evaluate-number (value m)))
|
|
sch-output)
|
|
(newline sch-output))))
|
|
macros))
|
|
(define (valid-ident? s)
|
|
(andmap (lambda (c)
|
|
(or (char-upper-case? c)
|
|
(char-lower-case? c)
|
|
(char-numeric? c)
|
|
(char=? c #\_)))
|
|
(string->list s)))
|
|
|
|
(define (valid-number? s)
|
|
(let ((n (evaluate-number s)))
|
|
n))
|
|
|
|
(define (function-pair c-template template-args scheme-name arglist rett)
|
|
(display (instantiate c-template template-args) c-output)
|
|
(newline c-output)
|
|
(define-foreign scheme-name
|
|
`(function ,arglist ,rett)))
|
|
(define (basic-type-name type)
|
|
(let ((probe (assq (record-tag type)
|
|
'((char . "char")
|
|
(signed-char . "signed char")
|
|
(unsigned-char . "unsigned char")
|
|
(short . "short")
|
|
(unsigned-short . "unsigned short")
|
|
(int . "int")
|
|
(enum . "int")
|
|
(unsigned . "unsigned")
|
|
(long . "long")
|
|
(unsigned-long . "unsigned long")
|
|
(void . "void")
|
|
(pointer . "unsigned")
|
|
(float . "float")
|
|
(double . "double")
|
|
))))
|
|
(if probe
|
|
(cdr probe)
|
|
(begin (warn "Unknown type " type)
|
|
"***invalid***"))))
|
|
(define (c-cast-expression type)
|
|
(define (function-cast stars ftype)
|
|
(string-append (c-cast-expression (rett ftype))
|
|
"(" stars ")("
|
|
(apply string-append
|
|
(insert
|
|
","
|
|
(map c-cast-expression (arglist ftype))))
|
|
")"))
|
|
|
|
(cond ((primitive-type? type)
|
|
(basic-type-name type))
|
|
((pointer-type? type)
|
|
(let loop ((t (cadr type)) (stars "*"))
|
|
(cond ((eq? 'function (record-tag t))
|
|
(function-cast stars t))
|
|
((eq? 'pointer (record-tag t))
|
|
(loop (cadr t) (string-append "*" stars)))
|
|
(else
|
|
(string-append (c-cast-expression (cadr type)) "*")))))
|
|
((eq? (record-tag type) 'enum-ref)
|
|
(basic-type-name '(int ())))
|
|
((memq (record-tag type) '(struct-ref union-ref))
|
|
(let ((t (tag type)))
|
|
(if (user-defined-tag? t)
|
|
(string-append (if (eq? (record-tag type) 'struct-ref)
|
|
"struct "
|
|
"union ")
|
|
t)
|
|
(let ((names (if (eq? (record-tag type) 'struct-ref)
|
|
(struct-names type)
|
|
(union-names type))))
|
|
(if (= (length names) 1)
|
|
(car names)
|
|
(error "c-cast-expression: bad: " type))))))
|
|
(else
|
|
(warn "c-cast-expression: Too complicated: " type)
|
|
"unknown")))
|
|
|
|
(define (insert x l)
|
|
(define (loop l)
|
|
(if (null? (cdr l))
|
|
l
|
|
(cons (car l) (cons x (loop (cdr l))))))
|
|
(if (or (null? l)
|
|
(null? (cdr l)))
|
|
l
|
|
(loop l)))
|
|
(define (string-prefix=? s prefix)
|
|
(let ((limit (string-length prefix)))
|
|
(and (<= limit (string-length s))
|
|
(let loop ((i 0))
|
|
(or (= i limit)
|
|
(and (char=? (string-ref s i) (string-ref prefix i))
|
|
(loop (+ i 1))))))))
|
|
(define (rational-typename type)
|
|
(case (record-tag type)
|
|
((struct-ref)
|
|
(if (user-defined-tag? (tag type))
|
|
type
|
|
(let ((t (lookup (tag type) structs)))
|
|
(if (not t)
|
|
type
|
|
(list 'struct-ref (tag t))))))
|
|
((union-ref)
|
|
(if (user-defined-tag? (tag type))
|
|
type
|
|
(let ((t (lookup (tag type) unions)))
|
|
(if (not t)
|
|
type
|
|
(list 'union-ref (tag t))))))
|
|
(else type)))
|
|
(define (evaluate-number s)
|
|
(let ((k (string->list s)))
|
|
(cond ((null? k) #f)
|
|
((not (char-numeric? (car k))) #f)
|
|
((char=? (car k) #\0)
|
|
(cond ((null? (cdr k)) 0)
|
|
((or (char=? (cadr k) #\x) (char=? (cadr k) #\X))
|
|
(string->number (list->string (cddr k)) 16))
|
|
(else
|
|
(string->number s 8))))
|
|
(else
|
|
(string->number s)))))
|
|
|