reader-syntax.lisp

   1 (in-package :objcffi)
   2
   3 (defun read-until-characters (stream characters &key (eof 'eof) (skip t))
   4   (let* ((eos nil)
   5          (string (with-output-to-string (result)
   6                    (if skip
   7                        (loop for char = (read-char stream nil eof)
   8                           until (or (eq eof char) (find char characters :test #'char=))
   9                           do (write-char char result)
  10                           finally (setq eos char))
  11                        (loop for char = (peek-char nil stream)
  12                           until (or (eq eof char) (find char characters :test #'char=))
  13                           do (read-char stream nil)
  14                           do (write-char char result)
  15                           finally (setq eos char))))))
  16     (values string eos)))
  17
  18 (defun probably-objc-class-name (object name)
  19   (and (not (string= "" name))
  20        (symbolp object)
  21        (upper-case-p (elt name 0))))
  22
  23 (defun skip-whitespace (stream)
  24   (do ((ch (peek-char nil stream nil #\!)
  25            (peek-char nil stream nil #\!)))
  26       ((not (find ch '(#\Space #\Tab #\Newline #\Return))))
  27     (read-char stream)))
  28
  29 (defun utf-8-string (string)
  30   #+sbcl (sb-ext:string-to-octets string :external-format :utf-8))
  31
  32 (defun enable-objc-reader-syntax ()
  33   ;; Makes the following assumptions
  34   ;; if the first expression e.g. [expression ...]
  35   ;; starts with either #\[ or #\(,
  36   ;;   then it is a compound expression so (read) it
  37   ;; otherwise read up to 'whitespace'
  38   ;;   (which is assumed to be any of (#\space #\tab #\newline #\return))
  39   ;; and check if it "looks" like an objc-class-name
  40   (set-macro-character #\@ (lambda (stream char) ;; TODO if its not a string produce a warning
  41                              `(send "NSString" "stringWithUTF8String:" ,(utf-8-string (read stream)))))
  42   (set-macro-character #\] (get-macro-character #\) nil))
  43   (set-macro-character #\[ (lambda (stream char)
  44                              (declare (ignore char))
  45                                  (let* (object-name object
  46                                         (selector-name "")
  47                                         (parameters nil))
  48                                    (if (find (peek-char t stream) '(#\[ #\()) ;; this is -really- bad
  49                                        (setf object-name ""
  50                                              object (read stream))
  51                                        (setf object-name (read-until-characters stream
  52                                                            '(#\space #\tab #\newline #\return)) ;; again this sucks, a lot
  53                                              object (read-from-string object-name)))
  54                                    (labels ((read-parameter ()
  55                                               (skip-whitespace stream)
  56                                               (multiple-value-bind (name end)
  57                                                   (read-until-characters stream ":]")
  58                                                 (cond ((char= #\: end)
  59                                                        (setf selector-name
  60                                                              (concatenate 'string selector-name name ":"))
  61                                                        (push (read stream) parameters)
  62                                                        (read-parameter))
  63                                                       (t (setf selector-name
  64                                                                (concatenate 'string selector-name name)))))))
  65                                      (read-parameter))
  66                                    (setf parameters (reverse parameters))
  67                                    (append (list 'send
  68                                                  (if (probably-objc-class-name object object-name) object-name object)
  69                                                  selector-name)
  70                                            parameters)))))