4a30a92fb1
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@5180 626c5289-ae23-0410-ae9c-e8d60b6d4f22
56 lines
2 KiB
Scheme
56 lines
2 KiB
Scheme
;;;************************************************************************
|
|
;;;*common.scm
|
|
;;;*
|
|
;;;* This file contains generic SWIG GOOPS classes for generated
|
|
;;;* GOOPS file support
|
|
;;;*
|
|
;;;* Copyright (C) 2003 John Lenz (jelenz@wisc.edu)
|
|
;;;*
|
|
;;;* This file may be freely redistributed without license or fee provided
|
|
;;;* this copyright message remains intact.
|
|
;;;************************************************************************
|
|
|
|
(define-module (Swig common))
|
|
(use-modules (oop goops))
|
|
|
|
(define-class <swig-metaclass> (<class>)
|
|
(new-function #:init-value #f))
|
|
|
|
(define-method (compute-get-n-set (class <swig-metaclass>) s)
|
|
(case (slot-definition-allocation s)
|
|
((#:swig-virtual)
|
|
(list
|
|
;getter
|
|
(let ((func (get-keyword #:slot-ref (slot-definition-options s) #f)))
|
|
(lambda (x) (func (slot-ref x 'smob))))
|
|
;setter
|
|
(let ((func (get-keyword #:slot-set! (slot-definition-options s) #f)))
|
|
(lambda (x val) (func (slot-ref x 'smob) val)))))
|
|
((#:swig-virtual-class)
|
|
(list
|
|
;getter
|
|
(let ((func (get-keyword #:slot-ref (slot-definition-options s) #f))
|
|
(class (get-keyword #:class (slot-definition-options s) #f)))
|
|
(lambda (x) (make class #:init-smob (func (slot-ref x 'smob)))))
|
|
;setter
|
|
(let ((func (get-keyword #:slot-set! (slot-definition-options s) #f)))
|
|
(lambda (x val) (func (slot-ref x 'smob) (slot-ref val 'smob))))))
|
|
(else (next-method))))
|
|
|
|
(define-method (initialize (class <swig-metaclass>) initargs)
|
|
(slot-set! class 'new-function (get-keyword #:new-function initargs #f))
|
|
(next-method))
|
|
|
|
(define-class <swig> ()
|
|
(smob #:init-value #f)
|
|
#:metaclass <swig-metaclass>)
|
|
|
|
(define-method (initialize (obj <swig>) initargs)
|
|
(next-method)
|
|
(let ((arg (get-keyword #:init-smob initargs #f)))
|
|
(if arg
|
|
(slot-set! obj 'smob arg)
|
|
(slot-set! obj 'smob (apply (slot-ref (class-of obj) 'new-function)
|
|
(get-keyword #:args initargs '()))))))
|
|
|
|
(export <swig-metaclass> <swig>)
|