diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 967f2f7913..1dd4259bb6 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -97,7 +97,9 @@ TUPLE: no-parent-directory path ; ] } } cond drop ; -: copy-file ( from to -- ) +HOOK: copy-file io-backend ( from to -- ) + +M: object copy-file dup parent-directory make-directories [ stdio get swap diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index ddfb601be5..f13a5e2ab0 100644 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -58,8 +58,9 @@ SYMBOL: super-sent-messages "NSSavePanel" "NSView" "NSWindow" + "NSWorkspace" } [ - f import-objc-class + [ ] import-objc-class ] each : ( str -- alien ) -> autorelease ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 91c4262312..54ddbaa0cf 100644 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.compiler arrays assocs combinators compiler inference.transforms kernel math namespaces parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros -memoize ; +memoize debugger ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -201,8 +201,11 @@ H{ : import-objc-class ( name quot -- ) 2dup unless-defined dupd define-objc-class-word - dup objc-class register-objc-methods - objc-meta-class register-objc-methods ; + [ + dup + objc-class register-objc-methods + objc-meta-class register-objc-methods + ] curry try ; : root-class ( class -- root ) dup objc-class-super-class [ root-class ] [ ] ?if ; diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor old mode 100644 new mode 100755 index 8dda62faea..1c70c0c325 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -4,51 +4,51 @@ USING: kernel tools.test parser-combinators lazy-lists fjsc ; IN: temporary { T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "55 2abc1 100" 'expression' parse car parse-result-parsed + "55 2abc1 100" 'expression' parse-1 ] unit-test { T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "[ 55 2abc1 100 ]" 'quotation' parse car parse-result-parsed + "[ 55 2abc1 100 ]" 'quotation' parse-1 ] unit-test { T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ - "{ 55 2abc1 100 }" 'array' parse car parse-result-parsed + "{ 55 2abc1 100 }" 'array' parse-1 ] unit-test { T{ ast-stack-effect f { } { "d" "e" "f" } } } [ - "( -- d e f )" 'stack-effect' parse car parse-result-parsed + "( -- d e f )" 'stack-effect' parse-1 ] unit-test { T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [ - "( a b c -- d e f )" 'stack-effect' parse car parse-result-parsed + "( a b c -- d e f )" 'stack-effect' parse-1 ] unit-test { T{ ast-stack-effect f { "a" "b" "c" } { } } } [ - "( a b c -- )" 'stack-effect' parse car parse-result-parsed + "( a b c -- )" 'stack-effect' parse-1 ] unit-test { T{ ast-stack-effect f { } { } } } [ - "( -- )" 'stack-effect' parse car parse-result-parsed + "( -- )" 'stack-effect' parse-1 ] unit-test { } [ ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop ] unit-test - -{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ - "\"abcd\"" 'statement' parse car parse-result-parsed -] unit-test + +{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ + "\"abcd\"" 'statement' parse-1 +] unit-test { T{ ast-expression f { T{ ast-use f "foo" } } } } [ - "USE: foo" 'statement' parse car parse-result-parsed + "USE: foo" 'statement' parse-1 ] unit-test { T{ ast-expression f { T{ ast-in f "foo" } } } } [ - "IN: foo" 'statement' parse car parse-result-parsed + "IN: foo" 'statement' parse-1 ] unit-test { T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [ - "USING: foo bar ;" 'statement' parse car parse-result-parsed + "USING: foo bar ;" 'statement' parse-1 ] unit-test diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor old mode 100644 new mode 100755 index c6572f147c..22031afb25 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: kernel lazy-lists parser-combinators parser-combinators.simple - strings promises sequences math math.parser namespaces words + strings promises sequences math math.parser namespaces words quotations arrays hashtables io io.streams.string assocs ; IN: fjsc @@ -53,11 +53,11 @@ C: ast-hashtable [ CHAR: ] = not ] keep [ CHAR: ;" = not ] keep [ CHAR: " = not ] keep - digit? not + digit? not and and and and and ; -LAZY: 'identifier-ends' ( -- parser ) - [ +LAZY: 'identifier-ends' ( -- parser ) + [ [ blank? not ] keep [ CHAR: " = not ] keep [ CHAR: ;" = not ] keep @@ -67,23 +67,23 @@ LAZY: 'identifier-ends' ( -- parser ) and and and and and ] satisfy ; -LAZY: 'identifier-middle' ( -- parser ) +LAZY: 'identifier-middle' ( -- parser ) [ identifier-middle? ] satisfy ; LAZY: 'identifier' ( -- parser ) - 'identifier-ends' + 'identifier-ends' 'identifier-middle' <&> - 'identifier-ends' <:&> + 'identifier-ends' <:&> [ concat >string f ] <@ ; - + DEFER: 'expression' LAZY: 'effect-name' ( -- parser ) - [ + [ [ blank? not ] keep CHAR: - = not - and + and ] satisfy [ >string ] <@ ; LAZY: 'stack-effect' ( -- parser ) @@ -94,24 +94,24 @@ LAZY: 'stack-effect' ( -- parser ) ")" token sp <& [ first2 ] <@ ; LAZY: 'define' ( -- parser ) - ":" token sp + ":" token sp 'identifier' sp [ ast-identifier-value ] <@ &> 'stack-effect' sp <&> 'expression' <:&> ";" token sp <& [ first3 ] <@ ; LAZY: 'quotation' ( -- parser ) - "[" token sp + "[" token sp 'expression' [ ast-expression-values ] <@ &> "]" token sp <& [ ] <@ ; LAZY: 'array' ( -- parser ) - "{" token sp + "{" token sp 'expression' [ ast-expression-values ] <@ &> "}" token sp <& [ ] <@ ; LAZY: 'word' ( -- parser ) - "\\" token sp + "\\" token sp 'identifier' sp &> [ ast-identifier-value f ] <@ ; LAZY: 'atom' ( -- parser ) @@ -137,7 +137,7 @@ LAZY: 'USING:' ( -- parser ) ";" token sp <& [ ] <@ ; LAZY: 'hashtable' ( -- parser ) - "H{" token sp + "H{" token sp 'expression' [ ast-expression-values ] <@ &> "}" token sp <& [ ] <@ ; @@ -147,14 +147,14 @@ LAZY: 'parsing-word' ( -- parser ) 'IN:' <|> ; LAZY: 'expression' ( -- parser ) - 'comment' - 'parsing-word' sp <|> - 'quotation' sp <|> + 'comment' + 'parsing-word' sp <|> + 'quotation' sp <|> 'define' sp <|> 'array' sp <|> 'hashtable' sp <|> 'word' sp <|> - 'atom' sp <|> + 'atom' sp <|> <*> [ ] <@ ; LAZY: 'statement' ( -- parser ) @@ -163,41 +163,41 @@ LAZY: 'statement' ( -- parser ) GENERIC: (compile) ( ast -- ) GENERIC: (literal) ( ast -- ) -M: ast-number (literal) +M: ast-number (literal) ast-number-value number>string , ; -M: ast-number (compile) - "factor.push_data(" , - (literal) - "," , ; - -M: ast-string (literal) - "\"" , - ast-string-value , - "\"" , ; - -M: ast-string (compile) +M: ast-number (compile) "factor.push_data(" , (literal) "," , ; -M: ast-identifier (literal) +M: ast-string (literal) + "\"" , + ast-string-value , + "\"" , ; + +M: ast-string (compile) + "factor.push_data(" , + (literal) + "," , ; + +M: ast-identifier (literal) dup ast-identifier-vocab [ - "factor.get_word(\"" , + "factor.get_word(\"" , dup ast-identifier-vocab , "\",\"" , - ast-identifier-value , - "\")" , + ast-identifier-value , + "\")" , ] [ - "factor.find_word(\"" , ast-identifier-value , "\")" , + "factor.find_word(\"" , ast-identifier-value , "\")" , ] if ; -M: ast-identifier (compile) +M: ast-identifier (compile) (literal) ".execute(" , ; -M: ast-define (compile) - "factor.define_word(\"" , - dup ast-define-name , +M: ast-define (compile) + "factor.define_word(\"" , + dup ast-define-name , "\",\"source\"," , ast-define-expression (compile) "," , ; @@ -207,7 +207,7 @@ M: ast-define (compile) unclip dup ast-comment? not [ "function() {" , - (compile) + (compile) do-expressions ")}" , ] [ @@ -217,74 +217,74 @@ M: ast-define (compile) drop "factor.cont.next" , ] if ; -M: ast-quotation (literal) +M: ast-quotation (literal) "factor.make_quotation(\"source\"," , ast-quotation-values do-expressions ")" , ; -M: ast-quotation (compile) +M: ast-quotation (compile) "factor.push_data(factor.make_quotation(\"source\"," , ast-quotation-values do-expressions ")," , ; -M: ast-array (literal) - "[" , +M: ast-array (literal) + "[" , ast-array-elements [ "," , ] [ (literal) ] interleave "]" , ; -M: ast-array (compile) +M: ast-array (compile) "factor.push_data(" , (literal) "," , ; -M: ast-hashtable (literal) - "new Hashtable().fromAlist([" , +M: ast-hashtable (literal) + "new Hashtable().fromAlist([" , ast-hashtable-elements [ "," , ] [ (literal) ] interleave "])" , ; -M: ast-hashtable (compile) +M: ast-hashtable (compile) "factor.push_data(" , (literal) "," , ; M: ast-expression (literal) ast-expression-values [ - (literal) + (literal) ] each ; - + M: ast-expression (compile) ast-expression-values do-expressions ; -M: ast-word (literal) +M: ast-word (literal) dup ast-word-vocab [ - "factor.get_word(\"" , + "factor.get_word(\"" , dup ast-word-vocab , "\",\"" , - ast-word-value , - "\")" , + ast-word-value , + "\")" , ] [ - "factor.find_word(\"" , ast-word-value , "\")" , + "factor.find_word(\"" , ast-word-value , "\")" , ] if ; M: ast-word (compile) "factor.push_data(" , (literal) "," , ; - + M: ast-comment (compile) drop ; M: ast-stack-effect (compile) drop ; -M: ast-use (compile) +M: ast-use (compile) "factor.use(\"" , - ast-use-name , + ast-use-name , "\"," , ; -M: ast-in (compile) +M: ast-in (compile) "factor.set_in(\"" , - ast-in-name , + ast-in-name , "\"," , ; -M: ast-using (compile) +M: ast-using (compile) "factor.using([" , ast-using-names [ "," , @@ -308,17 +308,17 @@ M: string (parse-factor-quotation) ( object -- ast ) ; M: quotation (parse-factor-quotation) ( object -- ast ) - [ + [ [ (parse-factor-quotation) , ] each ] { } make ; M: array (parse-factor-quotation) ( object -- ast ) - [ + [ [ (parse-factor-quotation) , ] each ] { } make ; M: hashtable (parse-factor-quotation) ( object -- ast ) - >alist [ + >alist [ [ (parse-factor-quotation) , ] each ] { } make ; @@ -328,33 +328,33 @@ M: wrapper (parse-factor-quotation) ( object -- ast ) GENERIC: fjsc-parse ( object -- ast ) M: string fjsc-parse ( object -- ast ) - 'expression' parse car parse-result-parsed ; + 'expression' parse-1 ; M: quotation fjsc-parse ( object -- ast ) [ - [ (parse-factor-quotation) , ] each + [ (parse-factor-quotation) , ] each ] { } make ; : fjsc-compile ( ast -- string ) [ - [ + [ "(" , - (compile) + (compile) ")" , ] { } make [ write ] each ] string-out ; - + : fjsc-compile* ( string -- string ) - 'statement' parse car parse-result-parsed fjsc-compile ; + 'statement' parse-1 fjsc-compile ; : fc* ( string -- string ) [ - 'statement' parse car parse-result-parsed ast-expression-values do-expressions + 'statement' parse-1 ast-expression-values do-expressions ] { } make [ write ] each ; - + : fjsc-literal ( ast -- string ) [ [ (literal) ] { } make [ write ] each ] string-out ; - + diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor new file mode 100755 index 0000000000..d07ab24da5 --- /dev/null +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -0,0 +1,19 @@ +IN: temporary +USING: io.unix.launcher tools.test ; + +[ { } ] [ "" tokenize-command ] unit-test +[ { } ] [ " " tokenize-command ] unit-test +[ { "a" } ] [ "a" tokenize-command ] unit-test +[ { "abc" } ] [ "abc" tokenize-command ] unit-test +[ { "abc" } ] [ "abc " tokenize-command ] unit-test +[ { "abc" } ] [ " abc" tokenize-command ] unit-test +[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test +[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test +[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test +[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test +[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test +[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test +[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test +[ "'abc def' \"hey" tokenize-command ] unit-test-fails +[ "'abc def" tokenize-command ] unit-test-fails +[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\"ey\" " tokenize-command ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor old mode 100644 new mode 100755 index 0e7ec9ad16..ef45a0705e --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -2,17 +2,46 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.launcher io.unix.backend io.nonblocking sequences kernel namespaces math system alien.c-types -debugger continuations arrays assocs combinators unix.process ; +debugger continuations arrays assocs combinators unix.process +parser-combinators memoize promises strings ; IN: io.unix.launcher ! Search unix first USE: unix -: get-arguments ( -- seq ) - +command+ get - [ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ; +! Our command line parser. Supported syntax: +! foo bar baz -- simple tokens +! foo\ bar -- escaping the space +! 'foo bar' -- quotation +! "foo bar" -- quotation +LAZY: 'escaped-char' "\\" token any-char-parser &> ; -: assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; +LAZY: 'chars' 'escaped-char' any-char-parser <|> <*> ; + +LAZY: 'quoted-1' 'chars' "\"" "\"" surrounded-by ; + +LAZY: 'quoted-2' 'chars' "'" "'" surrounded-by ; + +LAZY: 'non-space-char' + 'escaped-char' [ CHAR: \s = not ] satisfy <|> ; + +LAZY: 'unquoted' 'non-space-char' <+> ; + +LAZY: 'argument' + 'quoted-1' 'quoted-2' 'unquoted' <|> <|> + [ >string ] <@ ; + +MEMO: 'arguments' ( -- parser ) + 'argument' " " token <+> list-of ; + +: tokenize-command ( command -- arguments ) + 'arguments' parse-1 ; + +: get-arguments ( -- seq ) + +command+ get [ tokenize-command ] [ +arguments+ get ] if* ; + +: assoc>env ( assoc -- env ) + [ "=" swap 3append ] { } assoc>map ; : (spawn-process) ( -- ) [ diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index d7dcad67d9..5a72a5426a 100644 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -13,7 +13,7 @@ IN: io.unix.mmap M: unix-io ( path length -- obj ) swap >r dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor - r> mmap-open \ mapped-file construct-boa ; + r> mmap-open f mapped-file construct-boa ; M: unix-io (close-mapped-file) ( mmap -- ) [ mapped-file-address ] keep diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 3caa2c7113..31893fab0c 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -53,8 +53,11 @@ TUPLE: CreateProcess-args CreateProcess-args-lpProcessInformation } get-slots CreateProcess win32-error=0/f ; +: escape-argument ( str -- newstr ) + [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; + : join-arguments ( args -- cmd-line ) - [ "\"" swap "\"" 3append ] map " " join ; + [ "\"" swap escape-argument "\"" 3append ] map " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ac0ede0e06..53ee82ed65 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -109,12 +109,14 @@ M: windows-io ( path -- stream ) open-append ; M: windows-io rename-file ( from to -- ) - [ normalize-pathname ] 2apply - MoveFile win32-error=0/f ; + [ normalize-pathname ] 2apply MoveFile win32-error=0/f ; M: windows-io delete-file ( path -- ) - normalize-pathname - DeleteFile win32-error=0/f ; + normalize-pathname DeleteFile win32-error=0/f ; + +M: windows-io copy-file ( from to -- ) + dup parent-directory make-directories + [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ; M: windows-io make-directory ( path -- ) normalize-pathname diff --git a/extra/parser-combinators/parser-combinators-docs.factor b/extra/parser-combinators/parser-combinators-docs.factor old mode 100644 new mode 100755 index b3d25e4cd3..7b575e4da9 --- a/extra/parser-combinators/parser-combinators-docs.factor +++ b/extra/parser-combinators/parser-combinators-docs.factor @@ -3,14 +3,23 @@ USING: help.markup help.syntax parser-combinators ; HELP: list-of -{ $values +{ $values { "items" "a parser object" } { "separator" "a parser object" } { "parser" "a parser object" } } -{ $description +{ $description "Return a parser for parsing the repetition of things that are " "separated by a certain symbol. For example, comma separated lists. " "'items' is a parser that can parse the individual elements. 'separator' " - "is a parser for the symbol that separatest them. The result tree of " + "is a parser for the symbol that separatest them. The result tree of " "the resulting parser is an array of the parsed elements." } -{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse car parse-result-parsed ." "{ 1 2 3 4 }" } +{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" } { $see-also list-of } ; +HELP: any-char-parser +{ $values + { "parser" "a parser object" } } +{ $description + "Return a parser that consumes a single value " + "from the input string. The value consumed is the " + "result of the parse." } +{ $examples +{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor old mode 100644 new mode 100755 index fa0733f321..6301f778f5 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -15,6 +15,9 @@ M: promise (parse) ( input parser -- list ) TUPLE: parse-result parsed unparsed ; +: parse-1 ( input parser -- result ) + parse car parse-result-parsed ; + C: parse-result TUPLE: token-parser string ; @@ -23,7 +26,7 @@ C: token token-parser ( string -- parser ) M: token-parser (parse) ( input parser -- list ) token-parser-string swap over ?head-slice [ - 1list + 1list ] [ 2drop nil ] if ; @@ -43,9 +46,12 @@ M: satisfy-parser (parse) ( input parser -- list ) swap 1list ] [ 2drop nil - ] if + ] if ] if ; +LAZY: any-char-parser ( -- parser ) + [ drop t ] satisfy ; + TUPLE: epsilon-parser ; C: epsilon epsilon-parser ( -- parser ) @@ -63,7 +69,7 @@ C: succeed succeed-parser ( result -- parser ) M: succeed-parser (parse) ( input parser -- list ) #! A parser that always returns 'result' as a - #! successful parse with no input consumed. + #! successful parse with no input consumed. succeed-parser-result swap 1list ; TUPLE: fail-parser ; @@ -81,7 +87,7 @@ TUPLE: and-parser parsers ; over and-parser? [ >r and-parser-parsers r> add ] [ - 2array + 2array ] if \ and-parser construct-boa ; : and-parser-parse ( list p1 -- list ) @@ -92,13 +98,13 @@ TUPLE: and-parser parsers ; [ parse-result-parsed 2array ] keep parse-result-unparsed ] lmap-with - ] lmap-with lconcat ; - + ] lmap-with lconcat ; + M: and-parser (parse) ( input parser -- list ) #! Parse 'input' by sequentially combining the #! two parsers. First parser1 is applied to the #! input then parser2 is applied to the rest of - #! the input strings from the first parser. + #! the input strings from the first parser. and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ; TUPLE: or-parser p1 p2 ; @@ -115,7 +121,7 @@ M: or-parser (parse) ( input parser1 -- list ) #! Return a new string without any leading whitespace #! from the original string. dup empty? [ - dup first blank? [ 1 tail-slice left-trim-slice ] when + dup first blank? [ 1 tail-slice left-trim-slice ] when ] unless ; TUPLE: sp-parser p1 ; @@ -136,7 +142,7 @@ C: just just-parser ( p1 -- parser ) M: just-parser (parse) ( input parser -- result ) #! Calls the given parser on the input removes #! from the results anything where the remaining - #! input to be parsed is not empty. So ensures a + #! input to be parsed is not empty. So ensures a #! fully parsed input string. just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ; @@ -150,8 +156,8 @@ M: apply-parser (parse) ( input parser -- result ) #! The result of that quotation then becomes the new parse result. #! This allows modification of parse tree results (like #! converting strings to integers, etc). - [ apply-parser-p1 ] keep apply-parser-quot - -rot parse [ + [ apply-parser-p1 ] keep apply-parser-quot + -rot parse [ [ parse-result-parsed swap call ] keep parse-result-unparsed ] lmap-with ; @@ -165,7 +171,7 @@ M: some-parser (parse) ( input parser -- result ) #! the parse is complete (the remaining input is empty), #! picks the first solution and only returns the parse #! tree since the remaining input is empty. - some-parser-p1 just parse car parse-result-parsed ; + some-parser-p1 just parse-1 ; : <& ( parser1 parser2 -- parser ) @@ -230,13 +236,13 @@ LAZY: ( parser -- parser ) #! required. only-first ; -LAZY: <(*)> ( parser -- parser ) - #! Like <*> but take shortest match first. +LAZY: <(*)> ( parser -- parser ) + #! Like <*> but take shortest match first. #! Implementation by Matthew Willis. { } succeed swap dup <(*)> <&:> <|> ; LAZY: <(+)> ( parser -- parser ) - #! Like <+> but take shortest match first. + #! Like <+> but take shortest match first. #! Implementation by Matthew Willis. dup <(*)> <&:> ; @@ -249,6 +255,9 @@ LAZY: pack ( close body open -- parser ) LAZY: list-of ( items separator -- parser ) #! Given a parser for the separator and for the #! items themselves, return a parser that parses - #! lists of those items. The parse tree is an + #! lists of those items. The parse tree is an #! array of the parsed items. - over &> <*> <&:> { } succeed <|> ; \ No newline at end of file + dup -rot over &> <*> <&:> &> { } succeed <|> ; + +LAZY: surrounded-by ( parser start end -- parser' ) + [ token ] 2apply swapd pack ; \ No newline at end of file diff --git a/extra/parser-combinators/replace/replace.factor b/extra/parser-combinators/replace/replace.factor old mode 100644 new mode 100755 index 0d9b7f743a..541bde7ac7 --- a/extra/parser-combinators/replace/replace.factor +++ b/extra/parser-combinators/replace/replace.factor @@ -13,21 +13,21 @@ IN: parser-combinators } cond ; : search ( string parser -- seq ) - 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ + any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ drop { } ] [ car parse-result-parsed [ ] subset ] if ; : search* ( string parsers -- seq ) - unclip [ <|> ] reduce 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ + unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [ drop { } ] [ car parse-result-parsed [ ] subset ] if ; : (replace) ( string parser -- seq ) - 'any-char' <|> <*> parse car parse-result-parsed ; + any-char-parser <|> <*> parse-1 ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] string-out ; diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor old mode 100644 new mode 100755 index b85d3ab5bb..52786aceae --- a/extra/parser-combinators/simple/simple-docs.factor +++ b/extra/parser-combinators/simple/simple-docs.factor @@ -3,17 +3,6 @@ USING: help.syntax help.markup parser-combinators parser-combinators.simple ; -HELP: 'any-char' -{ $values - { "parser" "a parser object" } } -{ $description - "Return a parser that consumes a single value " - "from the input string. The value consumed is the " - "result of the parse." } -{ $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" 'any-char' parse car parse-result-parsed ." "102" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; - HELP: 'digit' { $values { "parser" "a parser object" } } @@ -22,8 +11,7 @@ HELP: 'digit' "the input string. The numeric value of the digit " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse car parse-result-parsed ." "1" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; +{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ; HELP: 'integer' { $values @@ -33,9 +21,7 @@ HELP: 'integer' "the input string. The numeric value of the integer " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse car parse-result-parsed ." "123" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; - +{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ; HELP: 'string' { $values { "parser" "a parser object" } } @@ -44,9 +30,7 @@ HELP: 'string' "quotations from the input string. The string value " " consumed is the result of the parse." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse car parse-result-parsed ." "\"foo\"" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; - +{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ; HELP: 'bold' { $values { "parser" "a parser object" } } @@ -55,10 +39,8 @@ HELP: 'bold' "the '*' character from the input string. This is " "commonly used in markup languages to indicate bold " "faced text." } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse car parse-result-parsed ." "\"foo\"" } -{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse car parse-result-parsed ." "\"foo\"" } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; - +{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" } +{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } ; HELP: 'italic' { $values { "parser" "a parser object" } } @@ -68,10 +50,8 @@ HELP: 'italic' "commonly used in markup languages to indicate italic " "faced text." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse car parse-result-parsed ." "\"foo\"" } -{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse car parse-result-parsed ." "\"foo\"" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; - +{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" } +{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"\" swap \"\" 3append ] <@ parse-1 ." "\"foo\"" } } ; HELP: comma-list { $values { "element" "a parser object" } { "parser" "a parser object" } } @@ -80,5 +60,6 @@ HELP: comma-list "'element' should be a parser that can parse the elements. The " "result of the parser is a sequence of the parsed elements." } { $examples -{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse car parse-result-parsed ." "{ 1 2 3 4 }" } } -{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ; +{ $example "USING: lazy-lits parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ; + +{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor old mode 100644 new mode 100755 index 955807efa3..c5b84d86c6 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -4,9 +4,6 @@ USING: kernel strings math sequences lazy-lists words math.parser promises ; IN: parser-combinators -LAZY: 'any-char' ( -- parser ) - [ drop t ] satisfy ; - : 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index d59665488a..a5319563be 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -1,18 +1,16 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.launcher kernel namespaces sequences -system cocoa.plists cocoa.application tools.deploy -tools.deploy.config assocs hashtables prettyprint ; +system tools.deploy tools.deploy.config assocs hashtables +prettyprint unix io.unix.backend cocoa cocoa.plists +cocoa.application cocoa.classes ; IN: tools.deploy.macosx : touch ( path -- ) - "touch \"" swap "\"" 3append run-process ; + { "touch" } swap add run-process ; : rm ( path -- ) - "rm -rf \"" swap "\"" 3append run-process ; - -: chmod ( path perms -- ) - [ "chmod " % % " \"" % % "\"" % ] "" make run-process ; + { "rm" "-rf" } swap add run-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; @@ -24,7 +22,7 @@ IN: tools.deploy.macosx : copy-vm ( executable bundle-name -- vm ) "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep - [ "755" chmod ] keep ; + [ 755 chmod io-error ] keep ; : copy-fonts ( name -- ) "fonts/" resource-path @@ -63,6 +61,12 @@ TUPLE: macosx-deploy-implementation ; T{ macosx-deploy-implementation } deploy-implementation set-global +: show-in-finder ( path -- ) + NSWorkspace + -> sharedWorkspace + over rot parent-directory + -> selectFile:inFileViewerRootedAtPath: drop ; + M: macosx-deploy-implementation deploy ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd @@ -70,5 +74,6 @@ M: macosx-deploy-implementation deploy ( vocab -- ) bundle-name rm [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep - namespace - ] bind deploy* ; + namespace deploy* + bundle-name show-in-finder + ] bind ; diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 52722a2fab..6607a22f50 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -60,11 +60,19 @@ M: cocoa-ui-backend set-title ( string world -- ) drop ] if ; -M: cocoa-ui-backend (open-world-window) ( world -- ) +M: cocoa-ui-backend (open-window) ( world -- ) dup gadget-window dup auto-position world-handle second f -> makeKeyAndOrderFront: ; +M: cocoa-ui-backend (close-window) ( handle -- ) + first unregister-window ; + +M: cocoa-ui-backend close-window ( gadget -- ) + find-world [ + world-handle second f -> performClose: + ] when* ; + M: cocoa-ui-backend raise-window ( world -- ) world-handle [ second dup f -> orderFront: -> makeKeyWindow diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 31d6c89f8c..feac09ffc4 100644 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -3,7 +3,8 @@ USING: alien arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui -ui.gadgets ui.gadgets.worlds ui.gestures core-foundation ; +ui.gadgets ui.gadgets.worlds ui.gestures core-foundation +threads ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) @@ -313,8 +314,6 @@ CLASS: { { "dealloc" "void" { "id" "SEL" } [ drop - dup window stop-world - dup unregister-window dup remove-observer SUPER-> dealloc ] @@ -347,6 +346,12 @@ CLASS: { forget-rollover 2nip -> object -> contentView window unfocus-world ] +} + +{ "windowShouldClose:" "bool" { "id" "SEL" "id" } + [ + 2nip -> contentView window ungraft t + ] } ; : install-window-delegate ( window -- ) diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index c4b41e119f..e7d9161079 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -77,7 +77,8 @@ TUPLE: deploy-gadget vocab settings ; : com-deploy ( gadget -- ) dup com-save - find-deploy-vocab [ deploy ] curry call-listener ; + dup find-deploy-vocab [ deploy ] curry call-listener + close-window ; : com-help ( -- ) "ui-deploy" help-window ; @@ -86,7 +87,11 @@ TUPLE: deploy-gadget vocab settings ; { +nullary+ t } } define-command +: com-close ( gadget -- ) + close-window ; + deploy-gadget "toolbar" f { + { f com-close } { f com-help } { f com-revert } { f com-save } diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 4184591cec..48d341b4b8 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -67,11 +67,11 @@ M: workspace model-changed : com-profiler profiler-gadget select-tool ; workspace "tool-switching" f { - { T{ key-down f f "F2" } com-listener } - { T{ key-down f f "F3" } com-browser } - { T{ key-down f f "F4" } com-inspector } - { T{ key-down f f "F5" } com-walker } - { T{ key-down f f "F6" } com-profiler } + { T{ key-down f { C+ } "1" } com-listener } + { T{ key-down f { C+ } "2" } com-browser } + { T{ key-down f { C+ } "3" } com-inspector } + { T{ key-down f { C+ } "4" } com-walker } + { T{ key-down f { C+ } "5" } com-profiler } } define-command-map \ workspace-window @@ -86,8 +86,8 @@ H{ { +nullary+ t } { +listener+ t } } define-command workspace "workflow" f { { T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f f "ESC" } hide-popup } - { T{ key-down f f "F8" } refresh-all } - { T{ key-down f { A+ } "F8" } test-changes } + { T{ key-down f f "F2" } refresh-all } + { T{ key-down f { A+ } "F2" } test-changes } } define-command-map [ diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 0c3b3e7867..98549a16f7 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -72,7 +72,9 @@ M: world ungraft* >r [ 1 track, ] { 0 1 } make-track r> f open-world-window ; -: close-window ( gadget -- ) +HOOK: close-window ui-backend ( gadget -- ) + +M: object close-window find-world [ ungraft ] when* ; : find-window ( quot -- world ) @@ -127,7 +129,7 @@ SYMBOL: ui-hook ] { } make ; : redraw-worlds ( seq -- ) - [ dup update-hand [ draw-world ] time ] each ; + [ dup update-hand draw-world ] each ; : notify ( gadget -- ) dup gadget-graft-state { diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 165989d86a..857b13a973 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -158,18 +158,14 @@ M: world selection-request-event { [ t ] [ drop send-notify-failure ] } } cond ; -: close-window ( handle -- ) +M: x11-ui-backend (close-window) ( handle -- ) dup x11-handle-xic XDestroyIC dup x11-handle-glx destroy-glx x11-handle-window dup unregister-window destroy-window ; M: world client-event - swap close-box? [ - dup world-handle >r stop-world r> close-window - ] [ - drop - ] if ; + swap close-box? [ ungraft ] [ drop ] if ; : gadget-window ( world -- ) dup world-loc over rect-dim glx-window @@ -222,7 +218,7 @@ M: x11-ui-backend set-title ( string world -- ) world-handle x11-handle-window swap dpy get -rot 3dup set-title-old set-title-new ; -M: x11-ui-backend (open-world-window) ( world -- ) +M: x11-ui-backend (open-window) ( world -- ) dup gadget-window world-handle x11-handle-window dup set-closable map-window ; diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor old mode 100644 new mode 100755 index 2a5bb94e30..bede8846c1 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel furnace fjsc parser-combinators namespaces - lazy-lists io io.files furnace.validator sequences - http.client http.server http.server.responders + lazy-lists io io.files furnace.validator sequences + http.client http.server http.server.responders webapps.file ; IN: webapps.fjsc @@ -11,15 +11,15 @@ IN: webapps.fjsc #! Compile the factor code as a string, outputting the http #! response containing the javascript. serving-text - 'expression' parse car parse-result-parsed fjsc-compile + 'expression' parse-1 fjsc-compile write flush ; ! The 'compile' action results in an URL that looks like -! 'responder/fjsc/compile'. It takes one query or post +! 'responder/fjsc/compile'. It takes one query or post ! parameter called 'code'. It calls the 'compile' word ! passing the parameter to it on the stack. -\ compile { - { "code" v-required } +\ compile { + { "code" v-required } } define-action : compile-url ( url -- ) @@ -28,18 +28,18 @@ IN: webapps.fjsc "http://" host rot 3append http-get 2nip compile "();" write flush ; \ compile-url { - { "url" v-required } + { "url" v-required } } define-action : repl ( -- ) #! The main 'repl' page. f "repl" "head" render-page* ; -! An action called 'repl' +! An action called 'repl' \ repl { } define-action : fjsc-web-app ( -- ) - ! Create the web app, providing access + ! Create the web app, providing access ! under '/responder/fjsc' which calls the ! 'repl' action. "fjsc" "repl" "extra/webapps/fjsc" web-app diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3abb42ecf1..c7f4e4c2f1 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -18,7 +18,7 @@ TUPLE: posting author title date link body ; #! entries is an array of { author entries } pairs. dup [ [ fetch-feed ] [ error. drop f ] recover - ] parallel-map [ ] subset + ] parallel-map [ [ >r first r> 2array ] curry* map ] 2map concat ; : sort-entries ( entries -- entries' ) @@ -108,6 +108,7 @@ SYMBOL: cached-postings { "Kio M. Smallwood" "http://sekenre.wordpress.com/feed/atom/" "http://sekenre.wordpress.com/" } + { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" } { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" } { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" } } default-blogroll set-global diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 8776378929..bb8919dd70 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -566,7 +566,8 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped ) ! FUNCTION: CopyFileA ! FUNCTION: CopyFileExA ! FUNCTION: CopyFileExW -! FUNCTION: CopyFileW +FUNCTION: BOOL CopyFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName, BOOL bFailIfExists ) ; +: CopyFile CopyFileW ; inline ! FUNCTION: CopyLZFile ! FUNCTION: CreateActCtxA ! FUNCTION: CreateActCtxW @@ -575,7 +576,7 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped ) ! FUNCTION: CreateDirectoryExA ! FUNCTION: CreateDirectoryExW FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ; -: CreateDirectory CreateDirectoryW ; +: CreateDirectory CreateDirectoryW ; inline ! FUNCTION: CreateEventA ! FUNCTION: CreateEventW