From 9bcf5f61465b954837dea6472c7bdd6972d81f8b Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 13 Mar 2008 14:16:07 +0100
Subject: Add an internal reader macro for more readable type declarations.

darcs-hash:362e46ca84f20400936f066b7c7335417dcffa82
---
 Lisp/internal-reader-syntax.lisp | 91 ++++++++++++++++++++++++++++++++++++++++
 Lisp/reader-syntax.lisp          | 13 ------
 objective-cl.asd                 |  4 +-
 3 files changed, 94 insertions(+), 14 deletions(-)
 create mode 100644 Lisp/internal-reader-syntax.lisp

diff --git a/Lisp/internal-reader-syntax.lisp b/Lisp/internal-reader-syntax.lisp
new file mode 100644
index 0000000..e7bade8
--- /dev/null
+++ b/Lisp/internal-reader-syntax.lisp
@@ -0,0 +1,91 @@
+;;;; 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 enable-type-declaration-syntax ()
+  (save-readtable)
+  (set-dispatch-macro-character #\# #\? #'read-type-declaration))
+
+
+(defun disable-type-declaration-syntax ()
+  (restore-readtable))
+
+
+(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
+                                                          #'eq
+                                                          :count 2))
+           (function-name (cadr defun-form))
+           (arg-types (first typedecl-parts))
+           (return-types (second typedecl-parts)))
+    `(progn
+       (declaim (ftype ,function-name
+                       (function (,@arg-types) (values ,@return-types))))
+       ,defun-form))))
diff --git a/Lisp/reader-syntax.lisp b/Lisp/reader-syntax.lisp
index a8a4978..18174d2 100644
--- a/Lisp/reader-syntax.lisp
+++ b/Lisp/reader-syntax.lisp
@@ -20,19 +20,6 @@
 
 (defvar *method-syntax-macro-chars* (list))
 (defvar *bracket-syntax-macro-chars* (list))
-(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 enable-method-syntax ()
diff --git a/objective-cl.asd b/objective-cl.asd
index 96d94f6..dbc056e 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -102,7 +102,9 @@
                                                           "conditions"
                                                           "memory-management"))
                  (:file "reader-syntax"      :depends-on ("defpackage"
-                                                          "method-invocation"))
+                                                          "method-invocation"
+                                                          "internal-reader-syntax"))
+                 (:file "internal-reader-syntax" :depends-on ("defpackage"))
                  (:file "utilities"          :depends-on ("init"
                                                           "defpackage"
                                                           "method-invocation"
-- 
cgit v1.2.3