+
+;; foreign struct record type
+(define-record-type standard-foreign-record-type
+ (make-foreign-record-type name types fields)
+ foreign-record-type?
+ (name foreign-record-type-name)
+ (types foreign-record-type-types)
+ (fields foreign-record-type-fields))
+
+(define-record-type foreign-record
+ (make-foreign-record type pointer)
+ foreign-record?
+ (type foreign-record-type)
+ (pointer foreign-record-pointer set-foreign-record-pointer!))
+
+(set-record-type-printer! foreign-record
+ (lambda (record port)
+ (format port "#<~a" (foreign-record-type-name (foreign-record-type record)))
+ (let* ((pointer (foreign-record-pointer record))
+ (record-type (foreign-record-type record))
+ (types (foreign-record-type-types record-type))
+ (fields (foreign-record-type-fields record-type))
+ (values (parse-c-struct pointer types)))
+ (for-each (lambda (field value)
+ (format port " ~a: ~a" field value))
+ fields
+ values))
+ (format port ">")))
+
+(define-syntax define-foreign-record-type
+ (lambda (x)
+ (define (field-names field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name type getter) #'name)
+ ((name type getter setter) #'name)))
+ field-specs))
+ (define (field-types field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name type getter) #'type)
+ ((name type getter setter) #'type)))
+ field-specs))
+ (syntax-case x ()
+ ((_ name (make-name make-arg ...) predicate? field-spec ...)
+ (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
+ ((field-name ...) (field-names #'(field-spec ...))))
+ #'(begin
+ (define name
+ (make-foreign-record-type
+ 'name
+ (list type-id ...)
+ (list 'field-name ...)))
+ (define (make-name make-arg ...)
+ (let* ((types (foreign-record-type-types name))
+ (c-struct-pointer (make-c-struct types (list make-arg ...))))
+ (make-foreign-record name c-struct-pointer)))
+ (define (predicate? record)
+ (and
+ (foreign-record? record)
+ (let* ((record-type (foreign-record-type record))
+ (type-name (foreign-record-type-name record-type)))
+ (equal? type-name (foreign-record-type-name name)))))
+ (export name)
+ (export make-name)
+ (export predicate?)))))))