steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Conflicts:

	extra/benchmark/sockets/sockets.factor
db4
Daniel Ehrenberg 2008-03-05 16:57:06 -06:00
parent 816a580eb4 53575cb8b7
commit 4c9ef7946d
20 changed files with 809 additions and 760 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/generic/generic-docs.factor
View File

@ -116,16 +116,18 @@ HELP: method-spec
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
HELP: method HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } { $description "Looks up a method definition." } ;
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
{ method define-method POSTPONE: M: } related-words { method define-method POSTPONE: M: } related-words
HELP: <method> HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } } { $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ; { $description "Creates a new method." } ;
HELP: methods HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }

52
core/generic/generic.factor
View File

@ -33,8 +33,6 @@ M: generic definition drop f ;
dup { "unannotated-def" } reset-props dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ; dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f ) : method ( class generic -- method/f )
"methods" word-prop at ; "methods" word-prop at ;
@ -47,7 +45,7 @@ PREDICATE: pair method-spec
: methods ( word -- assoc ) : methods ( word -- assoc )
"methods" word-prop "methods" word-prop
[ keys sort-classes ] keep [ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ; [ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ; TUPLE: check-method class generic ;
@ -63,29 +61,33 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string ) : method-word-name ( class word -- string )
word-name "/" rot word-name 3append ; word-name "/" rot word-name 3append ;
: make-method-def ( quot word combination -- quot ) : make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ; "combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method" word-prop >boolean ; PREDICATE: word method-body "method-def" word-prop >boolean ;
M: method-body stack-effect M: method-body stack-effect
"method" word-prop method-generic stack-effect ; "method-generic" word-prop stack-effect ;
: <method-word> ( quot class generic -- word ) : method-word-props ( quot class generic -- assoc )
[ make-method-def ] 2keep [
method-word-name f <word> "method-generic" set
dup rot define "method-class" set
dup xref ; "method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method ) : <method> ( quot class generic -- word )
check-method check-method
[ <method-word> ] 3keep f \ method construct-boa [ make-method-def ] 3keep
dup method-word over "method" set-word-prop ; [ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
: redefine-method ( quot class generic -- ) : redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep [ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep [ make-method-def ] 2keep
method method-word swap define ; method swap define ;
: define-method ( quot class generic -- ) : define-method ( quot class generic -- )
>r bootstrap-word r> >r bootstrap-word r>
@ -102,21 +104,22 @@ M: method-body stack-effect
! Definition protocol ! Definition protocol
M: method-spec where M: method-spec where
dup first2 method [ method-word ] [ second ] ?if where ; dup first2 method [ ] [ second ] ?if where ;
M: method-spec set-where M: method-spec set-where
first2 method method-word set-where ; first2 method set-where ;
M: method-spec definer M: method-spec definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-spec definition M: method-spec definition
first2 method dup [ method-def ] when ; first2 method dup
[ "method-def" word-prop ] when ;
: forget-method ( class generic -- ) : forget-method ( class generic -- )
check-method check-method
[ delete-at* ] with-methods [ delete-at* ] with-methods
[ method-word forget-word ] [ drop ] if ; [ forget-word ] [ drop ] if ;
M: method-spec forget* M: method-spec forget*
first2 forget-method ; first2 forget-method ;
@ -125,11 +128,11 @@ M: method-body definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-body definition M: method-body definition
"method" word-prop method-def ; "method-def" word-prop ;
M: method-body forget* M: method-body forget*
"method" word-prop dup "method-class" word-prop
{ method-specializer method-generic } get-slots swap "method-generic" word-prop
forget-method ; forget-method ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
@ -168,8 +171,7 @@ M: word subwords drop f ;
M: generic subwords M: generic subwords
dup "methods" word-prop values dup "methods" word-prop values
swap "default-method" word-prop add swap "default-method" word-prop add ;
[ method-word ] map ;
M: generic forget-word M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ; dup subwords [ forget-word ] each (forget-word) ;

2
core/generic/math/math.factor
View File

@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot ) : applicable-method ( generic class -- quot )
over method over method
[ method-word word-def ] [ word-def ]
[ default-math-method ] ?if ; [ default-math-method ] ?if ;
: object-method ( generic -- quot ) : object-method ( generic -- quot )

2
core/generic/standard/standard.factor
View File

@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
] if ; ] if ;
: default-method ( word -- pair ) : default-method ( word -- pair )
"default-method" word-prop method-word "default-method" word-prop
object bootstrap-word swap 2array ; object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot ) : method-alist>quot ( alist base-class -- quot )

3
core/inference/backend/backend.factor
View File

@ -10,8 +10,7 @@ IN: inference.backend
recursive-state get at ; recursive-state get at ;
: inline? ( word -- ? ) : inline? ( word -- ? )
dup "method" word-prop dup "method-generic" word-prop swap or "inline" word-prop ;
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc ) : local-recursive-state ( -- assoc )
recursive-state get dup keys recursive-state get dup keys

416
core/optimizer/inlining/inlining.factor
View File

@ -1,208 +1,208 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ; optimizer.control kernel.private ;
IN: optimizer.inlining IN: optimizer.inlining
: remember-inlining ( node history -- ) : remember-inlining ( node history -- )
[ swap set-node-history ] curry each-node ; [ swap set-node-history ] curry each-node ;
: inlining-quot ( node quot -- node ) : inlining-quot ( node quot -- node )
over node-in-d dataflow-with over node-in-d dataflow-with
dup rot infer-classes/node ; dup rot infer-classes/node ;
: splice-quot ( #call quot history -- node ) : splice-quot ( #call quot history -- node )
#! Must add history *before* splicing in, otherwise #! Must add history *before* splicing in, otherwise
#! the rest of the IR will also remember the history #! the rest of the IR will also remember the history
pick node-history append pick node-history append
>r dupd inlining-quot dup r> remember-inlining >r dupd inlining-quot dup r> remember-inlining
tuck splice-node ; tuck splice-node ;
! A heuristic to avoid excessive inlining ! A heuristic to avoid excessive inlining
DEFER: (flat-length) DEFER: (flat-length)
: word-flat-length ( word -- n ) : word-flat-length ( word -- n )
{ {
! heuristic: { ... } declare comes up in method bodies ! heuristic: { ... } declare comes up in method bodies
! and we don't care about it ! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] } { [ dup \ declare eq? ] [ drop -2 ] }
! recursive ! recursive
{ [ dup get ] [ drop 1 ] } { [ dup get ] [ drop 1 ] }
! not inline ! not inline
{ [ dup inline? not ] [ drop 1 ] } { [ dup inline? not ] [ drop 1 ] }
! inline ! inline
{ [ t ] [ dup dup set word-def (flat-length) ] } { [ t ] [ dup dup set word-def (flat-length) ] }
} cond ; } cond ;
: (flat-length) ( seq -- n ) : (flat-length) ( seq -- n )
[ [
{ {
{ [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] } { [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] } { [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] } { [ t ] [ drop 1 ] }
} cond } cond
] map sum ; ] map sum ;
: flat-length ( seq -- n ) : flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ; [ word-def (flat-length) ] with-scope ;
! Single dispatch method inlining optimization ! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ; : specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class ) : node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ; over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class ) : dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ; [ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node ) : inline-standard-method ( node word -- node )
2dup dispatching-class dup [ 2dup dispatching-class dup [
over +inlined+ depends-on over +inlined+ depends-on
swap method method-word 1quotation f splice-quot swap method 1quotation f splice-quot
] [ ] [
3drop t 3drop t
] if ; ] if ;
! Partial dispatch of math-generic words ! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? ) : math-both-known? ( word left right -- ? )
math-class-max swap specific-method ; math-class-max swap specific-method ;
: inline-math-method ( #call word -- node ) : inline-math-method ( #call word -- node )
over node-input-classes first2 3dup math-both-known? over node-input-classes first2 3dup math-both-known?
[ math-method f splice-quot ] [ 2drop 2drop t ] if ; [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
: inline-method ( #call -- node ) : inline-method ( #call -- node )
dup node-param { dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] } { [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] } { [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] } { [ t ] [ 2drop t ] }
} cond ; } cond ;
! Resolve type checks at compile time where possible ! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? ) : comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes #! If actual is a subset of testing or if the two classes
#! are disjoint, return t. #! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ; 2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? ) : optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [ dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable? >r node-class-first r> comparable?
] [ ] [
2drop f 2drop f
] if ; ] if ;
: literal-quot ( node literals -- quot ) : literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and #! Outputs a quotation which drops the node's inputs, and
#! pushes some literals. #! pushes some literals.
>r node-in-d length \ drop <repetition> >r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ; r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node ) : inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor #! Make #shuffle -> #push -> #return -> successor
dupd literal-quot f splice-quot ; dupd literal-quot f splice-quot ;
: evaluate-predicate ( #call -- ? ) : evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r dup node-param "predicating" word-prop >r
node-class-first r> class< ; node-class-first r> class< ;
: optimize-predicate ( #call -- node ) : optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it #! If the predicate is followed by a branch we fold it
#! immediately #! immediately
dup evaluate-predicate swap dup evaluate-predicate swap
dup node-successor #if? [ dup node-successor #if? [
dup drop-inputs >r dup drop-inputs >r
node-successor swap 0 1 ? fold-branch node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep r> [ set-node-successor ] keep
] [ ] [
swap 1array inline-literals swap 1array inline-literals
] if ; ] if ;
: optimizer-hooks ( node -- conditions ) : optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ; node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f ) : optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ; dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- ) : optimize-hook ( node -- )
dup optimizer-hook second call ; dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- ) : define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ; "optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? ) : flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [ dup node-param "flushable" word-prop [
node-out-d [ unused? ] all? node-out-d [ unused? ] all?
] [ ] [
drop f drop f
] if ; ] if ;
: flush-eval ( #call -- node ) : flush-eval ( #call -- node )
dup node-param +inlined+ depends-on dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ; dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? ) : partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [ dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all? dup node-in-d [ node-literal? ] with all?
] [ ] [
drop f drop f
] if ; ] if ;
: literal-in-d ( #call -- inputs ) : literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ; dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node ) : partial-eval ( #call -- node )
dup node-param +inlined+ depends-on dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- ) : define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ; [ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot ) : find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep [ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find [ swap first in-d-match? ] curry find
nip dup [ second ] when ; nip dup [ second ] when ;
: apply-identities ( node -- node/f ) : apply-identities ( node -- node/f )
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? ) : optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [ dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail* >r node-input-classes r> specialized-length tail*
[ types length 1 = ] all? [ types length 1 = ] all?
] [ ] [
2drop f 2drop f
] if ; ] if ;
: splice-word-def ( #call word -- node ) : splice-word-def ( #call word -- node )
dup +inlined+ depends-on dup +inlined+ depends-on
dup word-def swap 1array splice-quot ; dup word-def swap 1array splice-quot ;
: optimistic-inline ( #call -- node ) : optimistic-inline ( #call -- node )
dup node-param over node-history memq? [ dup node-param over node-history memq? [
drop t drop t
] [ ] [
dup node-param splice-word-def dup node-param splice-word-def
] if ; ] if ;
: method-body-inline? ( #call -- ? ) : method-body-inline? ( #call -- ? )
node-param dup method-body? node-param dup method-body?
[ flat-length 10 <= ] [ drop f ] if ; [ flat-length 10 <= ] [ drop f ] if ;
M: #call optimize-node* M: #call optimize-node*
{ {
{ [ dup flush-eval? ] [ flush-eval ] } { [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] } { [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] } { [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] } { [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] } { [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] } { [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] } { [ t ] [ inline-method ] }
} cond dup not ; } cond dup not ;

756
core/optimizer/optimizer-tests.factor
View File

@ -1,378 +1,378 @@
USING: arrays compiler.units generic hashtables inference kernel USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ; continuations growable optimizer.inlining namespaces hints ;
IN: optimizer.tests IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
] unit-test ] unit-test
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ [ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test ] unit-test
! Test method inlining ! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test [ f ] [ fixnum { } min-class ] unit-test
[ string ] [ [ string ] [
\ string \ string
[ integer string array reversed sbuf [ integer string array reversed sbuf
slice vector quotation ] slice vector quotation ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ fixnum ] [ [ fixnum ] [
\ fixnum \ fixnum
[ fixnum integer object ] [ fixnum integer object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ integer ] [ [ integer ] [
\ fixnum \ fixnum
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ object ] [ [ object ] [
\ word \ word
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ reversed ] [ [ reversed ] [
\ reversed \ reversed
[ integer reversed slice ] [ integer reversed slice ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ t ] [ \ xyz compiled? ] unit-test [ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 : pred-test-1
dup fixnum? [ dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if dup integer? [ "integer" ] [ "nope" ] if
] [ ] [
"not a fixnum" "not a fixnum"
] if ; ] if ;
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test [ 1 "integer" ] [ 1 pred-test-1 ] unit-test
TUPLE: pred-test ; TUPLE: pred-test ;
: pred-test-2 : pred-test-2
dup tuple? [ dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if dup pred-test? [ "pred-test" ] [ "nope" ] if
] [ ] [
"not a tuple" "not a tuple"
] if ; ] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3 : pred-test-3
dup pred-test? [ dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if dup tuple? [ "pred-test" ] [ "nope" ] if
] [ ] [
"not a tuple" "not a tuple"
] if ; ] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test : inline-test
"nom" = ; "nom" = ;
[ t ] [ "nom" inline-test ] unit-test [ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test [ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test [ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ; : fixnum-declarations >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test [ ] [ 1000000 fixnum-declarations . ] unit-test
! regression ! regression
: literal-not-branch 0 not [ ] [ ] if ; : literal-not-branch 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test [ ] [ literal-not-branch ] unit-test
! regression ! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline : bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ; : bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test [ 3 ] [ t bad-kill-2 ] unit-test
! regression ! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline : (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ; : the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test [ 2 0 ] [ the-test ] unit-test
! regression ! regression
: (double-recursion) ( start end -- ) : (double-recursion) ( start end -- )
< [ < [
6 1 (double-recursion) 6 1 (double-recursion)
3 2 (double-recursion) 3 2 (double-recursion)
] when ; inline ] when ; inline
: double-recursion 0 2 (double-recursion) ; : double-recursion 0 2 (double-recursion) ;
[ ] [ double-recursion ] unit-test [ ] [ double-recursion ] unit-test
! regression ! regression
: double-label-1 ( a b c -- d ) : double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 ( a -- b ) : double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ; dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test [ 0 ] [ 10 double-label-2 ] unit-test
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ; : breakage "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test [ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline : test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
: test-2 ( -- ) 5 test-1 ; : test-2 ( -- ) 5 test-1 ;
[ f ] [ f test-2 ] unit-test [ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( m -- n ) : branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- m ) : branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ; 10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test [ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression ! another regression
: constant-branch-fold-0 "hey" ; foldable : constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline : constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression ! another regression
: foo f ; : foo f ;
: bar foo 4 4 = and ; : bar foo 4 4 = and ;
[ f ] [ bar ] unit-test [ f ] [ bar ] unit-test
! ensure identities are working in some form ! ensure identities are working in some form
[ t ] [ [ t ] [
[ { number } declare 0 + ] dataflow optimize [ { number } declare 0 + ] dataflow optimize
[ #push? ] node-exists? not [ #push? ] node-exists? not
] unit-test ] unit-test
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
: <tuple>-regression <tuple> ; : <tuple>-regression <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test [ t ] [ \ <tuple>-regression compiled? ] unit-test
GENERIC: foozul ( a -- b ) GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
M: integer foozul ; M: integer foozul ;
M: slice foozul ; M: slice foozul ;
[ reversed ] [ reversed \ foozul specific-method ] unit-test [ reversed ] [ reversed \ foozul specific-method ] unit-test
! regression ! regression
: constant-fold-2 f ; foldable : constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable : constant-fold-3 4 ; foldable
[ f t ] [ [ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call [ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test ] unit-test
: constant-fold-4 f ; foldable : constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable : constant-fold-5 f ; foldable
[ f ] [ [ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call [ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test ] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test [ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test [ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test [ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test [ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test [ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test [ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test [ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test [ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test [ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test [ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test [ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test [ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test [ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test [ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test [ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test [ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test [ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test [ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test [ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test [ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test [ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test [ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test [ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test [ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test [ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test [ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj ) GENERIC: detect-number ( obj -- obj )
M: number detect-number ; M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail [ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression ! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression ! Regression
USE: sorting USE: sorting
USE: sorting.private USE: sorting.private
: old-binsearch ( elt quot seq -- elt quot i ) : old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [ dup length 1 <= [
slice-from slice-from
] [ ] [
[ midpoint swap call ] 3keep roll dup zero? [ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ] [ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if [ partition old-binsearch ] if
] if ; inline ] if ; inline
[ 10 ] [ [ 10 ] [
10 20 >vector <flat-slice> 10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip [ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test ] unit-test
! Regression ! Regression
TUPLE: silly-tuple a b ; TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [ [ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 } T{ silly-tuple f 1 2 }
[ [
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep { silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-call ] compile-call
] unit-test ] unit-test
! Regression ! Regression
: empty-compound ; : empty-compound ;
: node-successor-f-bug ( x -- * ) : node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test [ t ] [ \ node-successor-f-bug compiled? ] unit-test
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test [ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics ! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ; : should-inline? method flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test [ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test [ f ] [ \ array \ equal? should-inline? ] unit-test
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test [ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression ! Regression
: lift-throw-tail-regression : lift-throw-tail-regression
dup integer? [ "an integer" ] [ dup integer? [ "an integer" ] [
dup string? [ "a string" ] [ dup string? [ "a string" ] [
"error" throw "error" throw
] if ] if
] if ; ] if ;
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test [ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- ) : lift-loop-tail-test-1 ( a quot -- )
over even? [ over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1 [ >r 3 - r> call ] keep lift-loop-tail-test-1
] [ ] [
over 0 < [ over 0 < [
2drop 2drop
] [ ] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1 [ >r 2 - r> call ] keep lift-loop-tail-test-1
] if ] if
] if ; inline ] if ; inline
: lift-loop-tail-test-2 : lift-loop-tail-test-2
10 [ ] lift-loop-tail-test-1 1 2 3 ; 10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Make sure we don't lose ! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y ) GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ; M: integer generic-inline-test ;
: generic-inline-test-1 : generic-inline-test-1
1 1
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test ; generic-inline-test ;
[ { t f } ] [ [ { t f } ] [
\ generic-inline-test-1 word-def dataflow \ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make [ optimize-1 , optimize-1 , drop ] { } make
] unit-test ] unit-test
! Forgot a recursive inline check ! Forgot a recursive inline check
: recursive-inline-hang ( a -- a ) : recursive-inline-hang ( a -- a )
dup array? [ recursive-inline-hang ] when ; dup array? [ recursive-inline-hang ] when ;
HINTS: recursive-inline-hang array ; HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 : recursive-inline-hang-1
{ } recursive-inline-hang ; { } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test [ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
DEFER: recursive-inline-hang-3 DEFER: recursive-inline-hang-3
: recursive-inline-hang-2 ( a -- a ) : recursive-inline-hang-2 ( a -- a )
dup array? [ recursive-inline-hang-3 ] when ; dup array? [ recursive-inline-hang-3 ] when ;
HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-2 array ;
: recursive-inline-hang-3 ( a -- a ) : recursive-inline-hang-3 ( a -- a )
dup array? [ recursive-inline-hang-2 ] when ; dup array? [ recursive-inline-hang-2 ] when ;
HINTS: recursive-inline-hang-3 array ; HINTS: recursive-inline-hang-3 array ;

14
core/prettyprint/prettyprint.factor
View File

@ -175,10 +175,10 @@ M: method-spec synopsis*
dup definer. [ pprint-word ] each ; dup definer. [ pprint-word ] each ;
M: method-body synopsis* M: method-body synopsis*
dup definer. dup dup
"method" word-prop dup definer.
method-specializer pprint* "method-class" word-prop pprint*
method-generic pprint* ; "method-generic" word-prop pprint* ;
M: mixin-instance synopsis* M: mixin-instance synopsis*
dup definer. dup definer.
@ -269,7 +269,7 @@ M: builtin-class see-class*
: see-implementors ( class -- seq ) : see-implementors ( class -- seq )
dup implementors dup implementors
[ method method-word ] with map [ method ] with map
natural-sort ; natural-sort ;
: see-class ( class -- ) : see-class ( class -- )
@ -280,9 +280,7 @@ M: builtin-class see-class*
] when drop ; ] when drop ;
: see-methods ( generic -- seq ) : see-methods ( generic -- seq )
"methods" word-prop "methods" word-prop values natural-sort ;
[ nip method-word ] { } assoc>map
natural-sort ;
M: word see M: word see
dup see-class dup see-class

2
core/vocabs/vocabs.factor
View File

@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
M: f set-vocab-docs-loaded? 2drop ; M: f set-vocab-docs-loaded? 2drop ;
M: f vocab-help ;
: create-vocab ( name -- vocab ) : create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ; dictionary get [ <vocab> ] cache ;

2
core/words/words.factor
View File

@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? ) : crossref? ( word -- ? )
{ {
{ [ dup "forgotten" word-prop ] [ f ] } { [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method" word-prop ] [ t ] } { [ dup "method-definition" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] } { [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] } { [ t ] [ f ] }
} cond nip ; } cond nip ;

123
extra/benchmark/sockets/sockets.factor
View File

@ -1,65 +1,58 @@
USING: io.sockets io kernel math threads io.encodings.ascii USING: io.sockets io kernel math threads
debugger tools.time prettyprint concurrency.count-downs debugger tools.time prettyprint concurrency.count-downs
namespaces arrays continuations ; namespaces arrays continuations ;
IN: benchmark.sockets IN: benchmark.sockets
SYMBOL: counter SYMBOL: counter
: number-of-requests 1 ; : number-of-requests 1 ;
: server-addr "127.0.0.1" 7777 <inet4> ; : server-addr "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- ) : server-loop ( server -- )
dup accept [ dup accept [
[ [
read1 CHAR: x = [ read1 CHAR: x = [
"server" get dispose "server" get dispose
] [ ] [
number-of-requests number-of-requests
[ read1 write1 flush ] times [ read1 write1 flush ] times
counter get count-down counter get count-down
] if ] if
] with-stream ] with-stream
] curry "Client handler" spawn drop server-loop ; ] curry "Client handler" spawn drop server-loop ;
: simple-server ( -- ) : simple-server ( -- )
[ [
server-addr ascii <server> dup "server" set [ server-addr ascii <server> dup "server" set [
server-loop server-loop
] with-disposal ] with-disposal
] ignore-errors ; ] ignore-errors ;
: simple-client ( -- ) : simple-client ( -- )
server-addr <client> [ server-addr ascii <client> [
CHAR: b write1 flush CHAR: b write1 flush
number-of-requests number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times [ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down counter get count-down
] with-stream ; ] with-stream ;
: stop-server ( -- ) : stop-server ( -- )
server-addr <client> [ server-addr ascii <client> [
CHAR: x write1 CHAR: x write1
] with-stream ; ] with-stream ;
: clients ( n -- ) : clients ( n -- )
dup pprint " clients: " write [ dup pprint " clients: " write [
dup 2 * <count-down> counter set dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop [ simple-server ] "Simple server" spawn drop
yield yield yield yield
[ [ simple-client ] "Simple client" spawn drop ] times [ [ simple-client ] "Simple client" spawn drop ] times
counter get await counter get await
stop-server stop-server
yield yield yield yield
] time ; ] time ;
: socket-benchmarks : socket-benchmarks ;
10 clients
20 clients MAIN: socket-benchmarks
40 clients ;
! 80 clients
! 160 clients
! 320 clients
! 640 clients ;
MAIN: socket-benchmarks

2
extra/bootstrap/image/upload/upload.factor
View File

@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
: destination ( -- dest ) : destination ( -- dest )
upload-images-destination get upload-images-destination get
"slava@/var/www/factorcode.org/newsite/images/latest/" "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ; or ;
: checksums "checksums.txt" temp-file ; : checksums "checksums.txt" temp-file ;

26
extra/help/markup/markup.factor Normal file → Executable file
View File

@ -144,20 +144,32 @@ M: f print-element drop ;
: $link ( element -- ) : $link ( element -- )
first ($link) ; first ($link) ;
: ($subsection) ( object -- ) : ($long-link) ( object -- )
[ article-title ] keep >link write-object ; dup article-title swap >link write-link ;
: $subsection ( element -- ) : ($subsection) ( element quot -- )
[ [
subsection-style get [ subsection-style get [
bullet get write bl bullet get write bl
first ($subsection) call
] with-style ] with-style
] ($block) ; ] ($block) ; inline
: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ; : $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
: $vocab-link ( element -- ) first ($vocab-link) ; : ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
: $vocab-subsection ( element -- )
[
first2 dup vocab-help dup [
2nip ($long-link)
] [
drop ($vocab-link)
] if
] ($subsection) ;
: $vocab-link ( element -- ) first dup ($vocab-link) ;
: $vocabulary ( element -- ) : $vocabulary ( element -- )
first word-vocabulary [ first word-vocabulary [

16
extra/io/launcher/launcher-docs.factor
View File

@ -35,33 +35,43 @@ HELP: +environment-mode+
HELP: +stdin+ HELP: +stdin+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard input is inherited" } { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard input is inherited from the current process" }
{ { $link +closed+ } " - standard input is closed" } { { $link +closed+ } " - standard input is closed" }
{ "a path name - standard input is read from the given file, which must exist" } { "a path name - standard input is read from the given file, which must exist" }
{ "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +stdout+ HELP: +stdout+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard output is inherited" } { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard output is inherited from the current process" }
{ { $link +closed+ } " - standard output is closed" } { { $link +closed+ } " - standard output is closed" }
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +stderr+ HELP: +stderr+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $list
{ { $link f } " - standard error is inherited" } { { $link f } " - standard error is inherited from the current process" }
{ { $link +inherit+ } " - same as above" }
{ { $link +stdout+ } " - standard error is merged with standard output" }
{ { $link +closed+ } " - standard error is closed" } { { $link +closed+ } " - standard error is closed" }
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
} }
} ; } ;
HELP: +closed+ HELP: +closed+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +inherit+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +prepend-environment+ HELP: +prepend-environment+
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
$nl $nl

116
extra/io/windows/nt/launcher/launcher.factor
View File

@ -1,18 +1,38 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.windows.launcher io.windows.nt.pipes io.backend
combinators ; combinators shuffle ;
IN: io.windows.nt.launcher IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
swap ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
DUPLICATE_CLOSE_SOURCE ! options
DuplicateHandle win32-error=0/f
] keep *void* ;
! The below code is based on the example given in ! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle ) : redirect-default ( default obj access-mode create-mode -- handle )
>r >r 3drop ;
: redirect-inherit ( default obj access-mode create-mode -- handle )
4drop f ;
: redirect-closed ( default obj access-mode create-mode -- handle )
drop 2nip null-pipe ;
: redirect-file ( default path access-mode create-mode -- handle )
>r >r >r drop r>
normalize-pathname normalize-pathname
r> ! access-mode r> ! access-mode
share-mode share-mode
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
f ! template file f ! template file
CreateFile dup invalid-handle? dup close-later ; CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: set-inherit ( handle ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: redirect-stream ( default stream access-mode create-mode -- handle )
2drop nip
underlying-handle win32-file-handle
duplicate-handle dup t set-inherit ;
: redirect ( default obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
{ [ t ] [ redirect-stream ] }
} cond ;
: default-stdout ( args -- handle )
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
: redirect-stdout ( args -- handle )
default-stdout
+stdout+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_OUTPUT_HANDLE GetStdHandle or ;
: redirect-stderr ( args -- handle )
+stderr+ get +stdout+ eq? [
CreateProcess-args-lpStartupInfo
STARTUPINFO-hStdOutput
] [
drop
f
+stderr+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
: default-stdin ( args -- handle )
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
: redirect-stdin ( args -- handle )
default-stdin
+stdin+ get
GENERIC_READ
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
: add-pipe-dtors ( pipe -- ) : add-pipe-dtors ( pipe -- )
dup dup
pipe-in close-later pipe-in close-later

2
extra/io/windows/windows.factor
View File

@ -52,7 +52,7 @@ M: win32-file close-handle ( handle -- )
: open-file ( path access-mode create-mode flags -- handle ) : open-file ( path access-mode create-mode flags -- handle )
[ [
>r >r >r normalize-pathname r> >r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later dup invalid-handle? dup close-later
dup add-completion dup add-completion
] with-destructors ; ] with-destructors ;

12
extra/locals/locals.factor
View File

@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
! are unified ! are unified
: create-method ( class generic -- method ) : create-method ( class generic -- method )
2dup method dup 2dup method dup
[ 2nip method-word ] [ 2nip ]
[ drop 2dup [ ] -rot define-method create-method ] if ; [ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body ) : CREATE-METHOD ( -- class generic body )
@ -369,14 +369,14 @@ M: lambda-method definition
: method-stack-effect : method-stack-effect
dup "lambda" word-prop lambda-vars dup "lambda" word-prop lambda-vars
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when swap "method-generic" word-prop stack-effect
dup [ effect-out ] when
<effect> ; <effect> ;
M: lambda-method synopsis* M: lambda-method synopsis*
dup definer. dup dup definer.
dup "method" word-prop dup "method-specializer" word-prop pprint*
method-specializer pprint* "method-generic" word-prop pprint*
method-generic pprint*
method-stack-effect effect>string comment. ; method-stack-effect effect>string comment. ;
PRIVATE> PRIVATE>

2
extra/logging/insomniac/insomniac-docs.factor Normal file → Executable file
View File

@ -27,7 +27,7 @@ HELP: schedule-insomniac
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ; { $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
ARTICLE: "logging.insomniac" "Automating log analysis and rotation" ARTICLE: "logging.insomniac" "Automated log analysis"
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
$nl $nl
"Required configuration parameters:" "Required configuration parameters:"

6
extra/logging/logging-docs.factor Normal file → Executable file
View File

@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
{ $subsection "logging.levels" } { $subsection "logging.levels" }
{ $subsection "logging.messages" } { $subsection "logging.messages" }
{ $subsection "logging.rotation" } { $subsection "logging.rotation" }
{ $subsection "logging.parser" } { $vocab-subsection "Log file parser" "logging.parser" }
{ $subsection "logging.analysis" } { $vocab-subsection "Log analysis" "logging.analysis" }
{ $subsection "logging.insomniac" } { $vocab-subsection "Automated log analysis" "logging.insomniac" }
{ $subsection "logging.server" } ; { $subsection "logging.server" } ;
ABOUT: "logging" ABOUT: "logging"

5
extra/tools/profiler/profiler.factor
View File

@ -29,9 +29,8 @@ M: string (profile.)
dup <vocab-profile> write-object ; dup <vocab-profile> write-object ;
M: method-body (profile.) M: method-body (profile.)
"method" word-prop dup synopsis swap "method-generic" word-prop
dup method-specializer over method-generic 2array synopsis <usage-profile> write-object ;
swap method-generic <usage-profile> write-object ;
: counter. ( obj n -- ) : counter. ( obj n -- )
[ [