Refactor directory and source file layout.

darcs-hash:0eb031a60f3b86a678869960867410811ca5325c

1 files changed, 61 insertions, 0 deletions

diff --git a/Lisp/reader-syntax.lisp b/Lisp/reader-syntax.lisp
new file mode 100644
index 0000000..4a1491f
--- /dev/null
+++ b/Lisp/reader-syntax.lisp
@@ -0,0 +1,61 @@
+(in-package #:mulk.objective-cl)
+
+
+(defun install-reader-syntax ()
+  (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)
+                             `(objcl-find-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
+               'objcl-invoke-class-method
+               #+nil 'objcl-invoke-instance-method
+               #-nil 'objcl-invoke-class-method)
+           ,receiver
+           ,(make-array (list (length message))
+                        :element-type 'character
+                        :initial-contents message
+                        :adjustable nil
+                        :fill-pointer nil)
+           ,@args)))))