← Back to branch summary

~ubuntu-branches/ubuntu/lucid/gauche-c-wrapper/lucid

« back to all changes in this revision

Viewing changes to objc/objc-wrapper.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2008-04-07 09:15:03 UTC
  • Revision ID: james.westby@ubuntu.com-20080407091503-wu0h414koe95kj4i
Tags: upstream-0.5.2
Import upstream version 0.5.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
objc/objc-wrapper.scm
 
1
;; -*- coding: utf-8; mode: scheme -*-
 
2
;;
 
3
;; objc-wrapper.scm - A generic wrapper for Objective-C libraries
 
4
;; 
 
5
;;  Copyright (c) 2006 KOGURO, Naoki (naoki@koguro.net)
 
6
;; 
 
7
;;  Permission is hereby granted, free of charge, to any person 
 
8
;;  obtaining a copy of this software and associated 
 
9
;;  documentation files (the "Software"), to deal in the 
 
10
;;  Software without restriction, including without limitation 
 
11
;;  the rights to use, copy, modify, merge, publish, distribute, 
 
12
;;  sublicense, and/or sell copies of the Software, and to 
 
13
;;  permit persons to whom the Software is furnished to do so, 
 
14
;;  subject to the following conditions:
 
15
;; 
 
16
;;  The above copyright notice and this permission notice shall 
 
17
;;  be included in all copies or substantial portions of the 
 
18
;;  Software.
 
19
;; 
 
20
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY 
 
21
;;  KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE 
 
22
;;  WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 
 
23
;;  PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 
 
24
;;  OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
 
25
;;  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 
 
26
;;  OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 
 
27
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
28
;; 
 
29
;;  $Id: $
 
30
 
 
31
(define-module objc-wrapper
 
32
  (use util.match)
 
33
  
 
34
  (extend c-wrapper c-wrapper.objc-ffi)
 
35
 
 
36
  (export define-objc-class
 
37
          define-objc-method)
 
38
  )
 
39
 
 
40
(select-module objc-wrapper)
 
41
 
 
42
(define-syntax define-objc-class
 
43
  (syntax-rules ()
 
44
    ((_ class super-class)
 
45
     (define class
 
46
       (cast <id> (ptr (objc-make-class 'class (cast <Class> super-class))))))))
 
47
 
 
48
(define-macro (define-objc-method class ret-type lst . body)
 
49
  (receive (method-name arg-types arg-vars)
 
50
      (let loop ((rest lst)
 
51
                 (name-parts '())
 
52
                 (arg-types '())
 
53
                 (arg-vars '()))
 
54
        (match rest
 
55
         (()
 
56
          (values (string-append (string-join (reverse name-parts) ":")
 
57
                                 (if (< 1 (length name-parts)) ":" ""))
 
58
                  (reverse arg-types)
 
59
                  (reverse arg-vars)))
 
60
         ((('quote x) _ ...)
 
61
          (loop (cdr rest) (cons (x->string x) name-parts) arg-types arg-vars))
 
62
         (((? keyword? x) _ ...)
 
63
          (loop (cdr rest) (cons (x->string x) name-parts) arg-types arg-vars))
 
64
         (((? symbol? x) _ ...)
 
65
          (loop (cdr rest) name-parts (cons '<id> arg-types) (cons x arg-vars)))
 
66
         (((var type) _ ...)
 
67
          (loop (cdr rest) name-parts (cons type arg-types) (cons var arg-vars)))
 
68
         (else
 
69
          (errorf "Invalid arg spec ~s" lst))))
 
70
    (let ((sel (gensym)))
 
71
      `(begin
 
72
         (objc-add-method ,class ,method-name ,ret-type (list ,@arg-types)
 
73
                          (lambda (self ,sel ,@arg-vars)
 
74
                            (let ((super (make-super ,class self)))
 
75
                              ,@body)))
 
76
         (objc-register-method ,method-name (list ,ret-type ,@arg-types))))))
 
77
 
 
78
(provide "objc-wrapper")