You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

367 lines
14 KiB

(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)
(close-output-port c-output)
(close-output-port sch-output)
(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***)
(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)
(lambda (structure)
(if (referenced? structure)
(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)))))
(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 "")
(string-append qualifier "_" name)))
(cast (if (string=? qualifier "")
(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)
(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)))
(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)))))
(define global-template
"unsigned _glob_@0( void ) { return (unsigned)&@1; }")
(define (dump-functions)
(for-each (lambda (f) (define-foreign (name f) (type f)))
(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"
(set-car! l '(***invalid***))
(loop (cdr l)))
(loop (cdr l)))))
(if (structured-type? returntype)
(begin (warn "Cannot receive structured value of type"
(rational-typename returntype)
"from function"
(set! returntype '(***invalid***))))
`(define ,(string->symbol (canonical-name name))
(foreign-function ,name
,(chez-map-args argtypes name)
,(chez-type returntype)))
(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:"
(map (lambda (x)
(if (eq? (record-tag x) 'void)
(begin (warn "Varargs *cannot* be handled for" name)
(chez-type x)))
(define (dump-enums)
(for-each (lambda (x)
(display (instantiate "(define @0 @1)"
(vector (canonical-name (name x))
(number->string (value x))))
(newline sch-output))
(define (dump-macros)
(for-each (lambda (m)
(if (and (valid-ident? (name m))
(valid-number? (value m)))
(display `(define ,(canonical-name (name m))
,(evaluate-number (value m)))
(newline sch-output))))
(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)))
(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)
(define (c-cast-expression type)
(define (function-cast stars ftype)
(string-append (c-cast-expression (rett ftype))
"(" stars ")("
(apply string-append
(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)))
(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 ")
(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))))))
(warn "c-cast-expression: Too complicated: " type)
(define (insert x l)
(define (loop l)
(if (null? (cdr l))
(cons (car l) (cons x (loop (cdr l))))))
(if (or (null? l)
(null? (cdr 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)
(if (user-defined-tag? (tag type))
(let ((t (lookup (tag type) structs)))
(if (not t)
(list 'struct-ref (tag t))))))
(if (user-defined-tag? (tag type))
(let ((t (lookup (tag type) unions)))
(if (not t)
(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))
(string->number s 8))))
(string->number s)))))