(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
- scan {
+ scan-token {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
- scan create-function
+ scan-token create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
{ $values { "receiver" "an " { $snippet "NSObject" } } { "delegate" "an Objective C class" } }
{ $description "Sets the receiver's delegate to a new instance of the delegate class." } ;
-HELP: objc-error
-{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
-
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsections
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
-TUPLE: objc-error alien reason ;
-
-: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error boa throw ;
-
-M: objc-error summary ( error -- )
- drop "Objective C exception" ;
-
-[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
: running.app? ( -- ? )
#! Test if we're running a .app.
".app"
+++ /dev/null
-Kevin P. Reid
+++ /dev/null
-! Copyright (C) 2005, 2006 Kevin Reid.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types assocs kernel namespaces cocoa
-cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
-IN: cocoa.callbacks
-
-SYMBOL: callbacks
-
-: reset-callbacks ( -- )
- H{ } clone callbacks set-global ;
-
-reset-callbacks
-
-CLASS: {
- { +name+ "FactorCallback" }
- { +superclass+ "NSObject" }
-}
-
-{ "perform:" void { id SEL id }
- [ 2drop callbacks get at try ]
-}
-
-{ "dealloc" void { id SEL }
- [
- drop
- dup callbacks get delete-at
- SUPER-> dealloc
- ]
-} ;
-
-: <FactorCallback> ( quot -- id )
- FactorCallback -> alloc -> init
- [ callbacks get set-at ] keep ;
+++ /dev/null
-Allows you to use Factor quotations as Cocoa actions
FROM: alien.c-types => int void ;
IN: cocoa.tests
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Foo" }
-} {
- "foo:"
- void
- { id SEL NSRect }
- [ gc "x" set 2drop ]
-} ;
+CLASS: Foo < NSObject
+[
+ METHOD: void foo: NSRect rect [
+ gc rect "x" set
+ ]
+]
: test-foo ( -- )
Foo -> alloc -> init
[ 101.0 ] [ "x" get CGRect-w ] unit-test
[ 102.0 ] [ "x" get CGRect-h ] unit-test
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+]
Bar [
-> alloc -> init
[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} {
- "babb"
- int
- { id SEL int }
- [ 2nip sq ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+
+ METHOD: int babb: int x [ x sq ]
+]
[ 144 ] [
Bar [
-> alloc -> init
- dup 12 -> babb
+ dup 12 -> babb:
swap -> release
] compile-call
] unit-test
USING: help.markup help.syntax strings alien hashtables ;
IN: cocoa.subclassing
-HELP: define-objc-class
-{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
-{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
- { $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." }
- }
-"Every element of " { $snippet "imeth" } " defines an instance method, and is an array having the shape "
-{ $snippet "{ name return args quot }" }
-".:"
-{ $table
- { "name" { "a selector name" } }
- { "name" { "a C type name; see " { $link "c-data" } } }
- { "args" { "a sequence of C type names; see " { $link "c-data" } } }
- { "quot" { "a quotation to be run as a callback when the method is invoked; see " { $link alien-callback } } }
-}
-"The quotation is run with the following values on the stack:"
-{ $list
- { "the receiver of the message; an " { $link alien } " pointing to an instance of this class" }
- { "the selector naming the message; in most cases this value can be ignored" }
- "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." } ;
-
HELP: CLASS:
-{ $syntax "CLASS: spec imeth... ;" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
-{ $description "A sugared form of the following:"
- { $code "{ imeth... } \"spec\" define-objc-class" }
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
+{ $values { "name" "a new class name" } { "superclass" "a superclass name" } { "protocols" "zero or more protocol names" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
+{ $description "Defines a new Objective C class. 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." } ;
-{ 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"
-"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
-{ $subsections POSTPONE: CLASS: }
-"This word is actually syntax sugar for an ordinary word:"
-{ $subsections define-objc-class }
+"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
+{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
"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." ;
IN: cocoa.subclassing
-! 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.
-USING: alien alien.c-types alien.strings arrays assocs
-combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.utf8 continuations make fry ;
+USING: alien alien.c-types alien.parser alien.strings arrays
+assocs combinators compiler hashtables kernel lexer libc
+locals.parser locals.types math namespaces parser sequences
+words cocoa.messages cocoa.runtime locals compiler.units
+io.encodings.utf8 continuations make fry effects stack-checker
+stack-checker.errors ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
: add-protocols ( protocols class -- )
'[ [ _ ] dip objc-protocol add-protocol ] each ;
-: (define-objc-class) ( imeth protocols superclass name -- )
+: (define-objc-class) ( methods protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
] with-compilation-unit ;
:: (redefine-objc-method) ( class method -- )
- method init-method [| sel imp types |
- class sel class_getInstanceMethod [
- imp method_setImplementation drop
- ] [
- class sel imp types add-method
- ] if*
- ] call ;
+ method init-method :> ( sel imp types )
+
+ class sel class_getInstanceMethod [
+ imp method_setImplementation drop
+ ] [
+ class sel imp types add-method
+ ] if* ;
-: redefine-objc-methods ( imeth name -- )
+: redefine-objc-methods ( methods name -- )
dup class-exists? [
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
-SYMBOL: +name+
-SYMBOL: +protocols+
-SYMBOL: +superclass+
-
-: define-objc-class ( imeth hash -- )
- clone [
- prepare-methods
- +name+ get "cocoa.classes" create drop
- +name+ get 2dup redefine-objc-methods swap
- +protocols+ get +superclass+ get +name+ get
- '[ _ _ _ _ (define-objc-class) ]
- import-objc-class
- ] bind ;
+:: define-objc-class ( name superclass protocols methods -- )
+ methods prepare-methods :> methods
+ name "cocoa.classes" create drop
+ methods name redefine-objc-methods
+ name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
SYNTAX: CLASS:
- parse-definition unclip
- >hashtable define-objc-class ;
+ scan-token
+ "<" expect
+ scan-token
+ "[" parse-tokens
+ \ ] parse-until 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! ;
dup search dup lexical? [ nip ] [ drop ] if ;
: scan-string-param ( -- name/param )
- scan >string-param ;
+ scan-token >string-param ;
: scan-c-type-param ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
-M: output-port stream-element-type stream>> stream-element-type ; inline
+M: output-port stream-element-type
+ stream>> stream-element-type ; inline
M: output-port stream-write1
dup check-disposed
HOOK: (wait-to-write) io-backend ( port -- )
+: port-flush ( port -- )
+ dup buffer>> buffer-empty?
+ [ drop ] [ dup (wait-to-write) port-flush ] if ;
+
+M: output-port stream-flush ( port -- )
+ [ check-disposed ] [ port-flush ] bi ;
+
HOOK: tell-handle os ( handle -- n )
+
HOOK: seek-handle os ( n seek-type handle -- )
-M: buffered-port stream-tell ( stream -- n )
+M: input-port stream-tell ( stream -- n )
[ check-disposed ]
- [ handle>> tell-handle ]
- [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
+
+M: output-port stream-tell ( stream -- n )
+ [ check-disposed ]
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
M: input-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
M: object shutdown drop ;
-: port-flush ( port -- )
- dup buffer>> buffer-empty?
- [ drop ] [ dup (wait-to-write) port-flush ] if ;
-
-M: output-port stream-flush ( port -- )
- [ check-disposed ] [ port-flush ] bi ;
-
M: output-port dispose*
[
{
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
- scan {
- { [ dup not ] [ unexpected-eof ] }
+ scan-token {
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
: 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 [
global [
! Only keeps those methods that we actually call
FROM: alien.c-types => float ;
IN: tools.deploy.test.14
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar:"
- float
- { id SEL NSRect }
- [
- [ origin>> [ x>> ] [ y>> ] bi + ]
- [ size>> [ w>> ] [ h>> ] bi + ]
- bi +
+CLASS: Bar < NSObject
+[
+ METHOD: float bar: NSRect rect [
+ rect origin>> [ x>> ] [ y>> ] bi +
+ rect size>> [ w>> ] [ h>> ] bi +
+ +
]
-} ;
+]
: main ( -- )
Bar -> alloc -> init
] [ 2drop ] if*
init-thread-timer ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "applicationDidUpdate:" void { id SEL id }
- [ 3drop reset-run-loop ]
-} ;
+CLASS: FactorApplicationDelegate < NSObject
+[
+ METHOD: void applicationDidUpdate: id obj
+ [ reset-run-loop ]
+]
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
image save-panel [ save-image ] when* ;
! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "FactorApplicationDelegate" }
- { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-{ "application:openFiles:" void { id SEL id id }
- [ [ 3drop ] dip finder-run-files ]
-}
+CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
+[
+ METHOD: void application: id app openFiles: id files [ files finder-run-files ]
-{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
- [ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
-}
+ METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
-{ "factorListener:" id { id SEL id }
- [ 3drop show-listener f ]
-}
+ METHOD: id factorListener: id app [ show-listener f ]
-{ "factorBrowser:" id { id SEL id }
- [ 3drop show-browser f ]
-}
+ METHOD: id factorBrowser: id app [ show-browser f ]
-{ "newFactorListener:" id { id SEL id }
- [ 3drop listener-window f ]
-}
+ METHOD: id newFactorListener: id app [ listener-window f ]
-{ "newFactorBrowser:" id { id SEL id }
- [ 3drop browser-window f ]
-}
+ METHOD: id newFactorBrowser: id app [ browser-window f ]
-{ "runFactorFile:" id { id SEL id }
- [ 3drop menu-run-files f ]
-}
+ METHOD: id runFactorFile: id app [ menu-run-files f ]
-{ "saveFactorImage:" id { id SEL id }
- [ 3drop save f ]
-}
+ METHOD: id saveFactorImage: id app [ save f ]
-{ "saveFactorImageAs:" id { id SEL id }
- [ 3drop menu-save-image f ]
-}
+ METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
-{ "refreshAll:" id { id SEL id }
- [ 3drop [ refresh-all ] \ refresh-all call-listener f ]
-} ;
+ METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
+]
: install-app-delegate ( -- )
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- void
- { id SEL id id id }
- [
- nip
- [ eval-listener f ] do-service
- 2drop
- ]
-} {
- "evalToString:userData:error:"
- void
- { id SEL id id id }
+CLASS: FactorServiceProvider < NSObject
+[
+ METHOD: void evalInListener: id pboard userData: id userData error: id error
+ [ pboard error [ eval-listener f ] do-service ]
+
+ METHOD: void evalToString: id pboard userData: id userData error: id error
[
- nip
+ pboard error
[ [ (eval>string) ] with-interactive-vocabs ] do-service
- 2drop
]
-} ;
+]
: register-services ( -- )
NSApp
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
-core-foundation.strings core-graphics core-graphics.types threads
-combinators math.rectangles ;
+cocoa.runtime cocoa.types cocoa.windows sequences
+io.encodings.utf8 locals ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
+ [ mouse-location ] [ drop window ] 2bi
+ dup [ move-hand fire-motion yield ] [ 2drop ] if ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
[ event-modifiers ] [ key-code ] bi ;
: send-key-event ( view gesture -- )
- swap window propagate-key-gesture ;
+ swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-down ;
+ 2tri
+ dup [ send-button-down ] [ 3drop ] if ;
: send-button-up$ ( view event -- )
[ nip mouse-event>gesture <button-up> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-up ;
+ 2tri
+ dup [ send-button-up ] [ 3drop ] if ;
: send-scroll$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
- 2tri send-scroll ;
+ 2tri
+ dup [ send-scroll ] [ 3drop ] if ;
-: send-action$ ( view event gesture -- junk )
- [ drop window ] dip send-action f ;
+: send-action$ ( view event gesture -- )
+ [ drop window ] dip over [ send-action ] [ 2drop ] if ;
: add-resize-observer ( observer object -- )
[
selector>action at
[ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
+CLASS: FactorView < NSOpenGLView NSTextInput
+[
+ ! Rendering
+ METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
-! Rendering
-{ "drawRect:" void { id SEL NSRect }
- [ 2drop window draw-world ]
-}
+ ! Events
+ METHOD: char acceptsFirstMouse: id event [ 1 ]
-! Events
-{ "acceptsFirstMouse:" char { id SEL id }
- [ 3drop 1 ]
-}
+ METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
-{ "mouseEntered:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseExited: id event [ forget-rollover ]
-{ "mouseExited:" void { id SEL id }
- [ 3drop forget-rollover ]
-}
+ METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
-{ "mouseMoved:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
-{ "mouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
-{ "rightMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
-{ "otherMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDown: id event [ self event send-button-down$ ]
-{ "mouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
-
-{ "mouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void mouseUp: id event [ self event send-button-up$ ]
-{ "rightMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
-{ "rightMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
-{ "otherMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
-{ "otherMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
-{ "scrollWheel:" void { id SEL id }
- [ nip send-scroll$ ]
-}
+ METHOD: void scrollWheel: id event [ self event send-scroll$ ]
-{ "keyDown:" void { id SEL id }
- [ nip send-key-down-event ]
-}
+ METHOD: void keyDown: id event [ self event send-key-down-event ]
-{ "keyUp:" void { id SEL id }
- [ nip send-key-up-event ]
-}
+ METHOD: void keyUp: id event [ self event send-key-up-event ]
-{ "validateUserInterfaceItem:" char { id SEL id }
+ METHOD: char validateUserInterfaceItem: id event
[
- nip -> action
- 2dup [ window ] [ utf8 alien>string ] bi* validate-action
- [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+ self window [
+ event -> action utf8 alien>string validate-action
+ [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+ ] [ 0 ] if*
]
-}
-{ "undo:" id { id SEL id }
- [ nip undo-action send-action$ ]
-}
+ METHOD: id undo: id event [ self event undo-action send-action$ f ]
-{ "redo:" id { id SEL id }
- [ nip redo-action send-action$ ]
-}
+ METHOD: id redo: id event [ self event redo-action send-action$ f ]
-{ "cut:" id { id SEL id }
- [ nip cut-action send-action$ ]
-}
+ METHOD: id cut: id event [ self event cut-action send-action$ f ]
-{ "copy:" id { id SEL id }
- [ nip copy-action send-action$ ]
-}
+ METHOD: id copy: id event [ self event copy-action send-action$ f ]
-{ "paste:" id { id SEL id }
- [ nip paste-action send-action$ ]
-}
+ METHOD: id paste: id event [ self event paste-action send-action$ f ]
-{ "delete:" id { id SEL id }
- [ nip delete-action send-action$ ]
-}
+ METHOD: id delete: id event [ self event delete-action send-action$ f ]
-{ "selectAll:" id { id SEL id }
- [ nip select-all-action send-action$ ]
-}
+ METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
-{ "newDocument:" id { id SEL id }
- [ nip new-action send-action$ ]
-}
+ METHOD: id newDocument: id event [ self event new-action send-action$ f ]
-{ "openDocument:" id { id SEL id }
- [ nip open-action send-action$ ]
-}
+ METHOD: id openDocument: id event [ self event open-action send-action$ f ]
-{ "saveDocument:" id { id SEL id }
- [ nip save-action send-action$ ]
-}
+ METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
-{ "saveDocumentAs:" id { id SEL id }
- [ nip save-as-action send-action$ ]
-}
+ METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
-{ "revertDocumentToSaved:" id { id SEL id }
- [ nip revert-action send-action$ ]
-}
+ METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" void { id SEL id }
+ ! Multi-touch gestures
+ METHOD: void magnifyWithEvent: id event
[
- nip
+ self event
dup -> deltaZ sgn {
{ 1 [ zoom-in-action send-action$ ] }
{ -1 [ zoom-out-action send-action$ ] }
{ 0 [ 2drop ] }
} case
]
-}
-{ "swipeWithEvent:" void { id SEL id }
+ METHOD: void swipeWithEvent: id event
[
- nip
+ self event
dup -> deltaX sgn {
{ 1 [ left-action send-action$ ] }
{ -1 [ right-action send-action$ ] }
}
} case
]
-}
-{ "acceptsFirstResponder" char { id SEL }
- [ 2drop 1 ]
-}
+ METHOD: char acceptsFirstResponder [ 1 ]
-! Services
-{ "validRequestorForSendType:returnType:" id { id SEL id id }
+ ! Services
+ METHOD: id validRequestorForSendType: id sendType returnType: id returnType
[
! We return either self or nil
- [ over window-focus ] 2dip
- valid-service? [ drop ] [ 2drop f ] if
+ self window [
+ world-focus sendType returnType
+ valid-service? [ self ] [ f ] if
+ ] [ f ] if*
]
-}
-{ "writeSelectionToPasteboard:types:" char { id SEL id id }
+ METHOD: char writeSelectionToPasteboard: id pboard types: id types
[
- CF>string-array NSStringPboardType swap member? [
- [ drop window-focus gadget-selection ] dip over
- [ set-pasteboard-string 1 ] [ 2drop 0 ] if
- ] [ 3drop 0 ] if
+ NSStringPboardType types CF>string-array member? [
+ self window [
+ world-focus gadget-selection
+ [ pboard set-pasteboard-string 1 ] [ 0 ] if*
+ ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-{ "readSelectionFromPasteboard:" char { id SEL id }
+ METHOD: char readSelectionFromPasteboard: id pboard
[
- pasteboard-string dup [
- [ drop window ] dip swap user-input 1
- ] [ 3drop 0 ] if
+ self window :> window
+ window [
+ pboard pasteboard-string
+ [ window user-input 1 ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-! Text input
-{ "insertText:" void { id SEL id }
- [ nip CF>string swap window user-input ]
-}
+ ! Text input
+ METHOD: void insertText: id text
+ [
+ self window :> window
+ window [
+ text CF>string window user-input
+ ] when
+ ]
-{ "hasMarkedText" char { id SEL }
- [ 2drop 0 ]
-}
+ METHOD: char hasMarkedText [ 0 ]
-{ "markedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange markedRange [ 0 0 <NSRange> ]
-{ "selectedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
-{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
- [ 2drop 2drop ]
-}
+ METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
-{ "unmarkText" void { id SEL }
- [ 2drop ]
-}
+ METHOD: void unmarkText [ ]
-{ "validAttributesForMarkedText" id { id SEL }
- [ 2drop NSArray -> array ]
-}
+ METHOD: id validAttributesForMarkedText [ NSArray -> array ]
-{ "attributedSubstringFromRange:" id { id SEL NSRange }
- [ 3drop f ]
-}
+ METHOD: id attributedSubstringFromRange: NSRange range [ f ]
-{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
- [ 3drop 0 ]
-}
+ METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
-{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
- [ 3drop 0 0 0 0 <CGRect> ]
-}
+ METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
-{ "conversationIdentifier" NSInteger { id SEL }
- [ drop alien-address ]
-}
+ METHOD: NSInteger conversationIdentifier [ self alien-address ]
-! Initialization
-{ "updateFactorGadgetSize:" void { id SEL id }
- [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
-}
+ ! Initialization
+ METHOD: void updateFactorGadgetSize: id notification
+ [
+ self window :> window
+ window [
+ self view-dim window dim<< yield
+ ] when
+ ]
-{ "doCommandBySelector:" void { id SEL SEL }
- [ 3drop ]
-}
+ METHOD: void doCommandBySelector: SEL selector [ ]
-{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
+ METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
[
- [ drop ] 2dip
- SUPER-> initWithFrame:pixelFormat:
+ self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
dup dup add-resize-observer
]
-}
-{ "isOpaque" char { id SEL }
- [
- 2drop 0
- ]
-}
+ METHOD: char isOpaque [ 0 ]
-{ "dealloc" void { id SEL }
+ METHOD: void dealloc
[
- drop
- [ remove-observer ]
- [ SUPER-> dealloc ]
- bi
+ self remove-observer
+ self SUPER-> dealloc
]
-} ;
+]
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" void { id SEL id }
+CLASS: FactorWindowDelegate < NSObject
+[
+ METHOD: void windowDidMove: id notification
[
- 2nip -> object [ -> contentView window ] keep save-position
+ notification -> object -> contentView window
+ [ notification -> object save-position ] when*
]
-}
-{ "windowDidBecomeKey:" void { id SEL id }
+ METHOD: void windowDidBecomeKey: id notification
[
- 2nip -> object -> contentView window focus-world
+ notification -> object -> contentView window
+ [ focus-world ] when*
]
-}
-{ "windowDidResignKey:" void { id SEL id }
+ METHOD: void windowDidResignKey: id notification
[
forget-rollover
- 2nip -> object -> contentView
- dup -> isInFullScreenMode 0 =
- [ window [ unfocus-world ] when* ]
- [ drop ] if
+ notification -> object -> contentView :> view
+ view window :> window
+ window [
+ view -> isInFullScreenMode 0 =
+ [ window unfocus-world ] when
+ ] when
]
-}
-{ "windowShouldClose:" char { id SEL id }
- [
- 3drop 1
- ]
-}
+ METHOD: char windowShouldClose: id notification [ 1 ]
-{ "windowWillClose:" void { id SEL id }
+ METHOD: void windowWillClose: id notification
[
- 2nip -> object -> contentView
+ notification -> object -> contentView
[ window ungraft ] [ unregister-window ] bi
]
-} ;
+]
: install-window-delegate ( window -- )
FactorWindowDelegate install-delegate ;
: window ( handle -- world ) windows get-global at ;
-: window-focus ( handle -- gadget ) window world-focus ;
-
: register-window ( world handle -- )
#! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode-full ] unit-test
+
+[ ":foo" ] [ ":foo" url-encode ] unit-test
+[ "%3Afoo" ] [ ":foo" url-encode-full ] unit-test
+
[ "hello world" ] [ "hello+world" query-decode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+[ "foo=%3A" ] [ { { "foo" ":" } } assoc>query ] unit-test
+
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
[ "a" ] [ { { "a" f } } assoc>query ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
[ letter? ]
[ LETTER? ]
[ digit? ]
- [ "/_-.:" member? ]
+ [ "-._~/:" member? ]
} 1|| ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.2
: assoc>query ( assoc -- str )
[
assoc-strings [
- [ url-encode ] dip
- [ [ url-encode "=" glue , ] with each ] [ , ] if*
+ [ url-encode-full ] dip
+ [ [ url-encode-full "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name-delim ( end-delim string/f -- ? )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
+ ! Check for mistakes of this form:
+ !
+ ! TUPLE: blahblah foo bing
+ !
+ ! : ...
{
- { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
- dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+ dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
: parse-slot-value ( class slots -- )
- scan check-slot-name scan-object 2array , scan {
- { f [ \ } unexpected-eof ] }
+ scan check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
2dup parse-slot-value
- scan {
- { f [ 2drop \ } unexpected-eof ] }
+ scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
- scan {
- { f [ unexpected-eof ] }
+ scan-token {
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
: parse-effect-value ( token -- value )
":" ?tail [
- scan {
+ scan-token {
{ [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ]
} cond 2array
] when ;
"seek-test1" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 0 seek-absolute seek-output
+ tell-output 0 assert=
B{ 3 } write
+ tell-output 1 assert=
] with-file-writer
] [
file-contents
"seek-test2" unique-file binary
[
[
- B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ -1 seek-relative seek-output
+ tell-output 4 assert=
B{ 3 } write
+ tell-output 5 assert=
] with-file-writer
] [
file-contents
"seek-test3" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 1 seek-relative seek-output
+ tell-output 6 assert=
B{ 3 } write
+ tell-output 7 assert=
] with-file-writer
] [
file-contents
set-file-contents
] [
[
- -3 seek-end seek-input 1 read
+ tell-input 0 assert=
+ -3 seek-end seek-input
+ tell-input 2 assert=
+ 1 read
+ tell-input 3 assert=
] with-file-reader
] 2bi
] unit-test
set-file-contents
] [
[
+ tell-input 0 assert=
3 seek-absolute seek-input
+ tell-input 3 assert=
-2 seek-relative seek-input
+ tell-input 1 assert=
1 read
+ tell-input 2 assert=
] with-file-reader
] 2bi
] unit-test
HELP: scan
{ $values { "str/f" { $maybe string } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
+$parsing-note ;
+
+HELP: scan-token
+{ $values { "str" string } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
$parsing-note ;
HELP: still-parsing?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations
: push-parsing-word ( word -- )
lexer-parsing-word new
- swap >>word
- lexer get [
- [ line>> >>line ]
- [ line-text>> >>line-text ]
- [ column>> >>column ] tri
- ] [ parsing-words>> push ] bi ;
+ swap >>word
+ lexer get [
+ [ line>> >>line ]
+ [ line-text>> >>line-text ]
+ [ column>> >>column ] tri
+ ] [ parsing-words>> push ] bi ;
: pop-parsing-word ( -- )
lexer get parsing-words>> pop drop ;
[ line-text>> ]
} cleave subseq ;
-: parse-token ( lexer -- str/f )
+: parse-token ( lexer -- str/f )
dup still-parsing? [
dup skip-blank
dup still-parsing-line?
: unexpected-eof ( word -- * ) f unexpected ;
+: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
+
: expect ( token -- )
- scan
- [ 2dup = [ 2drop ] [ unexpected ] if ]
- [ unexpected-eof ]
- if* ;
+ scan-token 2dup = [ 2drop ] [ unexpected ] if ;
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
- [ scan ] 2dip {
- { [ 2over = ] [ 3drop ] }
- { [ pick not ] [ drop unexpected-eof ] }
- [ [ nip call ] [ each-token ] 2bi ]
- } cond ; inline recursive
+ [ scan-token ] 2dip 2over =
+ [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
collector [ each-token ] dip { } like ; inline
: <lexer-error> ( msg -- error )
\ lexer-error new
- lexer get [
- [ line>> >>line ]
- [ column>> >>column ] bi
- ] [
- [ line-text>> >>line-text ]
- [ parsing-words>> clone >>parsing-words ] bi
- ] bi
- swap >>error ;
+ lexer get [
+ [ line>> >>line ]
+ [ column>> >>column ] bi
+ ] [
+ [ line-text>> >>line-text ]
+ [ parsing-words>> clone >>parsing-words ] bi
+ ] bi
+ swap >>error ;
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- )
- dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+ dup parsing-words>>
+ [ simple-lexer-dump ]
+ [ last parsing-word-lexer-dump ] if-empty ;
: with-lexer ( lexer quot -- newquot )
[ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
+{ $subsections
+ scan-token
+ scan-object
+}
+"Lower-level words:"
{ $subsections
scan
scan-word
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
+
+HELP: scan-object
+{ $values { "object" object } }
+{ $description "Parses a literal representation of an object." }
+$parsing-note ;
"#!" [ POSTPONE: ! ] define-core-syntax
- "IN:" [ scan set-current-vocab ] define-core-syntax
+ "IN:" [ scan-token set-current-vocab ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
- "USE:" [ scan use-vocab ] define-core-syntax
+ "USE:" [ scan-token use-vocab ] define-core-syntax
- "UNUSE:" [ scan unuse-vocab ] define-core-syntax
+ "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
"USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
- "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
+ "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
- "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
+ "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
"FROM:" [
- scan "=>" expect ";" parse-tokens add-words-from
+ scan-token "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
- scan "=>" expect ";" parse-tokens add-words-excluding
+ scan-token "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
- scan scan "=>" expect scan add-renamed-word
+ scan-token scan-token "=>" expect scan-token add-renamed-word
] define-core-syntax
"HEX:" [ 16 parse-base ] define-core-syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
- scan {
+ scan-token {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
] define-core-syntax
"DEFER:" [
- scan current-vocab create
+ scan-token current-vocab create
[ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
"PREDICATE:" [
CREATE-CLASS
- scan "<" assert=
+ "<" expect
scan-word
parse-definition define-predicate-class
] define-core-syntax
] define-core-syntax
"SLOT:" [
- scan define-protocol-slot
+ scan-token define-protocol-slot
] define-core-syntax
"C:" [
OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
- OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
-
OBJ_STARTUP_QUOT = 20, /* startup quotation */
OBJ_GLOBAL, /* global namespace */
OBJ_SHUTDOWN_QUOT, /* shutdown quotation */
void factor_vm::c_to_factor_toplevel(cell quot)
{
- for(;;)
- {
-NS_DURING
- c_to_factor(quot);
- NS_VOIDRETURN;
-NS_HANDLER
- ctx->push(allot_alien(false_object,(cell)localException));
- quot = special_objects[OBJ_COCOA_EXCEPTION];
- if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
- {
- /* No Cocoa exception handler was registered, so
- basis/cocoa/ is not loaded. So we pass the exception
- along. */
- [localException raise];
- }
-NS_ENDHANDLER
- }
+ c_to_factor(quot);
}
void early_init(void)
projects / factor.git / commitdiff