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  ()
21  (new-function #:init-value #f))
22
23(define-method (initialize (class ) initargs)
24  (slot-set! class 'new-function (get-keyword #:new-function initargs #f))
25  (next-method))
26
27(define-class  ()
28  (swig-smob #:init-value #f)
29  #:metaclass 
30)
31
32(define-method (initialize (obj ) 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 ) 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  )
75
76;;; common.scm ends here
77