guile-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: Future of g-wrap (and guile wrappers in general).


From: Miroslav Silovic
Subject: Re: Future of g-wrap (and guile wrappers in general).
Date: 21 Aug 2001 17:20:31 +0200

Rob Browning <address@hidden> writes:

> This isn't actually all that complicated.  The complexity lies in
> the specification (which g-wrap also supports) of the types listed
> here for the arguments and the return values.  When you define a
> wrapped type, g-wrap lets you specify exactly what code gets
> generated for the c<->scheme conversions, c-side initialization
> code, argument checking code, etc.  What you can specify is *very*
> flexible, but unfortunately that also makes *how* you specify it
> somewhat complicated.

Well, I needed a wrapper generator for TOM, and after working with a
heavily hacked g-wrap variant used for guile-gtk, I decided to make
something similar, but more readable. The result is attached. It
generates the wrappers for TOM, but I don't think it'd be hard to
modify to output the Guile glue instead.

It simplifies the new type definitions by using GOOPS a lot.

Oh, and I use flatten-write so I can use list operators and
constructors without having to explicitely concatenate anything
(inspired by the string operations performance discussion on this list
- this wrapper generator does appear to be very snappy, but I haven't
tested it with a large body of code).

-------------------------------
Testcases:
-------------------------------

(define t-byte (make <tom-type> #:type-name 'tom_byte))
(define t-int (make <tom-type> #:type-name 'int))
(define t-float (make <tom-type> #:type-name 'float))
(flatten-write '("Foo" " bar" (" baz" " " "mumble")))
(define t-foo
  (make <tom-boxed>
            #:type-name 'Foo
            #:slots `((,t-int foo "<doc>The value of foo</doc>")
                      (burek bar "<doc>The value of bar</doc>"))
            #:readable '(foo)
            #:writable '(foo)
            #:tom-refs '(bar)
            #:ctype "struct foo *"
            #:ref 'foo_ref
            #:unref 'foo_unref))
(define e-blah
  (make <tom-enum>
            #:type-name 'Blah
            #:tags '((CREATE_WINDOW 1 "<doc>blah</doc>") (DESTROY_WINDOW 
"<doc>whatever</doc>") (BLAH_WINDOW 5))))
(define array-int
  (make <tom-ptrlenarray>
            #:type-name 'IntArray
            #:elements t-int))
(define array-foo
  (make <tom-ptrlenarray>
            #:type-name 'ObjectArray
            #:elements t-foo))
(define array-float
  (make <tom-ptrlenarray>
            #:type-name 'FloatArray
            #:elements t-float))
(define c-string
  (make <tom-termarray>
            #:type-name 'ByteString
            #:length-function 'strlen
            #:elements t-byte
            #:owned-by-c #f))

(flatten-write (tom-enum-decl e-blah))

(flatten-write (tom-gc-mark t-foo))

(flatten-write (add-to-return t-foo "ret_value" RET))

(type-name t-int)

(define arglist
  `((,t-int xWidth x)
    (,t-foo yWidth y)
    (self)
    (,e-blah count c ,INOUT)))

(output-arguments arglist)

(output-declaration-list (output-arguments arglist) t-int)

(input-arguments arglist)

(flatten-write
 (selector-declaration
  'makeBaklavaWith
  arglist
  t-int))

(flatten-write
 (glue-method
  'makeBaklava
  'makeBaklavaWith
  arglist
  t-int
"<doc>This is a test glue method</doc>"
  t-foo))

(flatten-write
 (glue-method
  'makeFoo
  'newFooWith
  `((,t-int Val v))
  t-foo
"<doc>This is a test glue method with interesting return</doc>"
  t-foo))

(flatten-write
 (glue-method
  'makeFoo
  'newFooWith
  `((,array-float Val v ,INOUT))
  'void
"<doc>This is a test glue method with arrays</doc>"
  t-foo))

(flatten-write
 (glue-method
  'makeFoo
  'newFooWith
  `((,array-foo Val v ,INOUT))
  'void
"<doc>This is a test glue method with arrays of structs</doc>"
  t-foo))

(flatten-write
 (glue-method
  'strdup
  'strdup
  `((,c-string From s ,IN))
  c-string
"<doc>The wrapper for strdup function</doc>"
  t-foo))

(flatten-write (glue-class 'Baklava
                               "<doc>This implements the Baklava class</doc>"
                               ()
                               t-foo
                               (list e-blah)
                               (lambda () ())
                               (lambda () ())))

(flatten-write
 (parse-arguments arglist e-blah t-foo))

(flatten-write
 (make-call 'makeBaklava arglist t-int t-foo))

-------------------------------
Wrapper generator:
-------------------------------

(use-modules (oop goops)
             (ice-9 common-list))

(define (flatten-write v)
  (if (not (null? v))
      (if (pair? v)
          (begin
            (flatten-write (car v))
            (flatten-write (cdr v)))
          (display v))))

(define *indent* "    ")

;;;TODO
;;; glue.t
;;;    initWithContents (for the arrays and the normal glued types)

;;; types

(define-class <tom-type> ()
  (type-name #:accessor type-name #:init-keyword #:type-name))

(define-class <tom-boxed> (<tom-type>)
  (slots #:accessor slots #:init-value () #:init-keyword #:slots)
  (readable #:accessor readable #:init-value () #:init-keyword #:readable)
  (writable #:accessor writable #:init-value () #:init-keyword #:writable)
  (tom-refs #:accessor tom-refs #:init-value () #:init-keyword #:tom-refs)
  (ctype #:accessor ctype #:init-value "" #:init-keyword #:ctype)
  (ref #:accessor ref #:init-value #f #:init-keyword #:ref)
  (unref #:accessor unref #:init-value #f #:init-keyword #:unref))

(define-class <tom-array> (<tom-type>)
  (elements #:accessor elements #:init-value "" #:init-keyword #:elements)
  (owned-by-c #:accessor owned-by-c #:init-value #f #:init-keyword 
#:owned-by-c))

(define-class <tom-ptrlenarray> (<tom-array>))

(define-class <tom-lenptrarray> (<tom-ptrlenarray>))

(define-class <tom-termarray> (<tom-array>)
    (length-function #:accessor length-function #:init-value 'len 
#:init-keyword #:length-function))

(define-class <tom-enum> (<tom-type>)
  (tags #:accessor tags #:accessor () #:init-keyword #:tags))

;;; argument modes

(define-class <argclass> ())

(define-class <in> (<argclass>))
(define IN (make <in>))

(define-class <out> (<argclass>))
(define OUT (make <out>))

(define-class <inout> (<in> <out>))
(define INOUT (make <inout>))

(define-class <ret> (<out>))
(define RET (make <ret>))

;;;; ------------------------ generics ----------------------

;;; the TOM type declaration
(define-generic tom-type)

(define-method (tom-type (type <tom-type>))
  (type-name type))

(define-method (tom-type (type <tom-enum>))
  'int)

;;; generate the GC mark function
(define-generic tom-gc-mark)

(define-method (tom-gc-mark (type <tom-boxed>))
  (let ((refs (tom-refs type))
        (ctype (ctype type)))
    (if (null? refs)
        ()
        (list
         "\nvoid\n  gc_mark\n{\n"
         (parse-tom-arg type 'self IN)
         "    <c>\n"
         (map (lambda (x) (list "        gc_mark(((" ctype ")p)->" x ");\n")) 
refs)
         "    </c>\n}\n"))))

;;; generate the finalise function
(define-generic tom-dealloc)

(define-method (tom-dealloc (type <tom-boxed>))
  (if (unref type)
      (list
       "\nvoid\n  dealloc\n{\n"
       (parse-tom-arg type 'self "    " IN)
       "    <c>\n"
       "        " (unref type) " (p);\n"
       "    </c>\n}\n")
      ()))

;;; the type visible from C

(define-generic C-type)

(define-method (C-type (type <tom-type>))
  (type-name type))

(define-method (C-type (type <tom-ptrlenarray>))
  (throw 'no-C-equivalent))

(define-method (C-type (type <tom-termarray>))
  (list (elements type) "*"))

;;; this is boxed type

(define-generic boxed-type?)

(define-method (boxed-type? (type <tom-type>))
  #f)

(define-method (boxed-type? (type <tom-boxed>))
  #t)

;;; return the variable name for the TOM return argument

(define-generic ret-tom-arg)

(define-method (ret-tom-arg (type <tom-type>) tom-argname)
  (list "ptr_" tom-argname))

(define-method (ret-tom-arg (type <tom-ptrlenarray>))
  (throw 'no-C-equivalent))

(define-method (ret-tom-arg (type <tom-termarray>))
  (list "ptr_" tom-argname))

;;; parse the TOM argument

(define-generic parse-tom-arg)

(define-method (parse-tom-arg (type <tom-type>) tom-argname (argclass <inout>))
  (cons (parse-tom-arg type tom-argname IN)
        (parse-tom-arg type tom-argname OUT)))

(define-method (parse-tom-arg (type <tom-type>) tom-argname (argclass <in>))
  ())

(define-method (parse-tom-arg (type <tom-boxed>) tom-argname (argclass <in>))
  (list *indent* "pointer ptr_" tom-argname " = [" tom-argname " contents];\n"))

(define-method (parse-tom-arg (type <tom-type>) tom-argname (argclass <out>))
  (list *indent* (tom-type type) " ptr_" tom-argname ";\n"))

(define-method (parse-tom-arg (type <tom-boxed>) tom-argname (argclass <inout>))
  (parse-tom-arg type tom-argname IN))

(define-method (parse-tom-arg (type <tom-array>) tom-argname (argclass <in>))
  (let ((array-prepare-method (if (boxed? (elements type))
                                  "prepareBoxedArray"
                                  "prepareArray")))
    (list *indent* "pointer ptr_" tom-argname "; int length_" tom-argname ";\n" 
*indent* "(ptr_" tom-argname ", length_" tom-argname ") = [" tom-argname " " 
array-prepare-method "];\n")))

(define-method (parse-tom-arg (type <tom-array>) tom-argname (argclass <out>))
  (list *indent* "pointer length_" tom-argname "; int ptr_" tom-argname ";\n"))

(define-method (parse-tom-arg (type <tom-array>) tom-argname (argclass <inout>))
  (parse-tom-arg type tom-argname IN))

(define-method (parse-tom-arg (type <tom-termarray>) tom-argname (argclass 
<in>))
  (let ((array-prepare-method (if (boxed-type? (elements type))
                                  "prepareBoxedTermArray"
                                  "prepareTerminatedArray")))
    (list *indent* "pointer ptr_" tom-argname " = [" tom-argname " " 
array-prepare-method "];\n")))

(define-method (parse-tom-arg (type <tom-termarray>) tom-argname (argclass 
<out>))
  (list *indent* (tom-type type) " ptr_" tom-argname ";\n"))

(define-method (parse-tom-arg (type <tom-termarray>) tom-argname (argclass 
<inout>))
  (parse-tom-arg type tom-argname IN))

;;; interpolate the TOM argument into the argument list of the wrapped
;;; function

(define-generic add-tom-arg)

(define-method (add-tom-arg (type <tom-type>) tom-argname (argclass <inout>))
  (add-tom-arg type tom-argname OUT))

(define-method (add-tom-arg (type <tom-type>) tom-argname (argclass <in>))
  (list tom-argname))

(define-method (add-tom-arg (type <tom-boxed>) tom-argname (argclass <in>))
  (list "ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-type>) tom-argname (argclass <out>))
  (list "&ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-ptrlenarray>) tom-argname (argclass 
<in>))
  (list "ptr_" tom-argname ", length_" tom-argname))

(define-method (add-tom-arg (type <tom-ptrlenarray>) tom-argname (argclass 
<out>))
  (list "&ptr_" tom-argname ", &length_" tom-argname))

(define-method (add-tom-arg (type <tom-ptrlenarray>) tom-argname (argclass 
<inout>))
  (add-tom-arg type tom-argname OUT))

(define-method (add-tom-arg (type <tom-lenptrarray>) tom-argname (argclass 
<in>))
  (list "length_" tom-argname ", ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-lenptrarray>) tom-argname (argclass 
<out>))
  (list "&length_" tom-argname ", &ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-lenptrarray>) tom-argname (argclass 
<inout>))
  (add-tom-arg type tom-argname OUT))

(define-method (Add-tom-arg (type <tom-termarray>) tom-argname (argclass <in>))
  (list "ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-termarray>) tom-argname (argclass <out>))
  (list "&ptr_" tom-argname))

(define-method (add-tom-arg (type <tom-termarray>) tom-argname (argclass 
<inout>))
  (add-tom-arg type tom-argname OUT))

;;; cleanup the (possible) copies of the input arguments

(define-generic cleanup-parsed-arg)

(define-method (cleanup-parsed-arg (type <tom-type>) tom-argname (argclass 
<argclass>))
  ())

(define-method (cleanup-parsed-arg (type <tom-array>) tom-argname (argclass 
<argclass>))
  (if (owned-by-c type)
      ()
      (list *indent* "<c> free (ptr_" tom-argname "); </c>\n")))

;;; marshall the output arguments

(define-generic prepare-for-return)

(define-method (prepare-for-return (type <tom-type>) tom-argname (argclass 
<out>))
  ())

(define-method (prepare-for-return (type <tom-termarray>) tom-argname (argclass 
<out>))
  (list
   *indent* "int length_" tom-argname "; <c> length_" tom-argname " = " 
(length-function type) " (ptr_" tom-argname "); </c>\n"
   *indent* (tom-type type) " out_" tom-argname
   " = [[" (tom-type type) " alloc] initWithContents (ptr_" tom-argname ", 
length_" tom-argname ")];\n"))

;;; add to the returned tuple

(define-generic add-to-return)

(define-method (add-to-return (type <tom-type>) tom-argname (argclass <out>))
  (ret-tom-arg type tom-argname))

(define-method (add-to-return (type <tom-boxed>) tom-argname (argclass <out>))
  (list "[[" (tom-type type) " alloc] initWithContents " (next-method) "]"))

(define-method (add-to-return (type <tom-array>) tom-argname (argclass <out>))
  (list "[[" (tom-type type) " alloc] initWithContents (ptr_" tom-argname ", 
length_" tom-argname ")]"))

(define-method (add-to-return (type <tom-termarray>) tom-argname (argclass 
<out>))
  (ret-tom-arg type tom-argname))

(define-method (add-to-return (type <tom-termarray>) tom-argname (argclass 
<inout>))
  (add-to-return type tom-argname OUT))

;;; write the class glue code

(define-generic extra-parents)
(define-generic instance-decl)
(define-generic class-decl)

(define-method (extra-parents (type <tom-type>))
  (throw 'wrapped-nonpointer-type))

(define-method (extra-parents (type <tom-boxed>))
  '(wrapper.BoxedWrapper))

(define-method (instance-decl (type <tom-type>))
  ())

(define-method (instance-decl (type <tom-boxed>))
  (let ((read-slots (readable type))
        (write-slots (writable type)))
    (list
     ;; First declare the contents
     "{\n" *indent* "pointer contents;\n}\n"
     ;; gc support
     (tom-gc-mark type)
     (tom-dealloc type)
     ;; Read/write accessor methods
     (map (lambda (slot)
            (let ((slot-type (car slot))
                  (slot-name (cadr slot))
                  (slot-doc (caddr slot)))
              (cons
               (if (member slot-name read-slots)
                   (list
                    "\n" (if slot-doc (cons slot-doc "\n") ())
                    (tom-type slot-type) "\n  " slot-name
                    "\n{\n"
                    (parse-tom-arg type 'self IN)
                    (parse-tom-arg slot-type 'ret_value RET)
                    *indent* "<c>\n"
                    *indent* *indent* (ret-tom-arg slot-type slot-name) " = "
                    "((" (C-type slot-type) ")"
                    (add-tom-arg type 'self IN)
                    ")->" slot-name ";\n"
                    *indent* "</c>\n"
                    (output-result () slot-type type)
                    "}\n")
                   ())
               (if (member slot-name write-slots)
                   (list
                    "\n" (if slot-doc (cons slot-doc "\n") ())
                    'void "\n  set_" slot-name " " (tom-type slot-type) " " 
'value
                    "\n{\n"
                    (parse-tom-arg type 'self IN)
                    (parse-tom-arg slot-type 'value IN)
                    *indent* "<c>\n"
                    *indent* *indent* "((" (C-type slot-type) ")"
                    (add-tom-arg type 'self IN) ")->" slot-name
                    " = "
                    (add-tom-arg slot-type 'value IN) ";\n"
                    *indent* "</c>\n"
                    "}\n")
                   ()))))
          (slots type))
     (if (ref type)
         (list "\nid\n  initWithContents pointer c\n{\n"
               (parse-tom-arg type 'self IN)
               *indent* "<c> ref (c); </c>\n"
               *indent* "contents = c;\n}\n")
        ()))))

(define-method (class-decl (type <tom-type>))
  ())

;;;-----------------------------------------

(define (tom-enum-decl enum)
  (let ((current-enum-value 0)
        (doc ())
        (doccheck ()))
    (map (lambda (x)
           (if (pair? x)
               (begin
                 (if (number? (cadr x))
                     (begin
                       (set! current-enum-value (cadr x))
                       (set! doccheck (cddr x)))
                     (set! doccheck (cdr x)))
                 (if (not (null? doccheck))
                     (set! doc (list "\n" *indent* (car doccheck) "\n")))
                 (set! x (car x))))
           (let ((out (list doc *indent* "const " x " = " current-enum-value 
";\n")))
             (set! current-enum-value (1+ current-enum-value))
             (set! doc ())
             out))
         (tags enum))))

(define (output-arguments arglist)
  (remove-if-not (lambda (head)
                   (and (> (length head) 3)
                        (or (eq? (cadddr head) OUT)
                            (eq? (cadddr head) INOUT))))
                 arglist))

(define (output-declaration-list outargs ret)
  (if (eq? ret 'void)
      outargs
      (cons (list ret "" "ret_value" RET) outargs)))

(define (input-arguments arglist)
  (remove-if (lambda (head)
               (or (equal? head '(self))
                   (and (> (length head) 3)
                        (eq? (cadddr head) OUT))))
             arglist))

(define (indent-by n)
  (let loop ((i 0)
             (result ""))
    (if (< i n)
        (loop (1+ i) (string-append result " "))
        result)))

(define (map-first f l)
  (let loop ((first #t) (result ()) (l l))
    (if (null? l)
        (reverse result)
        (loop #f (cons (f first (car l)) result) (cdr l)))))

(define (join-list delim l)
  (if (null? l)
      ()
      (let loop ((result ()) (l l))
        (if (null? (cdr l))
            (reverse (cons (car l) result))
            (loop (cons delim (cons (car l) result)) (cdr l))))))

(define (selector-declaration tom-selname-prefix arglist ret)
  (let* ((oa (output-arguments arglist))
         (ia (input-arguments arglist))
         (max-ia-length
          (if (null? ia)
              (string-length tom-selname-prefix)
              (apply max (map-first
                          (lambda (first x)
                            (+ (if first (string-length tom-selname-prefix) 0)
                               (string-length (cadr x)))) ia))))
         (return-decl
          (if (not (null? oa))
              (let loop ((outargs (output-declaration-list oa ret))
                         (result '("(")))
                (let ((arg (car outargs)))
                  (if (null? outargs)
                      result
                      (if (null? (cdr outargs))
                          `(,@result ,(tom-type (car arg)) ")")
                          (loop (cdr outargs) `(,@result ,(tom-type (car arg)) 
", "))))))
              (if (equal? ret 'void)
                  ret
                  (tom-type ret))))
         (in-decl
          (if (null? ia)
              ;; argumentless selector is named after the function it wraps
              (list "  " tom-selname-prefix "\n")
              (let loop ((inargs ia)
                         (result '())
                         (selname tom-selname-prefix))
                (if (null? inargs)
                    result
                    (let* ((arg (car inargs))
                           (tail (cdr inargs))
                           (argname (string-append selname (cadr arg)))
                           (arg-indent (indent-by (+ 2 (- max-ia-length 
(string-length argname))))))
                      (loop tail (list result arg-indent argname " " (tom-type 
(car arg)) " " (caddr arg) "\n") "")))))))
    (list return-decl "\n" in-decl)))

(define (parse-arguments arglist ret self-class)
  (if (not (equal? ret 'void))
      (set! arglist (cons (list ret "" "ret_value" RET) arglist)))
  (map (lambda (arg)
         (cond
          ((equal? arg '(self))
           (parse-tom-arg self-class 'self IN))
          ((< (length arg) 4)
           (parse-tom-arg (car arg) (caddr arg) IN))
          (else
           (parse-tom-arg (car arg) (caddr arg) (cadddr arg)))))
       arglist))

(define (make-call funcname arglist ret self-class)
  (list *indent* "<c>\n"
        *indent* *indent*
        (if (not (equal? ret 'void))
            (cons (ret-tom-arg ret "ret_value") " = ")
            ())
        funcname " ("
        (join-list ", "
                   (map (lambda (arg)
                          (list
                           (cond
                            ((equal? arg '(self))
                             (add-tom-arg self-class 'self IN))
                            ((< (length arg) 4)
                             (add-tom-arg (car arg) (caddr arg) IN))
                            (else
                             (add-tom-arg (car arg) (caddr arg) (cadddr 
arg))))))
                        arglist))
        ");\n" *indent* "</c>\n"))

(define (output-result arglist ret self-class)
  (define oa (output-declaration-list (output-arguments arglist) ret))
  (list
   (map (lambda (arg) (prepare-for-return (car arg) (caddr arg) (cadddr arg))) 
oa)
   (map (lambda (arg) (cond
                       ((equal? arg '(self))
                        (cleanup-parsed-arg self-class 'self IN))
                       ((< (length arg) 4)
                        (cleanup-parsed-arg (car arg) (caddr arg) IN))
                       (else
                        (cleanup-parsed-arg (car arg) (caddr arg) (cadddr 
arg))))) 
        (if (eq? ret 'void) arglist (cons (list ret () 'ret_value RET) 
arglist)))
   *indent* "return ("
   (join-list ", " (map (lambda (arg)
                          (add-to-return (car arg) (caddr arg) (cadddr arg)))
                        oa))
   ");\n"))

(define (glue-method funcname tom-selname-prefix arguments ret doc self-class)
  (list
   "\n"
   (if doc
       (list doc "\n"))
   (selector-declaration tom-selname-prefix arguments ret)
   "{\n"
   (parse-arguments arguments ret self-class)
   (make-call funcname arguments ret self-class)
   (output-result arguments ret self-class)
   "}\n\n"))

(define (glue-class classname classdoc parents c-type enums class-methods 
instance-methods)
  (if c-type
      (set! parents (union parents (extra-parents c-type))))
  (list
   "\n"
   (if classdoc (cons classdoc "\n") "")
   "implementation class " classname
   (if (not (null? parents)) (list " : " (join-list ", " parents)) ())
   "\n"
   (if (not (null? enums))
       (list "{\n" (map (lambda (e) (tom-enum-decl e)) enums) "}\n")
       ())
   (if c-type
       (class-decl c-type)
       ())
   "\n"
   (class-methods)
   "end;\n\n"
   "implementation instance " classname "\n"
   (if c-type
       (instance-decl c-type)
       ())
   "\n"
   (instance-methods)
   "end;\n\n"))



-- 
How to eff the ineffable?



reply via email to

[Prev in Thread] Current Thread [Next in Thread]