blob: 63f3e24c2d42437aa6b77989b28e7c3045644a94 (
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
|
(in-package #:mulk.objective-cl)
;;; (@* "Method invocation")
(defun invoke (receiver message-start &rest message-components)
"FIXME"
(flet ((message-component->string (component)
()))
(do ((message-string ())))))
(defun invoke-by-name (receiver method-name &rest args)
"FIXME"
(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)))
(when *trace-method-calls*
(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 invoke-instance-method-by-name (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))))
;;; (@* "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"))))
|
