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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
;;;; Objective-CL, an Objective-C bridge for Common Lisp.
;;;; Copyright (C) 2007, 2008 Matthias Andreas Benkard.
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public License
;;;; as published by the Free Software Foundation, either version 3 of
;;;; the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this program. If not, see
;;;; <http://www.gnu.org/licenses/>.
(in-package #:mulk.objective-cl)
(defvar *readtable-stack* (list))
(defun restore-readtable ()
(when *readtable-stack*
(setq *readtable* (pop *readtable-stack*)))
(values))
(defun save-readtable ()
(push *readtable* *readtable-stack*)
(setq *readtable* (copy-readtable *readtable*))
(values))
(defun in-type-declaration-syntax ()
(setq *readtable* (copy-readtable *readtable*))
(set-dispatch-macro-character #\# #\? #'read-type-declaration)
(values))
(defun enable-type-declaration-syntax ()
(save-readtable)
(set-dispatch-macro-character #\# #\? #'read-type-declaration)
(values))
(defun disable-type-declaration-syntax ()
(restore-readtable)
(values))
(defun read-type-declaration (stream subchar argument)
(declare (ignore argument))
(let (defun-form typedecl-string)
(loop with finished-p = nil
with next-char = nil
with next-subchar = nil
until finished-p
for char = (read-char stream nil nil t)
while char
if (char= char #\Newline)
if (and (setq next-char (read-char stream nil nil t))
(char= next-char #\#))
if (and (setq next-subchar (read-char stream nil nil t))
(char= next-subchar subchar))
do (progn)
else do (progn
(cerror "Ignore the current line."
"Unknown macro subcharacter ~S found while ~
reading type declaration."
next-subchar)
(read-line stream t nil t)
(unread-char #\Newline stream))
else do (progn
(unread-char next-char stream)
(setq defun-form (read stream t nil t))
(setq finished-p t))
else
collect char into collected-chars
finally
(setq typedecl-string (coerce collected-chars 'string)))
(let* ((eof-value (gensym))
(typedecl (with-input-from-string (in typedecl-string)
(loop for x = (read in nil eof-value nil)
until (eq x eof-value)
collect x)))
(typedecl-parts
(split-sequence:split-sequence '->
typedecl
:test #'(lambda (x y)
(and (symbolp x)
(symbolp y)
(string=
(symbol-name x)
(symbol-name y))))
:count 2))
(arg-types (first typedecl-parts))
(return-types (second typedecl-parts))
(return-type `(values ,@return-types
,@(unless
(member '&rest return-types)
'(&rest nil)))))
(destructuring-bind (head function-name lambda-list . body) defun-form
(let* ((decls-end (position-if #'(lambda (form)
(not (or (stringp form)
(and (listp form)
(eq (first form)
'declare)))))
body))
(declarations-and-docs (subseq body 0 decls-end))
(real-body (subseq body decls-end)))
`(progn
(declaim (ftype (function (,@arg-types) ,return-type)
,function-name))
(,head ,function-name ,lambda-list
,@declarations-and-docs
(declare
,@(loop for arg in lambda-list
for type in arg-types
for arg-name = (cond ((atom arg) arg)
(t (car arg)))
unless (or (member arg lambda-list-keywords)
(and (symbolp type)
(string= (symbol-name type) "*")))
collect `(type ,type ,arg-name)))
(the ,return-type
,@real-body))))))))
|
