Merge branch 'master' of git://factorcode.org/git/factor

db4
U-FROGGER\erg 2008-03-26 00:20:54 -05:00
commit f368f4636b
13 changed files with 88 additions and 59 deletions

View File

@ -178,10 +178,10 @@ io.files.unique sequences strings accessors ;
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ "foo/" ] [ "foo/bar/." parent-directory ] unit-test [ "foo/bar/." parent-directory ] must-fail
[ "foo/" ] [ "foo/bar/./" parent-directory ] unit-test [ "foo/bar/./" parent-directory ] must-fail
[ "foo/" ] [ "foo/bar/baz/.." parent-directory ] unit-test [ "foo/bar/baz/.." parent-directory ] must-fail
[ "foo/" ] [ "foo/bar/baz/../" parent-directory ] unit-test [ "foo/bar/baz/../" parent-directory ] must-fail
[ "." parent-directory ] must-fail [ "." parent-directory ] must-fail
[ "./" parent-directory ] must-fail [ "./" parent-directory ] must-fail
@ -190,6 +190,8 @@ io.files.unique sequences strings accessors ;
[ "../../" parent-directory ] must-fail [ "../../" parent-directory ] must-fail
[ "foo/.." parent-directory ] must-fail [ "foo/.." parent-directory ] must-fail
[ "foo/../" parent-directory ] must-fail [ "foo/../" parent-directory ] must-fail
[ "" parent-directory ] must-fail
[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test [ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test [ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test

View File

@ -66,14 +66,12 @@ ERROR: no-parent-directory path ;
right-trim-separators right-trim-separators
dup last-path-separator [ dup last-path-separator [
1+ cut 1+ cut
{ ] [
{ "." [ 1 head* parent-directory ] } drop "." swap
{ ".." [ ] if
2 head* parent-directory parent-directory { "" "." ".." } member? [
] } no-parent-directory
[ drop ] ] when
} case
] [ no-parent-directory ] if
] unless ; ] unless ;
<PRIVATE <PRIVATE
@ -157,6 +155,8 @@ HOOK: cwd io-backend ( -- path )
SYMBOL: current-directory SYMBOL: current-directory
M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "current-directory" add-init-hook [ cwd current-directory set-global ] "current-directory" add-init-hook
: with-directory ( path quot -- ) : with-directory ( path quot -- )
@ -259,7 +259,7 @@ DEFER: copy-tree-into
prepend-path ; prepend-path ;
: ?resource-path ( path -- newpath ) : ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ; "resource:" ?head [ left-trim-separators resource-path ] when ;
: resource-exists? ( path -- ? ) : resource-exists? ( path -- ? )
?resource-path exists? ; ?resource-path exists? ;

View File

@ -38,6 +38,7 @@ SYMBOL: +low-priority+
SYMBOL: +normal-priority+ SYMBOL: +normal-priority+
SYMBOL: +high-priority+ SYMBOL: +high-priority+
SYMBOL: +highest-priority+ SYMBOL: +highest-priority+
SYMBOL: +realtime-priority+
: <process> ( -- process ) : <process> ( -- process )
process construct-empty process construct-empty

View File

@ -6,7 +6,6 @@ IN: io.unix.files.tests
[ "/" ] [ "/etc/" parent-directory ] unit-test [ "/" ] [ "/etc/" parent-directory ] unit-test
[ "/" ] [ "/etc" parent-directory ] unit-test [ "/" ] [ "/etc" parent-directory ] unit-test
[ "/" ] [ "/" parent-directory ] unit-test [ "/" ] [ "/" parent-directory ] unit-test
[ "asdf" parent-directory ] must-fail
[ f ] [ "" root-directory? ] unit-test [ f ] [ "" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test

View File

@ -24,6 +24,7 @@ USE: unix
{ +normal-priority+ 0 } { +normal-priority+ 0 }
{ +high-priority+ -10 } { +high-priority+ -10 }
{ +highest-priority+ -20 } { +highest-priority+ -20 }
{ +realtime-priority+ -20 }
} at set-priority } at set-priority
] when* ; ] when* ;

View File

@ -49,6 +49,17 @@ TUPLE: CreateProcess-args
: join-arguments ( args -- cmd-line ) : join-arguments ( args -- cmd-line )
[ escape-argument ] map " " join ; [ escape-argument ] map " " join ;
: lookup-priority ( process -- n )
priority>> {
{ +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
{ +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
{ +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
{ +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
{ +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
{ +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
[ drop f ]
} case ;
: app-name/cmd-line ( process -- app-name cmd-line ) : app-name/cmd-line ( process -- app-name cmd-line )
command>> dup string? [ command>> dup string? [
" " split1 " " split1
@ -71,6 +82,7 @@ TUPLE: CreateProcess-args
0 0
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
pick lookup-priority [ bitor ] when*
>>dwCreateFlags ; >>dwCreateFlags ;
: fill-lpEnvironment ( process args -- process args ) : fill-lpEnvironment ( process args -- process args )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences vectors classes combinators USING: kernel math sequences vectors classes classes.algebra
arrays words assocs parser namespaces definitions combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units kernel.private effects ; debugger io compiler.units kernel.private effects ;
IN: multi-methods IN: multi-methods

View File

@ -0,0 +1,10 @@
USING: help.syntax help.markup ;
IN: openssl
ARTICLE: "openssl" "OpenSSL"
"Factor on Windows has been tested with this version of OpenSSL: "
{ $url "http://www.openssl.org/related/binaries.html" } ;

View File

@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib peg.parsers unicode.categories multiline combinators.lib
splitting ; splitting accessors ;
IN: peg.ebnf IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-non-terminal symbol ;
@ -16,7 +16,7 @@ TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ; TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-repeat1 group ; TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional elements ; TUPLE: ebnf-optional group ;
TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ; TUPLE: ebnf-action parser code ;
TUPLE: ebnf rules ; TUPLE: ebnf rules ;
@ -198,7 +198,7 @@ DEFER: 'choice'
: 'rule' ( -- parser ) : 'rule' ( -- parser )
[ [
'non-terminal' [ ebnf-non-terminal-symbol ] action , 'non-terminal' [ symbol>> ] action ,
"=" syntax , "=" syntax ,
'choice' , 'choice' ,
] seq* [ first2 <ebnf-rule> ] action ; ] seq* [ first2 <ebnf-rule> ] action ;
@ -215,49 +215,53 @@ SYMBOL: main
H{ } clone dup dup [ parser set swap (transform) main set ] bind ; H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser ) M: ebnf (transform) ( ast -- parser )
ebnf-rules [ (transform) ] map peek ; rules>> [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser ) M: ebnf-rule (transform) ( ast -- parser )
dup ebnf-rule-elements (transform) [ dup elements>> (transform) [
swap ebnf-rule-symbol set swap symbol>> set
] keep ; ] keep ;
M: ebnf-sequence (transform) ( ast -- parser ) M: ebnf-sequence (transform) ( ast -- parser )
ebnf-sequence-elements [ (transform) ] map seq ; elements>> [ (transform) ] map seq ;
M: ebnf-choice (transform) ( ast -- parser ) M: ebnf-choice (transform) ( ast -- parser )
ebnf-choice-options [ (transform) ] map choice ; options>> [ (transform) ] map choice ;
M: ebnf-any-character (transform) ( ast -- parser ) M: ebnf-any-character (transform) ( ast -- parser )
drop any-char ; drop any-char ;
M: ebnf-range (transform) ( ast -- parser ) M: ebnf-range (transform) ( ast -- parser )
ebnf-range-pattern range-pattern ; pattern>> range-pattern ;
: transform-group ( ast -- parser )
#! convert a ast node with groups to a parser for that group
group>> (transform) ;
M: ebnf-ensure (transform) ( ast -- parser ) M: ebnf-ensure (transform) ( ast -- parser )
ebnf-ensure-group (transform) ensure ; transform-group ensure ;
M: ebnf-ensure-not (transform) ( ast -- parser ) M: ebnf-ensure-not (transform) ( ast -- parser )
ebnf-ensure-not-group (transform) ensure-not ; transform-group ensure-not ;
M: ebnf-repeat0 (transform) ( ast -- parser ) M: ebnf-repeat0 (transform) ( ast -- parser )
ebnf-repeat0-group (transform) repeat0 ; transform-group repeat0 ;
M: ebnf-repeat1 (transform) ( ast -- parser ) M: ebnf-repeat1 (transform) ( ast -- parser )
ebnf-repeat1-group (transform) repeat1 ; transform-group repeat1 ;
M: ebnf-optional (transform) ( ast -- parser ) M: ebnf-optional (transform) ( ast -- parser )
ebnf-optional-elements (transform) optional ; transform-group optional ;
M: ebnf-action (transform) ( ast -- parser ) M: ebnf-action (transform) ( ast -- parser )
[ ebnf-action-parser (transform) ] keep [ parser>> (transform) ] keep
ebnf-action-code string-lines [ parse-lines ] with-compilation-unit action ; code>> string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-terminal (transform) ( ast -- parser ) M: ebnf-terminal (transform) ( ast -- parser )
ebnf-terminal-symbol token sp ; symbol>> token sp ;
M: ebnf-non-terminal (transform) ( ast -- parser ) M: ebnf-non-terminal (transform) ( ast -- parser )
ebnf-non-terminal-symbol [ symbol>> [
, parser get , \ at , , parser get , \ at ,
] [ ] make delay sp ; ] [ ] make delay sp ;

View File

@ -3,7 +3,7 @@
USING: kernel sequences strings namespaces math assocs shuffle USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser unicode.categories sequences.lib compiler.units parser
words quotations effects memoize ; words quotations effects memoize accessors combinators.cleave ;
IN: peg IN: peg
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
@ -52,7 +52,7 @@ MATCH-VARS: ?token ;
] if ; ] if ;
M: token-parser (compile) ( parser -- quot ) M: token-parser (compile) ( parser -- quot )
token-parser-symbol [ parse-token ] curry ; symbol>> [ parse-token ] curry ;
TUPLE: satisfy-parser quot ; TUPLE: satisfy-parser quot ;
@ -72,7 +72,7 @@ MATCH-VARS: ?quot ;
] ; ] ;
M: satisfy-parser (compile) ( parser -- quot ) M: satisfy-parser (compile) ( parser -- quot )
satisfy-parser-quot \ ?quot satisfy-pattern match-replace ; quot>> \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
@ -100,12 +100,12 @@ TUPLE: seq-parser parsers ;
: seq-pattern ( -- quot ) : seq-pattern ( -- quot )
[ [
dup [ dup [
dup parse-result-remaining ?quot [ dup remaining>> ?quot [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep [ remaining>> swap (>>remaining) ] 2keep
parse-result-ast dup ignore = [ ast>> dup ignore = [
drop drop
] [ ] [
swap [ parse-result-ast push ] keep swap [ ast>> push ] keep
] if ] if
] [ ] [
drop f drop f
@ -118,7 +118,7 @@ TUPLE: seq-parser parsers ;
M: seq-parser (compile) ( parser -- quot ) M: seq-parser (compile) ( parser -- quot )
[ [
[ V{ } clone <parse-result> ] % [ V{ } clone <parse-result> ] %
seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each
] [ ] make ; ] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
@ -135,16 +135,16 @@ TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( parser -- quot ) M: choice-parser (compile) ( parser -- quot )
[ [
f , f ,
choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each
\ nip , \ nip ,
] [ ] make ; ] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
: (repeat0) ( quot result -- result ) : (repeat0) ( quot result -- result )
2dup parse-result-remaining swap call [ 2dup remaining>> swap call [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep [ remaining>> swap (>>remaining) ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep ast>> swap [ ast>> push ] keep
(repeat0) (repeat0)
] [ ] [
nip nip
@ -158,7 +158,7 @@ TUPLE: repeat0-parser p1 ;
M: repeat0-parser (compile) ( parser -- quot ) M: repeat0-parser (compile) ( parser -- quot )
[ [
[ V{ } clone <parse-result> ] % [ V{ } clone <parse-result> ] %
repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace % p1>> compiled-parser \ ?quot repeat0-pattern match-replace %
] [ ] make ; ] [ ] make ;
TUPLE: repeat1-parser p1 ; TUPLE: repeat1-parser p1 ;
@ -166,7 +166,7 @@ TUPLE: repeat1-parser p1 ;
: repeat1-pattern ( -- quot ) : repeat1-pattern ( -- quot )
[ [
[ ?quot ] swap (repeat0) [ [ ?quot ] swap (repeat0) [
dup parse-result-ast empty? [ dup ast>> empty? [
drop f drop f
] when ] when
] [ ] [
@ -177,7 +177,7 @@ TUPLE: repeat1-parser p1 ;
M: repeat1-parser (compile) ( parser -- quot ) M: repeat1-parser (compile) ( parser -- quot )
[ [
[ V{ } clone <parse-result> ] % [ V{ } clone <parse-result> ] %
repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace % p1>> compiled-parser \ ?quot repeat1-pattern match-replace %
] [ ] make ; ] [ ] make ;
TUPLE: optional-parser p1 ; TUPLE: optional-parser p1 ;
@ -188,7 +188,7 @@ TUPLE: optional-parser p1 ;
] ; ] ;
M: optional-parser (compile) ( parser -- quot ) M: optional-parser (compile) ( parser -- quot )
optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ; p1>> compiled-parser \ ?quot optional-pattern match-replace ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
@ -202,7 +202,7 @@ TUPLE: ensure-parser p1 ;
] ; ] ;
M: ensure-parser (compile) ( parser -- quot ) M: ensure-parser (compile) ( parser -- quot )
ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ; p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
@ -216,7 +216,7 @@ TUPLE: ensure-not-parser p1 ;
] ; ] ;
M: ensure-not-parser (compile) ( parser -- quot ) M: ensure-not-parser (compile) ( parser -- quot )
ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ; p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
@ -225,13 +225,13 @@ MATCH-VARS: ?action ;
: action-pattern ( -- quot ) : action-pattern ( -- quot )
[ [
?quot dup [ ?quot dup [
dup parse-result-ast ?action call dup ast>> ?action call
swap [ set-parse-result-ast ] keep >>ast
] when ] when
] ; ] ;
M: action-parser (compile) ( parser -- quot ) M: action-parser (compile) ( parser -- quot )
{ action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip { [ p1>> ] [ quot>> ] } cleave [ compiled-parser ] dip
2array { ?quot ?action } action-pattern match-replace ; 2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
@ -245,7 +245,7 @@ TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot ) M: sp-parser (compile) ( parser -- quot )
[ [
\ left-trim-slice , sp-parser-p1 compiled-parser , \ left-trim-slice , p1>> compiled-parser ,
] [ ] make ; ] [ ] make ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
@ -255,7 +255,7 @@ M: delay-parser (compile) ( parser -- quot )
#! This way it is run only once and the #! This way it is run only once and the
#! parser constructed once at run time. #! parser constructed once at run time.
[ [
delay-parser-quot % \ compile , quot>> % \ compile ,
] [ ] make ] [ ] make
{ } { "word" } <effect> memoize-quot { } { "word" } <effect> memoize-quot
[ % \ execute , ] [ ] make ; [ % \ execute , ] [ ] make ;

View File

@ -21,6 +21,7 @@ IN: tools.deploy.backend
swap >>command swap >>command
+stdout+ >>stderr +stdout+ >>stderr
+closed+ >>stdin +closed+ >>stdin
+low-priority+ >>priority
utf8 <process-stream> utf8 <process-stream>
dup copy-lines dup copy-lines
process>> wait-for-process zero? [ process>> wait-for-process zero? [

View File

@ -62,7 +62,7 @@ M: freetype-renderer free-fonts ( world -- )
} at ; } at ;
: ttf-path ( name -- string ) : ttf-path ( name -- string )
"/fonts/" swap ".ttf" 3append resource-path ; "resource:fonts/" swap ".ttf" 3append ?resource-path ;
: (open-face) ( path length -- face ) : (open-face) ( path length -- face )
#! We use FT_New_Memory_Face, not FT_New_Face, since #! We use FT_New_Memory_Face, not FT_New_Face, since

View File

@ -125,7 +125,6 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
: OF_REOPEN 32768 ; : OF_REOPEN 32768 ;
: OF_VERIFY 1024 ; : OF_VERIFY 1024 ;
: INFINITE HEX: FFFFFFFF ; inline : INFINITE HEX: FFFFFFFF ; inline
! From C:\cygwin\usr\include\w32api\winbase.h ! From C:\cygwin\usr\include\w32api\winbase.h