Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | ;;;************************************************************************ |
2 | ;;;*common.scm | |
3 | ;;;* | |
4 | ;;;* This file contains generic SWIG GOOPS classes for generated | |
5 | ;;;* GOOPS file support | |
6 | ;;;* | |
7 | ;;;* Copyright (C) 2003 John Lenz (jelenz@wisc.edu) | |
8 | ;;;* Copyright (C) 2004 Matthias Koeppe (mkoeppe@mail.math.uni-magdeburg.de) | |
9 | ;;;* | |
10 | ;;;* This file may be freely redistributed without license or fee provided | |
11 | ;;;* this copyright message remains intact. | |
12 | ;;;************************************************************************ | |
13 | ||
14 | (define-module (Swig swigrun)) | |
15 | ||
16 | (define-module (Swig common) | |
17 | #:use-module (oop goops) | |
18 | #:use-module (Swig swigrun)) | |
19 | ||
20 | (define-class <swig-metaclass> (<class>) | |
21 | (new-function #:init-value #f)) | |
22 | ||
23 | (define-method (initialize (class <swig-metaclass>) initargs) | |
24 | (slot-set! class 'new-function (get-keyword #:new-function initargs #f)) | |
25 | (next-method)) | |
26 | ||
27 | (define-class <swig> () | |
28 | (swig-smob #:init-value #f) | |
29 | #:metaclass <swig-metaclass> | |
30 | ) | |
31 | ||
32 | (define-method (initialize (obj <swig>) initargs) | |
33 | (next-method) | |
34 | (slot-set! obj 'swig-smob | |
35 | (let ((arg (get-keyword #:init-smob initargs #f))) | |
36 | (if arg | |
37 | arg | |
38 | (let ((ret (apply (slot-ref (class-of obj) 'new-function) (get-keyword #:args initargs '())))) | |
39 | ;; if the class is registered with runtime environment, | |
40 | ;; new-Function will return a <swig> goops class. In that case, extract the smob | |
41 | ;; from that goops class and set it as the current smob. | |
42 | (if (slot-exists? ret 'swig-smob) | |
43 | (slot-ref ret 'swig-smob) | |
44 | ret)))))) | |
45 | ||
46 | (define (display-address o file) | |
47 | (display (number->string (object-address o) 16) file)) | |
48 | ||
49 | (define (display-pointer-address o file) | |
50 | ;; Don't fail if the function SWIG-PointerAddress is not present. | |
51 | (let ((address (false-if-exception (SWIG-PointerAddress o)))) | |
52 | (if address | |
53 | (begin | |
54 | (display " @ " file) | |
55 | (display (number->string address 16) file))))) | |
56 | ||
57 | (define-method (write (o <swig>) file) | |
58 | ;; We display _two_ addresses to show the object's identity: | |
59 | ;; * first the address of the GOOPS proxy object, | |
60 | ;; * second the pointer address. | |
61 | ;; The reason is that proxy objects are created and discarded on the | |
62 | ;; fly, so different proxy objects for the same C object will appear. | |
63 | (let ((class (class-of o))) | |
64 | (if (slot-bound? class 'name) | |
65 | (begin | |
66 | (display "#<" file) | |
67 | (display (class-name class) file) | |
68 | (display #\space file) | |
69 | (display-address o file) | |
70 | (display-pointer-address o file) | |
71 | (display ">" file)) | |
72 | (next-method)))) | |
73 | ||
74 | (export <swig-metaclass> <swig>) | |
75 | ||
76 | ;;; common.scm ends here |