Commit 00911cca authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Use *ccl-readtable*. Updated for ccl-1.11.

parent b9e719bc
......@@ -58,8 +58,8 @@ cover generic FFI to both Apple and GNUstep objc2 runtimes.
((#:albert #:docbook #:textcolor) . "black"))
#+asdf-unicode :encoding #+asdf-unicode :utf-8
:depends-on ("com.informatimago.common-lisp.cesarum")
:components ((:file "objc-support" :depends-on ())
(:file "packages" :depends-on ("objc-support"))
:components ((:file "objc-support" :depends-on ("packages"))
(:file "packages" :depends-on ())
(:file "mac-roman" :depends-on ("packages"))
. #+(and ccl darwin)
((:file "oclo-ccl" :depends-on ("packages"))
......
......@@ -31,17 +31,31 @@
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
#+(and ccl darwin)
;; We'll try to catch in this variable the objective-c reader macros
;; installed by ccl require cocoa.
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (copy-readtable ccl::%initial-readtable%)))
(defvar com.informatimago.objcl.readtable:*ccl-readtable* nil))
#+(and ccl darwin); for now, not on non-darwin
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable*
#-(and ccl darwin)
(copy-readtable nil)
#+(and ccl darwin) ; #+ccl (require :cocoa) needs the botched readtable.
(copy-readtable ccl::%initial-readtable%))
;; When we (require :objc-support) before (require :cocoa), ccl
;; can't find the main bundle. So we must require :cocoa for the
;; applications that need it.
#-darwin (require :objc-support)
#+darwin (require :cocoa)
#+darwin (require :cocoa)
(unless com.informatimago.objcl.readtable:*ccl-readtable*
(setf com.informatimago.objcl.readtable:*ccl-readtable* (copy-readtable *readtable*)))
(pushnew :objc-support *features*))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (copy-readtable nil)))
;;;; THE END ;;;;
......@@ -32,12 +32,13 @@
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>
;;;;**************************************************************************
#+(and ccl darwin)
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (copy-readtable ccl::%initial-readtable%)))
#-(and ccl darwin)
(eval-when (:compile-toplevel :load-toplevel :execute)
#+(and ccl darwin)
(setf *readtable* (copy-readtable com.informatimago.objcl.readtable:*ccl-readtable*))
#-(and ccl darwin)
(error "We need a readtable for CCL specific dispatching reader macro #$"))
(in-package "COM.INFORMATIMAGO.OBJECTIVE-CL")
(define-condition read-error (stream-error)
......@@ -117,44 +118,46 @@ Basically the same as *lisp-readtable*, but with readtable-case set to :preserve
(peek-char nil stream nil nil t)))))
(defun split-string (string &optional (separators " "))
"
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun split-string (string &optional (separators " "))
"
NOTE: current implementation only accepts as separators
a string containing literal characters.
"
(let ((chunks '())
(position 0)
(nextpos 0)
(strlen (length string)))
(loop :while (< position strlen) :do
(let ((chunks '())
(position 0)
(nextpos 0)
(strlen (length string)))
(loop :while (< position strlen) :do
(loop
:while (and (< nextpos strlen)
(not (find (aref string nextpos) separators)))
:do (incf nextpos))
:while (and (< nextpos strlen)
(not (find (aref string nextpos) separators)))
:do (incf nextpos))
(push (subseq string position nextpos) chunks)
(setf position (incf nextpos)))
(nreverse chunks)))
(nreverse chunks)))
(defun objc-to-lisp-classname (identifier &optional (*package* *package*))
(let ((classname (oclo:objc-to-lisp-classname identifier *package*)))
(etypecase classname
(string (intern classname *package*))
(symbol classname))))
(defun objc-to-lisp-identifier (identifier)
(or (oclo:objc-to-lisp-classname-p identifier)
(let ((*readtable* *lisp-readtable*))
(read-from-string identifier))))
(defun objc-to-lisp-classname (identifier &optional (*package* *package*))
(let ((classname (oclo:objc-to-lisp-classname identifier *package*)))
(etypecase classname
(string (intern classname *package*))
(symbol classname))))
(defun objc-to-lisp-message (selector)
(mapcar (lambda (name)
(if (zerop (length name))
:||
(first (oclo:objc-to-lisp-message (concatenate 'string name ":")))))
(split-string selector ":")))
(defun objc-to-lisp-identifier (identifier)
(or (oclo:objc-to-lisp-classname-p identifier)
(let ((*readtable* *lisp-readtable*))
(read-from-string identifier))))
(defun objc-to-lisp-message (selector)
(mapcar (lambda (name)
(if (zerop (length name))
:||
(first (oclo:objc-to-lisp-message (concatenate 'string name ":")))))
(split-string selector ":")))
);;eval-when
(defun read-type-specifier (stream)
(assert (eql #\( (skip-spaces stream)))
......
......@@ -37,15 +37,61 @@
(in-package "COM.INFORMATIMAGO.OBJECTIVE-C.LOWER")
(defmacro stret (expression)
(defmacro stret (expression &environment env)
(let ((result (gensym "structure-result-")))
`(slet ((,result ,expression)) ,result)))
`(slet ((,result ,(macroexpand expression env))) ,result)))
(defun needs-stret (o msg args env &optional sclassname)
(multiple-value-bind (msg args vargs) (ccl::parse-message (cons msg args))
(let ((message-info (ccl::get-objc-message-info msg)))
(unless message-info
(error "Unknown message: ~S" msg))
;; If a vararg exists, make sure that the message can accept it
(when (and vargs (not (getf (ccl::objc-message-info-flags message-info)
:accepts-varargs)))
(error "Message ~S cannot accept a variable number of arguments" msg))
(unless (= (length args) (ccl::objc-message-info-req-args message-info))
(error "Message ~S requires ~a ~d args, but ~d were provided."
msg
(if vargs "at least" "exactly")
(ccl::objc-message-info-req-args message-info)
(length args)))
(multiple-value-bind (args svarforms sinitforms) (ccl::sletify-message-args args)
(let* ((ambiguous (getf (ccl::objc-message-info-flags message-info) :ambiguous))
(methods (ccl::objc-message-info-methods message-info))
(method-info (if ambiguous
(let ((class (if sclassname
(ccl::find-objc-class sclassname)
(ccl::get-objc-class-from-declaration (ccl::declared-type o env)))))
(when class
(dolist (m methods)
(unless (getf (ccl::objc-method-info-flags m) :protocol)
(let ((mclass (or (ccl::get-objc-method-info-class m)
(error "Can't find ObjC class named ~s"
(ccl::objc-method-info-class-name m)))))
(when (subtypep class mclass)
(return m)))))))
(car methods))))
(if method-info
(ccl::result-type-requires-structure-return
(ccl::objc-method-info-result-type method-info))
(error "Cannot find method result type for message -~A sent to ~S. Try declaring the class of the recipient."
(ccl::objc-message-info-message-name message-info) o)))))))
#-(and)
(defmacro send (&whole w o msg &rest args &environment env)
(ccl::make-optimized-send o msg args env))
(if (needs-stret o msg args env)
`(stret ,w)
(ccl::make-optimized-send o msg args env)))
#-(and)
(defmacro send/stret (&whole w s o msg &rest args &environment env)
(ccl::make-optimized-send o msg args env s))
(if (needs-stret o msg args env)
(if s
(ccl::make-optimized-send o msg args env s)
`(stret (send ,@(cddr w))))
(ccl::make-optimized-send o msg args env)))
;;;; THE END ;;;;
......@@ -43,7 +43,13 @@
;; (#/initWithPath: mainBundle (namestring (truename ccl::*cocoa-ide-path*)))))))
;; #+(and ccl darwin)
(defpackage "COM.INFORMATIMAGO.OBJCL.MAC-ROMAN"
(defpackage "COM.INFORMATIMAGO.OBJECTIVE-CL.READTABLE"
(:nicknames "COM.INFORMATIMAGO.OBJCL.READTABLE")
(:use "COMMON-LISP")
(:export "*CCL-READTABLE*"))
(defpackage "COM.INFORMATIMAGO.OBJECTIVE-CL.MAC-ROMAN"
(:nicknames "COM.INFORMATIMAGO.OBJCL.MAC-ROMAN")
(:use "COMMON-LISP")
(:export "MAC-ROMAN-CHAR-P" "MAC-ROMAN-STRING-P")
(:documentation "
......@@ -56,108 +62,122 @@ This package is licensed under the GPL.
See source file for details.
"))
(defpackage "COM.INFORMATIMAGO.OBJECTIVE-C.LOWER"
(:nicknames "COM.INFORMATIMAGO.OCLO"
"OCLO")
(:use "CL")
#+(and ccl objc-support)
(:shadowing-import-from "OBJC"
"*OBJC-DESCRIPTION-MAX-LENGTH*"
"@CLASS"
"@SELECTOR"
"DEFINE-OBJC-CLASS-METHOD"
"DEFINE-OBJC-METHOD"
"DEFMETHOD"
"LISP-STRING-FROM-NSSTRING"
"LOAD-FRAMEWORK"
"MAKE-NSSTRING"
"MAKE-OBJC-INSTANCE"
"OBJC-CLASS"
"OBJC-CLASS-OBJECT"
"OBJC-MESSAGE-SEND"
"OBJC-MESSAGE-SEND-STRET"
"OBJC-MESSAGE-SEND-SUPER"
"OBJC-MESSAGE-SEND-SUPER-STRET"
"OBJC-METACLASS"
"OBJC-OBJECT"
"REMOVE-LISP-SLOTS"
"RETURNING-FOREIGN-STRUCT"
"SEND-SUPER"
"SEND-SUPER/STRET"
;; "SEND"
;; "SEND/STRET"
"WITH-AUTORELEASE-POOL"
"WITH-AUTORELEASED-NSSTRINGS")
#+(and ccl objc-support)
(:shadowing-import-from "CCL"
#-ccl-1.9 "*COCOA-APPLICATION-FRAMEWORKS*"
"@"
"DEFINE-CLASSNAME-TRANSLATION"
"LISP-TO-OBJC-CLASSNAME"
"LISP-TO-OBJC-MESSAGE"
"OBJC-TO-LISP-CLASSNAME"
"OBJC-TO-LISP-MESSAGE"
"SLET"
"UPDATE-OBJC-METHOD-INFO")
(:export
"SELF" "SUPER"
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *oclo-ccl-symbol-names*)
(defparameter *oclo-objc-symbol-names*
'("*OBJC-DESCRIPTION-MAX-LENGTH*"
"@CLASS"
"@SELECTOR"
"DEFINE-OBJC-CLASS-METHOD"
"DEFINE-OBJC-METHOD"
"DEFMETHOD"
"LISP-STRING-FROM-NSSTRING"
"LOAD-FRAMEWORK"
"MAKE-NSSTRING"
"MAKE-OBJC-INSTANCE"
"OBJC-CLASS"
"OBJC-CLASS-OBJECT"
"OBJC-MESSAGE-SEND"
"OBJC-MESSAGE-SEND-STRET"
"OBJC-MESSAGE-SEND-SUPER"
"OBJC-MESSAGE-SEND-SUPER-STRET"
"OBJC-METACLASS"
"OBJC-OBJECT"
"REMOVE-LISP-SLOTS"
"RETURNING-FOREIGN-STRUCT"
"SEND-SUPER"
"SEND-SUPER/STRET"
"SEND"
"SEND/STRET"
"WITH-AUTORELEASE-POOL"
"WITH-AUTORELEASED-NSSTRINGS"
#-ccl-1.9 "*COCOA-APPLICATION-FRAMEWORKS*"
"@"
"DEFINE-CLASSNAME-TRANSLATION"
"LISP-TO-OBJC-CLASSNAME"
"LISP-TO-OBJC-MESSAGE"
"OBJC-TO-LISP-CLASSNAME"
"OBJC-TO-LISP-MESSAGE"
"SLET"
"UPDATE-OBJC-METHOD-INFO")))
(print
'(defpackage "COM.INFORMATIMAGO.OBJECTIVE-C.LOWER"
(:nicknames "COM.INFORMATIMAGO.OCLO"
"OCLO")
(:use "CL")
#+(and ccl objc-support)
(:shadowing-import-from "OBJC" . #.(let ((o '())
(c '()))
(dolist (s *oclo-objc-symbol-names*)
(cond
((find-symbol s "OBJC") (push s o))
((find-symbol s "CCL") (push s c))
(t (error "~A is not found in OBJC or CCL" s))))
(setf *oclo-ccl-symbol-names* c)
o))
#+(and ccl objc-support)
(:shadowing-import-from "CCL" . #.*oclo-ccl-symbol-names*)
(:export
"SELF" "SUPER"
;; from objc.
"*OBJC-DESCRIPTION-MAX-LENGTH*"
"@CLASS"
"@SELECTOR"
"DEFINE-OBJC-CLASS-METHOD"
"DEFINE-OBJC-METHOD"
"DEFMETHOD"
"LISP-STRING-FROM-NSSTRING"
"LOAD-FRAMEWORK"
"MAKE-NSSTRING"
"MAKE-OBJC-INSTANCE"
"OBJC-CLASS"
"OBJC-CLASS-OBJECT"
"OBJC-MESSAGE-SEND"
"OBJC-MESSAGE-SEND-STRET"
"OBJC-MESSAGE-SEND-SUPER"
"OBJC-MESSAGE-SEND-SUPER-STRET"
"OBJC-METACLASS"
"OBJC-OBJECT"
"REMOVE-LISP-SLOTS"
"RETURNING-FOREIGN-STRUCT"
"SEND"
"SEND-SUPER"
"SEND-SUPER/STRET"
"SEND/STRET"
"SLET"
"WITH-AUTORELEASE-POOL"
"WITH-AUTORELEASED-NSSTRINGS"
;; from ccl.
#-ccl-1.9 "*COCOA-APPLICATION-FRAMEWORKS*"
"@"
"DEFINE-CLASSNAME-TRANSLATION"
"LISP-TO-OBJC-CLASSNAME"
"LISP-TO-OBJC-MESSAGE"
"OBJC-TO-LISP-CLASSNAME"
"OBJC-TO-LISP-MESSAGE"
"UPDATE-OBJC-METHOD-INFO"
;; implemented in oclo.lisp
"STRET"
;; implemented in oclo-<implementation>.lisp
"LISP-TO-OBJC-CLASSNAME-P"
"OBJC-TO-LISP-CLASSNAME-P"
"*NULL*" "NULLP"
"SELECTOR")
;; from objc.
"*OBJC-DESCRIPTION-MAX-LENGTH*"
"@CLASS"
"@SELECTOR"
"DEFINE-OBJC-CLASS-METHOD"
"DEFINE-OBJC-METHOD"
"DEFMETHOD"
"LISP-STRING-FROM-NSSTRING"
"LOAD-FRAMEWORK"
"MAKE-NSSTRING"
"MAKE-OBJC-INSTANCE"
"OBJC-CLASS"
"OBJC-CLASS-OBJECT"
"OBJC-MESSAGE-SEND"
"OBJC-MESSAGE-SEND-STRET"
"OBJC-MESSAGE-SEND-SUPER"
"OBJC-MESSAGE-SEND-SUPER-STRET"
"OBJC-METACLASS"
"OBJC-OBJECT"
"REMOVE-LISP-SLOTS"
"RETURNING-FOREIGN-STRUCT"
"SEND"
"SEND-SUPER"
"SEND-SUPER/STRET"
"SEND/STRET"
"SLET"
"WITH-AUTORELEASE-POOL"
"WITH-AUTORELEASED-NSSTRINGS"
;; from ccl.
#-ccl-1.9 "*COCOA-APPLICATION-FRAMEWORKS*"
"@"
"DEFINE-CLASSNAME-TRANSLATION"
"LISP-TO-OBJC-CLASSNAME"
"LISP-TO-OBJC-MESSAGE"
"OBJC-TO-LISP-CLASSNAME"
"OBJC-TO-LISP-MESSAGE"
"UPDATE-OBJC-METHOD-INFO"
;; implemented in oclo.lisp
"STRET"
;; implemented in oclo-<implementation>.lisp
"LISP-TO-OBJC-CLASSNAME-P"
"OBJC-TO-LISP-CLASSNAME-P"
"*NULL*" "NULLP"
"SELECTOR")
(:documentation "
(:documentation "
This package exports low level Objective-C stuff,
basically the ccl Objective-C bridge, in a nifty
single package exporting all these symbols.
"))
")))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment