blob: 2586b106f316cbbf456ba92c0ddeb710886d6ba1 (
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
98
99
100
101
102
103
104
105
106
107
108
|
;;;; 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))
(function-name (cadr defun-form))
(arg-types (first typedecl-parts))
(return-types (second typedecl-parts)))
`(progn
(declaim (ftype (function (,@arg-types)
(values ,@return-types
,@(unless
(member '&rest return-types)
'(&rest nil))))
,function-name))
,defun-form))))
|
