1;; guile-gnome 2;; Copyright (C) 2003,2004,2015 Andy Wingo <wingo at pobox dot com> 3 4;; This program is free software; you can redistribute it and/or 5;; modify it under the terms of the GNU General Public License as 6;; published by the Free Software Foundation; either version 2 of 7;; the License, or (at your option) any later version. 8;; 9;; This program is distributed in the hope that it will be useful, 10;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12;; GNU General Public License for more details. 13;; 14;; You should have received a copy of the GNU General Public License 15;; along with this program; if not, contact: 16;; 17;; Free Software Foundation Voice: +1-617-542-5942 18;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 19;; Boston, MA 02111-1307, USA gnu@gnu.org 20 21;;; Commentary: 22;; 23;; Base support for the GLib type system. 24;; 25;; The GLib runtime type system is broken into a number of modules, of 26;; which GType is the base. A GType is a simply a named type. Some types 27;; are fundamental and cannot be subclassed, such as integers. Others 28;; can form the root of complicated object hierarchies, such as 29;; @code{<gobject>}. 30;; 31;; One can obtain the class for a type if you know its name. For 32;; example, 33;; 34;; @lisp 35;; (gtype-name->class "guint64") @result{} #<<gvalue-class> <guint64>> 36;; @end lisp 37;; 38;; A more detailed reference on the GLib type system may be had at 39;; @uref{http://library.gnome.org/devel/gobject/stable/}. 40;; 41;;; Code: 42 43(define-module (gnome gobject gtype) 44 #:use-module (oop goops) 45 #:use-module (gnome gobject utils) 46 #:use-module (gnome gobject config) 47 #:export (<gtype-class> <gtype-instance> 48 gtype-name->class class-name->gtype-name 49 gruntime-error 50 gtype-instance-destroy!)) 51 52(eval-when (expand load eval) 53 (dynamic-call "scm_init_gnome_gobject_gc" 54 (dynamic-link *guile-gnome-gobject-lib-path*)) 55 (dynamic-call "scm_init_gnome_gobject_types" 56 (dynamic-link *guile-gnome-gobject-lib-path*))) 57 58(define (gruntime-error format-string . args) 59 "Signal a runtime error. The error will be thrown to the key 60@code{gruntime-error}." 61 (scm-error 'gruntime-error #f format-string args '())) 62 63 64;;; 65;;; {Base Class Hierarchy] 66;;; 67 68(define-class-with-docs <gtype-class> (<class>) 69 "The metaclass of all GType classes. Ensures that GType classes have a 70@code{gtype} slot, which records the primitive GType information for 71this class." 72 (gtype #:class <foreign-slot>)) 73 74(define-method (initialize (class <gtype-class>) initargs) 75 (let ((gtype-name (or (get-keyword #:gtype-name initargs #f) 76 (gruntime-error "Need #:gtype-name initarg: ~a" 77 (pk initargs))))) 78 ;; allow gtype-name of #t for base classes without gtypes (e.g. 79 ;; <gtype-instance>) 80 (if (not (eq? gtype-name #t)) 81 (%gtype-class-bind class gtype-name)) 82 (next-method) 83 (%gtype-class-inherit-magic class))) 84 85(define-method (write (class <gtype-class>) file) 86 (format file "#<~a ~a>" (class-name (class-of class)) (class-name class))) 87 88(eval-when (expand load eval) 89 (dynamic-call "scm_init_gnome_gobject_types_gtype_class" 90 (dynamic-link *guile-gnome-gobject-lib-path*))) 91 92(define-class-with-docs <gtype-instance> () 93 "The root class of all instantiatable GType classes. Adds a slot, 94@code{gtype-instance}, to instances, which holds a pointer to the C 95value." 96 (gtype-instance #:class <read-only-slot>) 97 #:gtype-name #t 98 #:metaclass <gtype-class>) 99 100(define-method (initialize (instance <gtype-instance>) initargs) 101 (next-method) 102 (%gtype-instance-construct instance initargs)) 103 104(eval-when (expand load eval) 105 (dynamic-call "scm_init_gnome_gobject_types_gtype_instance" 106 (dynamic-link *guile-gnome-gobject-lib-path*))) 107 108 109;;; 110;;; {Misc] 111;;; 112 113(define (class-name->gtype-name class-name) 114 "Convert the name of a class into a suitable name for a GType. For 115example: 116 117@lisp 118 (class-name->gtype-name '<foo-bar>) @result{} \"FooBar\" 119@end lisp" 120 ;; By convention, GTypes are named with StudlyCaps. 121 (list->string 122 (reverse! 123 (let loop ((to-process (string->list (symbol->string class-name))) (ret '()) (caps? #t)) 124 (cond 125 ((null? to-process) 126 ret) 127 ((char-alphabetic? (car to-process)) 128 (loop (cdr to-process) 129 (cons (if caps? (char-upcase (car to-process)) (car to-process)) ret) 130 #f)) 131 ((char-numeric? (car to-process)) 132 (loop (cdr to-process) 133 (cons (car to-process) ret) 134 #f)) 135 (else 136 (loop (cdr to-process) ret #t))))))) 137