1;; guile-gnome 2;; Copyright (C) 2001 Martin Baulig <martin@gnome.org> 3;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com> 4 5;; This program is free software; you can redistribute it and/or 6;; modify it under the terms of the GNU General Public License as 7;; published by the Free Software Foundation; either version 2 of 8;; the License, or (at your option) any later version. 9;; 10;; This program is distributed in the hope that it will be useful, 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13;; GNU General Public License for more details. 14;; 15;; You should have received a copy of the GNU General Public License 16;; along with this program; if not, contact: 17;; 18;; Free Software Foundation Voice: +1-617-542-5942 19;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 20;; Boston, MA 02111-1307, USA gnu@gnu.org 21 22;;; Commentary: 23;; 24;; Parameters are constraints for values, both in type and in range. 25;; This module wraps the parameters code of the GLib type system, 26;; allowing parameters to be manipulated and created from Scheme. 27;; 28;; There is a parameter class for each type of parameter: 29;; @code{<gparam-int>}, @code{<gparam-object>}, etc. 30 31;; 32;;; Code: 33 34(define-module (gnome gobject gparameter) 35 #:use-module (oop goops) 36 #:use-module (gnome gobject config) 37 #:use-module (gnome gobject utils) 38 #:use-module (gnome gobject gtype) 39 #:use-module (gnome gobject gvalue) 40 41 #:export ( ;; GOOPS parameter base class 42 <gparam> 43 ;; Parameter classes 44 <gparam-char> <gparam-uchar> <gparam-boolean> <gparam-int> 45 <gparam-uint> <gparam-long> <gparam-ulong> <gparam-int64> 46 <gparam-uint64> <gparam-float> <gparam-double> 47 <gparam-unichar> <gparam-pointer> <gparam-string> 48 <gparam-boxed> <gparam-enum> <gparam-flags> <gparam-gtype> 49 ;; Helper class 50 <gparam-spec-flags> 51 ;; Limits 52 gparameter:uint-max gparameter:int-min gparameter:int-max 53 gparameter:ulong-max gparameter:long-min 54 gparameter:long-max gparameter:uint64-max 55 gparameter:int64-min gparameter:int64-max 56 gparameter:float-max gparameter:float-min 57 gparameter:double-max gparameter:double-min 58 gparameter:byte-order 59 )) 60 61(define-class-with-docs <gparam-spec-flags> (<gflags>) 62 "A @code{<gflags>} type for the flags allowable on a @code{<gparam>}: 63@code{read}, @code{write}, @code{construct}, @code{construct-only}, and 64@code{lax-validation}." 65 #:vtable 66 #((read "Readable" 1) 67 (write "Writable" 2) 68 (construct "Set on object construction" 4) 69 (construct-only "Only set on object construction" 8) 70 (lax-validation "Don't require strict validation on parameter conversion" 16))) 71 72;; The C code needs to reference <gparam> for use in its predicates. 73;; Define it now before loading the library. 74(define-class <gparam-class> (<gtype-class>) 75 (value-type #:init-keyword #:value-type)) 76 77(define-method (compute-get-n-set (class <gparam-class>) s) 78 (case (slot-definition-allocation s) 79 ((#:checked) 80 (let ((already-allocated (slot-ref class 'nfields)) 81 (pred (get-keyword #:pred (slot-definition-options s) #f)) 82 (trans (get-keyword #:trans (slot-definition-options s) #f))) 83 (or pred (gruntime-error "Missing #:pred for #:checked slot")) 84 ;; allocate a field in the struct 85 (slot-set! class 'nfields (+ already-allocated 1)) 86 ;; struct-ref and struct-set! don't work on the structs that back 87 ;; GOOPS objects, because they are "light structs", without the 88 ;; hidden word that says how many fields are in the struct. 89 ;; Patches submitted to guile-devel on 10 April 2008. Until then, 90 ;; use our own struct accessors. 91 (list (lambda (instance) 92 (%hacky-struct-ref instance already-allocated)) 93 (lambda (instance value) 94 (let ((value (if trans (trans value) value))) 95 (if (pred value) 96 (%hacky-struct-set! instance already-allocated value) 97 (gruntime-error 98 "Bad value for slot ~A on instance ~A: ~A" 99 (slot-definition-name s) instance value))))))) 100 101 (else (next-method)))) 102 103(define-class-with-docs <gparam> (<gtype-instance>) 104 "The base class for GLib parameter objects. (Doc slots)" 105 (name #:init-keyword #:name #:allocation #:checked #:pred symbol?) 106 (nick #:init-keyword #:nick #:allocation #:checked #:pred string?) 107 (blurb #:init-keyword #:blurb #:allocation #:checked #:pred string?) 108 (flags #:init-keyword #:flags #:init-value '(read write) 109 #:allocation #:checked #:pred number? 110 #:trans (lambda (x) 111 (apply + (gflags->value-list 112 (make <gparam-spec-flags> #:value x))))) 113 #:gtype-name "GParam" 114 #:metaclass <gparam-class>) 115 116 117(eval-when (expand load eval) 118 (dynamic-call "scm_init_gnome_gobject_parameters" 119 (dynamic-link *guile-gnome-gobject-lib-path*))) 120 121(define-class-with-docs <gparam-char> (<gparam>) 122 "Parameter for @code{<gchar>} values." 123 (minimum 124 #:init-keyword #:minimum #:init-value (integer->char 0) 125 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 126 (maximum 127 #:init-keyword #:maximum #:init-value (integer->char 127) 128 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 129 (default-value 130 #:init-keyword #:default-value #:init-value (integer->char 127) 131 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 132 #:value-type <gchar> 133 #:gtype-name "GParamChar") 134 135(define-class-with-docs <gparam-uchar> (<gparam>) 136 "Parameter for @code{<guchar>} values." 137 (minimum 138 #:init-keyword #:minimum #:init-value (integer->char 0) 139 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 140 (maximum 141 #:init-keyword #:maximum #:init-value (integer->char 255) 142 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 143 (default-value 144 #:init-keyword #:default-value #:init-value (integer->char 255) 145 #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x)))) 146 #:value-type <guchar> 147 #:gtype-name "GParamUChar") 148 149(define-class-with-docs <gparam-boolean> (<gparam>) 150 "Parameter for @code{<gboolean>} values." 151 (default-value 152 #:init-keyword #:default-value #:init-value #f 153 #:allocation #:checked #:pred boolean?) 154 #:value-type <gboolean> 155 #:gtype-name "GParamBoolean") 156 157(define-class-with-docs <gparam-int> (<gparam>) 158 "Parameter for @code{<gint>} values." 159 (minimum 160 #:init-keyword #:minimum #:init-value gparameter:int-min 161 #:allocation #:checked #:pred integer?) 162 (maximum 163 #:init-keyword #:maximum #:init-value gparameter:int-max 164 #:allocation #:checked #:pred integer?) 165 (default-value 166 #:init-keyword #:default-value #:init-value 0 167 #:allocation #:checked #:pred integer?) 168 #:value-type <gint> 169 #:gtype-name "GParamInt") 170 171(define-class-with-docs <gparam-uint> (<gparam>) 172 "Parameter for @code{<guint>} values." 173 (minimum 174 #:init-keyword #:minimum #:init-value 0 175 #:allocation #:checked #:pred integer?) 176 (maximum 177 #:init-keyword #:maximum #:init-value gparameter:uint-max 178 #:allocation #:checked #:pred integer?) 179 (default-value 180 #:init-keyword #:default-value #:init-value 0 181 #:allocation #:checked #:pred integer?) 182 #:value-type <guint> 183 #:gtype-name "GParamUInt") 184 185(define-class-with-docs <gparam-unichar> (<gparam>) 186 "Parameter for Unicode codepoints, represented as @code{<guint>} 187values." 188 (default-value 189 #:init-keyword #:default-value #:init-value 0 190 #:allocation #:checked #:pred integer?) 191 #:value-type <guint> 192 #:gtype-name "GParamUnichar") 193 194(define-class-with-docs <gparam-long> (<gparam>) 195 "Parameter for @code{<glong>} values." 196 (minimum 197 #:init-keyword #:minimum #:init-value gparameter:long-min 198 #:allocation #:checked #:pred integer?) 199 (maximum 200 #:init-keyword #:maximum #:init-value gparameter:long-max 201 #:allocation #:checked #:pred integer?) 202 (default-value 203 #:init-keyword #:default-value #:init-value 0 204 #:allocation #:checked #:pred integer?) 205 #:value-type <glong> 206 #:gtype-name "GParamLong") 207 208(define-class-with-docs <gparam-ulong> (<gparam>) 209 "Parameter for @code{<gulong>} values." 210 (minimum 211 #:init-keyword #:minimum #:init-value 0 212 #:allocation #:checked #:pred integer?) 213 (maximum 214 #:init-keyword #:maximum #:init-value gparameter:ulong-max 215 #:allocation #:checked #:pred integer?) 216 (default-value 217 #:init-keyword #:default-value #:init-value 0 218 #:allocation #:checked #:pred integer?) 219 #:value-type <gulong> 220 #:gtype-name "GParamULong") 221 222(define-class-with-docs <gparam-int64> (<gparam>) 223 "Parameter for @code{<gint64>} values." 224 (minimum 225 #:init-keyword #:minimum #:init-value gparameter:int64-min 226 #:allocation #:checked #:pred integer?) 227 (maximum 228 #:init-keyword #:maximum #:init-value gparameter:int64-max 229 #:allocation #:checked #:pred integer?) 230 (default-value 231 #:init-keyword #:default-value #:init-value 0 232 #:allocation #:checked #:pred integer?) 233 #:value-type <gint64> 234 #:gtype-name "GParamInt64") 235 236(define-class-with-docs <gparam-uint64> (<gparam>) 237 "Parameter for @code{<guint64>} values." 238 (minimum 239 #:init-keyword #:minimum #:init-value 0 240 #:allocation #:checked #:pred integer?) 241 (maximum 242 #:init-keyword #:maximum #:init-value gparameter:uint64-max 243 #:allocation #:checked #:pred integer?) 244 (default-value 245 #:init-keyword #:default-value #:init-value 0 246 #:allocation #:checked #:pred integer?) 247 #:value-type <guint64> 248 #:gtype-name "GParamUInt64") 249 250(define-class-with-docs <gparam-float> (<gparam>) 251 "Parameter for @code{<gfloat>} values." 252 (minimum 253 #:init-keyword #:minimum #:init-value (- gparameter:float-max) 254 #:allocation #:checked #:pred real?) 255 (maximum 256 #:init-keyword #:maximum #:init-value gparameter:float-max 257 #:allocation #:checked #:pred real?) 258 (default-value 259 #:init-keyword #:default-value #:init-value 0.0 260 #:allocation #:checked #:pred real?) 261 #:value-type <gfloat> 262 #:gtype-name "GParamFloat") 263 264(define-class-with-docs <gparam-double> (<gparam>) 265 "Parameter for @code{<gdouble>} values." 266 (minimum 267 #:init-keyword #:minimum #:init-value (- gparameter:double-max) 268 #:allocation #:checked #:pred real?) 269 (maximum 270 #:init-keyword #:maximum #:init-value gparameter:double-max 271 #:allocation #:checked #:pred real?) 272 (default-value 273 #:init-keyword #:default-value #:init-value 0.0 274 #:allocation #:checked #:pred real?) 275 #:value-type <gdouble> 276 #:gtype-name "GParamDouble") 277 278(define-class-with-docs <gparam-pointer> (<gparam>) 279 "Parameter for @code{<gpointer>} values." 280 #:value-type <gpointer> 281 #:gtype-name "GParamPointer") 282 283(define-class-with-docs <gparam-string> (<gparam>) 284 "Parameter for @code{<gchararray>} values." 285 (default-value 286 #:init-keyword #:default-value #:init-value "" 287 #:allocation #:checked #:pred (lambda (x) (or (not x) (string? x)))) 288 #:value-type <gchararray> 289 #:gtype-name "GParamString") 290 291(define (class-is-a? x is-a) 292 (memq is-a (class-precedence-list x))) 293 294(define-class-with-docs <gparam-boxed> (<gparam>) 295 "Parameter for @code{<gboxed>} values." 296 (boxed-type 297 #:init-keyword #:boxed-type #:allocation #:checked 298 #:pred (lambda (x) (class-is-a? x <gboxed>))) 299 #:value-type <gboxed> 300 #:gtype-name "GParamBoxed") 301 302(define-class-with-docs <gparam-enum> (<gparam>) 303 "Parameter for @code{<genum>} values." 304 (enum-type 305 #:init-keyword #:enum-type #:allocation #:checked 306 #:pred (lambda (x) (class-is-a? x <genum>))) 307 (default-value 308 #:init-keyword #:default-value #:init-value 0 309 #:allocation #:checked #:pred number?) 310 #:value-type <genum> 311 #:gtype-name "GParamEnum") 312 313(define-class-with-docs <gparam-flags> (<gparam>) 314 "Parameter for @code{<gflags>} values." 315 (flags-type 316 #:init-keyword #:flags-type #:allocation #:checked 317 #:pred (lambda (x) (class-is-a? x <gflags>))) 318 (default-value 319 #:init-keyword #:default-value #:init-value 0 320 #:allocation #:checked #:pred number?) 321 #:value-type <gflags> 322 #:gtype-name "GParamFlags") 323 324(define-class-with-docs <gparam-value-array> (<gparam>) 325 "Parameter for @code{<gvalue-array>} values." 326 (element-spec 327 #:init-keyword #:element-spec #:allocation #:checked 328 #:pred (lambda (x) (or (not x) (is-a? x <gparam>)))) 329 #:value-type <gvalue-array> 330 #:gtype-name "GParamValueArray") 331 332(define-class-with-docs <gparam-gtype> (<gparam>) 333 "Parameter for @code{<gtype>} values." 334 (is-a-type 335 #:init-keyword #:is-a-type #:allocation #:checked 336 #:pred (lambda (x) (or (not x) (is-a? x <gtype-class>)))) 337 #:value-type <gtype-class> 338 #:gtype-name "GParamGType") 339 340;;; 341;;; {Instance Initialization} 342;;; 343 344;; fixme, make me more useful 345(define-method (write (param <gparam>) file) 346 (let ((class (class-of param)) 347 (loc (number->string (object-address param) 16))) 348 (if (slot-bound? class 'name) 349 (with-accessors (name) 350 (format file "<~a ~a ~a>" (class-name class) (name param) loc)) 351 (format file "<~a (uninitialized) ~a>" (class-name class) loc)))) 352