Home | History | Annotate | Download | only in guile 
      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  ()
     15   (new-function #:init-value #f))
     16 
     17 (define-method (initialize (class ) initargs)
     18   (slot-set! class 'new-function (get-keyword #:new-function initargs #f))
     19   (next-method))
     20 
     21 (define-class  ()
     22   (swig-smob #:init-value #f)
     23   #:metaclass 
     24 )
     25 
     26 (define-method (initialize (obj ) 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 ) 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  )
     69 
     70 ;;; common.scm ends here
     71