/usr/share/guile-gnome-2/gnome/gobject/gvalue.scm is in guile-gnome2-glib 2.16.2-2.
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 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 | ;; guile-gnome
;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; Commentary:
;;
;; GLib supports generic typed values via its GValue module. These
;; values are wrapped in Scheme as instances of @code{<gvalue-class>}
;; classes, such as @code{<gint>}, @code{<gfloat>}, etc.
;;
;; In most cases, use of @code{<gvalue>} is transparent to the Scheme
;; user. Values which can be represented directly as Scheme values are
;; normally given to the user in their Scheme form, e.g. @code{#\a}
;; instead of @code{#<gvalue <gchar> 3020c708 a>}. However, when dealing
;; with low-level routines it is sometimes necessary to have values in
;; @code{<gvalue>} form. The conversion between the two is performed via
;; the @code{scm->gvalue} and @code{gvalue->scm} functions.
;;
;; The other set of useful procedures exported by this module are those
;; dealing with enumerated values and flags. These objects are normally
;; represented on the C side with integers, but they have symbolic
;; representations registered in the GLib type system.
;;
;; On the Scheme side, enumerated and flags values are canonically
;; expressed as @code{<gvalue>} objects. They can be converted to
;; integers or symbols using the conversion procedures exported by this
;; module. It is conventional for Scheme procedures that take enumerated
;; values to accept any form for the values, which can be canonicalized
;; using @code{(make <your-enum-type> #:value @var{value})}, where
;; @var{value} can be an integer, a symbol (or symbol list in the case
;; of flags), or the string ``nickname'' (or string list) of the
;; enumerated/flags value.
;;
;;; Code:
(define-module (gnome gobject gvalue)
#:use-module (oop goops)
#:use-module (gnome gobject utils)
#:use-module (gnome gobject config)
#:use-module (gnome gobject gtype)
#:export (;; Base class
<gvalue>
;; Simple classes
<gboolean> <gchar> <guchar> <gint> <guint> <glong>
<gulong> <gint64> <guint64> <gfloat> <gdouble>
<gchararray> <gboxed> <gboxed-scm> <gvalue-array>
<gpointer>
;; Enums and Flags Classes
<genum> <gflags>
genum-register-static gflags-register-static
genum-class->value-table gflags-class->value-table
;; Conversion (from C)
scm->gvalue gvalue->scm
;; Enums and Flags
genum->symbol genum->name genum->value
gflags->value
gflags->symbol-list gflags->name-list gflags->value-list))
;;;
;;; {Generic Values}
;;;
(define-class <gvalue-class> (<gtype-class>))
(define-class <gvalue> ()
(value #:class <read-only-slot>)
#:gtype-name #t
#:metaclass <gvalue-class>)
(dynamic-call "scm_init_gnome_gobject_values"
(dynamic-link *guile-gnome-gobject-lib-path*))
(%bless-gvalue-class <gvalue>)
(define-method (allocate-instance (class <gvalue-class>) initargs)
(let ((instance (next-method)))
(%allocate-gvalue class instance)
instance))
(define-method (initialize (instance <gvalue>) initargs)
(or (memq #:value initargs)
(gruntime-error "Missing #:value argument"))
(%gvalue-set! instance (get-keyword #:value initargs 'foo)))
(define-method (write (obj <gvalue>) file)
(format file "#<~a ~a ~a>"
(class-name (class-of obj))
(number->string (object-address obj) 16)
(let ((converted (gvalue->scm obj)))
;; should be able to use eq?, but gvalue->scm always rips us
;; a fresh one. bugs, bugs..
(if (is-a? converted <gvalue>)
"[native]"
converted))))
;;;
;;; {Simple Classes}
;;;
(define-class-with-docs <gchar> (<gvalue>)
"A @code{<gvalue>} class for signed 8-bit values."
#:gtype-name "gchar")
(define-class-with-docs <guchar> (<gvalue>)
"A @code{<gvalue>} class for unsigned 8-bit values."
#:gtype-name "guchar")
(define-class-with-docs <gboolean> (<gvalue>)
"A @code{<gvalue>} class for boolean values."
#:gtype-name "gboolean")
(define-class-with-docs <gint> (<gvalue>)
"A @code{<gvalue>} class for signed 32-bit values."
#:gtype-name "gint")
(define-class-with-docs <guint> (<gvalue>)
"A @code{<gvalue>} class for unsigned 32-bit values."
#:gtype-name "guint")
(define-class-with-docs <glong> (<gvalue>)
"A @code{<gvalue>} class for signed ``long'' (32- or 64-bit)
values."
#:gtype-name "glong")
(define-class-with-docs <gulong> (<gvalue>)
"A @code{<gvalue>} class for unsigned ``long'' (32- or 64-bit)
values."
#:gtype-name "gulong")
(define-class-with-docs <gint64> (<gvalue>)
"A @code{<gvalue>} class for signed 64-bit values."
#:gtype-name "gint64")
(define-class-with-docs <guint64> (<gvalue>)
"A @code{<gvalue>} class for unsigned 64-bit values."
#:gtype-name "guint64")
(define-class-with-docs <gfloat> (<gvalue>)
"A @code{<gvalue>} class for 32-bit floating-point values."
#:gtype-name "gfloat")
(define-class-with-docs <gdouble> (<gvalue>)
"A @code{<gvalue>} class for 64-bit floating-point values."
#:gtype-name "gdouble")
(define-class-with-docs <gchararray> (<gvalue>)
"A @code{<gvalue>} class for arrays of 8-bit values (C strings)."
#:gtype-name "gchararray")
(define-class-with-docs <gboxed> (<gvalue>)
"A @code{<gvalue>} class for ``boxed'' types, a way of wrapping
generic C structures. You won't see instances of this class, only of its
subclasses."
#:gtype-name "GBoxed")
(define-class-with-docs <gvalue-array> (<gboxed>)
"A @code{<gvalue>} class for arrays of @code{<gvalue>}."
#:gtype-name "GValueArray")
(define-class-with-docs <gboxed-scm> (<gboxed>)
"A @code{<gboxed>} class for holding arbitrary Scheme objects."
#:gtype-name "GBoxedSCM")
(define-class-with-docs <gpointer> (<gvalue>)
"A @code{<gvalue>} class for opaque pointers."
#:gtype-name "gpointer")
;;;
;;; {Enums}
;;;
(define (vtable-ref vtable keyfunc val)
(let lp ((i (1- (vector-length vtable))))
(cond ((< i 0) (gruntime-error "No such value in ~A: ~A" vtable val))
((equal? (keyfunc (vector-ref vtable i)) val)
(vector-ref vtable i))
(else (lp (1- i))))))
(define vtable-symbol car)
(define vtable-name cadr)
(define vtable-index caddr)
(define (vtable-by-value vtable v)
(vtable-ref vtable
(cond ((integer? v) vtable-index)
((symbol? v) vtable-symbol)
((string? v) vtable-name)
(else (gruntime-error "Wrong type argument: ~S" v)))
v))
(define-class <genum-class> (<gvalue-class>))
(define-class-with-docs <genum> (<gvalue>)
"A @code{<gvalue>} base class for enumerated values. Users may define
new enumerated value types via subclssing from @code{<genum>}, passing
@code{#:vtable @var{table}} as an initarg, where @var{table} should be
in a format suitable for passing to @code{genum-register-static}."
#:gtype-name "GEnum"
#:metaclass <genum-class>)
(define (has-kw-arg? args key)
(cond ((null? args) #f)
((eq? (car args) key) #t)
(else (has-kw-arg? (cddr args) key))))
(define (supply-initarg-if-missing initargs key proc)
(cond ((has-kw-arg? initargs key) initargs)
(else (cons* key (proc initargs) initargs))))
(define (override-initarg initargs key val)
(cons* key val initargs))
(define (kw-ref initargs key)
(or (has-kw-arg? initargs key)
(error "Missing required keyword argument:" key))
(get-keyword key initargs #f))
(define-method (initialize (class <genum-class>) initargs)
(next-method class
(supply-initarg-if-missing
initargs #:gtype-name
(lambda (initargs)
(let ((name (class-name->gtype-name (kw-ref initargs #:name))))
(genum-register-static name (kw-ref initargs #:vtable))
name)))))
(define-method (initialize (instance <genum>) initargs)
(next-method
instance
(override-initarg
initargs #:value
(vtable-index
(vtable-by-value
(genum-class->value-table (class-of instance))
(kw-ref initargs #:value))))))
(define-method (write (obj <genum>) file)
(format file "#<~a ~a ~a>"
(class-name (class-of obj))
(number->string (object-address obj) 16)
(genum->symbol obj)))
(define (genum->enum obj)
(vtable-by-value (genum-class->value-table (class-of obj))
(genum->value obj)))
(define (genum->symbol obj)
"Convert the enumerated value @var{obj} from a @code{<gvalue>} to its
symbol representation (its ``nickname'')."
(vtable-symbol (genum->enum obj)))
(define (genum->name obj)
"Convert the enumerated value @var{obj} from a @code{<gvalue>} to its
representation as a string (its ``name'')."
(vtable-name (genum->enum obj)))
;;;
;;; {Flags}
;;;
(define-class <gflags-class> (<gvalue-class>))
(define-class-with-docs <gflags> (<gvalue>)
"A @code{<gvalue>} base class for flag values. Users may define new
flag value types via subclssing from @code{<gflags>}, passing
@code{#:vtable @var{table}} as an initarg, where @var{table} should be
in a format suitable for passing to @code{gflags-register-static}."
#:gtype-name "GFlags"
#:metaclass <gflags-class>)
(define-method (initialize (class <gflags-class>) initargs)
(next-method class
(supply-initarg-if-missing
initargs #:gtype-name
(lambda (initargs)
(let ((name (class-name->gtype-name (kw-ref initargs #:name))))
(gflags-register-static name (kw-ref initargs #:vtable))
name)))))
(define-method (write (obj <gflags>) file)
(format file "#<~a ~a ~a>"
(class-name (class-of obj))
(number->string (object-address obj) 16)
(gflags->symbol-list obj)))
(define (gflags->element-list obj)
(let ((vtable (gflags-class->value-table (class-of obj)))
(value (gflags->value obj)))
(filter (lambda (v)
(= (logand value (vtable-index v)) (vtable-index v)))
(vector->list vtable))))
(define (gflags->symbol-list obj)
"Convert the flags value @var{obj} from a @code{<gvalue>} to a list of
the symbols that it represents."
(map vtable-symbol (gflags->element-list obj)))
(define (gflags->name-list obj)
"Convert the flags value @var{obj} from a @code{<gvalue>} to a list of
strings, the names of the values it represents."
(map vtable-name (gflags->element-list obj)))
(define (gflags->value-list obj)
"Convert the flags value @var{obj} from a @code{<gvalue>} to a list of
integers, which when @code{logand}'d together yield the flags' value."
(map vtable-index (gflags->element-list obj)))
|