blob: c7e881041998c0167dc6e9f995db5307a866e61b (
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
97
|
(in-package #:mulk.objective-cl)
;;; (@* "Method invocation")
(defun invoke (receiver message-start &rest message-components)
"FIXME"
(flet ((message-component->string (symbol)
(let* ((components (split-sequence #\- (symbol-name symbol)
:remove-empty-subseqs t))
(acc-string
(reduce #'(lambda (x y) (concatenate 'string x y))
(mapcar #'(lambda (x)
(concatenate 'string
(string (char x 0))
(string-downcase (subseq x 1))))
(subseq components 1))
:initial-value (string-downcase (first components)))))
(if (eql (find-package '#:keyword)
(symbol-package symbol))
(concatenate 'string acc-string ":")
acc-string))))
(do* ((components-left (cons message-start message-components)
(cddr components-left))
(message-string (message-component->string message-start)
(concatenate 'string
message-string
(message-component->string (first components-left))))
(arglist (if (null (rest components-left))
nil
(list (second components-left)))
(if (null (rest components-left))
arglist
(cons (second components-left) arglist))))
((null (cddr components-left))
(apply #'invoke-by-name receiver message-string (nreverse arglist))))))
(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"))))
|
