blob: ccb4ff01bc424319e94e7771fc9b834ddf5a23d7 (
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
|
(in-package #:mulk.objective-cl)
(defun install-reader-syntax ()
"FIXME"
(set-macro-character #\] (get-macro-character #\)))
(set-macro-character #\[ #'(lambda (stream char)
(declare (ignore char))
(parse-objc-call stream))))
(defun parse-objc-call (stream)
(let ((*standard-input* stream))
(flet ((read-message-part (buffer)
(do ((char (read-char stream t nil t)
(read-char stream t nil t)))
((not (or (alphanumericp char)
(member char (coerce ":_-" 'list))))
(unread-char char))
(vector-push-extend char buffer)))
(slurp-whitespace ()
(do ((char nil
(read-char stream t nil t)))
((not (member (peek-char) '(#\Space #\Newline #\Tab)))))))
(let* ((class-method-p nil)
(receiver (if (upper-case-p (peek-char))
;; A class name.
(let ((*readtable* (copy-readtable)))
(setf class-method-p t)
(setf (readtable-case *readtable*) :preserve)
`(find-objc-class
,(symbol-name (read stream t nil t))))
;; Something else.
(read stream t nil t)))
(args (list))
(message (make-array '(0) :element-type 'character
:adjustable t :fill-pointer t)))
(slurp-whitespace)
(do ()
((char= #\] (peek-char)))
(read-message-part message)
(slurp-whitespace)
(unless (char= #\] (peek-char))
(push (read stream t nil t) args)
(slurp-whitespace)))
;; Slurp the trailing #\].
(assert (char= #\] (read-char)))
(setf args (nreverse args))
`(,(if class-method-p
'invoke-by-name
#+nil 'objcl-invoke-instance-method
#-nil 'invoke-by-name)
,receiver
,(make-array (list (length message))
:element-type 'character
:initial-contents message
:adjustable nil
:fill-pointer nil)
,@args)))))
|
