(in-package :objc-runtime)
(serapeum:eval-always
(named-readtables:in-readtable :objc-readtable))
(serapeum:eval-always
(cffi:define-foreign-library cocoa
(:darwin (:framework "Cocoa")))
(cffi:define-foreign-library foundation
(:darwin (:framework "Foundation")))
(cffi:define-foreign-library appkit
(:darwin (:framework "AppKit"))))
(use-foreign-library foundation)
(use-foreign-library cocoa)
(use-foreign-library appkit)
(defctype o-class :pointer)
(defctype o-selector :pointer)
(defcfun (objc-look-up-class "objc_lookUpClass" :library foundation)
o-class
(name :string))
(defcfun (objc-allocate-class-pair "objc_allocateClassPair" :library foundation)
:pointer
(superclass :pointer)
(name :string)
(extra-bytes :int))
(defcfun (objc-register-class-pair "objc_registerClassPair" :library foundation)
:void
(superclass :pointer))
(defcfun (objc-get-protocol "objc_getProtocol" :library foundation)
:pointer
(name :string))
(defcfun (class-add-protocol "class_addProtocol" :library foundation)
:boolean
(class :pointer)
(protocol :pointer))
(serapeum:eval-always
(defctype sizet
:ulong
#+32-bit-target :uint))
(defcfun (class-add-ivar "class_addIvar" :library foundation)
:boolean
(class :pointer)
(name :string)
(size :ulong)
(alignment :uint8)
(types :string))
(defun add-pointer-ivar (class name)
(class-add-ivar class name
(foreign-type-size :pointer)
(floor (log (foreign-type-size :pointer)
2))
"@"))
#+nil
(defun make-app-delegate-class (outlets)
(let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
#@NSObject "AppDelegate" 0)))
(objc-runtime:add-pointer-ivar app-delegate-class "window")
(objc-runtime:add-pointer-ivar app-delegate-class "delegate")
(loop for outlet in outlets do
(objc-runtime:add-pointer-ivar app-delegate-class outlet))
app-delegate-class))
#+(or)
(defun %setup-objc-class (name base ivars)
(let ((class-pair (objc-allocate-class-pair base name 0)))
(loop for ivar in ivars
)))
(defcfun (objc-class-get-name "class_getName" :library foundation)
:string
(cls o-class))
(defcfun (objc-class-get-superclass "class_getSuperclass" :library foundation)
:pointer
(cls o-class))
(defcfun (objc-get-class-list "objc_getClassList" :library foundation)
:int
(cls-buffer o-class)
(buffer-count :int))
(defcfun (sel-register-name "sel_registerName" :library foundation)
o-selector
(name :string))
(defmacro safe-objc-msg-send (result-type thing selector &rest args)
(alexandria:once-only (thing selector)
`(if [,thing @(respondsToSelector:) :pointer ,selector]b
,(ccase result-type
(:string `[,thing ,selector ,@args]s)
(:nsstring `[,thing ,selector ,@args]@)
(:pointer `[,thing ,selector ,@args])
(:int `[,thing ,selector ,@args]#)
(:bool `[,thing ,selector ,@args]b))
(error "invalid selector"))))
;;; This is a macro, because objc-msg-send is a macro.... which makes "apply" impossible
;;; \o/
(defmacro objc-msg-send-nsstring (thing selector &rest args)
`[[,thing ,selector ,@args] @(UTF8String)]s)
(defmacro objc-msg-send-bool (thing selector &rest args)
`(= 1 [,thing ,selector ,@args]#))
(defcfun (class-copy-method-list "class_copyMethodList" :library foundation)
:pointer
(cls o-class)
(numMethods (:pointer :int)))
(defcfun (method-get-name "method_getName")
:string
(method :pointer))
(defcfun (method-get-type-encoding "method_getTypeEncoding")
:string
(method :pointer))
(defcfun (sel-get-name "sel_getName")
:string
(sel o-selector))
(defcfun (class-get-instance-variable "class_getInstanceVariable" :library foundation)
:pointer
(cls o-class)
(name :string))
(defcfun (class-add-method "class_addMethod" :library foundation)
:boolean
(class :pointer)
(selector :pointer)
(cb :pointer)
(type :string))
(defcfun (object-get-class "object_getClass" :library foundation)
:pointer
(object :pointer))
(defcfun (object-get-ivar "object_getIvar" :library foundation)
:pointer
(object :pointer)
(ivar :pointer))
(defcfun (object-get-instance-variable "object_getInstanceVariable" :library foundation)
:pointer
(object :pointer)
(name :string)
(out :pointer))
(defcfun (class-get-property "class_getProperty" :library foundation)
:pointer
(cls o-class)
(name :string))
(defcstruct objc-property-attribute-t
(name :string)
(value :string))
(defcfun (class-add-property "class_addProperty" :library foundation)
:pointer
(cls o-class)
(name :string)
(attributes (:pointer (:struct objc-property-attribute-t)))
(attribute-count :unsigned-int))
(defcfun (property-copy-attribute-value "property_copyAttributeValue" :library foundation)
:string
(prop :pointer)
(name :string))
(defcfun (property-get-attributes "property_getAttributes" :library foundation)
:string
(prop :pointer))
(defun get-classes ()
(let ((num-classes (objc-get-class-list (null-pointer) 0))
(result (list)))
(with-foreign-object (classes :pointer num-classes)
(dotimes (n (objc-get-class-list classes num-classes) (nreverse result))
(push (mem-aref classes :pointer n)
result)))))
(defgeneric get-methods (class)
(:method ((class string))
(get-methods (objc-look-up-class class)))
#+ccl
(:method ((class ccl:macptr))
(with-foreign-object (num-methods :int)
(let ((methods (class-copy-method-list class num-methods)))
(let ((result (list)))
(dotimes (n (mem-aref num-methods :int) (nreverse result))
(push (mem-aref methods :pointer n)
result))))))
#+sbcl
(:method ((class sb-sys:system-area-pointer))
(with-foreign-object (num-methods :int)
(let ((methods (class-copy-method-list class num-methods)))
(let ((result (list)))
(dotimes (n (mem-aref num-methods :int) (nreverse result))
(push (mem-aref methods :pointer n)
result)))))))
(defmethod get-methods (f)
(list))
(defun make-nsstring (str)
[[#@NSString @(alloc)] @(initWithCString:encoding:) :string str :uint 4])
(defun extract-nsstring (ns-str)
[ns-str @(UTF8String)]s)
(defun get-method-name (method)
(sel-get-name (method-get-name method)))
(defun get-method-names (thing)
(mapcar (alexandria:compose #'sel-get-name
#'method-get-name)
(get-methods thing)))
(defgeneric graph->dot (graph stream)
(:method :around (graph stream)
(declare (ignore graph))
(format stream "~&digraph {~%~4trankdir=LR;~%")
(call-next-method)
(format stream "~&}"))
(:method ((graph hash-table) stream)
(loop for class being the hash-keys of graph using (hash-value superclass)
do (format stream "~&~4t\"~a\" -> \"~a\"~%" class superclass))))
(defparameter *selector-cache* (make-hash-table :test 'equal))
(defparameter *class-cache* (make-hash-table :test 'equal))
(serapeum:eval-always
(defun normalize-selector-name (sel-name)
(substitute #\: #\? sel-name)))
(defun ensure-class (name)
(let ((objc-class (objc-look-up-class name)))
(when (and objc-class (not (null-pointer-p objc-class)))
(alexandria:ensure-gethash name *class-cache* objc-class))))
(defun ensure-selector (name)
(alexandria:ensure-gethash name
*selector-cache*
(sel-register-name name)))
(defmacro with-objc-classes ((&rest class-defs) &body body)
`(let (,@(mapcar (fw.lu:destructuring-lambda ((lisp-name foreign-name))
`(,lisp-name (objc-look-up-class ,foreign-name)))
class-defs))
,@body))
(cffi:defcvar (ns-app "NSApp" :library appkit) :pointer)
(defclass objc-class ()
((%objc-class-name :initarg :name :reader name)
(%class-pointer :initarg :pointer :reader class-pointer)
(%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-class-cache)))
(defclass objc-selector ()
((%objc-selector-name :initarg :name :reader name)
(%selector-pointer :initarg :pointer :reader selector-pointer)
(%args :initarg :args :reader args)
(%result-type :initarg :result-type :reader result-type)
(%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-selector-cache))
(:metaclass closer-mop:funcallable-standard-class))
(defun make-message-lambda-form (args rettype)
(alexandria:with-gensyms ((target :target))
(fw.lu:with (arg-syms (mapcar (serapeum:op _ (gensym "arg")) args))
`(lambda (selector)
(lambda (,target ,@arg-syms)
(cffi:foreign-funcall
"objc_msgSend"
:pointer ,target
:pointer selector
,@(mapcan #'list args arg-syms)
,rettype))))))
(defmethod initialize-instance :after ((sel objc-selector) &key &allow-other-keys)
(with-accessors ((pointer selector-pointer)
(args args)
(rettype result-type))
sel
(closer-mop:set-funcallable-instance-function
sel
(funcall (compile nil (make-message-lambda-form args rettype))
pointer))))
(defgeneric reset-class-cache (class)
(:method ((class symbol))
(reset-class-cache (find-class class)))
(:method ((class class))
(setf (slot-value (closer-mop:class-prototype class) '%cache)
(make-hash-table :test 'equal))))
(define-condition no-such-objc-class (serious-condition)
((%wanted-name :initarg :wanted-name :reader wanted-name))
(:report (lambda (c s)
(format s "No such Objective-C class: ~a" (wanted-name c)))))
(defun %ensure-wrapped-objc-class (name)
(let* ((class-cache (objc-class-cache (closer-mop:class-prototype (find-class 'objc-class))))
(cached (gethash name class-cache)))
(if cached
cached
(let ((objc-class (objc-look-up-class name)))
(if (null-pointer-p objc-class)
(error 'no-such-objc-class :wanted-name name)
(setf (gethash name class-cache)
(make-instance 'objc-class
:name name
:pointer objc-class)))))))
;; TODO: should this error if there is no corresponding selector?
;; Or should we let that fall through to message sending?
(defun %ensure-wrapped-objc-selector (name target-class result-type args)
(assert (= (count #\: name)
(length args))
(name args)
"Invalid number of arg types for selector ~s" name)
(let* ((class-cache (objc-selector-cache (closer-mop:class-prototype (find-class 'objc-selector))))
(cached (gethash (list name target-class)
class-cache)))
(if cached
cached
(let ((objc-selector (ensure-selector name)))
(setf (gethash (list name target-class) class-cache)
(make-instance 'objc-selector
:name name
:pointer objc-selector
:result-type result-type
:args args))))))
(defgeneric make-objc-instance (class &rest args)
(:method ((class string) &rest args)
(apply #'make-objc-instance (objc-look-up-class class) args))
#+ccl
(:method ((class ccl:macptr) &rest args)
(declare (ignore args))
(with-selectors (alloc init)
[[class alloc] init]))
#+sbcl
(:method ((class sb-sys:system-area-pointer) &rest args)
(declare (ignore args))
(with-selectors (alloc init)
[[class alloc] init])))
(defun ensure-wrapped-objc-class (name)
(tagbody
retry (restart-case (return-from ensure-wrapped-objc-class
(%ensure-wrapped-objc-class name))
(use-value (new)
:interactive (lambda ()
(format t "New Objective-C class name: ")
(multiple-value-list (read)))
:report "Retry with new class name"
(setf name new)
(go retry)))))
(defmacro with-selectors ((&rest selector-specs) &body body)
`(let (,@(mapcar (fw.lu:destructuring-lambda ((sym foreign-selector))
`(,sym (ensure-selector ,foreign-selector)))
(mapcar (fwoar.anonymous-gf:glambda (spec)
(:method ((spec symbol))
(list spec (normalize-selector-name
(string-downcase spec))))
(:method ((spec cons))
(list (car spec) (cadr spec))))
selector-specs)))
,@body))
(defmacro with-typed-selectors ((&rest defs) &body body)
(let ((expanded-defs (loop for ((name objc-name) args ret-type) in defs
collect
`((,name (&rest r) (apply ,name r))
(,name (%ensure-wrapped-objc-selector ,objc-name ',ret-type ',args))))))
`(let (,@(mapcar #'second expanded-defs))
(flet (,@(mapcar #'first expanded-defs))
,@body))))
(defun description (nsobject)
[nsobject @(description)]@)
(defun future-ns-date (seconds)
[[#@NSDate @(alloc)]
@(initWithTimeIntervalSinceNow:)
:double (coerce seconds 'double-float)])
(defun tick-ns-runloop (run-loop &optional (time 0.5d0))
(let ((date (future-ns-date time)))
(unwind-protect [run-loop @(runUntilDate:)
:pointer date]
[date @(release)])))