Merge git://factorcode.org/git/factor

release
Doug Coleman 2007-11-24 18:40:37 -06:00
commit ac5471c216
25 changed files with 281 additions and 203 deletions

View File

@ -97,7 +97,9 @@ TUPLE: no-parent-directory path ;
] } ] }
} cond drop ; } cond drop ;
: copy-file ( from to -- ) HOOK: copy-file io-backend ( from to -- )
M: object copy-file
dup parent-directory make-directories dup parent-directory make-directories
<file-writer> [ <file-writer> [
stdio get swap stdio get swap

View File

@ -58,8 +58,9 @@ SYMBOL: super-sent-messages
"NSSavePanel" "NSSavePanel"
"NSView" "NSView"
"NSWindow" "NSWindow"
"NSWorkspace"
} [ } [
f import-objc-class [ ] import-objc-class
] each ] each
: <NSString> ( str -- alien ) <CFString> -> autorelease ; : <NSString> ( str -- alien ) <CFString> -> autorelease ;

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.compiler
arrays assocs combinators compiler inference.transforms kernel arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros quotations sequences strings words cocoa.runtime io macros
memoize ; memoize debugger ;
IN: cocoa.messages IN: cocoa.messages
: make-sender ( method function -- quot ) : make-sender ( method function -- quot )
@ -201,8 +201,11 @@ H{
: import-objc-class ( name quot -- ) : import-objc-class ( name quot -- )
2dup unless-defined 2dup unless-defined
dupd define-objc-class-word 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 ) : root-class ( class -- root )
dup objc-class-super-class [ root-class ] [ ] ?if ; dup objc-class-super-class [ root-class ] [ ] ?if ;

28
extra/fjsc/fjsc-tests.factor Normal file → Executable file
View File

@ -4,51 +4,51 @@ USING: kernel tools.test parser-combinators lazy-lists fjsc ;
IN: temporary IN: temporary
{ T{ ast-expression f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { 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 ] unit-test
{ T{ ast-quotation f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { 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 ] unit-test
{ T{ ast-array f { T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { 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 ] unit-test
{ T{ ast-stack-effect f { } { "d" "e" "f" } } } [ { 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 ] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { "d" "e" "f" } } } [ { 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 ] unit-test
{ T{ ast-stack-effect f { "a" "b" "c" } { } } } [ { 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 ] unit-test
{ T{ ast-stack-effect f { } { } } } [ { T{ ast-stack-effect f { } { } } } [
"( -- )" 'stack-effect' parse car parse-result-parsed "( -- )" 'stack-effect' parse-1
] unit-test ] unit-test
{ } [ { } [
": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop ": foo ( a b -- c d ) abcdefghijklmn 123 ;" 'expression' parse car drop
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-string f "abcd" } } } } [ { T{ ast-expression f { T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse car parse-result-parsed "\"abcd\"" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-use f "foo" } } } } [ { T{ ast-expression f { T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse car parse-result-parsed "USE: foo" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-in f "foo" } } } } [ { T{ ast-expression f { T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse car parse-result-parsed "IN: foo" 'statement' parse-1
] unit-test ] unit-test
{ T{ ast-expression f { T{ ast-using f { "foo" "bar" } } } } } [ { 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 ] unit-test

148
extra/fjsc/fjsc.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved. ! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel lazy-lists parser-combinators parser-combinators.simple 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 ; quotations arrays hashtables io io.streams.string assocs ;
IN: fjsc IN: fjsc
@ -53,11 +53,11 @@ C: <ast-hashtable> ast-hashtable
[ CHAR: ] = not ] keep [ CHAR: ] = not ] keep
[ CHAR: ;" = not ] keep [ CHAR: ;" = not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
digit? not digit? not
and and and and and ; and and and and and ;
LAZY: 'identifier-ends' ( -- parser ) LAZY: 'identifier-ends' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
[ CHAR: ;" = not ] keep [ CHAR: ;" = not ] keep
@ -67,23 +67,23 @@ LAZY: 'identifier-ends' ( -- parser )
and and and and and and and and and and
] satisfy <!*> ; ] satisfy <!*> ;
LAZY: 'identifier-middle' ( -- parser ) LAZY: 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy <!+> ; [ identifier-middle? ] satisfy <!+> ;
LAZY: 'identifier' ( -- parser ) LAZY: 'identifier' ( -- parser )
'identifier-ends' 'identifier-ends'
'identifier-middle' <&> 'identifier-middle' <&>
'identifier-ends' <:&> 'identifier-ends' <:&>
[ concat >string f <ast-identifier> ] <@ ; [ concat >string f <ast-identifier> ] <@ ;
DEFER: 'expression' DEFER: 'expression'
LAZY: 'effect-name' ( -- parser ) LAZY: 'effect-name' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
CHAR: - = not CHAR: - = not
and and
] satisfy <!+> [ >string ] <@ ; ] satisfy <!+> [ >string ] <@ ;
LAZY: 'stack-effect' ( -- parser ) LAZY: 'stack-effect' ( -- parser )
@ -94,24 +94,24 @@ LAZY: 'stack-effect' ( -- parser )
")" token sp <& [ first2 <ast-stack-effect> ] <@ ; ")" token sp <& [ first2 <ast-stack-effect> ] <@ ;
LAZY: 'define' ( -- parser ) LAZY: 'define' ( -- parser )
":" token sp ":" token sp
'identifier' sp [ ast-identifier-value ] <@ &> 'identifier' sp [ ast-identifier-value ] <@ &>
'stack-effect' sp <!?> <&> 'stack-effect' sp <!?> <&>
'expression' <:&> 'expression' <:&>
";" token sp <& [ first3 <ast-define> ] <@ ; ";" token sp <& [ first3 <ast-define> ] <@ ;
LAZY: 'quotation' ( -- parser ) LAZY: 'quotation' ( -- parser )
"[" token sp "[" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"]" token sp <& [ <ast-quotation> ] <@ ; "]" token sp <& [ <ast-quotation> ] <@ ;
LAZY: 'array' ( -- parser ) LAZY: 'array' ( -- parser )
"{" token sp "{" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-array> ] <@ ; "}" token sp <& [ <ast-array> ] <@ ;
LAZY: 'word' ( -- parser ) LAZY: 'word' ( -- parser )
"\\" token sp "\\" token sp
'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ; 'identifier' sp &> [ ast-identifier-value f <ast-word> ] <@ ;
LAZY: 'atom' ( -- parser ) LAZY: 'atom' ( -- parser )
@ -137,7 +137,7 @@ LAZY: 'USING:' ( -- parser )
";" token sp <& [ <ast-using> ] <@ ; ";" token sp <& [ <ast-using> ] <@ ;
LAZY: 'hashtable' ( -- parser ) LAZY: 'hashtable' ( -- parser )
"H{" token sp "H{" token sp
'expression' [ ast-expression-values ] <@ &> 'expression' [ ast-expression-values ] <@ &>
"}" token sp <& [ <ast-hashtable> ] <@ ; "}" token sp <& [ <ast-hashtable> ] <@ ;
@ -147,14 +147,14 @@ LAZY: 'parsing-word' ( -- parser )
'IN:' <|> ; 'IN:' <|> ;
LAZY: 'expression' ( -- parser ) LAZY: 'expression' ( -- parser )
'comment' 'comment'
'parsing-word' sp <|> 'parsing-word' sp <|>
'quotation' sp <|> 'quotation' sp <|>
'define' sp <|> 'define' sp <|>
'array' sp <|> 'array' sp <|>
'hashtable' sp <|> 'hashtable' sp <|>
'word' sp <|> 'word' sp <|>
'atom' sp <|> 'atom' sp <|>
<*> [ <ast-expression> ] <@ ; <*> [ <ast-expression> ] <@ ;
LAZY: 'statement' ( -- parser ) LAZY: 'statement' ( -- parser )
@ -163,41 +163,41 @@ LAZY: 'statement' ( -- parser )
GENERIC: (compile) ( ast -- ) GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- ) GENERIC: (literal) ( ast -- )
M: ast-number (literal) M: ast-number (literal)
ast-number-value number>string , ; ast-number-value number>string , ;
M: ast-number (compile) M: ast-number (compile)
"factor.push_data(" ,
(literal)
"," , ;
M: ast-string (literal)
"\"" ,
ast-string-value ,
"\"" , ;
M: ast-string (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (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 [ dup ast-identifier-vocab [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-identifier-vocab , dup ast-identifier-vocab ,
"\",\"" , "\",\"" ,
ast-identifier-value , ast-identifier-value ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-identifier-value , "\")" , "factor.find_word(\"" , ast-identifier-value , "\")" ,
] if ; ] if ;
M: ast-identifier (compile) M: ast-identifier (compile)
(literal) ".execute(" , ; (literal) ".execute(" , ;
M: ast-define (compile) M: ast-define (compile)
"factor.define_word(\"" , "factor.define_word(\"" ,
dup ast-define-name , dup ast-define-name ,
"\",\"source\"," , "\",\"source\"," ,
ast-define-expression (compile) ast-define-expression (compile)
"," , ; "," , ;
@ -207,7 +207,7 @@ M: ast-define (compile)
unclip unclip
dup ast-comment? not [ dup ast-comment? not [
"function() {" , "function() {" ,
(compile) (compile)
do-expressions do-expressions
")}" , ")}" ,
] [ ] [
@ -217,74 +217,74 @@ M: ast-define (compile)
drop "factor.cont.next" , drop "factor.cont.next" ,
] if ; ] if ;
M: ast-quotation (literal) M: ast-quotation (literal)
"factor.make_quotation(\"source\"," , "factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions ast-quotation-values do-expressions
")" , ; ")" , ;
M: ast-quotation (compile) M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," , "factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions ast-quotation-values do-expressions
")," , ; ")," , ;
M: ast-array (literal) M: ast-array (literal)
"[" , "[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave ast-array-elements [ "," , ] [ (literal) ] interleave
"]" , ; "]" , ;
M: ast-array (compile) M: ast-array (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-hashtable (literal) M: ast-hashtable (literal)
"new Hashtable().fromAlist([" , "new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave ast-hashtable-elements [ "," , ] [ (literal) ] interleave
"])" , ; "])" , ;
M: ast-hashtable (compile) M: ast-hashtable (compile)
"factor.push_data(" , (literal) "," , ; "factor.push_data(" , (literal) "," , ;
M: ast-expression (literal) M: ast-expression (literal)
ast-expression-values [ ast-expression-values [
(literal) (literal)
] each ; ] each ;
M: ast-expression (compile) M: ast-expression (compile)
ast-expression-values do-expressions ; ast-expression-values do-expressions ;
M: ast-word (literal) M: ast-word (literal)
dup ast-word-vocab [ dup ast-word-vocab [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-word-vocab , dup ast-word-vocab ,
"\",\"" , "\",\"" ,
ast-word-value , ast-word-value ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-word-value , "\")" , "factor.find_word(\"" , ast-word-value , "\")" ,
] if ; ] if ;
M: ast-word (compile) M: ast-word (compile)
"factor.push_data(" , "factor.push_data(" ,
(literal) (literal)
"," , ; "," , ;
M: ast-comment (compile) M: ast-comment (compile)
drop ; drop ;
M: ast-stack-effect (compile) M: ast-stack-effect (compile)
drop ; drop ;
M: ast-use (compile) M: ast-use (compile)
"factor.use(\"" , "factor.use(\"" ,
ast-use-name , ast-use-name ,
"\"," , ; "\"," , ;
M: ast-in (compile) M: ast-in (compile)
"factor.set_in(\"" , "factor.set_in(\"" ,
ast-in-name , ast-in-name ,
"\"," , ; "\"," , ;
M: ast-using (compile) M: ast-using (compile)
"factor.using([" , "factor.using([" ,
ast-using-names [ ast-using-names [
"," , "," ,
@ -308,17 +308,17 @@ M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ; <ast-string> ;
M: quotation (parse-factor-quotation) ( object -- ast ) M: quotation (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ; ] { } make <ast-quotation> ;
M: array (parse-factor-quotation) ( object -- ast ) M: array (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-array> ; ] { } make <ast-array> ;
M: hashtable (parse-factor-quotation) ( object -- ast ) M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [ >alist [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ; ] { } make <ast-hashtable> ;
@ -328,33 +328,33 @@ M: wrapper (parse-factor-quotation) ( object -- ast )
GENERIC: fjsc-parse ( object -- ast ) GENERIC: fjsc-parse ( object -- ast )
M: string 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 ) M: quotation fjsc-parse ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-expression> ; ] { } make <ast-expression> ;
: fjsc-compile ( ast -- string ) : fjsc-compile ( ast -- string )
[ [
[ [
"(" , "(" ,
(compile) (compile)
")" , ")" ,
] { } make [ write ] each ] { } make [ write ] each
] string-out ; ] string-out ;
: fjsc-compile* ( string -- string ) : fjsc-compile* ( string -- string )
'statement' parse car parse-result-parsed fjsc-compile ; 'statement' parse-1 fjsc-compile ;
: fc* ( string -- string ) : 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 ; ] { } make [ write ] each ;
: fjsc-literal ( ast -- string ) : fjsc-literal ( ast -- string )
[ [
[ (literal) ] { } make [ write ] each [ (literal) ] { } make [ write ] each
] string-out ; ] string-out ;

View File

@ -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

39
extra/io/unix/launcher/launcher.factor Normal file → Executable file
View File

@ -2,17 +2,46 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.launcher io.unix.backend io.nonblocking USING: io io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types 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 IN: io.unix.launcher
! Search unix first ! Search unix first
USE: unix USE: unix
: get-arguments ( -- seq ) ! Our command line parser. Supported syntax:
+command+ get ! foo bar baz -- simple tokens
[ "/bin/sh" "-c" rot 3array ] [ +arguments+ get ] if* ; ! 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) ( -- ) : (spawn-process) ( -- )
[ [

View File

@ -13,7 +13,7 @@ IN: io.unix.mmap
M: unix-io <mapped-file> ( path length -- obj ) M: unix-io <mapped-file> ( path length -- obj )
swap >r swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor 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 -- ) M: unix-io (close-mapped-file) ( mmap -- )
[ mapped-file-address ] keep [ mapped-file-address ] keep

View File

@ -53,8 +53,11 @@ TUPLE: CreateProcess-args
CreateProcess-args-lpProcessInformation CreateProcess-args-lpProcessInformation
} get-slots CreateProcess win32-error=0/f ; } get-slots CreateProcess win32-error=0/f ;
: escape-argument ( str -- newstr )
[ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ;
: join-arguments ( args -- cmd-line ) : join-arguments ( args -- cmd-line )
[ "\"" swap "\"" 3append ] map " " join ; [ "\"" swap escape-argument "\"" 3append ] map " " join ;
: app-name/cmd-line ( -- app-name cmd-line ) : app-name/cmd-line ( -- app-name cmd-line )
+command+ get [ +command+ get [

View File

@ -109,12 +109,14 @@ M: windows-io <file-appender> ( path -- stream )
open-append <win32-file> <writer> ; open-append <win32-file> <writer> ;
M: windows-io rename-file ( from to -- ) M: windows-io rename-file ( from to -- )
[ normalize-pathname ] 2apply [ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- ) M: windows-io delete-file ( path -- )
normalize-pathname normalize-pathname DeleteFile win32-error=0/f ;
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 -- ) M: windows-io make-directory ( path -- )
normalize-pathname normalize-pathname

17
extra/parser-combinators/parser-combinators-docs.factor Normal file → Executable file
View File

@ -3,14 +3,23 @@
USING: help.markup help.syntax parser-combinators ; USING: help.markup help.syntax parser-combinators ;
HELP: list-of HELP: list-of
{ $values { $values
{ "items" "a parser object" } { "separator" "a parser object" } { "parser" "a parser object" } } { "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 " "Return a parser for parsing the repetition of things that are "
"separated by a certain symbol. For example, comma separated lists. " "separated by a certain symbol. For example, comma separated lists. "
"'items' is a parser that can parse the individual elements. 'separator' " "'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." } "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 } ; { $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" } } ;

43
extra/parser-combinators/parser-combinators.factor Normal file → Executable file
View File

@ -15,6 +15,9 @@ M: promise (parse) ( input parser -- list )
TUPLE: parse-result parsed unparsed ; TUPLE: parse-result parsed unparsed ;
: parse-1 ( input parser -- result )
parse car parse-result-parsed ;
C: <parse-result> parse-result C: <parse-result> parse-result
TUPLE: token-parser string ; TUPLE: token-parser string ;
@ -23,7 +26,7 @@ C: token token-parser ( string -- parser )
M: token-parser (parse) ( input parser -- list ) M: token-parser (parse) ( input parser -- list )
token-parser-string swap over ?head-slice [ token-parser-string swap over ?head-slice [
<parse-result> 1list <parse-result> 1list
] [ ] [
2drop nil 2drop nil
] if ; ] if ;
@ -43,9 +46,12 @@ M: satisfy-parser (parse) ( input parser -- list )
swap <parse-result> 1list swap <parse-result> 1list
] [ ] [
2drop nil 2drop nil
] if ] if
] if ; ] if ;
LAZY: any-char-parser ( -- parser )
[ drop t ] satisfy ;
TUPLE: epsilon-parser ; TUPLE: epsilon-parser ;
C: epsilon epsilon-parser ( -- parser ) C: epsilon epsilon-parser ( -- parser )
@ -63,7 +69,7 @@ C: succeed succeed-parser ( result -- parser )
M: succeed-parser (parse) ( input parser -- list ) M: succeed-parser (parse) ( input parser -- list )
#! A parser that always returns 'result' as a #! A parser that always returns 'result' as a
#! successful parse with no input consumed. #! successful parse with no input consumed.
succeed-parser-result swap <parse-result> 1list ; succeed-parser-result swap <parse-result> 1list ;
TUPLE: fail-parser ; TUPLE: fail-parser ;
@ -81,7 +87,7 @@ TUPLE: and-parser parsers ;
over and-parser? [ over and-parser? [
>r and-parser-parsers r> add >r and-parser-parsers r> add
] [ ] [
2array 2array
] if \ and-parser construct-boa ; ] if \ and-parser construct-boa ;
: and-parser-parse ( list p1 -- list ) : and-parser-parse ( list p1 -- list )
@ -92,13 +98,13 @@ TUPLE: and-parser parsers ;
[ parse-result-parsed 2array ] keep [ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ] lmap-with
] lmap-with lconcat ; ] lmap-with lconcat ;
M: and-parser (parse) ( input parser -- list ) M: and-parser (parse) ( input parser -- list )
#! Parse 'input' by sequentially combining the #! Parse 'input' by sequentially combining the
#! two parsers. First parser1 is applied to the #! two parsers. First parser1 is applied to the
#! input then parser2 is applied to the rest of #! 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 ; and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ;
TUPLE: or-parser p1 p2 ; TUPLE: or-parser p1 p2 ;
@ -115,7 +121,7 @@ M: or-parser (parse) ( input parser1 -- list )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
#! from the original string. #! from the original string.
dup empty? [ dup empty? [
dup first blank? [ 1 tail-slice left-trim-slice ] when dup first blank? [ 1 tail-slice left-trim-slice ] when
] unless ; ] unless ;
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
@ -136,7 +142,7 @@ C: just just-parser ( p1 -- parser )
M: just-parser (parse) ( input parser -- result ) M: just-parser (parse) ( input parser -- result )
#! Calls the given parser on the input removes #! Calls the given parser on the input removes
#! from the results anything where the remaining #! 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. #! fully parsed input string.
just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ; 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. #! The result of that quotation then becomes the new parse result.
#! This allows modification of parse tree results (like #! This allows modification of parse tree results (like
#! converting strings to integers, etc). #! converting strings to integers, etc).
[ apply-parser-p1 ] keep apply-parser-quot [ apply-parser-p1 ] keep apply-parser-quot
-rot parse [ -rot parse [
[ parse-result-parsed swap call ] keep [ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ; ] lmap-with ;
@ -165,7 +171,7 @@ M: some-parser (parse) ( input parser -- result )
#! the parse is complete (the remaining input is empty), #! the parse is complete (the remaining input is empty),
#! picks the first solution and only returns the parse #! picks the first solution and only returns the parse
#! tree since the remaining input is empty. #! 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 ) : <& ( parser1 parser2 -- parser )
@ -230,13 +236,13 @@ LAZY: <!?> ( parser -- parser )
#! required. #! required.
<?> only-first ; <?> only-first ;
LAZY: <(*)> ( parser -- parser ) LAZY: <(*)> ( parser -- parser )
#! Like <*> but take shortest match first. #! Like <*> but take shortest match first.
#! Implementation by Matthew Willis. #! Implementation by Matthew Willis.
{ } succeed swap dup <(*)> <&:> <|> ; { } succeed swap dup <(*)> <&:> <|> ;
LAZY: <(+)> ( parser -- parser ) LAZY: <(+)> ( parser -- parser )
#! Like <+> but take shortest match first. #! Like <+> but take shortest match first.
#! Implementation by Matthew Willis. #! Implementation by Matthew Willis.
dup <(*)> <&:> ; dup <(*)> <&:> ;
@ -249,6 +255,9 @@ LAZY: pack ( close body open -- parser )
LAZY: list-of ( items separator -- parser ) LAZY: list-of ( items separator -- parser )
#! Given a parser for the separator and for the #! Given a parser for the separator and for the
#! items themselves, return a parser that parses #! 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. #! array of the parsed items.
over &> <*> <&:> { } succeed <|> ; dup <?> -rot over &> <*> <&:> &> { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' )
[ token ] 2apply swapd pack ;

6
extra/parser-combinators/replace/replace.factor Normal file → Executable file
View File

@ -13,21 +13,21 @@ IN: parser-combinators
} cond ; } cond ;
: search ( string parser -- seq ) : search ( string parser -- seq )
'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { } drop { }
] [ ] [
car parse-result-parsed [ ] subset car parse-result-parsed [ ] subset
] if ; ] if ;
: search* ( string parsers -- seq ) : search* ( string parsers -- seq )
unclip [ <|> ] reduce 'any-char' [ drop f ] <@ <|> <*> parse dup nil? [ unclip [ <|> ] reduce any-char-parser [ drop f ] <@ <|> <*> parse dup nil? [
drop { } drop { }
] [ ] [
car parse-result-parsed [ ] subset car parse-result-parsed [ ] subset
] if ; ] if ;
: (replace) ( string parser -- seq ) : (replace) ( string parser -- seq )
'any-char' <|> <*> parse car parse-result-parsed ; any-char-parser <|> <*> parse-1 ;
: replace ( string parser -- result ) : replace ( string parser -- result )
[ (replace) [ tree-write ] each ] string-out ; [ (replace) [ tree-write ] each ] string-out ;

39
extra/parser-combinators/simple/simple-docs.factor Normal file → Executable file
View File

@ -3,17 +3,6 @@
USING: help.syntax help.markup parser-combinators USING: help.syntax help.markup parser-combinators
parser-combinators.simple ; 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' HELP: 'digit'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -22,8 +11,7 @@ HELP: 'digit'
"the input string. The numeric value of the digit " "the input string. The numeric value of the digit "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse car parse-result-parsed ." "1" } } { $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'integer' HELP: 'integer'
{ $values { $values
@ -33,9 +21,7 @@ HELP: 'integer'
"the input string. The numeric value of the integer " "the input string. The numeric value of the integer "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse car parse-result-parsed ." "123" } } { $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'string' HELP: 'string'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -44,9 +30,7 @@ HELP: 'string'
"quotations from the input string. The string value " "quotations from the input string. The string value "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse car parse-result-parsed ." "\"foo\"" } } { $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'bold' HELP: 'bold'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -55,10 +39,8 @@ HELP: 'bold'
"the '*' character from the input string. This is " "the '*' character from the input string. This is "
"commonly used in markup languages to indicate bold " "commonly used in markup languages to indicate bold "
"faced text." } "faced text." }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse car parse-result-parsed ." "\"foo\"" } { $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse car parse-result-parsed ." "\"<strong>foo</strong>\"" } { $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: 'italic' HELP: 'italic'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -68,10 +50,8 @@ HELP: 'italic'
"commonly used in markup languages to indicate italic " "commonly used in markup languages to indicate italic "
"faced text." } "faced text." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse car parse-result-parsed ." "\"foo\"" } { $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse car parse-result-parsed ." "\"<emphasis>foo</emphasis>\"" } } { $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
HELP: comma-list HELP: comma-list
{ $values { $values
{ "element" "a parser object" } { "parser" "a parser object" } } { "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 " "'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." } "result of the parser is a sequence of the parsed elements." }
{ $examples { $examples
{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse car parse-result-parsed ." "{ 1 2 3 4 }" } } { $example "USING: lazy-lits parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'any-char' 'digit' 'integer' 'string' 'bold' 'italic' comma-list } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words

3
extra/parser-combinators/simple/simple.factor Normal file → Executable file
View File

@ -4,9 +4,6 @@ USING: kernel strings math sequences lazy-lists words
math.parser promises ; math.parser promises ;
IN: parser-combinators IN: parser-combinators
LAZY: 'any-char' ( -- parser )
[ drop t ] satisfy ;
: 'digit' ( -- parser ) : 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] <@ ; [ digit? ] satisfy [ digit> ] <@ ;

View File

@ -1,18 +1,16 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.launcher kernel namespaces sequences USING: io io.files io.launcher kernel namespaces sequences
system cocoa.plists cocoa.application tools.deploy system tools.deploy tools.deploy.config assocs hashtables
tools.deploy.config assocs hashtables prettyprint ; prettyprint unix io.unix.backend cocoa cocoa.plists
cocoa.application cocoa.classes ;
IN: tools.deploy.macosx IN: tools.deploy.macosx
: touch ( path -- ) : touch ( path -- )
"touch \"" swap "\"" 3append run-process ; { "touch" } swap add run-process ;
: rm ( path -- ) : rm ( path -- )
"rm -rf \"" swap "\"" 3append run-process ; { "rm" "-rf" } swap add run-process ;
: chmod ( path perms -- )
[ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
: bundle-dir ( -- dir ) : bundle-dir ( -- dir )
vm parent-directory parent-directory ; vm parent-directory parent-directory ;
@ -24,7 +22,7 @@ IN: tools.deploy.macosx
: copy-vm ( executable bundle-name -- vm ) : copy-vm ( executable bundle-name -- vm )
"Contents/MacOS/" path+ swap path+ vm swap "Contents/MacOS/" path+ swap path+ vm swap
[ copy-file ] keep [ copy-file ] keep
[ "755" chmod ] keep ; [ 755 chmod io-error ] keep ;
: copy-fonts ( name -- ) : copy-fonts ( name -- )
"fonts/" resource-path "fonts/" resource-path
@ -63,6 +61,12 @@ TUPLE: macosx-deploy-implementation ;
T{ macosx-deploy-implementation } deploy-implementation set-global T{ macosx-deploy-implementation } deploy-implementation set-global
: show-in-finder ( path -- )
NSWorkspace
-> sharedWorkspace
over <NSString> rot parent-directory <NSString>
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx-deploy-implementation deploy ( vocab -- ) M: macosx-deploy-implementation deploy ( vocab -- )
".app deploy tool" assert.app ".app deploy tool" assert.app
"." resource-path cd "." resource-path cd
@ -70,5 +74,6 @@ M: macosx-deploy-implementation deploy ( vocab -- )
bundle-name rm bundle-name rm
[ bundle-name create-app-dir ] keep [ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep [ bundle-name deploy.app-image ] keep
namespace namespace deploy*
] bind deploy* ; bundle-name show-in-finder
] bind ;

View File

@ -60,11 +60,19 @@ M: cocoa-ui-backend set-title ( string world -- )
drop drop
] if ; ] if ;
M: cocoa-ui-backend (open-world-window) ( world -- ) M: cocoa-ui-backend (open-window) ( world -- )
dup gadget-window dup gadget-window
dup auto-position dup auto-position
world-handle second f -> makeKeyAndOrderFront: ; 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 -- ) M: cocoa-ui-backend raise-window ( world -- )
world-handle [ world-handle [
second dup f -> orderFront: -> makeKeyWindow second dup f -> orderFront: -> makeKeyWindow

View File

@ -3,7 +3,8 @@
USING: alien arrays assocs cocoa kernel math cocoa.messages USING: alien arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui 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 IN: ui.cocoa.views
: send-mouse-moved ( view event -- ) : send-mouse-moved ( view event -- )
@ -313,8 +314,6 @@ CLASS: {
{ "dealloc" "void" { "id" "SEL" } { "dealloc" "void" { "id" "SEL" }
[ [
drop drop
dup window stop-world
dup unregister-window
dup remove-observer dup remove-observer
SUPER-> dealloc SUPER-> dealloc
] ]
@ -347,6 +346,12 @@ CLASS: {
forget-rollover forget-rollover
2nip -> object -> contentView window unfocus-world 2nip -> object -> contentView window unfocus-world
] ]
}
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
[
2nip -> contentView window ungraft t
]
} ; } ;
: install-window-delegate ( window -- ) : install-window-delegate ( window -- )

View File

@ -77,7 +77,8 @@ TUPLE: deploy-gadget vocab settings ;
: com-deploy ( gadget -- ) : com-deploy ( gadget -- )
dup com-save dup com-save
find-deploy-vocab [ deploy ] curry call-listener ; dup find-deploy-vocab [ deploy ] curry call-listener
close-window ;
: com-help ( -- ) : com-help ( -- )
"ui-deploy" help-window ; "ui-deploy" help-window ;
@ -86,7 +87,11 @@ TUPLE: deploy-gadget vocab settings ;
{ +nullary+ t } { +nullary+ t }
} define-command } define-command
: com-close ( gadget -- )
close-window ;
deploy-gadget "toolbar" f { deploy-gadget "toolbar" f {
{ f com-close }
{ f com-help } { f com-help }
{ f com-revert } { f com-revert }
{ f com-save } { f com-save }

View File

@ -67,11 +67,11 @@ M: workspace model-changed
: com-profiler profiler-gadget select-tool ; : com-profiler profiler-gadget select-tool ;
workspace "tool-switching" f { workspace "tool-switching" f {
{ T{ key-down f f "F2" } com-listener } { T{ key-down f { C+ } "1" } com-listener }
{ T{ key-down f f "F3" } com-browser } { T{ key-down f { C+ } "2" } com-browser }
{ T{ key-down f f "F4" } com-inspector } { T{ key-down f { C+ } "3" } com-inspector }
{ T{ key-down f f "F5" } com-walker } { T{ key-down f { C+ } "4" } com-walker }
{ T{ key-down f f "F6" } com-profiler } { T{ key-down f { C+ } "5" } com-profiler }
} define-command-map } define-command-map
\ workspace-window \ workspace-window
@ -86,8 +86,8 @@ H{ { +nullary+ t } { +listener+ t } } define-command
workspace "workflow" f { workspace "workflow" f {
{ T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f { C+ } "n" } workspace-window }
{ T{ key-down f f "ESC" } hide-popup } { T{ key-down f f "ESC" } hide-popup }
{ T{ key-down f f "F8" } refresh-all } { T{ key-down f f "F2" } refresh-all }
{ T{ key-down f { A+ } "F8" } test-changes } { T{ key-down f { A+ } "F2" } test-changes }
} define-command-map } define-command-map
[ [

View File

@ -72,7 +72,9 @@ M: world ungraft*
>r [ 1 track, ] { 0 1 } make-track r> >r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ; f <world> open-world-window ;
: close-window ( gadget -- ) HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ; find-world [ ungraft ] when* ;
: find-window ( quot -- world ) : find-window ( quot -- world )
@ -127,7 +129,7 @@ SYMBOL: ui-hook
] { } make ; ] { } make ;
: redraw-worlds ( seq -- ) : redraw-worlds ( seq -- )
[ dup update-hand [ draw-world ] time ] each ; [ dup update-hand draw-world ] each ;
: notify ( gadget -- ) : notify ( gadget -- )
dup gadget-graft-state { dup gadget-graft-state {

View File

@ -158,18 +158,14 @@ M: world selection-request-event
{ [ t ] [ drop send-notify-failure ] } { [ t ] [ drop send-notify-failure ] }
} cond ; } cond ;
: close-window ( handle -- ) M: x11-ui-backend (close-window) ( handle -- )
dup x11-handle-xic XDestroyIC dup x11-handle-xic XDestroyIC
dup x11-handle-glx destroy-glx dup x11-handle-glx destroy-glx
x11-handle-window dup unregister-window x11-handle-window dup unregister-window
destroy-window ; destroy-window ;
M: world client-event M: world client-event
swap close-box? [ swap close-box? [ ungraft ] [ drop ] if ;
dup world-handle >r stop-world r> close-window
] [
drop
] if ;
: gadget-window ( world -- ) : gadget-window ( world -- )
dup world-loc over rect-dim glx-window 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 world-handle x11-handle-window swap dpy get -rot
3dup set-title-old set-title-new ; 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 dup gadget-window
world-handle x11-handle-window dup set-closable map-window ; world-handle x11-handle-window dup set-closable map-window ;

18
extra/webapps/fjsc/fjsc.factor Normal file → Executable file
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: kernel furnace fjsc parser-combinators namespaces USING: kernel furnace fjsc parser-combinators namespaces
lazy-lists io io.files furnace.validator sequences lazy-lists io io.files furnace.validator sequences
http.client http.server http.server.responders http.client http.server http.server.responders
webapps.file ; webapps.file ;
IN: webapps.fjsc IN: webapps.fjsc
@ -11,15 +11,15 @@ IN: webapps.fjsc
#! Compile the factor code as a string, outputting the http #! Compile the factor code as a string, outputting the http
#! response containing the javascript. #! response containing the javascript.
serving-text serving-text
'expression' parse car parse-result-parsed fjsc-compile 'expression' parse-1 fjsc-compile
write flush ; write flush ;
! The 'compile' action results in an URL that looks like ! 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 ! parameter called 'code'. It calls the 'compile' word
! passing the parameter to it on the stack. ! passing the parameter to it on the stack.
\ compile { \ compile {
{ "code" v-required } { "code" v-required }
} define-action } define-action
: compile-url ( url -- ) : compile-url ( url -- )
@ -28,18 +28,18 @@ IN: webapps.fjsc
"http://" host rot 3append http-get 2nip compile "();" write flush ; "http://" host rot 3append http-get 2nip compile "();" write flush ;
\ compile-url { \ compile-url {
{ "url" v-required } { "url" v-required }
} define-action } define-action
: repl ( -- ) : repl ( -- )
#! The main 'repl' page. #! The main 'repl' page.
f "repl" "head" render-page* ; f "repl" "head" render-page* ;
! An action called 'repl' ! An action called 'repl'
\ repl { } define-action \ repl { } define-action
: fjsc-web-app ( -- ) : fjsc-web-app ( -- )
! Create the web app, providing access ! Create the web app, providing access
! under '/responder/fjsc' which calls the ! under '/responder/fjsc' which calls the
! 'repl' action. ! 'repl' action.
"fjsc" "repl" "extra/webapps/fjsc" web-app "fjsc" "repl" "extra/webapps/fjsc" web-app

View File

@ -18,7 +18,7 @@ TUPLE: posting author title date link body ;
#! entries is an array of { author entries } pairs. #! entries is an array of { author entries } pairs.
dup [ dup [
[ fetch-feed ] [ error. drop f ] recover [ fetch-feed ] [ error. drop f ] recover
] parallel-map [ ] subset ] parallel-map
[ [ >r first r> 2array ] curry* map ] 2map concat ; [ [ >r first r> 2array ] curry* map ] 2map concat ;
: sort-entries ( entries -- entries' ) : sort-entries ( entries -- entries' )
@ -108,6 +108,7 @@ SYMBOL: cached-postings
{ "Kio M. Smallwood" { "Kio M. Smallwood"
"http://sekenre.wordpress.com/feed/atom/" "http://sekenre.wordpress.com/feed/atom/"
"http://sekenre.wordpress.com/" } "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/" } { "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/" } { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
} default-blogroll set-global } default-blogroll set-global

View File

@ -566,7 +566,8 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
! FUNCTION: CopyFileA ! FUNCTION: CopyFileA
! FUNCTION: CopyFileExA ! FUNCTION: CopyFileExA
! FUNCTION: CopyFileExW ! FUNCTION: CopyFileExW
! FUNCTION: CopyFileW FUNCTION: BOOL CopyFileW ( LPCTSTR lpExistingFileName, LPCTSTR lpNewFileName, BOOL bFailIfExists ) ;
: CopyFile CopyFileW ; inline
! FUNCTION: CopyLZFile ! FUNCTION: CopyLZFile
! FUNCTION: CreateActCtxA ! FUNCTION: CreateActCtxA
! FUNCTION: CreateActCtxW ! FUNCTION: CreateActCtxW
@ -575,7 +576,7 @@ FUNCTION: BOOL ConnectNamedPipe ( HANDLE hNamedPipe, LPOVERLAPPED lpOverlapped )
! FUNCTION: CreateDirectoryExA ! FUNCTION: CreateDirectoryExA
! FUNCTION: CreateDirectoryExW ! FUNCTION: CreateDirectoryExW
FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ; FUNCTION: BOOL CreateDirectoryW ( LPCTSTR lpPathName, LPSECURITY_ATTRIBUTES lpSecurityAttribytes ) ;
: CreateDirectory CreateDirectoryW ; : CreateDirectory CreateDirectoryW ; inline
! FUNCTION: CreateEventA ! FUNCTION: CreateEventA
! FUNCTION: CreateEventW ! FUNCTION: CreateEventW