From cbe46baae2862d9fbff66730a5ade936fa009637 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 00:55:36 -0400 Subject: [PATCH 1/7] urls.encoding: tweak assoc>query to fix problem with OAuth --- basis/urls/encoding/encoding-tests.factor | 8 ++++++++ basis/urls/encoding/encoding.factor | 8 ++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor index f3e0497588..84e6eaa890 100644 --- a/basis/urls/encoding/encoding-tests.factor +++ b/basis/urls/encoding/encoding-tests.factor @@ -11,6 +11,12 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ "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 @@ -25,6 +31,8 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ 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 diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index f87c21d2ff..b035670614 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -1,4 +1,4 @@ -! 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 @@ -11,7 +11,7 @@ IN: urls.encoding [ letter? ] [ LETTER? ] [ digit? ] - [ "/_-.:" member? ] + [ "-._~/:" member? ] } 1|| ; foldable ! see http://tools.ietf.org/html/rfc3986#section-2.2 @@ -120,7 +120,7 @@ PRIVATE> : 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 ; From 8a0525e5cecc32de7e778d6ac8e598b068586037 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 16:20:08 -0400 Subject: [PATCH 2/7] Add a scan-token word which is like scan, except throws an error on EOF; document scan-object word; mention that scan-token/scan-object are preferred over scan/scan-word --- basis/alien/parser/parser.factor | 2 +- basis/alien/syntax/syntax.factor | 2 +- basis/classes/struct/struct.factor | 3 +- basis/functors/backend/backend.factor | 2 +- basis/locals/parser/parser.factor | 3 +- core/classes/tuple/parser/parser.factor | 23 +++++------- core/effects/parser/parser.factor | 3 +- core/lexer/authors.txt | 1 + core/lexer/lexer-docs.factor | 7 +++- core/lexer/lexer.factor | 50 ++++++++++++------------- core/parser/parser-docs.factor | 10 +++++ core/syntax/syntax.factor | 24 ++++++------ 12 files changed, 68 insertions(+), 62 deletions(-) diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 332683a0ac..7d72442819 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -32,7 +32,7 @@ SYMBOL: current-library (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 ] } [ parse-c-type ] diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 570ebf60a5..6c2dc5ca85 100755 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -19,7 +19,7 @@ SYNTAX: FUNCTION: (FUNCTION:) make-function define-declared ; SYNTAX: FUNCTION-ALIAS: - scan create-function + scan-token create-function (FUNCTION:) (make-function) define-declared ; SYNTAX: CALLBACK: diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index c15e21f651..3699cdb7d1 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -334,10 +334,9 @@ PRIVATE> scan scan-c-type \ } parse-until ; : parse-struct-slots ( slots -- slots' more? ) - scan { + scan-token { { ";" [ f ] } { "{" [ parse-struct-slot suffix! t ] } - { f [ unexpected-eof ] } [ invalid-struct-slot ] } case ; diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor index 331864417e..9ade1d50f8 100644 --- a/basis/functors/backend/backend.factor +++ b/basis/functors/backend/backend.factor @@ -20,7 +20,7 @@ SYNTAX: FUNCTOR-SYNTAX: 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 ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 01be7bcd20..5248d50ced 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -55,8 +55,7 @@ M: lambda-parser parse-quotation ( -- quotation ) H{ } clone (parse-lambda) ; : parse-binding ( end -- pair/f ) - scan { - { [ dup not ] [ unexpected-eof ] } + scan-token { { [ 2dup = ] [ 2drop f ] } [ nip scan-object 2array ] } cond ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 5016bb38f6..631ab92743 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -34,21 +34,19 @@ ERROR: invalid-slot-name name ; [ 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 ; @@ -74,16 +72,14 @@ ERROR: bad-slot-name class slot ; 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 ] @@ -109,8 +105,7 @@ M: tuple-class boa>object 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 ] } diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index cd484ddd2e..07ecc0d88b 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -26,9 +26,8 @@ SYMBOL: effect-var : 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 ; diff --git a/core/lexer/authors.txt b/core/lexer/authors.txt index 1901f27a24..580f882c8d 100644 --- a/core/lexer/authors.txt +++ b/core/lexer/authors.txt @@ -1 +1,2 @@ Slava Pestov +Joe Groff diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index 3dc534cdfd..0fbf3b3563 100644 --- a/core/lexer/lexer-docs.factor +++ b/core/lexer/lexer-docs.factor @@ -59,7 +59,12 @@ HELP: parse-token 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? diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index d5eecde1a2..98a1277ac7 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -1,4 +1,4 @@ -! 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 @@ -18,12 +18,12 @@ TUPLE: lexer-parsing-word word line line-text column ; : 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 ; @@ -77,7 +77,7 @@ M: lexer skip-word ( lexer -- ) [ line-text>> ] } cleave subseq ; -: parse-token ( lexer -- str/f ) +: parse-token ( lexer -- str/f ) dup still-parsing? [ dup skip-blank dup still-parsing-line? @@ -90,18 +90,14 @@ PREDICATE: unexpected-eof < unexpected got>> not ; : 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 @@ -117,14 +113,14 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; : ( 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 ] @@ -148,7 +144,9 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; [ (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 [ rethrow ] recover ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index c04a0f568e..6889f497e1 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -7,6 +7,11 @@ IN: parser ARTICLE: "reading-ahead" "Reading ahead" "Parsing words can consume input:" +{ $subsections + scan-token + scan-object +} +"Lower-level words:" { $subsections scan scan-word @@ -249,3 +254,8 @@ HELP: staging-violation 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 ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 92211a5b01..07ff0d3c92 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -41,32 +41,32 @@ IN: bootstrap.syntax "#!" [ POSTPONE: ! ] define-core-syntax - "IN:" [ scan set-current-vocab ] define-core-syntax + "IN:" [ scan-token set-current-vocab ] define-core-syntax "" [ 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 @@ -79,7 +79,7 @@ IN: bootstrap.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 ) ] @@ -133,7 +133,7 @@ IN: bootstrap.syntax ] define-core-syntax "DEFER:" [ - scan current-vocab create + scan-token current-vocab create [ fake-definition ] [ set-word ] [ undefined-def define ] tri ] define-core-syntax @@ -190,7 +190,7 @@ IN: bootstrap.syntax "PREDICATE:" [ CREATE-CLASS - scan "<" assert= + "<" expect scan-word parse-definition define-predicate-class ] define-core-syntax @@ -208,7 +208,7 @@ IN: bootstrap.syntax ] define-core-syntax "SLOT:" [ - scan define-protocol-slot + scan-token define-protocol-slot ] define-core-syntax "C:" [ From 1106c033180763df986bfa3ddf344008964ca7eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 17:45:50 -0400 Subject: [PATCH 3/7] Remove cocoa.callbacks since nothing uses it --- basis/cocoa/callbacks/authors.txt | 1 - basis/cocoa/callbacks/callbacks.factor | 33 -------------------------- basis/cocoa/callbacks/platforms.txt | 1 - basis/cocoa/callbacks/summary.txt | 1 - 4 files changed, 36 deletions(-) delete mode 100644 basis/cocoa/callbacks/authors.txt delete mode 100644 basis/cocoa/callbacks/callbacks.factor delete mode 100644 basis/cocoa/callbacks/platforms.txt delete mode 100644 basis/cocoa/callbacks/summary.txt diff --git a/basis/cocoa/callbacks/authors.txt b/basis/cocoa/callbacks/authors.txt deleted file mode 100644 index 30212305ba..0000000000 --- a/basis/cocoa/callbacks/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Kevin P. Reid diff --git a/basis/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor deleted file mode 100644 index 87b5f628a9..0000000000 --- a/basis/cocoa/callbacks/callbacks.factor +++ /dev/null @@ -1,33 +0,0 @@ -! 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 - ] -} ; - -: ( quot -- id ) - FactorCallback -> alloc -> init - [ callbacks get set-at ] keep ; diff --git a/basis/cocoa/callbacks/platforms.txt b/basis/cocoa/callbacks/platforms.txt deleted file mode 100644 index 6e806f449e..0000000000 --- a/basis/cocoa/callbacks/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -macosx diff --git a/basis/cocoa/callbacks/summary.txt b/basis/cocoa/callbacks/summary.txt deleted file mode 100644 index 0e0fad55b2..0000000000 --- a/basis/cocoa/callbacks/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Allows you to use Factor quotations as Cocoa actions From bc87b269c5215f3802392fa0a95e234dc9cdb479 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 17:48:37 -0400 Subject: [PATCH 4/7] Remove Cocoa exception handling support since it no longer works --- .../cocoa/application/application-docs.factor | 3 --- basis/cocoa/application/application.factor | 12 +----------- vm/objects.hpp | 2 -- vm/os-macosx.mm | 18 +----------------- 4 files changed, 2 insertions(+), 33 deletions(-) diff --git a/basis/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor index 337cff6f06..849983d00e 100644 --- a/basis/cocoa/application/application-docs.factor +++ b/basis/cocoa/application/application-docs.factor @@ -36,9 +36,6 @@ HELP: install-delegate { $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 diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index db1eefca14..b00f39fa1d 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -1,4 +1,4 @@ -! 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 @@ -40,16 +40,6 @@ FUNCTION: void NSBeep ( ) ; : 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" diff --git a/vm/objects.hpp b/vm/objects.hpp index 778df8642e..8d883ecdb7 100644 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -26,8 +26,6 @@ enum special_object { 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 */ diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index 05a9aef5c8..c5377be8ef 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -8,23 +8,7 @@ namespace factor 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(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) From bb4dae64f355795dac3851490451d698238e3ab4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 17:59:35 -0400 Subject: [PATCH 5/7] cocoa.subclassing: new METHOD: syntax cleans up class definitions --- basis/cocoa/cocoa-tests.factor | 38 +- .../cocoa/subclassing/subclassing-docs.factor | 25 +- basis/cocoa/subclassing/subclassing.factor | 58 ++- basis/tools/deploy/shaker/strip-cocoa.factor | 6 - basis/tools/deploy/test/14/14.factor | 17 +- basis/ui/backend/cocoa/cocoa.factor | 4 +- basis/ui/backend/cocoa/tools/tools.factor | 69 +--- basis/ui/backend/cocoa/views/views.factor | 370 +++++++----------- basis/ui/ui.factor | 2 - 9 files changed, 237 insertions(+), 352 deletions(-) diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index f35d151ad4..eefc04e2a1 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -7,12 +7,11 @@ IN: cocoa.tests CLASS: { { +superclass+ "NSObject" } { +name+ "Foo" } -} { - "foo:" - void - { id SEL NSRect } - [ gc "x" set 2drop ] -} ; +} + +METHOD: void foo: NSRect rect [ + gc rect "x" set +] ; : test-foo ( -- ) Foo -> alloc -> init @@ -29,12 +28,9 @@ test-foo CLASS: { { +superclass+ "NSObject" } { +name+ "Bar" } -} { - "bar" - NSRect - { id SEL } - [ 2drop test-foo "x" get ] -} ; +} + +METHOD: NSRect bar [ test-foo "x" get ] ; Bar [ -> alloc -> init @@ -51,22 +47,16 @@ Bar [ CLASS: { { +superclass+ "NSObject" } { +name+ "Bar" } -} { - "bar" - NSRect - { id SEL } - [ 2drop test-foo "x" get ] -} { - "babb" - int - { id SEL int } - [ 2nip sq ] -} ; +} + +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 diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor index 0944727e46..2e1d973169 100644 --- a/basis/cocoa/subclassing/subclassing-docs.factor +++ b/basis/cocoa/subclassing/subclassing-docs.factor @@ -24,20 +24,31 @@ HELP: define-objc-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." } ; +"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: { $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" } +{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } } +{ $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." } +} +"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: } +"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:" +{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: } "This word is actually syntax sugar for an ordinary word:" { $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." ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 1accb1e8dc..4c5099e04b 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -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. -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 ) @@ -49,13 +51,13 @@ IN: cocoa.subclassing ] 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 -- ) dup class-exists? [ @@ -79,3 +81,35 @@ SYMBOL: +superclass+ SYNTAX: CLASS: parse-definition unclip >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) ?rewrite-closures first ; + +: method-effect ( quadruple -- effect ) + [ third ] [ second void? { } { "x" } ? ] bi ; + +: 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! ; diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor index 7bb2f651dc..288d192e3b 100644 --- a/basis/tools/deploy/shaker/strip-cocoa.factor +++ b/basis/tools/deploy/shaker/strip-cocoa.factor @@ -13,12 +13,6 @@ IN: tools.deploy.shaker.cocoa : 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 diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor index 65fd50b5b8..0b98b45d68 100644 --- a/basis/tools/deploy/test/14/14.factor +++ b/basis/tools/deploy/test/14/14.factor @@ -9,16 +9,13 @@ IN: tools.deploy.test.14 CLASS: { { +superclass+ "NSObject" } { +name+ "Bar" } -} { - "bar:" - float - { id SEL NSRect } - [ - [ origin>> [ x>> ] [ y>> ] bi + ] - [ size>> [ w>> ] [ h>> ] bi + ] - bi + - ] -} ; +} + +METHOD: float bar: NSRect rect [ + rect origin>> [ x>> ] [ y>> ] bi + + rect size>> [ w>> ] [ h>> ] bi + + + +] ; : main ( -- ) Bar -> alloc -> init diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 7982458bb4..65286ab181 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -233,9 +233,7 @@ CLASS: { { +name+ "FactorApplicationDelegate" } } -{ "applicationDidUpdate:" void { id SEL id } - [ 3drop reset-run-loop ] -} ; +METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ; : install-app-delegate ( -- ) NSApp FactorApplicationDelegate install-delegate ; diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index 89fd8e7708..e41531b587 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -26,45 +26,25 @@ CLASS: { { +name+ "FactorWorkspaceApplicationDelegate" } } -{ "application:openFiles:" void { id SEL id id } - [ [ 3drop ] dip finder-run-files ] -} +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 ; @@ -78,25 +58,16 @@ CLASS: { 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 } - [ - nip - [ [ (eval>string) ] with-interactive-vocabs ] do-service - 2drop - ] -} ; +} + +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 +[ + pboard error + [ [ (eval>string) ] with-interactive-vocabs ] do-service +] ; : register-services ( -- ) NSApp diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 163be4e208..6b6e3a32c6 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -148,269 +148,168 @@ CLASS: { } ! Rendering -{ "drawRect:" void { id SEL NSRect } - [ 2drop window draw-world ] -} +METHOD: void drawRect: NSRect rect [ self window draw-world ] ! Events -{ "acceptsFirstMouse:" char { id SEL id } - [ 3drop 1 ] -} +METHOD: char acceptsFirstMouse: id event [ 1 ] -{ "mouseEntered:" void { id SEL id } - [ nip send-mouse-moved ] -} +METHOD: void mouseEntered: id event [ self event send-mouse-moved ] -{ "mouseExited:" void { id SEL id } - [ 3drop forget-rollover ] -} +METHOD: void mouseExited: id event [ forget-rollover ] -{ "mouseMoved:" void { id SEL id } - [ nip send-mouse-moved ] -} +METHOD: void mouseMoved: id event [ self event send-mouse-moved ] -{ "mouseDragged:" void { id SEL id } - [ nip send-mouse-moved ] -} +METHOD: void mouseDragged: id event [ self event send-mouse-moved ] -{ "rightMouseDragged:" void { id SEL id } - [ nip send-mouse-moved ] -} +METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ] -{ "otherMouseDragged:" void { id SEL id } - [ nip send-mouse-moved ] -} +METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ] -{ "mouseDown:" void { id SEL id } - [ nip send-button-down$ ] -} +METHOD: void mouseDown: id event [ self event 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 } - [ - nip -> action - 2dup [ window ] [ utf8 alien>string ] bi* validate-action - [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if - ] -} +METHOD: char validateUserInterfaceItem: id event +[ + self window + event -> action utf8 alien>string validate-action + [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if +] -{ "undo:" id { id SEL id } - [ nip undo-action send-action$ ] -} +METHOD: id undo: id event [ self event undo-action send-action$ ] -{ "redo:" id { id SEL id } - [ nip redo-action send-action$ ] -} +METHOD: id redo: id event [ self event redo-action send-action$ ] -{ "cut:" id { id SEL id } - [ nip cut-action send-action$ ] -} +METHOD: id cut: id event [ self event cut-action send-action$ ] -{ "copy:" id { id SEL id } - [ nip copy-action send-action$ ] -} +METHOD: id copy: id event [ self event copy-action send-action$ ] -{ "paste:" id { id SEL id } - [ nip paste-action send-action$ ] -} +METHOD: id paste: id event [ self event paste-action send-action$ ] -{ "delete:" id { id SEL id } - [ nip delete-action send-action$ ] -} +METHOD: id delete: id event [ self event delete-action send-action$ ] -{ "selectAll:" id { id SEL id } - [ nip select-all-action send-action$ ] -} +METHOD: id selectAll: id event [ self event select-all-action send-action$ ] -{ "newDocument:" id { id SEL id } - [ nip new-action send-action$ ] -} +METHOD: id newDocument: id event [ self event new-action send-action$ ] -{ "openDocument:" id { id SEL id } - [ nip open-action send-action$ ] -} +METHOD: id openDocument: id event [ self event open-action send-action$ ] -{ "saveDocument:" id { id SEL id } - [ nip save-action send-action$ ] -} +METHOD: id saveDocument: id event [ self event save-action send-action$ ] -{ "saveDocumentAs:" id { id SEL id } - [ nip save-as-action send-action$ ] -} +METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ] -{ "revertDocumentToSaved:" id { id SEL id } - [ nip revert-action send-action$ ] -} +METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ] -! Multi-touch gestures: this is undocumented. -! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html -{ "magnifyWithEvent:" void { id SEL id } - [ - nip - dup -> deltaZ sgn { - { 1 [ zoom-in-action send-action$ ] } - { -1 [ zoom-out-action send-action$ ] } - { 0 [ 2drop ] } - } case - ] -} +! Multi-touch gestures +METHOD: void magnifyWithEvent: id event +[ + self event + dup -> deltaZ sgn { + { 1 [ zoom-in-action send-action$ drop ] } + { -1 [ zoom-out-action send-action$ drop ] } + { 0 [ 2drop ] } + } case +] -{ "swipeWithEvent:" void { id SEL id } - [ - nip - dup -> deltaX sgn { - { 1 [ left-action send-action$ ] } - { -1 [ right-action send-action$ ] } - { 0 - [ - dup -> deltaY sgn { - { 1 [ up-action send-action$ ] } - { -1 [ down-action send-action$ ] } - { 0 [ 2drop ] } - } case - ] - } - } case - ] -} +METHOD: void swipeWithEvent: id event +[ + self event + dup -> deltaX sgn { + { 1 [ left-action send-action$ drop ] } + { -1 [ right-action send-action$ drop ] } + { 0 + [ + dup -> deltaY sgn { + { 1 [ up-action send-action$ drop ] } + { -1 [ down-action send-action$ drop ] } + { 0 [ 2drop ] } + } case + ] + } + } case +] -{ "acceptsFirstResponder" char { id SEL } - [ 2drop 1 ] -} +METHOD: char acceptsFirstResponder [ 1 ] ! Services -{ "validRequestorForSendType:returnType:" id { id SEL id id } - [ - ! We return either self or nil - [ over window-focus ] 2dip - valid-service? [ drop ] [ 2drop f ] if - ] -} +METHOD: id validRequestorForSendType: id sendType returnType: id returnType +[ + ! We return either self or nil + self window world-focus sendType returnType + valid-service? [ self ] [ f ] if +] -{ "writeSelectionToPasteboard:types:" char { id SEL id id } - [ - CF>string-array NSStringPboardType swap member? [ - [ drop window-focus gadget-selection ] dip over - [ set-pasteboard-string 1 ] [ 2drop 0 ] if - ] [ 3drop 0 ] if - ] -} +METHOD: char writeSelectionToPasteboard: id pboard types: id types +[ + NSStringPboardType types CF>string-array member? [ + self window world-focus gadget-selection + [ pboard set-pasteboard-string 1 ] [ 0 ] if* + ] [ 0 ] if +] -{ "readSelectionFromPasteboard:" char { id SEL id } - [ - pasteboard-string dup [ - [ drop window ] dip swap user-input 1 - ] [ 3drop 0 ] if - ] -} +METHOD: char readSelectionFromPasteboard: id pboard +[ + pboard pasteboard-string + [ self window user-input 1 ] [ 0 ] if* +] ! Text input -{ "insertText:" void { id SEL id } - [ nip CF>string swap window user-input ] -} +METHOD: void insertText: id text +[ text CF>string self window user-input ] -{ "hasMarkedText" char { id SEL } - [ 2drop 0 ] -} +METHOD: char hasMarkedText [ 0 ] -{ "markedRange" NSRange { id SEL } - [ 2drop 0 0 ] -} +METHOD: NSRange markedRange [ 0 0 ] -{ "selectedRange" NSRange { id SEL } - [ 2drop 0 0 ] -} +METHOD: NSRange selectedRange [ 0 0 ] -{ "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 ] -} +METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 ] -{ "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 ] -} +METHOD: void updateFactorGadgetSize: id notification +[ self view-dim self window dim<< yield ] -{ "doCommandBySelector:" void { id SEL SEL } - [ 3drop ] -} +METHOD: void doCommandBySelector: SEL selector [ ] -{ "initWithFrame:pixelFormat:" id { id SEL NSRect id } - [ - [ drop ] 2dip - SUPER-> initWithFrame:pixelFormat: - dup dup add-resize-observer - ] -} +METHOD: id initWithFrame: NSRect frame pixelFormat: id 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 } - [ - drop - [ remove-observer ] - [ SUPER-> dealloc ] - bi - ] -} ; +METHOD: void dealloc +[ + self remove-observer + self SUPER-> dealloc +] ; : sync-refresh-to-screen ( GLView -- ) -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 @@ -423,44 +322,37 @@ CLASS: { -> frame CGRect-top-left 2array >>window-loc drop ; CLASS: { - { +superclass+ "NSObject" } { +name+ "FactorWindowDelegate" } + { +superclass+ "NSObject" } } -{ "windowDidMove:" void { id SEL id } - [ - 2nip -> object [ -> contentView window ] keep save-position - ] -} +METHOD: void windowDidMove: id notification +[ + notification -> object -> contentView window + notification -> object save-position +] -{ "windowDidBecomeKey:" void { id SEL id } - [ - 2nip -> object -> contentView window focus-world - ] -} +METHOD: void windowDidBecomeKey: id notification +[ + notification -> object -> contentView window + focus-world +] -{ "windowDidResignKey:" void { id SEL id } - [ - forget-rollover - 2nip -> object -> contentView - dup -> isInFullScreenMode 0 = - [ window [ unfocus-world ] when* ] - [ drop ] if - ] -} +METHOD: void windowDidResignKey: id notification +[ + forget-rollover + notification -> object -> contentView + dup -> isInFullScreenMode 0 = + [ window [ unfocus-world ] when* ] [ drop ] if +] -{ "windowShouldClose:" char { id SEL id } - [ - 3drop 1 - ] -} +METHOD: char windowShouldClose: id notification [ 1 ] -{ "windowWillClose:" void { id SEL id } - [ - 2nip -> object -> contentView - [ window ungraft ] [ unregister-window ] bi - ] -} ; +METHOD: void windowWillClose: id notification +[ + notification -> object -> contentView + [ window ungraft ] [ unregister-window ] bi +] ; : install-window-delegate ( window -- ) FactorWindowDelegate install-delegate ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index eaeeb01f03..d65f4725a9 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -16,8 +16,6 @@ SYMBOL: windows : 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 From 425c572fa8cf614c06cef8dabfdba5692725b62c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jul 2010 19:02:52 -0400 Subject: [PATCH 6/7] cocoa.subclassing: cleaner CLASS: syntax; ui.backend.cocoa: ignore events delivered after window closed to fix FEP (reported by Doug Coleman) --- basis/cocoa/cocoa-tests.factor | 36 +- .../cocoa/subclassing/subclassing-docs.factor | 39 +- basis/cocoa/subclassing/subclassing.factor | 29 +- basis/tools/deploy/test/14/14.factor | 18 +- basis/ui/backend/cocoa/cocoa.factor | 11 +- basis/ui/backend/cocoa/tools/tools.factor | 50 +- basis/ui/backend/cocoa/views/views.factor | 437 +++++++++--------- 7 files changed, 295 insertions(+), 325 deletions(-) diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index eefc04e2a1..fee8c60c21 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -4,14 +4,12 @@ tools.test memory compiler.units math core-graphics.types ; FROM: alien.c-types => int void ; IN: cocoa.tests -CLASS: { - { +superclass+ "NSObject" } - { +name+ "Foo" } -} - -METHOD: void foo: NSRect rect [ - gc rect "x" set -] ; +CLASS: Foo < NSObject +[ + METHOD: void foo: NSRect rect [ + gc rect "x" set + ] +] : test-foo ( -- ) Foo -> alloc -> init @@ -25,12 +23,10 @@ test-foo [ 101.0 ] [ "x" get CGRect-w ] unit-test [ 102.0 ] [ "x" get CGRect-h ] unit-test -CLASS: { - { +superclass+ "NSObject" } - { +name+ "Bar" } -} - -METHOD: NSRect bar [ test-foo "x" get ] ; +CLASS: Bar < NSObject +[ + METHOD: NSRect bar [ test-foo "x" get ] +] Bar [ -> alloc -> init @@ -44,14 +40,12 @@ Bar [ [ 102.0 ] [ "x" get CGRect-h ] unit-test ! Make sure that we can add methods -CLASS: { - { +superclass+ "NSObject" } - { +name+ "Bar" } -} +CLASS: Bar < NSObject +[ + METHOD: NSRect bar [ test-foo "x" get ] -METHOD: NSRect bar [ test-foo "x" get ] - -METHOD: int babb: int x [ x sq ] ; + METHOD: int babb: int x [ x sq ] +] [ 144 ] [ Bar [ diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor index 2e1d973169..2c83e60dde 100644 --- a/basis/cocoa/subclassing/subclassing-docs.factor +++ b/basis/cocoa/subclassing/subclassing-docs.factor @@ -1,41 +1,10 @@ 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 an assoc." } ; - HELP: CLASS: -{ $syntax "CLASS: spec imeth... ;" } -{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } } -{ $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." } -} -"Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word." +{ $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." } ; @@ -49,8 +18,6 @@ HELP: METHOD: ARTICLE: "objc-subclassing" "Subclassing Objective C classes" "Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:" { $subsections POSTPONE: CLASS: POSTPONE: METHOD: } -"This word is actually syntax sugar for an ordinary word:" -{ $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." ; IN: cocoa.subclassing diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 4c5099e04b..b88d3afd7b 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -29,7 +29,7 @@ IN: cocoa.subclassing : 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 ; @@ -59,28 +59,23 @@ IN: cocoa.subclassing 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 { diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor index 0b98b45d68..95ab68916a 100644 --- a/basis/tools/deploy/test/14/14.factor +++ b/basis/tools/deploy/test/14/14.factor @@ -6,16 +6,14 @@ kernel math ; FROM: alien.c-types => float ; IN: tools.deploy.test.14 -CLASS: { - { +superclass+ "NSObject" } - { +name+ "Bar" } -} - -METHOD: float bar: NSRect rect [ - rect origin>> [ x>> ] [ y>> ] bi + - rect size>> [ w>> ] [ h>> ] bi + - + -] ; +CLASS: Bar < NSObject +[ + METHOD: float bar: NSRect rect [ + rect origin>> [ x>> ] [ y>> ] bi + + rect size>> [ w>> ] [ h>> ] bi + + + + ] +] : main ( -- ) Bar -> alloc -> init diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 65286ab181..13f07b9d41 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -228,12 +228,11 @@ M: cocoa-ui-backend system-alert ] [ 2drop ] if* init-thread-timer ; -CLASS: { - { +superclass+ "NSObject" } - { +name+ "FactorApplicationDelegate" } -} - -METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ; +CLASS: FactorApplicationDelegate < NSObject +[ + METHOD: void applicationDidUpdate: id obj + [ reset-run-loop ] +] : install-app-delegate ( -- ) NSApp FactorApplicationDelegate install-delegate ; diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index e41531b587..bacd6f02e4 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -21,30 +21,28 @@ IN: ui.backend.cocoa.tools image save-panel [ save-image ] when* ; ! Handle Open events from the Finder -CLASS: { - { +superclass+ "FactorApplicationDelegate" } - { +name+ "FactorWorkspaceApplicationDelegate" } -} +CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate +[ + METHOD: void application: id app openFiles: id files [ files finder-run-files ] -METHOD: void application: id app openFiles: id files [ files finder-run-files ] + METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ] -METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ] + METHOD: id factorListener: id app [ show-listener f ] -METHOD: id factorListener: id app [ show-listener f ] + METHOD: id factorBrowser: id app [ show-browser f ] -METHOD: id factorBrowser: id app [ show-browser f ] + METHOD: id newFactorListener: id app [ listener-window f ] -METHOD: id newFactorListener: id app [ listener-window f ] + METHOD: id newFactorBrowser: id app [ browser-window f ] -METHOD: id newFactorBrowser: id app [ browser-window f ] + METHOD: id runFactorFile: id app [ menu-run-files f ] -METHOD: id runFactorFile: id app [ menu-run-files f ] + METHOD: id saveFactorImage: id app [ save f ] -METHOD: id saveFactorImage: id app [ save f ] + METHOD: id saveFactorImageAs: id app [ menu-save-image f ] -METHOD: id saveFactorImageAs: id app [ menu-save-image f ] - -METHOD: id refreshAll: id app [ [ 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 ; @@ -55,19 +53,17 @@ METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ] dup [ quot call( string -- result/f ) ] when [ pboard set-pasteboard-string ] when* ; -CLASS: { - { +superclass+ "NSObject" } - { +name+ "FactorServiceProvider" } -} - -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 +CLASS: FactorServiceProvider < NSObject [ - pboard error - [ [ (eval>string) ] with-interactive-vocabs ] do-service -] ; + 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 + [ + pboard error + [ [ (eval>string) ] with-interactive-vocabs ] do-service + ] +] : register-services ( -- ) NSApp diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 6b6e3a32c6..e98c31b295 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -3,14 +3,16 @@ 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 @@ -62,7 +64,7 @@ CONSTANT: key-codes [ 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: ; @@ -82,22 +84,25 @@ CONSTANT: key-codes [ nip mouse-event>gesture ] [ mouse-location ] [ drop window ] - 2tri send-button-down ; + 2tri + dup [ send-button-down ] [ 3drop ] if ; : send-button-up$ ( view event -- ) [ nip mouse-event>gesture ] [ 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 -- ) [ @@ -141,176 +146,191 @@ CONSTANT: selector>action H{ selector>action at [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ; -CLASS: { - { +superclass+ "NSOpenGLView" } - { +name+ "FactorView" } - { +protocols+ { "NSTextInput" } } -} - -! Rendering -METHOD: void drawRect: NSRect rect [ self window draw-world ] - -! Events -METHOD: char acceptsFirstMouse: id event [ 1 ] - -METHOD: void mouseEntered: id event [ self event send-mouse-moved ] - -METHOD: void mouseExited: id event [ forget-rollover ] - -METHOD: void mouseMoved: id event [ self event send-mouse-moved ] - -METHOD: void mouseDragged: id event [ self event send-mouse-moved ] - -METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ] - -METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ] - -METHOD: void mouseDown: id event [ self event send-button-down$ ] - -METHOD: void mouseUp: id event [ self event send-button-up$ ] - -METHOD: void rightMouseDown: id event [ self event send-button-down$ ] - -METHOD: void rightMouseUp: id event [ self event send-button-up$ ] - -METHOD: void otherMouseDown: id event [ self event send-button-down$ ] - -METHOD: void otherMouseUp: id event [ self event send-button-up$ ] - -METHOD: void scrollWheel: id event [ self event send-scroll$ ] - -METHOD: void keyDown: id event [ self event send-key-down-event ] - -METHOD: void keyUp: id event [ self event send-key-up-event ] - -METHOD: char validateUserInterfaceItem: id event +CLASS: FactorView < NSOpenGLView NSTextInput [ - self window - event -> action utf8 alien>string validate-action - [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if + ! Rendering + METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ] + + ! Events + METHOD: char acceptsFirstMouse: id event [ 1 ] + + METHOD: void mouseEntered: id event [ self event send-mouse-moved ] + + METHOD: void mouseExited: id event [ forget-rollover ] + + METHOD: void mouseMoved: id event [ self event send-mouse-moved ] + + METHOD: void mouseDragged: id event [ self event send-mouse-moved ] + + METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ] + + METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ] + + METHOD: void mouseDown: id event [ self event send-button-down$ ] + + METHOD: void mouseUp: id event [ self event send-button-up$ ] + + METHOD: void rightMouseDown: id event [ self event send-button-down$ ] + + METHOD: void rightMouseUp: id event [ self event send-button-up$ ] + + METHOD: void otherMouseDown: id event [ self event send-button-down$ ] + + METHOD: void otherMouseUp: id event [ self event send-button-up$ ] + + METHOD: void scrollWheel: id event [ self event send-scroll$ ] + + METHOD: void keyDown: id event [ self event send-key-down-event ] + + METHOD: void keyUp: id event [ self event send-key-up-event ] + + METHOD: char validateUserInterfaceItem: id event + [ + self window [ + event -> action utf8 alien>string validate-action + [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if + ] [ 0 ] if* + ] + + METHOD: id undo: id event [ self event undo-action send-action$ f ] + + METHOD: id redo: id event [ self event redo-action send-action$ f ] + + METHOD: id cut: id event [ self event cut-action send-action$ f ] + + METHOD: id copy: id event [ self event copy-action send-action$ f ] + + METHOD: id paste: id event [ self event paste-action send-action$ f ] + + METHOD: id delete: id event [ self event delete-action send-action$ f ] + + METHOD: id selectAll: id event [ self event select-all-action send-action$ f ] + + METHOD: id newDocument: id event [ self event new-action send-action$ f ] + + METHOD: id openDocument: id event [ self event open-action send-action$ f ] + + METHOD: id saveDocument: id event [ self event save-action send-action$ f ] + + METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ] + + METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ] + + ! Multi-touch gestures + METHOD: void magnifyWithEvent: id event + [ + self event + dup -> deltaZ sgn { + { 1 [ zoom-in-action send-action$ ] } + { -1 [ zoom-out-action send-action$ ] } + { 0 [ 2drop ] } + } case + ] + + METHOD: void swipeWithEvent: id event + [ + self event + dup -> deltaX sgn { + { 1 [ left-action send-action$ ] } + { -1 [ right-action send-action$ ] } + { 0 + [ + dup -> deltaY sgn { + { 1 [ up-action send-action$ ] } + { -1 [ down-action send-action$ ] } + { 0 [ 2drop ] } + } case + ] + } + } case + ] + + METHOD: char acceptsFirstResponder [ 1 ] + + ! Services + METHOD: id validRequestorForSendType: id sendType returnType: id returnType + [ + ! We return either self or nil + self window [ + world-focus sendType returnType + valid-service? [ self ] [ f ] if + ] [ f ] if* + ] + + METHOD: char writeSelectionToPasteboard: id pboard types: id types + [ + NSStringPboardType types CF>string-array member? [ + self window [ + world-focus gadget-selection + [ pboard set-pasteboard-string 1 ] [ 0 ] if* + ] [ 0 ] if* + ] [ 0 ] if + ] + + METHOD: char readSelectionFromPasteboard: id pboard + [ + self window :> window + window [ + pboard pasteboard-string + [ window user-input 1 ] [ 0 ] if* + ] [ 0 ] if + ] + + ! Text input + METHOD: void insertText: id text + [ + self window :> window + window [ + text CF>string window user-input + ] when + ] + + METHOD: char hasMarkedText [ 0 ] + + METHOD: NSRange markedRange [ 0 0 ] + + METHOD: NSRange selectedRange [ 0 0 ] + + METHOD: void setMarkedText: id text selectedRange: NSRange range [ ] + + METHOD: void unmarkText [ ] + + METHOD: id validAttributesForMarkedText [ NSArray -> array ] + + METHOD: id attributedSubstringFromRange: NSRange range [ f ] + + METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ] + + METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 ] + + METHOD: NSInteger conversationIdentifier [ self alien-address ] + + ! Initialization + METHOD: void updateFactorGadgetSize: id notification + [ + self window :> window + window [ + self view-dim window dim<< yield + ] when + ] + + METHOD: void doCommandBySelector: SEL selector [ ] + + METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat + [ + self frame pixelFormat SUPER-> initWithFrame:pixelFormat: + dup dup add-resize-observer + ] + + METHOD: char isOpaque [ 0 ] + + METHOD: void dealloc + [ + self remove-observer + self SUPER-> dealloc + ] ] -METHOD: id undo: id event [ self event undo-action send-action$ ] - -METHOD: id redo: id event [ self event redo-action send-action$ ] - -METHOD: id cut: id event [ self event cut-action send-action$ ] - -METHOD: id copy: id event [ self event copy-action send-action$ ] - -METHOD: id paste: id event [ self event paste-action send-action$ ] - -METHOD: id delete: id event [ self event delete-action send-action$ ] - -METHOD: id selectAll: id event [ self event select-all-action send-action$ ] - -METHOD: id newDocument: id event [ self event new-action send-action$ ] - -METHOD: id openDocument: id event [ self event open-action send-action$ ] - -METHOD: id saveDocument: id event [ self event save-action send-action$ ] - -METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ] - -METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ] - -! Multi-touch gestures -METHOD: void magnifyWithEvent: id event -[ - self event - dup -> deltaZ sgn { - { 1 [ zoom-in-action send-action$ drop ] } - { -1 [ zoom-out-action send-action$ drop ] } - { 0 [ 2drop ] } - } case -] - -METHOD: void swipeWithEvent: id event -[ - self event - dup -> deltaX sgn { - { 1 [ left-action send-action$ drop ] } - { -1 [ right-action send-action$ drop ] } - { 0 - [ - dup -> deltaY sgn { - { 1 [ up-action send-action$ drop ] } - { -1 [ down-action send-action$ drop ] } - { 0 [ 2drop ] } - } case - ] - } - } case -] - -METHOD: char acceptsFirstResponder [ 1 ] - -! Services -METHOD: id validRequestorForSendType: id sendType returnType: id returnType -[ - ! We return either self or nil - self window world-focus sendType returnType - valid-service? [ self ] [ f ] if -] - -METHOD: char writeSelectionToPasteboard: id pboard types: id types -[ - NSStringPboardType types CF>string-array member? [ - self window world-focus gadget-selection - [ pboard set-pasteboard-string 1 ] [ 0 ] if* - ] [ 0 ] if -] - -METHOD: char readSelectionFromPasteboard: id pboard -[ - pboard pasteboard-string - [ self window user-input 1 ] [ 0 ] if* -] - -! Text input -METHOD: void insertText: id text -[ text CF>string self window user-input ] - -METHOD: char hasMarkedText [ 0 ] - -METHOD: NSRange markedRange [ 0 0 ] - -METHOD: NSRange selectedRange [ 0 0 ] - -METHOD: void setMarkedText: id text selectedRange: NSRange range [ ] - -METHOD: void unmarkText [ ] - -METHOD: id validAttributesForMarkedText [ NSArray -> array ] - -METHOD: id attributedSubstringFromRange: NSRange range [ f ] - -METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ] - -METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 ] - -METHOD: NSInteger conversationIdentifier [ self alien-address ] - -! Initialization -METHOD: void updateFactorGadgetSize: id notification -[ self view-dim self window dim<< yield ] - -METHOD: void doCommandBySelector: SEL selector [ ] - -METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat -[ - self frame pixelFormat SUPER-> initWithFrame:pixelFormat: - dup dup add-resize-observer -] - -METHOD: char isOpaque [ 0 ] - -METHOD: void dealloc -[ - self remove-observer - self SUPER-> dealloc -] ; - : sync-refresh-to-screen ( GLView -- ) -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 CGLSetParameter drop ; @@ -321,38 +341,39 @@ METHOD: void dealloc : save-position ( world window -- ) -> frame CGRect-top-left 2array >>window-loc drop ; -CLASS: { - { +name+ "FactorWindowDelegate" } - { +superclass+ "NSObject" } -} - -METHOD: void windowDidMove: id notification +CLASS: FactorWindowDelegate < NSObject [ - notification -> object -> contentView window - notification -> object save-position + METHOD: void windowDidMove: id notification + [ + notification -> object -> contentView window + [ notification -> object save-position ] when* + ] + + METHOD: void windowDidBecomeKey: id notification + [ + notification -> object -> contentView window + [ focus-world ] when* + ] + + METHOD: void windowDidResignKey: id notification + [ + forget-rollover + notification -> object -> contentView :> view + view window :> window + window [ + view -> isInFullScreenMode 0 = + [ window unfocus-world ] when + ] when + ] + + METHOD: char windowShouldClose: id notification [ 1 ] + + METHOD: void windowWillClose: id notification + [ + notification -> object -> contentView + [ window ungraft ] [ unregister-window ] bi + ] ] -METHOD: void windowDidBecomeKey: id notification -[ - notification -> object -> contentView window - focus-world -] - -METHOD: void windowDidResignKey: id notification -[ - forget-rollover - notification -> object -> contentView - dup -> isInFullScreenMode 0 = - [ window [ unfocus-world ] when* ] [ drop ] if -] - -METHOD: char windowShouldClose: id notification [ 1 ] - -METHOD: void windowWillClose: id notification -[ - notification -> object -> contentView - [ window ungraft ] [ unregister-window ] bi -] ; - : install-window-delegate ( window -- ) FactorWindowDelegate install-delegate ; From a7384d5de6cebd2a1170809c68bf1aed06f32b70 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 7 Jul 2010 02:26:03 -0400 Subject: [PATCH 7/7] io.ports: fix stream-tell implementation --- basis/io/ports/ports.factor | 27 ++++++++++++++++----------- core/io/files/files-tests.factor | 28 ++++++++++++++++++++++++---- 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 6a30a1ed07..3864b37e48 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -105,7 +105,8 @@ TUPLE: output-port < buffered-port ; [ 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 @@ -128,13 +129,24 @@ M: output-port stream-write 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 ] @@ -150,13 +162,6 @@ GENERIC: shutdown ( handle -- ) 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* [ { diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index ff6eed4514..4986fedd79 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -161,8 +161,12 @@ CONSTANT: pt-array-1 "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 @@ -174,8 +178,12 @@ CONSTANT: pt-array-1 "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 @@ -187,8 +195,12 @@ CONSTANT: pt-array-1 "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 @@ -201,7 +213,11 @@ CONSTANT: pt-array-1 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 @@ -212,9 +228,13 @@ CONSTANT: pt-array-1 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