@@ -11,6 +11,8 @@ demo-app: dylib

 		--eval '(ql:quickload :objc-runtime)' \

 		--eval '(load (compile-file "demo-app.lisp"))' \

 		--eval '(ccl:save-application "demo-app" :toplevel-function '"'"'demo-app::main :prepend-kernel t)'

+		#--eval '(sb-ext:save-lisp-and-die "demo-app" :toplevel '"'"'demo-app::main :executable t)'

+

 demo-app.iconset: demo-app.svg

 	rm -rf demo-app.iconset

 	mkdir -p demo-app.iconset

@@ -117,26 +117,28 @@

   (declare (ignore a b sender))

   (show-alert "That Was Profitable!"))

+(defun alloc-init (cls)

+  [[cls @(alloc)] @(init)])

+

 (defun make-button-delegate (button cb)

   (let ((my-class (objc-runtime::objc-allocate-class-pair #@NSObject "ButtonDel" 0)))

-    (with-selectors ((do-magic "doMagic:") (set-target "setTarget:") (set-action "setAction:")

-                     alloc init)

-      (objc-runtime::class-add-method my-class do-magic cb "v@:@")

-      (fw.lu:prog1-bind (result [[my-class alloc] init])

-        [button set-target :pointer result]

-        [button set-action :pointer do-magic]))))

+    (objc-runtime::class-add-method my-class @(doMagic) cb "v@:@")

+    (fw.lu:prog1-bind (result (alloc-init my-class))

+      [button @(setTarget) :pointer result]

+      [button @(setAction) :pointer @(doMagic)])))

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

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

+         (objc-runtime:add-pointer-ivar app-delegate-class outlet))

     app-delegate-class))

+

 (defun load-nib (name)

   ;; find and activate the nib

   (let* ((bundle [#@NSBundle @(mainBundle)])

@@ -150,6 +152,7 @@

            :pointer objc-runtime::ns-app

            :pointer p])))

+;#+null

 (defun main ()

   #+sbcl

   (sb-int:set-floating-point-modes :traps '())

@@ -178,3 +181,72 @@

     [objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]

     [objc-runtime::ns-app @(run)]))

+

+(defclass application-shim ()

+  ((%main-view :initarg :main-view :accessor main-view)))

+

+(defparameter *application-shim* (make-instance 'application-shim))

+

+#+nil

+(defun old-code ()

+ (trivial-main-thread:with-body-in-main-thread (:blocking t)

+   (sb-int:with-float-traps-masked

+       (:underflow :overflow :inexact

+                   :invalid :divide-by-zero)

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

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

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

+                      (add-item "addItem:")

+                      (set-main-menu "setMainMenu:")

+                      (init-with-title "initWithTitle:action:keyEquivalent:")

+                      (set-submenu "setSubmenu:")

+                      (init-with-encoding "initWithCString:length:")

+                      (content-view "contentView")

+                      (add-subview "addSubview:")

+                      (set-target "setTarget:")

+                      (set-action "setAction:")

+                      terminate?

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

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

+                      ;; (finish-launching "finishLaunching")

+                      alloc new autorelease

+                      )

+       [#@NSAutoReleasePool new]

+       [#@NSApplication shared-application]

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

+

+

+

+       ;; (break)

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

+         (let* ((menubar [[#@NSMenu new] autorelease])

+                (app-menu-item [[#@NSMenuItem new] autorelease])

+                (app-menu [[#@NSMenu new] autorelease])

+                (quit-name [[#@NSString alloc] init-with-encoding :string "Quit" :uint 4])

+                (key [[#@NSString alloc] init-with-encoding :string "q" :uint 1])

+                (quit-menu-item

+                 [[[#@NSMenuItem alloc] init-with-title :pointer quit-name :pointer terminate? :string key] autorelease]))

+           [menubar add-item :pointer app-menu-item]

+           [app-menu add-item :pointer quit-menu-item]

+           [app-menu-item set-submenu :pointer app-menu]

+           [objc-runtime::ns-app set-main-menu :pointer menubar] )

+

+         (setf (main-view *application-shim*)

+               [#@NSStackView @(stackViewWithViews:) :pointer [[#@NSArray @(alloc)] @(init)]])

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

+           (let* ((foreign-rect (make-rect 10 10 120 120))

+                  (the-window (init-window [#@NSWindow alloc] foreign-rect 1 2 nil)))

+             

+             [(value-for-key the-window "contentView") add-subview :pointer (main-view *application-shim*)]

+             [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,32 @@

+(defpackage :mop-test

+  (:shadowing-import-from :closer-mop

+                          :standard-method :standard-generic-function

+                          :defmethod :defgeneric :standard-class)

+  (:use :cl :closer-mop)

+  (:export ))

+(in-package :mop-test)

+

+(defclass slot-logging-class (standard-class)

+  ((%log-stream :accessor log-stream :initform (make-synonym-stream '*trace-output*))))

+

+(defmethod validate-superclass ((class slot-logging-class) (super standard-class))

+  t)

+

+(defmethod slot-value-using-class ((class slot-logging-class) instance slotd)

+  (format (log-stream class) "~&Instance ~s of class ~s read slot ~s~%"

+          (class-name class)

+          instance

+          (slot-definition-name slotd))

+  (call-next-method))

+

+(defmethod (setf slot-value-using-class) (new-value (class slot-logging-class) instance slotd)

+  (format (log-stream class) "~&Instance ~s of class ~s write slot ~s: ~s~%"

+          (class-name class)

+          instance

+          (slot-definition-name slotd)

+          new-value)

+  (call-next-method))

+

+(defclass tmp (standard-object)

+  ((%a :reader a :initform :b))

+  (:metaclass slot-logging-class))

@@ -81,12 +81,27 @@

     o-selector

   (name :string))

+(defcfun (objc-msg-send-int "objc_msgSend")

+    :int

+  (cls o-class)

+  (sel o-selector)

+  &rest)

+

+(defcfun (objc-msg-send-string "objc_msgSend")

+    :string

+  (cls o-class)

+  (sel o-selector)

+  &rest)

+

 (defcfun (objc-msg-send "objc_msgSend")

     :pointer

   (cls o-class)

   (sel o-selector)

   &rest)

+(defun objc-msg-send-nsstring (thing selector &rest args)

+  [(apply 'objc-msg-send thing selector args) @(UTF8String)]s)

+

 (defcfun (class-copy-method-list "class_copyMethodList" :library foundation)

     :pointer

   (cls o-class)

@@ -143,6 +158,15 @@

     :string

   (prop :pointer))

+(defun get-classes ()

+  (let ((num-classes (objc-get-class-list (null-pointer) 0)))

+    (with-foreign-object (classes :pointer num-classes)

+      (objc-get-class-list classes num-classes)

+      (let ((result (list)))

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

@@ -334,3 +358,4 @@

     `(let (,@(mapcar #'second expanded-defs))

        (flet (,@(mapcar #'first expanded-defs))

          ,@body))))

+

@@ -23,4 +23,7 @@

    #:ns-size

    #:ns-rect

    #:get-method-names

-   #:ensure-wrapped-objc-class))

+   #:ensure-wrapped-objc-class

+   #:add-pointer-ivar

+   #:objc-msg-send-int

+   #:objc-msg-send-string))

@@ -26,10 +26,16 @@

   (:syntax-from :standard #\) #\])

   (:macro-char #\[ (lambda (s char)

                      char

-                     (let ((info (read-delimited-list #\] s t)))

+                     (let ((info (read-delimited-list #\] s t))

+                           (msg-send (case (peek-char nil s nil #\p t)

+                                       (#\# (read-char s t nil t) 'objc-msg-send-int)

+                                       (#\s (read-char s t nil t) 'objc-msg-send-string)

+                                       (#\@ (read-char s t nil t) 'objc-msg-send-nsstring)

+                                       (#\& (read-char s t nil t) 'objc-msg-send)

+                                       (t 'objc-msg-send))))

                        (when info

                          (destructuring-bind (obj message . args) info

-                           `(objc-msg-send ,obj ,message ,@args)))))

+                           `(,msg-send ,obj ,message ,@args)))))

                nil)

   (:dispatch-macro-char #\# #\@

                         (lambda (s c b)