Lib/guile/common.scm

   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