Merge branch 'master' into specialized-arrays

db4
Slava Pestov 2008-12-02 02:46:26 -06:00
commit e559a101e8
13 changed files with 29 additions and 54 deletions

View File

@ -27,6 +27,9 @@ HOOK: (set-os-envs) os ( seq -- )
} cond } cond
[ [
"FACTOR_ROOTS" os-env os windows? ";" ":" ? split "FACTOR_ROOTS" os-env
[
os windows? ";" ":" ? split
[ add-vocab-root ] each [ add-vocab-root ] each
] when*
] "environment" add-init-hook ] "environment" add-init-hook

View File

@ -46,10 +46,10 @@ $nl
"{ 10 20 30 } [ sq ] [ . ] compose each" "{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each" "{ 10 20 30 } [ sq . ] each"
} }
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed:" "The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
{ $code { $code
"{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map" "{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map" "{ 8 13 14 27 } [ even? dup 5 ? ] map"
} }
"The following is a no-op:" "The following is a no-op:"

View File

@ -1 +0,0 @@
Doug Coleman

View File

@ -1,6 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types unix.statfs io.files ;
IN: unix.statfs.netbsd

View File

@ -8,6 +8,6 @@ os {
{ linux [ "unix.statfs.linux" require ] } { linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] } { macosx [ "unix.statfs.macosx" require ] }
{ freebsd [ "unix.statfs.freebsd" require ] } { freebsd [ "unix.statfs.freebsd" require ] }
{ netbsd [ "unix.statfs.netbsd" require ] } ! { netbsd [ "unix.statfs.netbsd" require ] }
{ openbsd [ "unix.statfs.openbsd" require ] } ! { openbsd [ "unix.statfs.openbsd" require ] }
} case } case

View File

@ -1,30 +1,30 @@
USING: accessors sequences assocs kernel quotations namespaces USING: accessors sequences assocs kernel quotations namespaces
xml.data xml.utilities combinators macros parser lexer words ; xml.data xml.utilities combinators macros parser lexer words fry ;
IN: xmode.utilities IN: xmode.utilities
: implies >r not r> or ; inline : implies [ not ] dip or ; inline
: child-tags ( tag -- seq ) children>> [ tag? ] filter ; : child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt ) : map-find ( seq quot -- result elt )
f -rot f -rot
[ nip ] swap [ dup ] 3compose find '[ nip @ dup ] find
>r [ drop f ] unless r> ; inline [ [ drop f ] unless ] dip ; inline
: tag-init-form ( spec -- quot ) : tag-init-form ( spec -- quot )
{ {
{ [ dup quotation? ] [ [ object get tag get ] prepose ] } { [ dup quotation? ] [ [ object get tag get ] prepose ] }
{ [ dup length 2 = ] [ { [ dup length 2 = ] [
first2 [ first2 '[
>r >r tag get children>string tag get children>string
r> [ execute ] when* object get r> execute _ [ execute ] when* object get _ execute
] 2curry ]
] } ] }
{ [ dup length 3 = ] [ { [ dup length 3 = ] [
first3 [ first3 '[
>r >r tag get at _ tag get at
r> [ execute ] when* object get r> execute _ [ execute ] when* object get _ execute
] 3curry ]
] } ] }
} cond ; } cond ;
@ -36,7 +36,7 @@ MACRO: (init-from-tag) ( specs -- )
[ with-tag-initializer ] curry ; [ with-tag-initializer ] curry ;
: init-from-tag ( tag tuple specs -- tuple ) : init-from-tag ( tag tuple specs -- tuple )
over >r (init-from-tag) r> ; inline over [ (init-from-tag) ] dip ; inline
SYMBOL: tag-handlers SYMBOL: tag-handlers
SYMBOL: tag-handler-word SYMBOL: tag-handler-word

View File

@ -65,7 +65,7 @@ SYMBOL: error-stream
: with-streams ( input output quot -- ) : with-streams ( input output quot -- )
[ [ with-streams* ] 3curry ] [ [ with-streams* ] 3curry ]
[ [ drop dispose dispose ] 3curry ] 3bi [ drop [ [ dispose ] bi@ ] 2curry ] 3bi
[ ] cleanup ; inline [ ] cleanup ; inline
: tabular-output ( style quot -- ) : tabular-output ( style quot -- )

View File

@ -578,18 +578,6 @@ HELP: prepose
{ compose prepose } related-words { compose prepose } related-words
HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
"The following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
}
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
} ;
HELP: dip HELP: dip
{ $values { "x" object } { "quot" quotation } } { $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." } { $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
@ -814,7 +802,6 @@ ARTICLE: "compositional-combinators" "Compositional combinators"
{ $subsection 3curry } { $subsection 3curry }
{ $subsection with } { $subsection with }
{ $subsection compose } { $subsection compose }
{ $subsection 3compose }
{ $subsection prepose } { $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; "Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;

View File

@ -179,9 +179,6 @@ GENERIC: boa ( ... class -- tuple )
: prepose ( quot1 quot2 -- compose ) : prepose ( quot1 quot2 -- compose )
swap compose ; inline swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- compose )
compose compose ; inline
! Booleans ! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline : not ( obj -- ? ) [ f ] [ t ] if ; inline

View File

@ -142,7 +142,7 @@ MACRO: multikeep ( word out-indexes -- ... )
[ tuck 2slip ] dip while ; inline [ tuck 2slip ] dip while ; inline
: generate ( generator predicate -- obj ) : generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose '[ dup @ dup [ nip ] unless not ]
swap [ ] do-while ; swap [ ] do-while ;
MACRO: predicates ( seq -- quot/f ) MACRO: predicates ( seq -- quot/f )

View File

@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors sequences.private combinators mirrors
combinators.short-circuit ; combinators.short-circuit fry ;
IN: inverse IN: inverse
TUPLE: fail ; TUPLE: fail ;
@ -46,7 +46,7 @@ M: no-inverse summary
dup word? [ "Badly formed math inverse" throw ] when 1quotation ; dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot ) : swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second [ swap ] swap 3compose ; next assure-constant rot second '[ @ swap @ ] ;
: pull-inverse ( math-inverse revquot const -- revquot* quot ) : pull-inverse ( math-inverse revquot const -- revquot* quot )
assure-constant rot first compose ; assure-constant rot first compose ;
@ -236,8 +236,7 @@ DEFER: _
] recover ; inline ] recover ; inline
: true-out ( quot effect -- quot' ) : true-out ( quot effect -- quot' )
out>> [ ndrop ] curry out>> '[ @ _ ndrop t ] ;
[ t ] 3compose ;
: false-recover ( effect -- quot ) : false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ; in>> [ ndrop f ] curry [ recover-fail ] curry ;

View File

@ -5,7 +5,7 @@ USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib math.parser math.private sorting strings ascii macros assocs.lib
quotations hashtables math.order locals generalizations quotations hashtables math.order locals generalizations
math.ranges random ; math.ranges random fry ;
IN: sequences.lib IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline : each-withn ( seq quot n -- ) nwith each ; inline
@ -90,12 +90,8 @@ ERROR: element-not-found ;
dupd find over [ element-not-found ] unless dupd find over [ element-not-found ] unless
>r cut rest r> swap ; inline >r cut rest r> swap ; inline
: (map-until) ( quot pred -- quot )
[ dup ] swap 3compose
[ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
: map-until ( seq quot pred -- newseq ) : map-until ( seq quot pred -- newseq )
(map-until) { } make ; '[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
: take-while ( seq quot -- newseq ) : take-while ( seq quot -- newseq )
[ not ] compose [ not ] compose