cocoa.subclassing: new METHOD: syntax cleans up class definitions

db4
Slava Pestov 2010-07-06 17:59:35 -04:00
parent bc87b269c5
commit bb4dae64f3
9 changed files with 237 additions and 352 deletions

View File

@ -7,12 +7,11 @@ IN: cocoa.tests
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }
{ +name+ "Foo" } { +name+ "Foo" }
} { }
"foo:"
void METHOD: void foo: NSRect rect [
{ id SEL NSRect } gc rect "x" set
[ gc "x" set 2drop ] ] ;
} ;
: test-foo ( -- ) : test-foo ( -- )
Foo -> alloc -> init Foo -> alloc -> init
@ -29,12 +28,9 @@ test-foo
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }
{ +name+ "Bar" } { +name+ "Bar" }
} { }
"bar"
NSRect METHOD: NSRect bar [ test-foo "x" get ] ;
{ id SEL }
[ 2drop test-foo "x" get ]
} ;
Bar [ Bar [
-> alloc -> init -> alloc -> init
@ -51,22 +47,16 @@ Bar [
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }
{ +name+ "Bar" } { +name+ "Bar" }
} { }
"bar"
NSRect METHOD: NSRect bar [ test-foo "x" get ]
{ id SEL }
[ 2drop test-foo "x" get ] METHOD: int babb: int x [ x sq ] ;
} {
"babb"
int
{ id SEL int }
[ 2nip sq ]
} ;
[ 144 ] [ [ 144 ] [
Bar [ Bar [
-> alloc -> init -> alloc -> init
dup 12 -> babb dup 12 -> babb:
swap -> release swap -> release
] compile-call ] compile-call
] unit-test ] unit-test

View File

@ -24,20 +24,31 @@ HELP: define-objc-class
{ "the selector naming the message; in most cases this value can be ignored" } { "the selector naming the message; in most cases this value can be ignored" }
"arguments passed to the message, if any" "arguments passed to the message, if any"
} }
"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into a hashtable." } ; "There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into an assoc." } ;
HELP: CLASS: HELP: CLASS:
{ $syntax "CLASS: spec imeth... ;" } { $syntax "CLASS: spec imeth... ;" }
{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } } { $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
{ $description "A sugared form of the following:" { $description "Defines a new Objective C class. The hashtable can contain the following keys:"
{ $code "{ imeth... } \"spec\" define-objc-class" } { $list
{ { $link +name+ } " - a string naming the new class. Required." }
{ { $link +superclass+ } " - a string naming the superclass. Required." }
{ { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
}
"Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
$nl
"This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ; "This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
{ define-objc-class POSTPONE: CLASS: } related-words { define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
HELP: METHOD:
{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
ARTICLE: "objc-subclassing" "Subclassing Objective C classes" ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:" "Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
{ $subsections POSTPONE: CLASS: } { $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
"This word is actually syntax sugar for an ordinary word:" "This word is actually syntax sugar for an ordinary word:"
{ $subsections define-objc-class } { $subsections define-objc-class }
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ; "Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;

View File

@ -1,9 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff. ! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs USING: alien alien.c-types alien.parser alien.strings arrays
combinators compiler hashtables kernel libc math namespaces assocs combinators compiler hashtables kernel lexer libc
parser sequences words cocoa.messages cocoa.runtime locals locals.parser locals.types math namespaces parser sequences
compiler.units io.encodings.utf8 continuations make fry ; words cocoa.messages cocoa.runtime locals compiler.units
io.encodings.utf8 continuations make fry effects stack-checker
stack-checker.errors ;
IN: cocoa.subclassing IN: cocoa.subclassing
: init-method ( method -- sel imp types ) : init-method ( method -- sel imp types )
@ -49,13 +51,13 @@ IN: cocoa.subclassing
] with-compilation-unit ; ] with-compilation-unit ;
:: (redefine-objc-method) ( class method -- ) :: (redefine-objc-method) ( class method -- )
method init-method [| sel imp types | method init-method :> ( sel imp types )
class sel class_getInstanceMethod [
imp method_setImplementation drop class sel class_getInstanceMethod [
] [ imp method_setImplementation drop
class sel imp types add-method ] [
] if* class sel imp types add-method
] call ; ] if* ;
: redefine-objc-methods ( imeth name -- ) : redefine-objc-methods ( imeth name -- )
dup class-exists? [ dup class-exists? [
@ -79,3 +81,35 @@ SYMBOL: +superclass+
SYNTAX: CLASS: SYNTAX: CLASS:
parse-definition unclip parse-definition unclip
>hashtable define-objc-class ; >hashtable define-objc-class ;
: (parse-selector) ( -- )
scan-token {
{ [ dup "[" = ] [ drop ] }
{ [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
[ f f 3array , "[" expect ]
} cond ;
: parse-selector ( -- selector types names )
[ (parse-selector) ] { } make
flip first3
[ concat ]
[ sift { id SEL } prepend ]
[ sift { "self" "selector" } prepend ] tri* ;
: parse-method-body ( names -- quot )
[ [ make-local ] map ] H{ } make-assoc
(parse-lambda) <lambda> ?rewrite-closures first ;
: method-effect ( quadruple -- effect )
[ third ] [ second void? { } { "x" } ? ] bi <effect> ;
: check-method ( quadruple -- )
[ fourth infer ] [ method-effect ] bi
2dup effect<= [ 2drop ] [ effect-error ] if ;
SYNTAX: METHOD:
scan-c-type
parse-selector
parse-method-body [ swap ] 2dip 4array
dup check-method
suffix! ;

View File

@ -13,12 +13,6 @@ IN: tools.deploy.shaker.cocoa
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ; : pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
IN: cocoa.application
: objc-error ( error -- ) die ;
[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
H{ } clone \ pool [ H{ } clone \ pool [
global [ global [
! Only keeps those methods that we actually call ! Only keeps those methods that we actually call

View File

@ -9,16 +9,13 @@ IN: tools.deploy.test.14
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }
{ +name+ "Bar" } { +name+ "Bar" }
} { }
"bar:"
float METHOD: float bar: NSRect rect [
{ id SEL NSRect } rect origin>> [ x>> ] [ y>> ] bi +
[ rect size>> [ w>> ] [ h>> ] bi +
[ origin>> [ x>> ] [ y>> ] bi + ] +
[ size>> [ w>> ] [ h>> ] bi + ] ] ;
bi +
]
} ;
: main ( -- ) : main ( -- )
Bar -> alloc -> init Bar -> alloc -> init

View File

@ -233,9 +233,7 @@ CLASS: {
{ +name+ "FactorApplicationDelegate" } { +name+ "FactorApplicationDelegate" }
} }
{ "applicationDidUpdate:" void { id SEL id } METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ;
[ 3drop reset-run-loop ]
} ;
: install-app-delegate ( -- ) : install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ; NSApp FactorApplicationDelegate install-delegate ;

View File

@ -26,45 +26,25 @@ CLASS: {
{ +name+ "FactorWorkspaceApplicationDelegate" } { +name+ "FactorWorkspaceApplicationDelegate" }
} }
{ "application:openFiles:" void { id SEL id id } METHOD: void application: id app openFiles: id files [ files finder-run-files ]
[ [ 3drop ] dip finder-run-files ]
}
{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int } METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
{ "factorListener:" id { id SEL id } METHOD: id factorListener: id app [ show-listener f ]
[ 3drop show-listener f ]
}
{ "factorBrowser:" id { id SEL id } METHOD: id factorBrowser: id app [ show-browser f ]
[ 3drop show-browser f ]
}
{ "newFactorListener:" id { id SEL id } METHOD: id newFactorListener: id app [ listener-window f ]
[ 3drop listener-window f ]
}
{ "newFactorBrowser:" id { id SEL id } METHOD: id newFactorBrowser: id app [ browser-window f ]
[ 3drop browser-window f ]
}
{ "runFactorFile:" id { id SEL id } METHOD: id runFactorFile: id app [ menu-run-files f ]
[ 3drop menu-run-files f ]
}
{ "saveFactorImage:" id { id SEL id } METHOD: id saveFactorImage: id app [ save f ]
[ 3drop save f ]
}
{ "saveFactorImageAs:" id { id SEL id } METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
[ 3drop menu-save-image f ]
}
{ "refreshAll:" id { id SEL id } METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ] ;
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
: install-app-delegate ( -- ) : install-app-delegate ( -- )
NSApp FactorWorkspaceApplicationDelegate install-delegate ; NSApp FactorWorkspaceApplicationDelegate install-delegate ;
@ -78,25 +58,16 @@ CLASS: {
CLASS: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }
{ +name+ "FactorServiceProvider" } { +name+ "FactorServiceProvider" }
} { }
"evalInListener:userData:error:"
void METHOD: void evalInListener: id pboard userData: id userData error: id error
{ id SEL id id id } [ pboard error [ eval-listener f ] do-service ]
[
nip METHOD: void evalToString: id pboard userData: id userData error: id error
[ eval-listener f ] do-service [
2drop pboard error
] [ [ (eval>string) ] with-interactive-vocabs ] do-service
} { ] ;
"evalToString:userData:error:"
void
{ id SEL id id id }
[
nip
[ [ (eval>string) ] with-interactive-vocabs ] do-service
2drop
]
} ;
: register-services ( -- ) : register-services ( -- )
NSApp NSApp

View File

@ -148,269 +148,168 @@ CLASS: {
} }
! Rendering ! Rendering
{ "drawRect:" void { id SEL NSRect } METHOD: void drawRect: NSRect rect [ self window draw-world ]
[ 2drop window draw-world ]
}
! Events ! Events
{ "acceptsFirstMouse:" char { id SEL id } METHOD: char acceptsFirstMouse: id event [ 1 ]
[ 3drop 1 ]
}
{ "mouseEntered:" void { id SEL id } METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
[ nip send-mouse-moved ]
}
{ "mouseExited:" void { id SEL id } METHOD: void mouseExited: id event [ forget-rollover ]
[ 3drop forget-rollover ]
}
{ "mouseMoved:" void { id SEL id } METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
[ nip send-mouse-moved ]
}
{ "mouseDragged:" void { id SEL id } METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
[ nip send-mouse-moved ]
}
{ "rightMouseDragged:" void { id SEL id } METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
[ nip send-mouse-moved ]
}
{ "otherMouseDragged:" void { id SEL id } METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
[ nip send-mouse-moved ]
}
{ "mouseDown:" void { id SEL id } METHOD: void mouseDown: id event [ self event send-button-down$ ]
[ nip send-button-down$ ]
}
{ "mouseUp:" void { id SEL id } METHOD: void mouseUp: id event [ self event send-button-up$ ]
[ nip send-button-up$ ]
}
{ "rightMouseDown:" void { id SEL id } METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
[ nip send-button-down$ ]
}
{ "rightMouseUp:" void { id SEL id } METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
[ nip send-button-up$ ]
}
{ "otherMouseDown:" void { id SEL id } METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
[ nip send-button-down$ ]
}
{ "otherMouseUp:" void { id SEL id } METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
[ nip send-button-up$ ]
}
{ "scrollWheel:" void { id SEL id } METHOD: void scrollWheel: id event [ self event send-scroll$ ]
[ nip send-scroll$ ]
}
{ "keyDown:" void { id SEL id } METHOD: void keyDown: id event [ self event send-key-down-event ]
[ nip send-key-down-event ]
}
{ "keyUp:" void { id SEL id } METHOD: void keyUp: id event [ self event send-key-up-event ]
[ nip send-key-up-event ]
}
{ "validateUserInterfaceItem:" char { id SEL id } METHOD: char validateUserInterfaceItem: id event
[ [
nip -> action self window
2dup [ window ] [ utf8 alien>string ] bi* validate-action event -> action utf8 alien>string validate-action
[ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
] ]
}
{ "undo:" id { id SEL id } METHOD: id undo: id event [ self event undo-action send-action$ ]
[ nip undo-action send-action$ ]
}
{ "redo:" id { id SEL id } METHOD: id redo: id event [ self event redo-action send-action$ ]
[ nip redo-action send-action$ ]
}
{ "cut:" id { id SEL id } METHOD: id cut: id event [ self event cut-action send-action$ ]
[ nip cut-action send-action$ ]
}
{ "copy:" id { id SEL id } METHOD: id copy: id event [ self event copy-action send-action$ ]
[ nip copy-action send-action$ ]
}
{ "paste:" id { id SEL id } METHOD: id paste: id event [ self event paste-action send-action$ ]
[ nip paste-action send-action$ ]
}
{ "delete:" id { id SEL id } METHOD: id delete: id event [ self event delete-action send-action$ ]
[ nip delete-action send-action$ ]
}
{ "selectAll:" id { id SEL id } METHOD: id selectAll: id event [ self event select-all-action send-action$ ]
[ nip select-all-action send-action$ ]
}
{ "newDocument:" id { id SEL id } METHOD: id newDocument: id event [ self event new-action send-action$ ]
[ nip new-action send-action$ ]
}
{ "openDocument:" id { id SEL id } METHOD: id openDocument: id event [ self event open-action send-action$ ]
[ nip open-action send-action$ ]
}
{ "saveDocument:" id { id SEL id } METHOD: id saveDocument: id event [ self event save-action send-action$ ]
[ nip save-action send-action$ ]
}
{ "saveDocumentAs:" id { id SEL id } METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ]
[ nip save-as-action send-action$ ]
}
{ "revertDocumentToSaved:" id { id SEL id } METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ]
[ nip revert-action send-action$ ]
}
! Multi-touch gestures: this is undocumented. ! Multi-touch gestures
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html METHOD: void magnifyWithEvent: id event
{ "magnifyWithEvent:" void { id SEL id } [
[ self event
nip dup -> deltaZ sgn {
dup -> deltaZ sgn { { 1 [ zoom-in-action send-action$ drop ] }
{ 1 [ zoom-in-action send-action$ ] } { -1 [ zoom-out-action send-action$ drop ] }
{ -1 [ zoom-out-action send-action$ ] } { 0 [ 2drop ] }
{ 0 [ 2drop ] } } case
} case ]
]
}
{ "swipeWithEvent:" void { id SEL id } METHOD: void swipeWithEvent: id event
[ [
nip self event
dup -> deltaX sgn { dup -> deltaX sgn {
{ 1 [ left-action send-action$ ] } { 1 [ left-action send-action$ drop ] }
{ -1 [ right-action send-action$ ] } { -1 [ right-action send-action$ drop ] }
{ 0 { 0
[ [
dup -> deltaY sgn { dup -> deltaY sgn {
{ 1 [ up-action send-action$ ] } { 1 [ up-action send-action$ drop ] }
{ -1 [ down-action send-action$ ] } { -1 [ down-action send-action$ drop ] }
{ 0 [ 2drop ] } { 0 [ 2drop ] }
} case } case
] ]
} }
} case } case
] ]
}
{ "acceptsFirstResponder" char { id SEL } METHOD: char acceptsFirstResponder [ 1 ]
[ 2drop 1 ]
}
! Services ! Services
{ "validRequestorForSendType:returnType:" id { id SEL id id } METHOD: id validRequestorForSendType: id sendType returnType: id returnType
[ [
! We return either self or nil ! We return either self or nil
[ over window-focus ] 2dip self window world-focus sendType returnType
valid-service? [ drop ] [ 2drop f ] if valid-service? [ self ] [ f ] if
] ]
}
{ "writeSelectionToPasteboard:types:" char { id SEL id id } METHOD: char writeSelectionToPasteboard: id pboard types: id types
[ [
CF>string-array NSStringPboardType swap member? [ NSStringPboardType types CF>string-array member? [
[ drop window-focus gadget-selection ] dip over self window world-focus gadget-selection
[ set-pasteboard-string 1 ] [ 2drop 0 ] if [ pboard set-pasteboard-string 1 ] [ 0 ] if*
] [ 3drop 0 ] if ] [ 0 ] if
] ]
}
{ "readSelectionFromPasteboard:" char { id SEL id } METHOD: char readSelectionFromPasteboard: id pboard
[ [
pasteboard-string dup [ pboard pasteboard-string
[ drop window ] dip swap user-input 1 [ self window user-input 1 ] [ 0 ] if*
] [ 3drop 0 ] if ]
]
}
! Text input ! Text input
{ "insertText:" void { id SEL id } METHOD: void insertText: id text
[ nip CF>string swap window user-input ] [ text CF>string self window user-input ]
}
{ "hasMarkedText" char { id SEL } METHOD: char hasMarkedText [ 0 ]
[ 2drop 0 ]
}
{ "markedRange" NSRange { id SEL } METHOD: NSRange markedRange [ 0 0 <NSRange> ]
[ 2drop 0 0 <NSRange> ]
}
{ "selectedRange" NSRange { id SEL } METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
[ 2drop 0 0 <NSRange> ]
}
{ "setMarkedText:selectedRange:" void { id SEL id NSRange } METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
[ 2drop 2drop ]
}
{ "unmarkText" void { id SEL } METHOD: void unmarkText [ ]
[ 2drop ]
}
{ "validAttributesForMarkedText" id { id SEL } METHOD: id validAttributesForMarkedText [ NSArray -> array ]
[ 2drop NSArray -> array ]
}
{ "attributedSubstringFromRange:" id { id SEL NSRange } METHOD: id attributedSubstringFromRange: NSRange range [ f ]
[ 3drop f ]
}
{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint } METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
[ 3drop 0 ]
}
{ "firstRectForCharacterRange:" NSRect { id SEL NSRange } METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
[ 3drop 0 0 0 0 <CGRect> ]
}
{ "conversationIdentifier" NSInteger { id SEL } METHOD: NSInteger conversationIdentifier [ self alien-address ]
[ drop alien-address ]
}
! Initialization ! Initialization
{ "updateFactorGadgetSize:" void { id SEL id } METHOD: void updateFactorGadgetSize: id notification
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ] [ self view-dim self window dim<< yield ]
}
{ "doCommandBySelector:" void { id SEL SEL } METHOD: void doCommandBySelector: SEL selector [ ]
[ 3drop ]
}
{ "initWithFrame:pixelFormat:" id { id SEL NSRect id } METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
[ [
[ drop ] 2dip self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
SUPER-> initWithFrame:pixelFormat: dup dup add-resize-observer
dup dup add-resize-observer ]
]
}
{ "isOpaque" char { id SEL } METHOD: char isOpaque [ 0 ]
[
2drop 0
]
}
{ "dealloc" void { id SEL } METHOD: void dealloc
[ [
drop self remove-observer
[ remove-observer ] self SUPER-> dealloc
[ SUPER-> dealloc ] ] ;
bi
]
} ;
: sync-refresh-to-screen ( GLView -- ) : sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int> -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
@ -423,44 +322,37 @@ CLASS: {
-> frame CGRect-top-left 2array >>window-loc drop ; -> frame CGRect-top-left 2array >>window-loc drop ;
CLASS: { CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "FactorWindowDelegate" } { +name+ "FactorWindowDelegate" }
{ +superclass+ "NSObject" }
} }
{ "windowDidMove:" void { id SEL id } METHOD: void windowDidMove: id notification
[ [
2nip -> object [ -> contentView window ] keep save-position notification -> object -> contentView window
] notification -> object save-position
} ]
{ "windowDidBecomeKey:" void { id SEL id } METHOD: void windowDidBecomeKey: id notification
[ [
2nip -> object -> contentView window focus-world notification -> object -> contentView window
] focus-world
} ]
{ "windowDidResignKey:" void { id SEL id } METHOD: void windowDidResignKey: id notification
[ [
forget-rollover forget-rollover
2nip -> object -> contentView notification -> object -> contentView
dup -> isInFullScreenMode 0 = dup -> isInFullScreenMode 0 =
[ window [ unfocus-world ] when* ] [ window [ unfocus-world ] when* ] [ drop ] if
[ drop ] if ]
]
}
{ "windowShouldClose:" char { id SEL id } METHOD: char windowShouldClose: id notification [ 1 ]
[
3drop 1
]
}
{ "windowWillClose:" void { id SEL id } METHOD: void windowWillClose: id notification
[ [
2nip -> object -> contentView notification -> object -> contentView
[ window ungraft ] [ unregister-window ] bi [ window ungraft ] [ unregister-window ] bi
] ] ;
} ;
: install-window-delegate ( window -- ) : install-window-delegate ( window -- )
FactorWindowDelegate install-delegate ; FactorWindowDelegate install-delegate ;

View File

@ -16,8 +16,6 @@ SYMBOL: windows
: window ( handle -- world ) windows get-global at ; : window ( handle -- world ) windows get-global at ;
: window-focus ( handle -- gadget ) window world-focus ;
: register-window ( world handle -- ) : register-window ( world handle -- )
#! Add the new window just below the topmost window. Why? #! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus #! So that if the new window doesn't actually receive focus