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