| 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 |