blob: ebd6fca51701bf46f3ccff1ffd397c3a8e304c5d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
(in-package #:mulk.objective-cl)
;;; (@* "Method invocation")
(defun objcl-invoke-class-method (receiver method-name &rest args)
(let* ((arglist (arglist-intersperse-types
(mapcar #'lisp->obj-data args)))
(return-value (apply-macro '%objcl-invoke-class-method
(lisp->obj-data receiver)
method-name
(length args)
arglist)))
(format t "~&Invoking [~A].~%" method-name)
(unwind-protect
(let ((value
(let ((*skip-retaining* (or *skip-retaining*
(constructor-name-p method-name))))
(obj-data->lisp return-value))))
(if (typep value 'condition)
(cerror "Return NIL from OBJCL-INVOKE-CLASS-METHOD" value)
value))
(dealloc-obj-data return-value))))
#+nil
(defun objcl-invoke-class-method (receiver method-name &rest args)
(let* ((arglist (arglist-intersperse-types
(mapcar #'lisp->obj-data args)))
(return-value (apply-macro '%objcl-invoke-instance-method
(lisp->obj-data receiver)
method-name
(length args)
arglist)))
(format t "~&Invoking <~A>.~%" method-name)
(unwind-protect
(let ((value
(let ((*skip-retaining* (or *skip-retaining*
(constructor-name-p method-name))))
(obj-data->lisp return-value))))
(if (typep value 'condition)
(cerror "Return NIL from OBJCL-INVOKE-INSTANCE-METHOD" value)
value))
(dealloc-obj-data return-value))))
;;; (@* "Data conversion")
(defun lisp->obj-data (value)
(let ((obj-data (foreign-alloc 'obj-data))
(type-name (lisp-value->type-name value)))
(with-foreign-slots ((type data) obj-data obj-data)
(setf (foreign-slot-value data
'obj-data-union
(type-name->slot-name type-name))
(typecase value
((or objc-id objc-class objc-selector objc-exception)
(pointer-to value))
(string (foreign-string-alloc value))
(otherwise value)))
(setf type
(foreign-string-alloc (type-name->type-id type-name))))
obj-data))
(defun obj-data->lisp (obj-data)
(with-foreign-slots ((type data) obj-data obj-data)
(let* ((type-name (type-id->type-name (foreign-string-to-lisp type)))
(lisp-type (type-name->lisp-type type-name))
(value (if (eq 'void type-name)
(values)
(foreign-slot-value data
'obj-data-union
(type-name->slot-name type-name)))))
(case lisp-type
((objc-id objc-class objc-selector objc-exception)
(make-instance lisp-type :pointer value))
((string) (foreign-string-to-lisp value))
(otherwise value)))))
;;; (@* "Helper functions")
(defun arglist-intersperse-types (arglist)
(mapcan #'(lambda (arg)
(list :pointer arg))
arglist))
(defun constructor-name-p (method-name)
(flet ((method-name-starts-with (prefix)
(and (>= (length method-name) (length prefix))
(or (and (string= prefix
(subseq method-name 0 (length prefix)))
(or (= (length method-name)
(length prefix))
(not (lower-case-p (char method-name (length prefix))))))))))
(or (method-name-starts-with "alloc")
(method-name-starts-with "new"))))
|
