[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
define-foreign & C structs
I've found the following useful in dealing with C code. Olin Shivers suggested
I share it:
(herald c-struct) ; C-compatible structures for T.
;;; This file defines one form, (DEFINE-C-STRUCT-TYPE type-id . specs),
;;; which defines a structure object whose underlying data
;;; representation is a bytev suitable for passing to procedures
;;; written in the C language and made accessible via DEFINE-FOREIGN.
;;; Evaluating a DEFINE-C-STRUCT-TYPE form results in the definition
;;; of a constructor function, a type predicate, and settable
;;; component accessor functions. Applying the operation C-REP returns
;;; the underlying bytev, suitable for passing as REP/EXTEND.
;;; For example, the form: (define-c-struct-type writer
;;; (char coal)
;;; (double trouble)
;;; (short life)
;;; (unsigned-short love-letter)
;;; (pointer bird-dog)
;;; (unsigned hate-mail))
;;; expands to (block (define (make-writer)
;;; (let ((storage (make-bytev 21)))
;;; (object nil
;;; ((c-rep self) storage)
;;; ((writer? self) '#t)
;;; ((print self strm)
;;; (format strm "#{C-struct ~s ~s}"
;;; 'writer (object-hash self)))
;;; (((setter writer-coal) self val)
;;; (set (bref-8 storage 0) val))
;;; ((writer-coal self) (bref-8 storage 0))
;;; (((setter writer-trouble) self val)
;;; (set (inaccessable storage 1) val))
;;; ((writer-trouble self) (inaccessable storage 1))
;;; (((setter writer-life) self val)
;;; (set (bref-16 storage 9) val))
;;; ((writer-life self) (bref-16 storage 9))
;;; (((setter writer-love-letter) self val)
;;; (set (bref-16-u storage 11) val))
;;; ((writer-love-letter self) (bref-16-u storage 11))
;;; (((setter writer-bird-dog) self val)
;;; (set (bref-32 storage 13) val))
;;; ((writer-bird-dog self) (bref-32 storage 13))
;;; (((setter writer-hate-mail) self val)
;;; (set (bref-32 storage 17) val))
;;; ((writer-hate-mail self) (bref-32 storage 17)))))
;;; (define-predicate writer?)
;;; (define-settable-operation writer-coal)
;;; (define-settable-operation writer-trouble)
;;; (define-settable-operation writer-life)
;;; (define-settable-operation writer-love-letter)
;;; (define-settable-operation writer-bird-dog)
;;; (define-settable-operation writer-hate-mail))
;;; Many improvements are possible. First, it might be convenient if more type
;;; information were preserved: for example, a structure field of C type
;;; 'char*' should perhaps be manipulated as a T string, a field of C type
;;; 'char' as a T character, and a field of C type 'double' as a T flonum.
;;; This macro isn't quite as parameterized as I'd like it to be: it should be
;;; trivial to add new T-accessible representations for the underlying C types
;;; as just mentioned. It should allow for 'empty space' in a structure, for C
;;; compilers that pad fields to longword boundaries. There should be a
;;; companion C program to automatically generate the basic C type information.
;;; It should be easy to add new abstract T types corresponding to "abstract" C
;;; types. (Should the c-type-table be accessible to the user?) Finally,
;;; support for C unions is imperative, and support for C embedded structures
;;; is desirable.
;;; -- Derek Beatty 2-December-1988 <beatty@cs.cmu.edu>
(let ((c-type-table (make-symbol-table)))
(walk (lambda (lst)
(set (table-entry c-type-table (car lst)) (cdr lst)))
'((char 1 . bref-8)
(short 2 . bref-16)
(int 4 . bref-32)
(long 4 . bref-32)
(unsigned 4 . bref-32)
(float 4 . bref-32)
(double 8 . inaccessable)
(short-int 2 . bref-16)
(long-int 4 . bref-32)
(long-float 8 . inaccessable)
(unsigned-char 1 . bref-8-u)
(unsigned-short 2 . bref-16-u)
(unsigned-int 4 . bref-32)
(unsigned-long 4 . bref-32)
(unsigned-short-int 2 . bref-16-u)
(unsigned-long-int 4 . bref-32)
(pointer 4 . bref-32)))
(define-syntax (define-c-struct-type type-id . specs)
(let ((struct-size
(do ((s specs (cdr s))
(i 0
(+ i (let ((te (table-entry c-type-table (caar s))))
(if (not (null? te)) (car te)
(error "invalid spec in C-STRUCT form"))))))
((null? s) i))))
`(block
(define (,(concatenate-symbol 'make- type-id))
(let ((storage (make-bytev ,struct-size)))
(object nil
((c-rep self) storage)
((,(concatenate-symbol type-id '?) self) '#t)
((print self strm) (format strm "#{C-struct ~s ~s}"
(quote ,type-id)
(object-hash self)))
,@(do ((s specs (cdr s))
(spec-info (table-entry c-type-table (caar specs))
(table-entry c-type-table (caadr s)))
(offset 0 (fx+ offset (car spec-info)))
(z '()
(cons
`((,(concatenate-symbol type-id '- (cadar s)) self)
(,(cdr spec-info) storage ,offset))
(cons
`(((setter ,(concatenate-symbol
type-id '- (cadar s))) self val)
(set (,(cdr spec-info) storage ,offset) val))
z))))
((null? s) (reverse! z))))))
(define-predicate ,(concatenate-symbol type-id '?))
,@(do ((s specs (cdr s))
(z '()
(cons `(define-settable-operation
,(concatenate-symbol type-id '- (cadar s)))
z)))
((null? s) (reverse! z)))))))
(define-operation c-rep)
(lset *c-struct-syntax-table*
(make-syntax-table (env-syntax-table (repl-env))))