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