da75eb42 | (in-package :objc-runtime) |
116081f3 | #+ccl (defgeneric send-message (object message &rest args) (:method ((object ccl:macptr) (message (eql 'alloc)) &rest args) (apply #'objc-msg-send object (ensure-selector "alloc") args))) |
6b08248f | (defun read-until (test symbol-prefix &optional stop-before-chars) "Read from a string until" (lambda (s c b) (declare (ignore c b)) (let ((class-name (coerce (loop for next-char = (peek-char nil s nil nil t) |
9a92915d | while next-char until (funcall test next-char) collect (read-char s t nil t) finally (when (and (not (member next-char stop-before-chars)) (funcall test next-char)) (read-char s t nil t))) |
6b08248f | 'string))) `(,symbol-prefix ,class-name)))) |
9a92915d | (defun read-objc-form (s char) (declare (ignore char)) (flet ((get-call-form (safe-p result-type base-form) (if safe-p `(safe-objc-msg-send ,result-type) `(,base-form)))) (let* ((info (read-delimited-list #\] s t)) (safe-p (when (eql #\? (peek-char nil s nil #\p t)) (read-char s t nil t))) (msg-send (case (peek-char nil s nil #\p t) (#\# (read-char s t nil t) (get-call-form safe-p 'num 'objc-msg-send-int)) (#\& (read-char s t nil t) (get-call-form safe-p 'id 'objc-msg-send)) (#\@ (read-char s t nil t) (get-call-form safe-p 'nsstring 'objc-msg-send-nsstring)) (#\b (read-char s t nil t) (get-call-form safe-p 'bool 'objc-msg-send-bool)) (#\s (read-char s t nil t) (get-call-form safe-p 'string 'objc-msg-send-string)) (t (get-call-form safe-p 'id 'objc-msg-send))))) (when info (destructuring-bind (obj message . args) info `(,@msg-send ,obj ,message ,@args)))))) |
da75eb42 | (named-readtables:defreadtable :objc-readtable (:merge :standard) (:syntax-from :standard #\) #\]) |
9a92915d | (:macro-char #\[ 'read-objc-form nil) |
da75eb42 | (:dispatch-macro-char #\# #\@ (lambda (s c b) c b |
6b08248f | (let ((class-name (coerce (loop for c = (peek-char nil s nil nil t) |
9a92915d | until (or (null c) (serapeum:whitespacep c) (member c '(#\) #\( #\[ #\]))) collect (read-char s t nil t)) |
da75eb42 | 'string))) |
382ab041 | `(ensure-class ,class-name)))) |
6b08248f | (:macro-char #\@ :dispatch t) (:dispatch-macro-char #\@ #\( (read-until (serapeum:op (char= _ #\))) 'ensure-selector)) (:dispatch-macro-char #\@ #\" (read-until (serapeum:op (char= _ #\")) 'make-nsstring))) |