Merge branch 'master' of factorcode.org:/git/factor
commit
4785479ea0
|
@ -14,7 +14,7 @@ SYMBOL: sent-messages
|
||||||
|
|
||||||
SYNTAX: -> scan-token dup remember-send suffix! \ send suffix! ;
|
SYNTAX: -> scan-token dup remember-send suffix! \ send suffix! ;
|
||||||
|
|
||||||
SYNTAX: ?-> scan-token dup remember-send suffix! \ ?send suffix! ;
|
SYNTAX: ?-> dup last cache-stubs scan-token dup remember-send suffix! \ ?send suffix! ;
|
||||||
|
|
||||||
SYNTAX: SEL:
|
SYNTAX: SEL:
|
||||||
scan-token
|
scan-token
|
||||||
|
|
|
@ -4,8 +4,8 @@ USING: accessors alien alien.c-types alien.data alien.strings
|
||||||
arrays assocs classes.struct cocoa.runtime cocoa.types
|
arrays assocs classes.struct cocoa.runtime cocoa.types
|
||||||
combinators core-graphics.types fry generalizations
|
combinators core-graphics.types fry generalizations
|
||||||
io.encodings.utf8 kernel layouts libc locals macros make math
|
io.encodings.utf8 kernel layouts libc locals macros make math
|
||||||
memoize namespaces quotations sequences specialized-arrays
|
memoize namespaces quotations sequences sets specialized-arrays
|
||||||
stack-checker strings words ;
|
splitting stack-checker strings words ;
|
||||||
QUALIFIED-WITH: alien.c-types c
|
QUALIFIED-WITH: alien.c-types c
|
||||||
IN: cocoa.messages
|
IN: cocoa.messages
|
||||||
|
|
||||||
|
@ -44,7 +44,11 @@ super-message-senders [ H{ } clone ] initialize
|
||||||
|
|
||||||
TUPLE: selector-tuple name object ;
|
TUPLE: selector-tuple name object ;
|
||||||
|
|
||||||
MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ;
|
: selector-name ( name -- name' )
|
||||||
|
CHAR: . over index [ 0 > [ "." split1 nip ] when ] when* ;
|
||||||
|
|
||||||
|
MEMO: <selector> ( name -- sel )
|
||||||
|
selector-name f selector-tuple boa ;
|
||||||
|
|
||||||
: selector ( selector -- alien )
|
: selector ( selector -- alien )
|
||||||
dup object>> expired? [
|
dup object>> expired? [
|
||||||
|
@ -90,7 +94,7 @@ MACRO:: (?send) ( effect selector super? -- quot )
|
||||||
selector dup ?lookup-method effect or super?
|
selector dup ?lookup-method effect or super?
|
||||||
[ make-prepare-send ] 2keep
|
[ make-prepare-send ] 2keep
|
||||||
super-message-senders message-senders ? get at
|
super-message-senders message-senders ? get at
|
||||||
[ 1quotation append ] [ effect selector sender-stub 1quotation append ] if* ;
|
1quotation append ;
|
||||||
|
|
||||||
: ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
|
: ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
|
||||||
|
|
||||||
|
@ -234,16 +238,28 @@ ERROR: no-objc-type name ;
|
||||||
: method-name ( method -- name )
|
: method-name ( method -- name )
|
||||||
method_getName sel_getName ;
|
method_getName sel_getName ;
|
||||||
|
|
||||||
: register-objc-method ( method -- )
|
:: register-objc-method ( classname method -- )
|
||||||
[ method-name ]
|
method method-return-type
|
||||||
[ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
|
method method-arg-types 2array :> signature
|
||||||
[ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
|
method method-name :> name
|
||||||
|
classname "." name 3append :> fullname
|
||||||
|
signature cache-stubs
|
||||||
|
signature name objc-methods get set-at
|
||||||
|
signature fullname objc-methods get set-at ;
|
||||||
|
|
||||||
: each-method-in-class ( class quot -- )
|
: method-collisions ( -- collisions )
|
||||||
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip
|
objc-methods get >alist
|
||||||
over 0 = [ 3drop ] [
|
[ first CHAR: . swap member? ] filter
|
||||||
|
[ first "." split1 nip ] collect-by
|
||||||
|
[ nip values members length 1 > ] assoc-filter ;
|
||||||
|
|
||||||
|
: each-method-in-class ( class quot: ( class method -- ) -- )
|
||||||
|
[
|
||||||
|
[ class_getName ] keep
|
||||||
|
{ uint } [ class_copyMethodList ] with-out-parameters
|
||||||
|
] dip over 0 = [ 4drop ] [
|
||||||
[ void* <c-direct-array> ] dip
|
[ void* <c-direct-array> ] dip
|
||||||
[ each ] [ drop (free) ] 2bi
|
[ with each ] [ drop (free) ] 2bi
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: register-objc-methods ( class -- )
|
: register-objc-methods ( class -- )
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2017 Doug Coleman.
|
! Copyright (C) 2017 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types cocoa cocoa.classes cocoa.messages
|
USING: alien.c-types cocoa cocoa.classes cocoa.messages
|
||||||
cocoa.runtime combinators compiler.units core-foundation.strings
|
cocoa.runtime combinators core-foundation.strings kernel locals
|
||||||
init kernel locals namespaces sequences ;
|
;
|
||||||
IN: cocoa.touchbar
|
IN: cocoa.touchbar
|
||||||
|
|
||||||
: make-touchbar ( seq self -- touchbar )
|
: make-touchbar ( seq self -- touchbar )
|
||||||
|
@ -21,25 +21,3 @@ IN: cocoa.touchbar
|
||||||
action-string lookup-selector { id { id SEL id id SEL } } ?-> buttonWithTitle:target:action: :> button
|
action-string lookup-selector { id { id SEL id id SEL } } ?-> buttonWithTitle:target:action: :> button
|
||||||
item button -> setView:
|
item button -> setView:
|
||||||
item ;
|
item ;
|
||||||
|
|
||||||
! Temporary hack to support new touchbar API on old macOS build
|
|
||||||
! machines by attempting to re-import the objc-class which
|
|
||||||
! causes re-registering of the objc-methods which were not
|
|
||||||
! present on the macOS 10.11 build machine. We use a flag
|
|
||||||
! to cause this delay only the first time the image is run
|
|
||||||
! and then saved.
|
|
||||||
<PRIVATE
|
|
||||||
SYMBOL: imported?
|
|
||||||
PRIVATE>
|
|
||||||
[
|
|
||||||
imported? get-global [
|
|
||||||
[
|
|
||||||
{
|
|
||||||
"NSCustomTouchBarItem"
|
|
||||||
"NSTouchBar"
|
|
||||||
"NSTouchBarItem"
|
|
||||||
} [ [ ] import-objc-class ] each
|
|
||||||
] with-compilation-unit
|
|
||||||
t imported? set-global
|
|
||||||
] unless
|
|
||||||
] "cocoa.touchbar" add-startup-hook
|
|
||||||
|
|
|
@ -189,11 +189,9 @@ M: send-touchbar-command send-queued-gesture
|
||||||
self SEL: setWantsBestResolutionOpenGLSurface:
|
self SEL: setWantsBestResolutionOpenGLSurface:
|
||||||
-> respondsToSelector: c-bool> [
|
-> respondsToSelector: c-bool> [
|
||||||
|
|
||||||
self SEL: setWantsBestResolutionOpenGLSurface: 1
|
self 1 { void { id SEL char } } ?-> setWantsBestResolutionOpenGLSurface:
|
||||||
void f "objc_msgSend" { id SEL char } f alien-invoke
|
|
||||||
|
|
||||||
self SEL: backingScaleFactor
|
self { double { id SEL } } ?-> backingScaleFactor
|
||||||
double f "objc_msgSend" { id SEL } f alien-invoke
|
|
||||||
|
|
||||||
dup 1.0 > [
|
dup 1.0 > [
|
||||||
gl-scale-factor set-global t retina? set-global
|
gl-scale-factor set-global t retina? set-global
|
||||||
|
@ -213,13 +211,13 @@ M: send-touchbar-command send-queued-gesture
|
||||||
METHOD: void touchBarCommand6 [ 6 touchbar-invoke-command ] ;
|
METHOD: void touchBarCommand6 [ 6 touchbar-invoke-command ] ;
|
||||||
METHOD: void touchBarCommand7 [ 7 touchbar-invoke-command ] ;
|
METHOD: void touchBarCommand7 [ 7 touchbar-invoke-command ] ;
|
||||||
|
|
||||||
METHOD: Class makeTouchBar [
|
METHOD: id makeTouchBar [
|
||||||
touchbar-commands drop [
|
touchbar-commands drop [
|
||||||
length 8 min <iota> [ number>string ] map
|
length 8 min <iota> [ number>string ] map
|
||||||
] [ { } ] if* self make-touchbar
|
] [ { } ] if* self make-touchbar
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
METHOD: Class touchBar: Class touchbar makeItemForIdentifier: Class string [
|
METHOD: id touchBar: id touchbar makeItemForIdentifier: id string [
|
||||||
touchbar-commands drop [
|
touchbar-commands drop [
|
||||||
[ self string CF>string dup string>number ] dip nth
|
[ self string CF>string dup string>number ] dip nth
|
||||||
second name>> "com-" ?head drop over
|
second name>> "com-" ?head drop over
|
||||||
|
@ -271,29 +269,29 @@ M: send-touchbar-command send-queued-gesture
|
||||||
] [ 0 ] if*
|
] [ 0 ] if*
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
METHOD: id undo: id event [ self event undo-action send-action$ f ] ;
|
METHOD: void undo: id event [ self event undo-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id redo: id event [ self event redo-action send-action$ f ] ;
|
METHOD: void redo: id event [ self event redo-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id cut: id event [ self event cut-action send-action$ f ] ;
|
METHOD: void cut: id event [ self event cut-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id copy: id event [ self event copy-action send-action$ f ] ;
|
METHOD: void copy: id event [ self event copy-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id paste: id event [ self event paste-action send-action$ f ] ;
|
METHOD: void paste: id event [ self event paste-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id delete: id event [ self event delete-action send-action$ f ] ;
|
METHOD: void delete: id event [ self event delete-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id selectAll: id event [ self event select-all-action send-action$ f ] ;
|
METHOD: void selectAll: id event [ self event select-all-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id newDocument: id event [ self event new-action send-action$ f ] ;
|
METHOD: void newDocument: id event [ self event new-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id openDocument: id event [ self event open-action send-action$ f ] ;
|
METHOD: void openDocument: id event [ self event open-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id saveDocument: id event [ self event save-action send-action$ f ] ;
|
METHOD: void saveDocument: id event [ self event save-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ] ;
|
METHOD: void saveDocumentAs: id event [ self event save-as-action send-action$ ] ;
|
||||||
|
|
||||||
METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ] ;
|
METHOD: void revertDocumentToSaved: id event [ self event revert-action send-action$ ] ;
|
||||||
|
|
||||||
! Multi-touch gestures
|
! Multi-touch gestures
|
||||||
METHOD: void magnifyWithEvent: id event
|
METHOD: void magnifyWithEvent: id event
|
||||||
|
|
Loading…
Reference in New Issue