Merge branch 'master' into specialized-arrays
						commit
						e559a101e8
					
				| 
						 | 
					@ -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
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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:"
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -1 +0,0 @@
 | 
				
			||||||
Doug Coleman
 | 
					 | 
				
			||||||
| 
						 | 
					@ -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
 | 
					 | 
				
			||||||
| 
						 | 
					@ -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
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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 -- )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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" } "." ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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 )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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 ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -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
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue