new file mode 100644

@@ -0,0 +1,101 @@

+(defpackage :demo-app

+  (:use :cl :objc-runtime)

+  (:export ))

+(in-package :demo-app)

+(named-readtables:in-readtable :objc-readtable)

+

+(cffi:defcallback exception-handler :void ((exception :pointer))

+  (with-selectors (reason)

+    (format t "~&Exxception: ~a~%" [exception reason])

+    (values)))

+

+

+#+null

+(cffi:defcfun (set-uncaught-exception-handler "set_uncaught_exception_handler"

+                                              :library objc-runtime::expose-stuff)

+    :void

+  (cb :pointer))

+

+(defun call-with-rect (x y w h cb)

+  (check-type x real)

+  (check-type y real)

+  (check-type w real)

+  (check-type h real)

+  (cffi:with-foreign-object (rect '(:struct ns-rect))

+    (cffi:with-foreign-slots (((:pointer ns-rect-origin) (:pointer ns-rect-size))

+                              rect (:struct ns-rect))

+      (cffi:with-foreign-slots ((ns-point-x ns-point-y) ns-rect-origin (:struct ns-point))

+        (setf ns-point-x (coerce x 'double-float)

+              ns-point-y (coerce y 'double-float)))

+      (cffi:with-foreign-slots ((ns-size-width ns-size-height)

+                                ns-rect-size (:struct ns-size))

+        (setf ns-size-width (coerce w 'double-float)

+              ns-size-height (coerce h 'double-float))))

+    (funcall cb rect)))

+

+(defun call-with-point (x y cb)

+  (check-type x real)

+  (check-type y real)

+  (cffi:with-foreign-object (point '(:struct ns-point))

+    (cffi:with-foreign-slots ((ns-point-x ns-point-y) point (:struct ns-point))

+      (setf ns-point-x (coerce x 'double-float)

+            ns-point-y (coerce y 'double-float)))

+    (funcall cb point)))

+

+(defmacro with-rect ((rect (x y) (w h)) &body body)

+  `(call-with-rect ,x ,y ,w ,h

+                   (lambda (,rect)

+                     ,@body)))

+

+(defmacro with-point ((point (x y)) &body body)

+  `(call-with-point ,x ,y

+                   (lambda (,point)

+                     ,@body)))

+

+(defun make-rect (x y w h)

+  (check-type x real)

+  (check-type y real)

+  (check-type w real)

+  (check-type h real)

+  (cffi:convert-to-foreign `(ns-rect-origin

+                             (objc-runtime:ns-point-x

+                              ,(coerce x 'double-float)

+                              objc-runtime:ns-point-y

+                              ,(coerce y 'double-float))

+                             ns-rect-size

+                             (objc-runtime:ns-size-width

+                              ,(coerce w 'double-float)

+                              objc-runtime:ns-size-height

+                              ,(coerce h 'double-float)))

+                           '(:struct objc-runtime:ns-rect)))

+

+(defun main ()

+  (with-selectors ((shared-application "sharedApplication")

+                   (process-info "processInfo")

+                   (process-name "processName")

+                   (set-activation-policy "setActivationPolicy:")

+                   (init-with-content-rect "initWithContentRect:styleMask:backing:defer:")

+                   (set-title "setTitle:")

+                   (run "run")

+                   (activate-ignoring-other-apps "activateIgnoringOtherApps:")

+                   alloc

+                   (make-key-and-order-front "makeKeyAndOrderFront:")

+                   (cascade-top-left-from-point "cascadeTopLeftFromPoint:")

+                   ;; (application-should-terminate "applicationShouldTerminate:")

+                   ;; (set-delegate "setDelegate:")

+                   ;; (finish-launching "finishLaunching")

+                   )

+    [#@NSApplication shared-application]

+    [objc-runtime::ns-app set-activation-policy :int 0]

+

+    (break)

+    (let* ((application-name [[#@NSProcessInfo process-info] process-name]))

+      (with-point (p (20 20))

+        (let* ((the-window [#@NSWindow alloc]))

+          [the-window init-with-content-rect :pointer (make-rect 10 10 120 120)

+                                             :char 1 :char 2 :boolean nil]

+          [the-window cascade-top-left-from-point :pointer p]

+          [the-window set-title :pointer application-name]

+          [the-window make-key-and-order-front :pointer (cffi:null-pointer)]

+          [ objc-runtime::ns-app activate-ignoring-other-apps :boolean t]

+          [ objc-runtime::ns-app run])))))

new file mode 100644

@@ -0,0 +1,31 @@

+(in-package :objc-runtime)

+

+(include "Foundation/NSGeometry.h")

+(include "AppKit/NSWindow.h")

+(include "AppKit/NSGraphics.h")

+

+(cc-flags "-x objective-c -framework Foundation -framework AppKit -ObjC")

+

+(cstruct ns-point "NSPoint"

+         (ns-point-x "x" :type :double)

+         (ns-point-y "y" :type :double))

+

+(cstruct ns-size "NSSize"

+         (ns-size-width "width" :type :double)

+         (ns-size-height "height" :type :double))

+

+(cstruct ns-rect "NSRect"

+         (ns-rect-origin "origin" :type (:struct ns-point))

+         (ns-rect-size "size" :type (:struct ns-size)))

+

+(cenum (ns-window-style-mask)

+       ((:ns-window-style-mask-borderless "NSWindowStyleMaskBorderless"))

+       ((:ns-window-style-mask-titled "NSWindowStyleMaskTitled"))

+       ((:ns-window-style-mask-closable "NSWindowStyleMaskClosable"))

+       ((:ns-window-style-mask-miniaturizable "NSWindowStyleMaskMiniaturizable"))

+       ((:ns-window-style-mask-resizable "NSWindowStyleMaskResizable")))

+

+(cenum (ns-backing-store-type)

+       ((:ns-backing-store-retained "NSBackingStoreRetained"))

+       ((:ns-backing-store-Nonretained "NSBackingStoreNonretained"))

+       ((:ns-backing-store-buffered "NSBackingStoreBuffered")))

new file mode 100644

@@ -0,0 +1,184 @@

+(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))

+

+|#

+

new file mode 100644

@@ -0,0 +1,24 @@

+(defpackage :objc-runtime/package

+  (:use :cl )

+  (:export ))

+(in-package :objc-runtime/package)

+

+(defpackage :objc-runtime

+  (:use :cl :cffi)

+  (:export

+   #:defmacro

+   #:*objc-readtable*

+   #:with-selectors

+   #:objc-msg-send

+   #:with-objc-classes

+   #:make-objc-instance

+   #:objc-readtable

+   #:ns-size-width

+   #:ns-size-height

+   #:ns-rect-origin

+   #:ns-rect-size

+   #:ns-point-x

+   #:ns-point-y

+   #:ns-point

+   #:ns-size

+   #:ns-rect))