(in-package :objc-runtime)
(serapeum:eval-always
(cffi:define-foreign-library cocoa
(:darwin (:framework "Cocoa")))
(define-foreign-library foundation
(:darwin (:framework "Foundation")))
(define-foreign-library appkit
(:darwin (:framework "AppKit")))
(define-foreign-library expose-stuff
(:darwin #p"./libnsrect-expose.dylib")))
(use-foreign-library foundation)
(use-foreign-library cocoa)
(use-foreign-library appkit)
(use-foreign-library expose-stuff)
(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-get-protocol "objc_getProtocol" :library foundation)
:pointer
(name :string))
(defcfun (class-add-protocol "class_addProtocol" :library foundation)
:boolean
(class :pointer)
(protocol :pointer))
(defcfun (class-add-method "class_addMethod" :library foundation)
:boolean
(class :pointer)
(selector :pointer)
(cb :pointer)
(type :string))
(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))
(defcfun (objc-msg-send "objc_msgSend")
:pointer
(cls o-class)
(sel o-selector)
&rest)
(defcfun (class-copy-method-list "class_copyMethodList" :library foundation)
:pointer
(cls o-class)
(numMethods (:pointer :int)))
(defcfun (method-get-name "method_getName")
:pointer
(method :pointer))
(defcfun (sel-get-name "sel_getName")
:string
(sel o-selector))
(defgeneric get-methods (class)
(:method ((class string))
(get-methods (objc-look-up-class class)))
#+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)))))))
(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)
(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))
(defun ensure-selector (name)
(alexandria:ensure-gethash name *selector-cache*
(sel-register-name name)))
(defmacro with-selectors ((&rest selector-specs) &body body)
`(let (,@(mapcar (fw.lu:destructuring-lambda ((sym foreign-selector))
`(,sym (ensure-selector ,foreign-selector)))
(mapcar (fw.lu:glambda (spec)
(:method ((spec symbol))
(list spec (string-downcase spec)))
(:method ((spec cons))
(list (car spec) (cadr spec))))
selector-specs)))
,@body))
(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))
(eval-when (:compile-toplevel :load-toplevel :execute)
(named-readtables:defreadtable :objc-readtable
(:merge :standard)
(:syntax-from :standard #\) #\])
(:macro-char #\[ (lambda (s char)
char
(destructuring-bind (obj message . args)
(read-delimited-list #\] s t)
`(objc-msg-send ,obj ,message ,@args)))
nil)
(:dispatch-macro-char #\# #\@
(lambda (s c b)
c b
(let ((class-name (coerce (loop for c = (read-char s nil nil t)
until (or (null c)
(serapeum:whitespacep c))
collect c)
'string)))
`(objc-look-up-class ,class-name))))))
(named-readtables:in-readtable :objc-readtable)
(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])))
(cffi:defcvar (ns-app "NSApp" :library appkit) :pointer)
#|
(uiop:nest (with-selectors (alloc init drain))
(with-objc-classes ((nsobject "NSAutoreleasepool")))
(eval-objc (objc-msg-send
(objc-msg-send
(objc-msg-send nsobject alloc)
init)
drain)))
(with-selectors (alloc init))
|#