New Objective C method invocation syntax
slava
parent
6c656c4c26
commit
c85235fe6a
|
|
@ -2,35 +2,33 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: cocoa
|
||||
USING: alien errors gadgets io kernel namespaces objc
|
||||
objc-NSApplication objc-NSAutoreleasePool objc-NSException
|
||||
objc-NSNotificationCenter objc-NSObject objc-NSView sequences
|
||||
threads ;
|
||||
objc-classes sequences threads ;
|
||||
|
||||
: NSApplicationDelegateReplySuccess 0 ;
|
||||
: NSApplicationDelegateReplyCancel 1 ;
|
||||
: NSApplicationDelegateReplyFailure 2 ;
|
||||
|
||||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool [new] slip [release] ; inline
|
||||
NSAutoreleasePool -> new slip -> release ; inline
|
||||
|
||||
: NSApp NSApplication [sharedApplication] ;
|
||||
: NSApp NSApplication -> sharedApplication ;
|
||||
|
||||
: with-cocoa ( quot -- )
|
||||
[ NSApp drop call ] with-autorelease-pool ;
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> [autorelease] ;
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
||||
: <NSArray> ( seq -- alien ) <CFArray> [autorelease] ;
|
||||
: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
|
||||
|
||||
: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
|
||||
|
||||
: next-event ( app -- event )
|
||||
0 f CFRunLoopDefaultMode 1
|
||||
[nextEventMatchingMask:untilDate:inMode:dequeue:] ;
|
||||
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
|
||||
|
||||
: do-event ( app -- ? )
|
||||
[
|
||||
dup next-event [ [sendEvent:] t ] [ drop f ] if*
|
||||
dup next-event [ -> sendEvent: t ] [ drop f ] if*
|
||||
] with-autorelease-pool ;
|
||||
|
||||
: do-events ( app -- )
|
||||
|
|
@ -41,20 +39,21 @@ threads ;
|
|||
event-loop ;
|
||||
|
||||
: add-observer ( observer selector name object -- )
|
||||
>r >r >r >r NSNotificationCenter [defaultCenter] r> r>
|
||||
sel_registerName r> r> [addObserver:selector:name:object:] ;
|
||||
>r >r >r >r NSNotificationCenter -> defaultCenter
|
||||
r> r> sel_registerName
|
||||
r> r> -> addObserver:selector:name:object: ;
|
||||
|
||||
: remove-observer ( observer -- )
|
||||
>r NSNotificationCenter [defaultCenter] r>
|
||||
[removeObserver:] ;
|
||||
>r NSNotificationCenter -> defaultCenter r>
|
||||
-> removeObserver: ;
|
||||
|
||||
: finish-launching ( -- ) NSApp [finishLaunching] ;
|
||||
: finish-launching ( -- ) NSApp -> finishLaunching ;
|
||||
|
||||
: install-delegate ( receiver delegate -- )
|
||||
[alloc] [init] [setDelegate:] ;
|
||||
-> alloc -> init -> setDelegate: ;
|
||||
|
||||
IN: errors
|
||||
|
||||
: objc-error. ( error -- )
|
||||
"Objective C exception:" print
|
||||
third [reason] CF>string print ;
|
||||
third -> reason CF>string print ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2005, 2006 Kevin Reid.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc-FactorCallback
|
||||
IN: objc-classes
|
||||
DEFER: FactorCallback
|
||||
|
||||
IN: cocoa
|
||||
USING: hashtables kernel namespaces objc objc-NSObject ;
|
||||
USING: hashtables kernel namespaces objc ;
|
||||
|
||||
SYMBOL: callbacks
|
||||
|
||||
|
|
@ -22,11 +22,11 @@ reset-callbacks
|
|||
[
|
||||
drop
|
||||
dup callbacks get remove-hash
|
||||
SUPER-> [dealloc]
|
||||
SUPER-> dealloc
|
||||
]
|
||||
}
|
||||
} { } define-objc-class
|
||||
|
||||
: <FactorCallback> ( quot -- id | quot: id -- )
|
||||
FactorCallback [alloc] [init]
|
||||
FactorCallback -> alloc -> init
|
||||
[ callbacks get set-hash ] keep ;
|
||||
|
|
@ -1,19 +1,18 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: cocoa
|
||||
USING: kernel objc-NSObject objc-NSOpenPanel objc-NSSavePanel
|
||||
sequences ;
|
||||
USING: kernel objc-classes sequences ;
|
||||
|
||||
: <NSOpenPanel> ( -- panel )
|
||||
NSOpenPanel [openPanel]
|
||||
dup 1 [setCanChooseFiles:]
|
||||
dup 0 [setCanChooseDirectories:]
|
||||
dup 1 [setResolvesAliases:]
|
||||
dup 1 [setAllowsMultipleSelection:] ;
|
||||
NSOpenPanel -> openPanel
|
||||
dup 1 -> setCanChooseFiles:
|
||||
dup 0 -> setCanChooseDirectories:
|
||||
dup 1 -> setResolvesAliases:
|
||||
dup 1 -> setAllowsMultipleSelection: ;
|
||||
|
||||
: NSOKButton 1 ;
|
||||
: NSCancelButton 0 ;
|
||||
|
||||
: open-panel ( -- paths )
|
||||
<NSOpenPanel> dup f [runModalForTypes:] NSOKButton =
|
||||
[ [filenames] CF>string-array ] [ drop f ] if ;
|
||||
<NSOpenPanel> dup f -> runModalForTypes: NSOKButton =
|
||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -21,4 +21,4 @@ USING: compiler io parser sequences words ;
|
|||
] each
|
||||
|
||||
"Compiling Cocoa bindings..." print
|
||||
vocabs [ "objc-" head? ] subset compile-vocabs
|
||||
{ "cocoa" "objc" "objc-classes" } compile-vocabs
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cocoa compiler gadgets gadgets-browser gadgets-launchpad
|
||||
gadgets-layouts gadgets-listener kernel memory objc
|
||||
objc-FactorCallback objc-NSApplication objc-NSMenu
|
||||
objc-NSMenuItem objc-NSObject objc-NSWindow sequences strings
|
||||
words ;
|
||||
objc-classes sequences strings words ;
|
||||
IN: cocoa
|
||||
|
||||
! -------------------------------------------------------------------------
|
||||
|
|
@ -18,36 +16,36 @@ M: quotation to-target-and-action
|
|||
<FactorCallback> "perform:" sel_registerName swap ;
|
||||
|
||||
: <NSMenu> ( title -- )
|
||||
NSMenu [alloc]
|
||||
swap <NSString> [initWithTitle:]
|
||||
[autorelease] ;
|
||||
NSMenu -> alloc
|
||||
swap <NSString> -> initWithTitle:
|
||||
-> autorelease ;
|
||||
|
||||
: set-main-menu ( menu -- ) NSApp swap [setMainMenu:] ;
|
||||
: set-main-menu ( menu -- ) NSApp swap -> setMainMenu: ;
|
||||
|
||||
: <NSMenuItem> ( title action equivalent -- item )
|
||||
>r >r >r
|
||||
NSMenuItem [alloc]
|
||||
NSMenuItem -> alloc
|
||||
r> <NSString>
|
||||
r> dup [ sel_registerName ] when
|
||||
r> <NSString>
|
||||
[initWithTitle:action:keyEquivalent:] [autorelease] ;
|
||||
-> initWithTitle:action:keyEquivalent: -> autorelease ;
|
||||
|
||||
: make-menu-item ( title spec -- item )
|
||||
to-target-and-action >r swap <NSMenuItem> dup
|
||||
r> [setTarget:] ;
|
||||
r> -> setTarget: ;
|
||||
|
||||
: submenu-to-item ( menu -- item )
|
||||
dup [title] CF>string f "" <NSMenuItem> dup
|
||||
rot [setSubmenu:] ;
|
||||
dup -> title CF>string f "" <NSMenuItem> dup
|
||||
rot -> setSubmenu: ;
|
||||
|
||||
: add-submenu ( menu submenu -- )
|
||||
submenu-to-item [addItem:] ;
|
||||
submenu-to-item -> addItem: ;
|
||||
|
||||
: and-modifiers ( item key-equivalent-modifier-mask -- item )
|
||||
dupd [setKeyEquivalentModifierMask:] ;
|
||||
dupd -> setKeyEquivalentModifierMask: ;
|
||||
|
||||
: and-alternate ( item -- item )
|
||||
dup 1 [setAlternate:] ;
|
||||
dup 1 -> setAlternate: ;
|
||||
|
||||
: and-option-equivalent-modifier 1572864 and-modifiers ;
|
||||
|
||||
|
|
@ -66,7 +64,7 @@ DEFER: described-menu
|
|||
! this is a mess
|
||||
: described-item ( desc -- menu-item )
|
||||
dup length 0 = [
|
||||
drop NSMenuItem [separatorItem]
|
||||
drop NSMenuItem -> separatorItem
|
||||
] [
|
||||
dup first string? [
|
||||
[ first3 swap make-menu-item ] keep
|
||||
|
|
@ -79,7 +77,7 @@ DEFER: described-menu
|
|||
] if ;
|
||||
|
||||
: and-described-item ( menu desc -- same-menu )
|
||||
described-item dupd [addItem:] ;
|
||||
described-item dupd -> addItem: ;
|
||||
|
||||
: described-menu ( { title items* } -- menu )
|
||||
[ first <NSMenu> ] keep
|
||||
|
|
@ -102,14 +100,14 @@ DEFER: described-menu
|
|||
! Preferences goes here
|
||||
{ {
|
||||
"Services"
|
||||
} [ NSApp over [setServicesMenu:] ] }
|
||||
} [ NSApp over -> setServicesMenu: ] }
|
||||
{ }
|
||||
{ "Hide Factor" "hide:" "h" }
|
||||
{ "Hide Others" "hideOtherApplications:" "h" [ and-option-equivalent-modifier ] }
|
||||
{ "Show All" "unhideAllApplications:" "" }
|
||||
{ }
|
||||
{ "Quit" "terminate:" "q" }
|
||||
} [ NSApp over [setAppleMenu:] ] }
|
||||
} [ NSApp over -> setAppleMenu: ] }
|
||||
{ {
|
||||
"File"
|
||||
{ "New Listener" listener-window "n" }
|
||||
|
|
@ -143,7 +141,7 @@ DEFER: described-menu
|
|||
{ "Minimize All" "miniaturizeAll:" "m" [ and-alternate and-option-equivalent-modifier ] }
|
||||
{ }
|
||||
{ "Bring All to Front" "arrangeInFront:" "" }
|
||||
} [ NSApp over [setWindowsMenu:] ] }
|
||||
} [ NSApp over -> setWindowsMenu: ] }
|
||||
{ {
|
||||
"Help"
|
||||
{ "Factor Documentation" handbook-window "?" }
|
||||
|
|
|
|||
|
|
@ -1,21 +1,21 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: cocoa
|
||||
USING: arrays kernel objc-NSPasteboard sequences ;
|
||||
USING: arrays kernel objc-classes sequences ;
|
||||
|
||||
: NSStringPboardType "NSStringPboardType" ;
|
||||
|
||||
: pasteboard-string? ( type id -- seq )
|
||||
NSStringPboardType swap [types] CF>string-array member? ;
|
||||
NSStringPboardType swap -> types CF>string-array member? ;
|
||||
|
||||
: pasteboard-string ( id -- str )
|
||||
NSStringPboardType <NSString> [stringForType:]
|
||||
NSStringPboardType <NSString> -> stringForType:
|
||||
dup [ CF>string ] when ;
|
||||
|
||||
: set-pasteboard-types ( seq id -- )
|
||||
swap <NSArray> f [declareTypes:owner:] drop ;
|
||||
swap <NSArray> f -> declareTypes:owner: drop ;
|
||||
|
||||
: set-pasteboard-string ( str id -- )
|
||||
NSStringPboardType <NSString>
|
||||
dup 1array pick set-pasteboard-types
|
||||
>r swap <NSString> r> [setString:forType:] drop ;
|
||||
>r swap <NSString> r> -> setString:forType: drop ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
IN: objc-FactorServiceProvider
|
||||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc-classes
|
||||
DEFER: FactorServiceProvider
|
||||
|
||||
IN: cocoa
|
||||
USING: alien gadgets-presentations io kernel namespaces objc
|
||||
objc-NSApplication objc-NSObject parser prettyprint styles ;
|
||||
parser prettyprint styles ;
|
||||
|
||||
: pasteboard-error ( error str -- f )
|
||||
"Pasteboard does not hold a string" <NSString>
|
||||
|
|
@ -36,5 +38,5 @@ objc-NSApplication objc-NSObject parser prettyprint styles ;
|
|||
|
||||
: register-services ( -- )
|
||||
NSApp
|
||||
FactorServiceProvider [alloc] [init]
|
||||
[setServicesProvider:] ;
|
||||
FactorServiceProvider -> alloc -> init
|
||||
-> setServicesProvider: ;
|
||||
|
|
|
|||
|
|
@ -1,18 +1,16 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc-FactorApplicationDelegate
|
||||
|
||||
IN: objc-classes
|
||||
DEFER: FactorApplicationDelegate
|
||||
|
||||
IN: cocoa
|
||||
USING: arrays gadgets gadgets-layouts gadgets-listener
|
||||
hashtables kernel namespaces objc objc-NSApplication
|
||||
objc-NSObject objc-NSWindow sequences ;
|
||||
hashtables kernel namespaces objc sequences errors freetype ;
|
||||
|
||||
: finder-run-files ( alien -- )
|
||||
CF>string-array listener-run-files
|
||||
NSApp NSApplicationDelegateReplySuccess
|
||||
[replyToOpenOrPrint:] ;
|
||||
-> replyToOpenOrPrint: ;
|
||||
|
||||
! Handle Open events from the Finder
|
||||
"NSObject" "FactorApplicationDelegate" {
|
||||
|
|
@ -39,30 +37,28 @@ objc-NSObject objc-NSWindow sequences ;
|
|||
dup <FactorView>
|
||||
dup rot rect>NSRect <ViewWindow>
|
||||
dup install-window-delegate
|
||||
over [release]
|
||||
over -> release
|
||||
2array
|
||||
] keep set-world-handle ;
|
||||
|
||||
IN: gadgets
|
||||
USING: errors freetype objc-NSOpenGLContext
|
||||
objc-NSOpenGLView objc-NSView ;
|
||||
|
||||
: redraw-world ( world -- )
|
||||
world-handle first 1 [setNeedsDisplay:] ;
|
||||
world-handle first 1 -> setNeedsDisplay: ;
|
||||
|
||||
: set-title ( string world -- )
|
||||
world-handle second swap <NSString> [setTitle:] ;
|
||||
world-handle second swap <NSString> -> setTitle: ;
|
||||
|
||||
: open-window* ( world -- )
|
||||
dup gadget-window
|
||||
dup start-world
|
||||
world-handle second f [makeKeyAndOrderFront:] ;
|
||||
world-handle second f -> makeKeyAndOrderFront: ;
|
||||
|
||||
: select-gl-context ( handle -- )
|
||||
first [openGLContext] [makeCurrentContext] ;
|
||||
first -> openGLContext -> makeCurrentContext ;
|
||||
|
||||
: flush-gl-context ( handle -- )
|
||||
first [openGLContext] [flushBuffer] ;
|
||||
first -> openGLContext -> flushBuffer ;
|
||||
|
||||
IN: shells
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,54 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc
|
||||
USING: alien arrays errors hashtables kernel math
|
||||
USING: alien arrays errors hashtables inference kernel math
|
||||
namespaces parser sequences strings words ;
|
||||
|
||||
: make-alien-invoke [ ] make \ alien-invoke add ; inline
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
[ over first , f , , second , ] make-alien-invoke ;
|
||||
|
||||
: make-sender-stret ( method function -- quot )
|
||||
[
|
||||
[ "void" f ] %
|
||||
"_stret" append ,
|
||||
{ "void*" } swap second append ,
|
||||
] make-alien-invoke ;
|
||||
|
||||
: sender-stub ( method function -- word )
|
||||
over first c-struct?
|
||||
[ make-sender-stret ] [ make-sender ] if
|
||||
define-temp ;
|
||||
|
||||
SYMBOL: msg-senders
|
||||
H{ } clone msg-senders set-global
|
||||
|
||||
SYMBOL: super-msg-senders
|
||||
H{ } clone super-msg-senders set-global
|
||||
|
||||
: (cache-stub) ( method function hash -- word )
|
||||
[
|
||||
over second get dup [
|
||||
2nip
|
||||
] [
|
||||
drop over >r sender-stub dup r> second set
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
: cache-stub ( method super? -- word )
|
||||
[ "objc_msgSendSuper" "objc_msgSend" ? ] keep
|
||||
super-msg-senders msg-senders ? get
|
||||
(cache-stub) ;
|
||||
|
||||
: <super> ( receiver -- super )
|
||||
"objc-super" <c-object> [
|
||||
>r dup objc-object-isa objc-class-super-class r>
|
||||
set-objc-super-class
|
||||
] keep
|
||||
[ set-objc-super-receiver ] keep ;
|
||||
|
||||
: make-stret-quot ( returns -- quot )
|
||||
[ <c-object> dup ] curry 1 make-dip ;
|
||||
|
||||
TUPLE: selector name object ;
|
||||
|
||||
C: selector ( name -- sel ) [ set-selector-name ] keep ;
|
||||
|
|
@ -16,10 +61,61 @@ C: selector ( name -- sel ) [ set-selector-name ] keep ;
|
|||
selector-object
|
||||
] if ;
|
||||
|
||||
: objc-classes ( -- seq )
|
||||
f 0 objc_getClassList
|
||||
[ "void*" <c-array> dup ] keep objc_getClassList
|
||||
[ swap void*-nth objc-class-name ] map-with ;
|
||||
SYMBOL: selectors
|
||||
|
||||
H{ } clone selectors set-global
|
||||
|
||||
: cache-selector selectors get-global [ <selector> ] cache ;
|
||||
|
||||
SYMBOL: objc-methods
|
||||
H{ } clone objc-methods set-global
|
||||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get hash
|
||||
[ ] [ "No such method: " swap append throw ] ?if ;
|
||||
|
||||
: (make-prepare-send) ( selector method -- quot )
|
||||
[
|
||||
[ \ <super> , ] when
|
||||
dup first c-struct? [ make-stret-quot % ] [ drop ] if
|
||||
cache-selector , \ selector ,
|
||||
] [ ] make ;
|
||||
|
||||
: make-prepare-send ( selector method super? -- quot )
|
||||
over second length 2 - >r (make-prepare-send) r> make-dip ;
|
||||
|
||||
: make-objc-send ( selector super? -- quot )
|
||||
>r dup lookup-method r> 2dup cache-stub >r
|
||||
make-prepare-send r> add ;
|
||||
|
||||
: infer-send ( super? -- )
|
||||
pop-literal rot make-objc-send infer-quot-value ;
|
||||
|
||||
: compile-send-error
|
||||
"Objective C message sends must be compiled" throw ;
|
||||
|
||||
: send ( ... selector -- ... ) compile-send-error ;
|
||||
|
||||
\ send [ f infer-send ] "infer-quot" set-word-prop
|
||||
|
||||
: -> scan parsed \ send parsed ; parsing
|
||||
|
||||
: super-send ( ... selector -- ... ) compile-send-error ;
|
||||
|
||||
\ super-send [ t infer-send ] "infer-quot" set-word-prop
|
||||
|
||||
: SUPER-> scan parsed \ super-send parsed ; parsing
|
||||
|
||||
! Runtime introspection
|
||||
: (objc-class) ( string word -- class )
|
||||
dupd execute
|
||||
[ ] [ "No such class: " swap append throw ] ?if ; inline
|
||||
|
||||
: objc-class ( string -- class )
|
||||
\ objc_getClass (objc-class) ;
|
||||
|
||||
: objc-meta-class ( string -- class )
|
||||
\ objc_getMetaClass (objc-class) ;
|
||||
|
||||
: method-arg-type ( method i -- type )
|
||||
f <void*> 0 <int> over
|
||||
|
|
@ -49,6 +145,7 @@ H{
|
|||
{ ":" "SEL" }
|
||||
} objc>alien-types set-global
|
||||
|
||||
! The transpose of the above map
|
||||
SYMBOL: alien>objc-types
|
||||
|
||||
objc>alien-types get hash>alist [ reverse ] map alist>hash
|
||||
|
|
@ -81,87 +178,27 @@ H{
|
|||
#! Undocumented hack! Apple does not support this feature!
|
||||
objc-method-types parse-objc-type ;
|
||||
|
||||
: objc-method-info ( method -- { return name args } )
|
||||
[ method-return-type ] keep
|
||||
[ objc-method-name sel_getName ] keep
|
||||
method-arg-types 3array ;
|
||||
: register-objc-method ( method -- )
|
||||
dup method-return-type over method-arg-types 2array
|
||||
swap objc-method-name sel_getName
|
||||
objc-methods get set-hash ;
|
||||
|
||||
: method-list@ ( ptr -- ptr )
|
||||
"objc-method-list" c-size swap <displaced-alien> ;
|
||||
|
||||
: method-list>seq ( method-list -- seq )
|
||||
dup method-list@ swap objc-method-list-count
|
||||
[ swap objc-method-nth objc-method-info ] map-with ;
|
||||
: (register-objc-methods) ( objc-class iterator -- )
|
||||
2dup class_nextMethodList [
|
||||
dup method-list@ swap objc-method-list-count [
|
||||
swap objc-method-nth register-objc-method
|
||||
] each-with (register-objc-methods)
|
||||
] [
|
||||
2drop
|
||||
] if* ;
|
||||
|
||||
: (objc-methods) ( objc-class iterator -- )
|
||||
2dup class_nextMethodList
|
||||
[ method-list>seq % (objc-methods) ] [ 2drop ] if* ;
|
||||
: register-objc-methods ( class -- seq )
|
||||
f <void*> (register-objc-methods) ;
|
||||
|
||||
: objc-methods ( class -- seq )
|
||||
[ f <void*> (objc-methods) ] { } make ;
|
||||
|
||||
: (objc-class) ( string word -- class )
|
||||
dupd execute
|
||||
[ ] [ "No such class: " swap append throw ] ?if ; inline
|
||||
|
||||
: objc-class ( string -- class )
|
||||
\ objc_getClass (objc-class) ;
|
||||
|
||||
: objc-meta-class ( string -- class )
|
||||
\ objc_getMetaClass (objc-class) ;
|
||||
|
||||
: class-exists? ( string -- class )
|
||||
objc_getClass >boolean ;
|
||||
|
||||
: instance-methods ( classname -- seq )
|
||||
objc-class objc-methods ;
|
||||
|
||||
: class-methods ( classname -- seq )
|
||||
objc-meta-class objc-methods ;
|
||||
|
||||
: <super> ( receiver class -- super )
|
||||
"objc-super" <c-object>
|
||||
[ set-objc-super-class ] keep
|
||||
[ set-objc-super-receiver ] keep ;
|
||||
|
||||
: SUPER-> \ SUPER-> on ; inline
|
||||
|
||||
: ?super ( obj -- class )
|
||||
objc-object-isa \ SUPER-> [ f ] change
|
||||
[ objc-class-super-class ] when ; inline
|
||||
|
||||
: selector-quot ( string -- )
|
||||
[
|
||||
[ dup ?super <super> ] % <selector> , \ selector ,
|
||||
] [ ] make ;
|
||||
|
||||
: make-objc-invoke
|
||||
[
|
||||
>r over length 2 - make-dip % r> call \ alien-invoke ,
|
||||
] [ ] make ;
|
||||
|
||||
: make-objc-send ( returns args selector -- )
|
||||
selector-quot
|
||||
[ swap , [ f "objc_msgSendSuper" ] % , ] make-objc-invoke ;
|
||||
|
||||
: make-objc-send-stret ( returns args selector -- )
|
||||
>r swap [ <c-object> dup ] curry 1 make-dip r>
|
||||
selector-quot append [
|
||||
"void" ,
|
||||
[ f "objc_msgSendSuper_stret" ] %
|
||||
{ "void*" } swap append ,
|
||||
] make-objc-invoke ;
|
||||
|
||||
: make-objc-method ( returns args selector -- )
|
||||
pick c-struct?
|
||||
[ make-objc-send-stret ] [ make-objc-send ] if ;
|
||||
|
||||
: import-objc-method ( returns types selector -- )
|
||||
[ make-objc-method "[" ] keep "]" append3 create-in
|
||||
swap define-compound ;
|
||||
|
||||
: import-objc-methods ( seq -- )
|
||||
[ first3 swap import-objc-method ] each ;
|
||||
: class-exists? ( string -- class ) objc_getClass >boolean ;
|
||||
|
||||
: unless-defined ( class quot -- )
|
||||
>r class-exists? r> unless ; inline
|
||||
|
|
@ -169,18 +206,13 @@ H{
|
|||
: define-objc-class-word ( name quot -- )
|
||||
[
|
||||
over , , \ unless-defined , dup , \ objc-class ,
|
||||
] [ ] make >r create-in r> define-compound ;
|
||||
] [ ] make >r "objc-classes" create r> define-compound ;
|
||||
|
||||
: import-objc-class ( name quot -- )
|
||||
#! The quotation is prepended to the class word. It should
|
||||
#! "regenerate" the class as appropriate (by loading a
|
||||
#! framework or defining the class in some manner).
|
||||
2dup unless-defined [
|
||||
"objc-" pick append in set
|
||||
2dup unless-defined
|
||||
dupd define-objc-class-word
|
||||
dup instance-methods import-objc-methods
|
||||
class-methods import-objc-methods
|
||||
] with-scope ;
|
||||
|
||||
: root-class ( class -- class )
|
||||
dup objc-class-super-class [ root-class ] [ ] ?if ;
|
||||
dup objc-class register-objc-methods
|
||||
objc-meta-class register-objc-methods ;
|
||||
|
|
|
|||
|
|
@ -1,35 +1,33 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc-FactorView
|
||||
IN: objc-classes
|
||||
DEFER: FactorView
|
||||
|
||||
IN: cocoa
|
||||
USING: arrays gadgets gadgets-layouts hashtables kernel math
|
||||
namespaces objc objc-NSEvent objc-NSObject
|
||||
objc-NSOpenGLContext objc-NSOpenGLView objc-NSView opengl
|
||||
sequences ;
|
||||
namespaces objc opengl sequences ;
|
||||
|
||||
: <GLView> ( class dim -- view )
|
||||
>r [alloc] 0 0 r> first2 <NSRect>
|
||||
NSOpenGLView [defaultPixelFormat]
|
||||
[initWithFrame:pixelFormat:]
|
||||
dup 1 [setPostsBoundsChangedNotifications:]
|
||||
dup 1 [setPostsFrameChangedNotifications:] ;
|
||||
>r -> alloc 0 0 r> first2 <NSRect>
|
||||
NSOpenGLView -> defaultPixelFormat
|
||||
-> initWithFrame:pixelFormat:
|
||||
dup 1 -> setPostsBoundsChangedNotifications:
|
||||
dup 1 -> setPostsFrameChangedNotifications: ;
|
||||
|
||||
: view-dim [bounds] dup NSRect-w swap NSRect-h 0 3array ;
|
||||
: view-dim -> bounds dup NSRect-w swap NSRect-h 0 3array ;
|
||||
|
||||
: mouse-location ( view event -- loc )
|
||||
over >r
|
||||
[locationInWindow] f [convertPoint:fromView:]
|
||||
-> locationInWindow f -> convertPoint:fromView:
|
||||
dup NSPoint-x swap NSPoint-y
|
||||
r> [frame] NSRect-h swap - 0 3array ;
|
||||
r> -> frame NSRect-h swap - 0 3array ;
|
||||
|
||||
: send-mouse-moved ( view event -- )
|
||||
over >r mouse-location r> window move-hand ;
|
||||
|
||||
: button ( event -- n )
|
||||
#! Cocoa -> Factor UI button mapping
|
||||
[buttonNumber] H{ { 0 1 } { 2 2 } { 1 3 } } hash ;
|
||||
-> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } hash ;
|
||||
|
||||
: button&loc ( view event -- button# loc )
|
||||
dup button -rot mouse-location ;
|
||||
|
|
@ -57,18 +55,18 @@ sequences ;
|
|||
} ;
|
||||
|
||||
: key-code ( event -- string )
|
||||
dup [keyCode] key-codes hash
|
||||
[ ] [ [charactersIgnoringModifiers] CF>string ] ?if ;
|
||||
dup -> keyCode key-codes hash
|
||||
[ ] [ -> charactersIgnoringModifiers CF>string ] ?if ;
|
||||
|
||||
: event>gesture ( event -- modifiers keycode )
|
||||
dup [modifierFlags] modifiers modifier swap key-code ;
|
||||
dup -> modifierFlags modifiers modifier swap key-code ;
|
||||
|
||||
: send-key-event ( view event quot -- )
|
||||
>r event>gesture r> call swap window world-focus
|
||||
handle-gesture ; inline
|
||||
|
||||
: send-user-input ( view event -- )
|
||||
[characters] CF>string swap window world-focus user-input ;
|
||||
-> characters CF>string swap window world-focus user-input ;
|
||||
|
||||
: send-key-down-event ( view event -- )
|
||||
2dup [ <key-down> ] send-key-event
|
||||
|
|
@ -84,7 +82,7 @@ sequences ;
|
|||
over >r button&loc r> window send-button-up ;
|
||||
|
||||
: send-wheel$ ( view event -- )
|
||||
[ [deltaY] 0 > ] 2keep mouse-location
|
||||
[ -> deltaY 0 > ] 2keep mouse-location
|
||||
rot window send-wheel ;
|
||||
|
||||
: add-resize-observer ( observer object -- )
|
||||
|
|
@ -160,7 +158,7 @@ sequences ;
|
|||
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
|
||||
[
|
||||
rot drop
|
||||
SUPER-> [initWithFrame:pixelFormat:]
|
||||
SUPER-> initWithFrame:pixelFormat:
|
||||
dup dup add-resize-observer
|
||||
]
|
||||
}
|
||||
|
|
@ -171,7 +169,7 @@ sequences ;
|
|||
dup window close-world
|
||||
dup unregister-window
|
||||
dup remove-observer
|
||||
SUPER-> [dealloc]
|
||||
SUPER-> dealloc
|
||||
]
|
||||
}
|
||||
} { } define-objc-class
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: objc-FactorWindowDelegate
|
||||
IN: objc-classes
|
||||
DEFER: FactorWindowDelegate
|
||||
|
||||
IN: cocoa
|
||||
USING: arrays gadgets gadgets-layouts kernel math objc
|
||||
objc-NSNotification objc-NSObject objc-NSView objc-NSWindow
|
||||
sequences ;
|
||||
|
||||
: NSBorderlessWindowMask 0 ; inline
|
||||
|
|
@ -25,24 +24,24 @@ sequences ;
|
|||
NSResizableWindowMask bitor ; inline
|
||||
|
||||
: <NSWindow> ( rect -- window )
|
||||
NSWindow [alloc] swap
|
||||
NSWindow -> alloc swap
|
||||
standard-window-type NSBackingStoreBuffered 1
|
||||
[initWithContentRect:styleMask:backing:defer:] ;
|
||||
-> initWithContentRect:styleMask:backing:defer: ;
|
||||
|
||||
: <ViewWindow> ( view bounds -- window )
|
||||
<NSWindow> [ swap [setContentView:] ] keep
|
||||
dup dup [contentView] [setInitialFirstResponder:]
|
||||
dup 1 [setAcceptsMouseMovedEvents:] ;
|
||||
<NSWindow> [ swap -> setContentView: ] keep
|
||||
dup dup -> contentView -> setInitialFirstResponder:
|
||||
dup 1 -> setAcceptsMouseMovedEvents: ;
|
||||
|
||||
: window-pref-dim [contentView] window pref-dim ;
|
||||
: window-pref-dim -> contentView window pref-dim ;
|
||||
|
||||
: frame-content-rect ( window rect -- rect )
|
||||
swap [styleMask] NSWindow -rot
|
||||
[frameRectForContentRect:styleMask:] ;
|
||||
swap -> styleMask NSWindow -rot
|
||||
-> frameRectForContentRect:styleMask: ;
|
||||
|
||||
: window-content-rect ( window -- rect )
|
||||
NSWindow over [frame] rot [styleMask]
|
||||
[contentRectForFrameRect:styleMask:] ;
|
||||
NSWindow over -> frame rot -> styleMask
|
||||
-> contentRectForFrameRect:styleMask: ;
|
||||
|
||||
"NSObject" "FactorWindowDelegate" {
|
||||
{
|
||||
|
|
@ -58,21 +57,21 @@ sequences ;
|
|||
|
||||
{
|
||||
"windowDidMove:" "void" { "id" "SEL" "id" } [
|
||||
2nip [object]
|
||||
2nip -> object
|
||||
dup window-content-rect NSRect-x-y 0 3array
|
||||
swap [contentView] window set-world-loc
|
||||
swap -> contentView window set-world-loc
|
||||
]
|
||||
}
|
||||
|
||||
{
|
||||
"windowDidBecomeKey:" "void" { "id" "SEL" "id" } [
|
||||
2nip [object] [contentView] window focus-world
|
||||
2nip -> object -> contentView window focus-world
|
||||
]
|
||||
}
|
||||
|
||||
{
|
||||
"windowDidResignKey:" "void" { "id" "SEL" "id" } [
|
||||
2nip [object] [contentView] window unfocus-world
|
||||
2nip -> object -> contentView window unfocus-world
|
||||
]
|
||||
}
|
||||
} { } define-objc-class
|
||||
|
|
|
|||
Loading…
Reference in New Issue