PageRenderTime 20ms CodeModel.GetById 8ms app.highlight 8ms RepoModel.GetById 1ms app.codeStats 0ms

/trunk/Lib/guile/common.scm

#
Lisp | 70 lines | 43 code | 11 blank | 16 comment | 0 complexity | b0f17388ccd067039a4179da43f3f5b5 MD5 | raw file
 1;;;************************************************************************
 2;;;*common.scm
 3;;;*
 4;;;*     This file contains generic SWIG GOOPS classes for generated
 5;;;*     GOOPS file support
 6;;;************************************************************************
 7
 8(define-module (Swig swigrun))
 9
10(define-module (Swig common)
11  #:use-module (oop goops)
12  #:use-module (Swig swigrun))
13
14(define-class <swig-metaclass> (<class>)
15  (new-function #:init-value #f))
16
17(define-method (initialize (class <swig-metaclass>) initargs)
18  (slot-set! class 'new-function (get-keyword #:new-function initargs #f))
19  (next-method))
20
21(define-class <swig> () 
22  (swig-smob #:init-value #f)
23  #:metaclass <swig-metaclass>
24)
25
26(define-method (initialize (obj <swig>) initargs)
27  (next-method)
28  (slot-set! obj 'swig-smob
29    (let ((arg (get-keyword #:init-smob initargs #f)))
30      (if arg
31        arg
32        (let ((ret (apply (slot-ref (class-of obj) 'new-function) (get-keyword #:args initargs '()))))
33          ;; if the class is registered with runtime environment,
34          ;; new-Function will return a <swig> goops class.  In that case, extract the smob
35          ;; from that goops class and set it as the current smob.
36          (if (slot-exists? ret 'swig-smob)
37            (slot-ref ret 'swig-smob)
38            ret))))))
39
40(define (display-address o file)
41  (display (number->string (object-address o) 16) file))
42
43(define (display-pointer-address o file)
44  ;; Don't fail if the function SWIG-PointerAddress is not present.
45  (let ((address (false-if-exception (SWIG-PointerAddress o))))
46    (if address
47	(begin
48	  (display " @ " file)
49	  (display (number->string address 16) file)))))
50
51(define-method (write (o <swig>) file)
52  ;; We display _two_ addresses to show the object's identity:
53  ;;  * first the address of the GOOPS proxy object,
54  ;;  * second the pointer address.
55  ;; The reason is that proxy objects are created and discarded on the
56  ;; fly, so different proxy objects for the same C object will appear.
57  (let ((class (class-of o)))
58    (if (slot-bound? class 'name)
59	(begin
60	  (display "#<" file)
61	  (display (class-name class) file)
62	  (display #\space file)
63	  (display-address o file)
64	  (display-pointer-address o file)
65	  (display ">" file))
66	(next-method))))
67                                              
68(export <swig-metaclass> <swig>)
69
70;;; common.scm ends here