/usr/share/gauche-0.9/site/lib/h2s/objects.scm is in gauche-gtk 0.6~pre1+git20121223-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | ;;;mmc: base class for objects passed from parsing to emitting?
;;
(define-module h2s.objects
(export
<gtk-type>
find-type
find-type-or-create
find-type-in-archive-function
;; accessors ... generics!!
get-slot-boxer
c-name-of
scm-type-of
body-of
|setter of body-of|
;; useless?
<gtk-type-alias>
;; late-commer: for <instance-pool-meta>
for-each-instance
;;
)
(use gauche.mop.instance-pool)
;; utils?
(use h2s.utils)
)
(select-module h2s.objects)
(define debug #f)
; (define-generic body-of)
; (define-generic |setter of body-of|)
; (define-generic c-name-of)
;; <GTK-TYPE> - type
(define-class <gtk-type> (<instance-pool-mixin>)
((c-name :init-keyword :c-name :accessor c-name-of)
;; symbol, such as 'GdkWindow*
(body :init-keyword :body :init-value #f :accessor body-of)
;; has <gtk-struct>, <gtk-enum> or <gtk-array> if applicable.
;; symbol when this is a primitive type.
))
(define-method write-object ((self <gtk-type>) port)
(format port "<~a>" (c-name-of self)))
;; this is a hack: we need acyclic dependency of modules.
;; But we need a hook from this, low level module, to call
;; function from a higher module (which looks-up in database).
(define find-type-in-archive-function #f)
(define (find-type name . rest)
(or
(instance-pool-find <gtk-type>
(lambda (item) (eq? (c-name-of item) name)))
(if find-type-in-archive-function
;; could be a list!
(find-type-in-archive-function name)
(begin
(if (null? rest)
(logformat-color 10 "find-type: not found ~a\n" name))
#f))))
(define (find-type-or-create name)
(or (find-type name #t)
(begin
(if debug (logformat-color 10 "find-type-or-create ~a\n" name))
(make <gtk-type> :c-name name)))) ;mmc: no body for now
;; mmc:
(define-class <gtk-type-alias> (<gtk-type>)
((alias :init-keyword :alias)))
;; get-slot-boxer depends only on the body? almost.
;; The embedded uses the c-name, to get at another type: the pointer one! So, we should keep a canonical type!
;;
(define-method get-slot-boxer ((self <gtk-type-alias>))
(get-slot-boxer (slot-ref self 'alias)))
(define-method scm-type-of ((self <gtk-type-alias>)) ;mmc: this could be the alias name!
;(exit)
(scm-type-of (slot-ref self 'alias)))
;; c-name-of remains. b/c find-type uses it :(
(define-method write-object ((self <gtk-type-alias>) port)
(write-object (slot-ref self 'alias) port))
;;================================================================
;; CLASSES
;;
(define-method for-each-instance (proc (class <instance-pool-meta>)) ; mmc: i would have thought this is standard
(for-each proc (instance-pool->list class)))
(provide "h2s/objects")
|