define-foreign & C structs

[Derek Beatty <beatty@cs.cmu.edu>]

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))))