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

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

Conflicts:

	basis/cocoa/types/types.factor
db4
Joe Groff 2008-09-12 06:37:24 -07:00
parent 7eb6ceb08c 45425fccd7
commit eb77923e09
384 changed files with 3586 additions and 1463 deletions
basis
alien
arrays
c-types
structs/fields
base64
bootstrap/image
channels/remote
checksums
cocoa
combinators/short-circuit
compiler
compiler.factor
generator
tests
tree
concurrency/messaging
core-foundation/fsevents
cpu
csv
db
debugger
delegate
disjoint-sets
documents
fry
furnace
generalizations
help
hints
html
Show More

2
basis/alien/arrays/arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel namespaces libc cpu.architecture ;
sequences math kernel namespaces make libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;

2
basis/alien/c-types/c-types.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations ;

2
basis/alien/structs/fields/fields.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel kernel.private math namespaces
sequences strings words effects combinators alien.c-types ;
make sequences strings words effects combinators alien.c-types ;
IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;

16
basis/base64/base64.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences io.binary splitting grouping ;
USING: kernel math sequences io.binary splitting grouping
accessors ;
IN: base64
<PRIVATE
: count-end ( seq quot -- count )
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
: count-end ( seq quot -- n )
trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@ -21,13 +22,16 @@ IN: base64
} nth ;
: encode3 ( seq -- seq )
be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
be> 4 <reversed> [
-6 * shift HEX: 3f bitand ch>base64
] with B{ } map-as ;
: decode4 ( str -- str )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
[ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
[ 3 0 pad-right encode3 ] [ length 1+ ] bi
head-slice 4 CHAR: = pad-right ;
PRIVATE>
@ -42,5 +46,5 @@ PRIVATE>
: base64> ( base64 -- str )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = not ] count-end ]
[ [ CHAR: = = ] count-end ]
bi head* ;

4
basis/bootstrap/image/image.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io kernel kernel.private math namespaces
hashtables.private io kernel kernel.private math namespaces make
parser prettyprint sequences sequences.private strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple
@ -280,7 +280,7 @@ M: f '
[
[
{
[ hashcode , ]
[ hashcode <fake-bignum> , ]
[ name>> , ]
[ vocabulary>> , ]
[ def>> , ]

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
kernel io.files bootstrap.image sequences io namespaces make
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload

2
basis/channels/remote/remote.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Remote Channels
USING: kernel init namespaces assocs arrays random
USING: kernel init namespaces make assocs arrays random
sequences channels match concurrency.messaging
concurrency.distributed threads accessors ;
IN: channels.remote

2
basis/checksums/common/common.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
grouping ;
make grouping ;
IN: checksums.common
SYMBOL: bytes-read

4
basis/checksums/sha1/sha1.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
math parser sequences assocs grouping vectors io.binary hashtables
symbols math.bitwise checksums checksums.common ;
make math parser sequences assocs grouping vectors io.binary
hashtables symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.

2
basis/checksums/sha2/sha2.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces
USING: kernel splitting grouping math sequences namespaces make
io.binary symbols math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2

4
basis/cocoa/enumeration/enumeration.factor
View File

@ -15,7 +15,7 @@ IN: cocoa.enumeration
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ , void*-nth quot call ] each
'[ _ void*-nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline recursive
@ -24,7 +24,7 @@ IN: cocoa.enumeration
: NSFastEnumeration-map ( object quot -- vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ , push ] NSFastEnumeration-each ] keep ; inline
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
: NSFastEnumeration>vector ( object -- vector )
[ ] NSFastEnumeration-map ;

11
basis/cocoa/messages/messages.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings
arrays assocs combinators compiler kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger io.encodings.ascii effects compiler.generator
libc libc.private ;
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects compiler.generator libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii generalizations
continuations ;
continuations make ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )

2
basis/cocoa/views/views.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel math namespaces cocoa
USING: alien.c-types arrays kernel math namespaces make cocoa
cocoa.messages cocoa.classes cocoa.types sequences
continuations ;
IN: cocoa.views

4
basis/combinators/short-circuit/short-circuit.factor
View File

@ -11,7 +11,7 @@ IN: combinators.short-circuit
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
map
[ t ] [ N nnip ] 2array suffix
'[ f , cond ] ;
'[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
@ -25,7 +25,7 @@ MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
'[ f , cond ] ;
'[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;

2
basis/compiler/compiler.factor
View File

@ -54,7 +54,7 @@ SYMBOL: +failed+
H{ } clone dependencies set
H{ } clone generic-dependencies set
, {
_ {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover

2
basis/compiler/generator/fixup/fixup.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;

16
basis/compiler/generator/generator.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
kernel.private layouts math math.parser namespaces prettyprint
quotations sequences system threads words vectors sets deques
continuations.private summary alien alien.c-types
kernel.private layouts math math.parser namespaces make
prettyprint quotations sequences system threads words vectors
sets deques continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining
compiler.tree compiler.tree.builder compiler.tree.combinators
compiler.tree.propagation.info compiler.generator.fixup
compiler.generator.registers compiler.generator.iterator ;
stack-checker.inlining compiler.tree compiler.tree.builder
compiler.tree.combinators compiler.tree.propagation.info
compiler.generator.fixup compiler.generator.registers
compiler.generator.iterator ;
IN: compiler.generator
SYMBOL: compile-queue

22
basis/compiler/generator/registers/registers.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math namespaces quotations
sequences system vectors words effects alien byte-arrays
accessors sets math.order cpu.architecture
combinators hashtables kernel layouts math namespaces make
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order cpu.architecture
compiler.generator.fixup ;
IN: compiler.generator.registers
@ -50,13 +50,21 @@ C: <vreg> vreg ( n reg-class -- vreg )
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
M: vreg move-spec reg-class>> move-spec ;
M: vreg move-spec
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
M: vreg operand-class*
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
INSTANCE: vreg value
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
SINGLETON: temp-reg

40
basis/compiler/tests/alien.factor
View File

@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors ;
memory system threads tools.test math accessors combinators ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -401,3 +401,41 @@ C-STRUCT: test_struct_13
FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
[ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
! Joe Groff found this problem
C-STRUCT: double-rect
{ "double" "a" }
{ "double" "b" }
{ "double" "c" }
{ "double" "d" } ;
: <double-rect> ( a b c d -- foo )
"double-rect" <c-object>
{
[ set-double-rect-d ]
[ set-double-rect-c ]
[ set-double-rect-b ]
[ set-double-rect-a ]
[ ]
} cleave ;
: >double-rect< ( foo -- a b c d )
{
[ double-rect-a ]
[ double-rect-b ]
[ double-rect-c ]
[ double-rect-d ]
} cleave ;
: double-rect-callback ( -- alien )
"void" { "void*" "void*" "double-rect" } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
"void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
assocs namespaces make compiler.units ;
IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
basis/compiler/tests/templates-early.factor
View File

@ -3,7 +3,7 @@ IN: compiler.tests
USING: compiler compiler.generator compiler.generator.registers
compiler.generator.registers.private tools.test namespaces
sequences words kernel math effects definitions compiler.units
accessors cpu.architecture ;
accessors cpu.architecture make ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;

45
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -10,12 +10,13 @@ compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.checker ;
: cleaned-up-tree ( quot -- nodes )
build-tree normalize propagate cleanup dup check-nodes ;
build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
@ -36,7 +37,7 @@ compiler.tree.checker ;
: inlined? ( quot seq/word -- ? )
[ cleaned-up-tree ] dip
dup word? [ 1array ] when
'[ dup #call? [ word>> , member? ] [ drop f ] if ]
'[ dup #call? [ word>> _ member? ] [ drop f ] if ]
contains-node? not ;
[ f ] [
@ -457,3 +458,43 @@ cell-bits 32 = [
[ [ >r "A" throw r> ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
! Regression from benchmark.nsieve
: chicken-fingers ( i seq -- )
2dup < [
2drop
] [
chicken-fingers
] if ; inline recursive
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
>r 1+ r> buffalo-wings
] [
2drop
] if ; inline recursive
[ t ] [
[ 2 swap >fixnum buffalo-wings ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
! A reduction
: buffalo-sauce f ;
: steak ( -- )
buffalo-sauce [ steak ] when ; inline recursive
: ribs ( i seq -- )
2dup < [
steak
>r 1+ r> ribs
] [
2drop
] if ; inline recursive
[ t ] [
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test

8
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -101,7 +101,7 @@ M: #declare cleanup* drop f ;
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
,
_
[ [ [ drop ] [ delete-nodes ] if ] 2each ]
[ select-children ]
2bi
@ -148,9 +148,9 @@ M: #branch cleanup*
M: #phi cleanup*
#! Remove #phi function inputs which no longer exist.
live-branches get
[ '[ , sift-children ] change-phi-in-d ]
[ '[ , sift-children ] change-phi-info-d ]
[ '[ , sift-children ] change-terminated ] tri
[ '[ _ sift-children ] change-phi-in-d ]
[ '[ _ sift-children ] change-phi-info-d ]
[ '[ _ sift-children ] change-terminated ] tri
eliminate-phi
live-branches off ;

16
basis/compiler/tree/combinators/combinators.factor
View File

@ -6,12 +6,12 @@ IN: compiler.tree.combinators
: each-node ( nodes quot: ( node -- ) -- )
dup dup '[
, [
_ [
dup #branch? [
children>> [ , each-node ] each
children>> [ _ each-node ] each
] [
dup #recursive? [
child>> , each-node
child>> _ each-node
] [ drop ] if
] if
] bi
@ -21,22 +21,22 @@ IN: compiler.tree.combinators
dup dup '[
@
dup #branch? [
[ [ , map-nodes ] map ] change-children
[ [ _ map-nodes ] map ] change-children
] [
dup #recursive? [
[ , map-nodes ] change-child
[ _ map-nodes ] change-child
] when
] if
] map flatten ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
, keep swap [ drop t ] [
_ keep swap [ drop t ] [
dup #branch? [
children>> [ , contains-node? ] contains?
children>> [ _ contains-node? ] contains?
] [
dup #recursive? [
child>> , contains-node?
child>> _ contains-node?
] [ drop f ] if
] if
] if

6
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -33,7 +33,7 @@ M: #branch remove-dead-code*
: live-value-indices ( values -- indices )
[ length ] keep live-values get
'[ , nth , key? ] filter ; inline
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ nths ] 2bi
@ -44,13 +44,13 @@ M: #branch remove-dead-code*
: insert-drops ( nodes values indices -- nodes' )
'[
over ends-with-terminate?
[ drop ] [ , drop-indexed-values suffix ] if
[ drop ] [ _ drop-indexed-values suffix ] if
] 2map ;
: hoist-drops ( #phi -- )
if-node get swap
[ phi-in-d>> ] [ out-d>> live-value-indices ] bi
'[ , , insert-drops ] change-children drop ;
'[ _ _ insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d drop ;

10
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -3,16 +3,17 @@ compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io
prettyprint words sequences.deep sequences.private arrays
classes kernel.private ;
compiler.tree.recursive compiler.tree.normalization
compiler.tree.checker tools.test kernel math stack-checker.state
accessors combinators io prettyprint words sequences.deep
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
build-tree
analyze-recursive
normalize
propagate
cleanup
@ -64,6 +65,7 @@ IN: compiler.tree.dead-code.tests
: optimize-quot ( quot -- quot' )
build-tree
analyze-recursive
normalize
propagate
cleanup

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -53,7 +53,7 @@ M: #alien-invoke compute-live-values* nip look-at-inputs ;
M: #alien-indirect compute-live-values* nip look-at-inputs ;
: filter-mapping ( assoc -- assoc' )
live-values get '[ drop , key? ] assoc-filter ;
live-values get '[ drop _ key? ] assoc-filter ;
: filter-corresponding ( new old -- old' )
#! Remove elements from 'old' if the element with the same

4
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs fry match accessors namespaces effects
USING: kernel assocs fry match accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints
@ -16,7 +16,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
[ '[ , ] ] assoc-map '[ , match-cond ] ;
[ [ ] curry ] assoc-map [ match-cond ] curry ;
MATCH-VARS: ?a ?b ?c ;

17
basis/compiler/tree/def-use/def-use-tests.factor
View File

@ -1,9 +1,10 @@
USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
sorting math.order binary-search compiler.tree.checker ;
compiler.tree.recursive compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.def-use arrays kernel.private sorting math.order
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
@ -18,6 +19,7 @@ IN: compiler.tree.def-use.tests
: test-def-use ( quot -- )
build-tree
analyze-recursive
normalize
propagate
cleanup
@ -27,7 +29,14 @@ IN: compiler.tree.def-use.tests
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
[ ] [
[ too-deep ]
build-tree
analyze-recursive
normalize
compute-def-use
check-nodes
] unit-test
! compute-def-use checks for SSA violations, so we use that to
! ensure we generate some common patterns correctly.

16
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -1,13 +1,14 @@
IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple
compiler.intrinsics namespaces compiler.tree.propagation.info
stack-checker.errors kernel.private ;
compiler.tree.recursive compiler.tree.normalization
math.functions compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple compiler.intrinsics namespaces
compiler.tree.propagation.info stack-checker.errors
kernel.private ;
\ escape-analysis must-infer
@ -28,6 +29,7 @@ M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
analyze-recursive
normalize
propagate
cleanup

4
basis/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -28,7 +28,7 @@ IN: compiler.tree.escape-analysis.recursive
: recursive-stacks ( #enter-recursive -- stacks )
recursive-phi-in
escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
escaping-values get '[ [ _ disjoint-set-member? ] all? ] filter
flip ;
: analyze-recursive-phi ( #enter-recursive -- )
@ -67,5 +67,5 @@ M: #return-recursive escape-analysis* ( #return-recursive -- )
[ call-next-method ]
[
[ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each
[ out-d>> escaping-values get '[ _ equate ] 2each ] with each
] bi ;

6
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
fry namespaces math math.order memoize classes.builtin
fry namespaces make math math.order memoize classes.builtin
classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.propagation.info
@ -39,6 +40,7 @@ M: #shuffle finalize*
: splice-quot ( quot -- nodes )
[
build-tree
analyze-recursive
normalize
propagate
cleanup
@ -68,7 +70,7 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
[ '[ [ , set-slot ] keep ] % ] each
[ '[ [ _ set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )

98
basis/compiler/tree/identities/identities.factor Normal file
View File

@ -0,0 +1,98 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry words math
math.partial-dispatch combinators arrays hashtables
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info ;
IN: compiler.tree.identities
: define-identities ( word identities -- )
[ integer-derived-ops ] dip
'[ _ "identities" set-word-prop ] each ;
SYMBOL: X
\ + {
{ { X 0 } drop }
{ { 0 X } nip }
} define-identities
\ - {
{ { X 0 } drop }
} define-identities
\ * {
{ { X 1 } drop }
{ { 1 X } nip }
{ { X 0 } nip }
{ { 0 X } drop }
} define-identities
\ / {
{ { X 1 } drop }
} define-identities
\ mod {
{ { X 1 } 0 }
} define-identities
\ rem {
{ { X 1 } 0 }
} define-identities
\ bitand {
{ { X -1 } drop }
{ { -1 X } nip }
{ { X 0 } nip }
{ { 0 X } drop }
} define-identities
\ bitor {
{ { X 0 } drop }
{ { 0 X } nip }
{ { X -1 } nip }
{ { -1 X } drop }
} define-identities
\ bitxor {
{ { X 0 } drop }
{ { 0 X } nip }
} define-identities
\ shift {
{ { 0 X } drop }
{ { X 0 } drop }
} define-identities
: matches? ( pattern infos -- ? )
[ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ;
: find-identity ( patterns infos -- result )
'[ first _ matches? ] find swap [ second ] when ;
GENERIC: apply-identities* ( node -- node )
: simplify-to-constant ( #call constant -- nodes )
[ [ in-d>> #drop ] [ out-d>> first ] bi ] dip swap #push
2array ;
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
pick nth over first associate #shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [
over node-input-infos find-identity [
{
{ \ drop [ 0 select-input ] }
{ \ nip [ 1 select-input ] }
[ simplify-to-constant ]
} case
] when*
] when* ;
M: node apply-identities* ;
: apply-identities ( nodes -- nodes' )
[ apply-identities* ] map-nodes ;

36
basis/compiler/tree/normalization/introductions/introductions.factor Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences accessors math kernel
compiler.tree ;
IN: compiler.tree.normalization.introductions
SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each
introductions get
] with-scope ;
: introductions+ ( n -- ) introductions [ + ] change ;
M: #introduce count-introductions*
out-d>> length introductions+ ;
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
introductions+ ;
M: #recursive count-introductions*
[ label>> ] [ child>> count-introductions ] bi
>>introductions
drop ;
M: node count-introductions* drop ;

20
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -1,5 +1,8 @@
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
USING: compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
@ -22,27 +25,30 @@ sequences accessors tools.test kernel math ;
[ 0 2 ] [
[ foo ] build-tree
[ recursive-inputs ]
[ normalize recursive-inputs ] bi
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
: test-normalization ( quot -- )
build-tree analyze-recursive normalize check-nodes ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
[ ] [ [ bbb ] test-normalization ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
[ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee
: ddd ( -- ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive
[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
[ ] [ [ eee ] test-normalization ] unit-test
: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
[ ] [ [ call-recursive-5 swap ] test-normalization ] unit-test

113
basis/compiler/tree/normalization/normalization.factor
View File

@ -6,7 +6,9 @@ stack-checker.backend
stack-checker.branches
stack-checker.inlining
compiler.tree
compiler.tree.combinators ;
compiler.tree.combinators
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming ;
IN: compiler.tree.normalization
! A transform pass done before optimization can begin to
@ -16,9 +18,6 @@ IN: compiler.tree.normalization
! replaced with a single one, at the beginning of a program.
! This simplifies subsequent analysis.
!
! - We collect #return-recursive and #call-recursive nodes and
! store them in the #recursive's label slot.
!
! - We normalize #call-recursive as follows. The stack checker
! says that the inputs of a #call-recursive are the entire stack
! at the time of the call. This is a conservative estimate; we
@ -28,93 +27,6 @@ IN: compiler.tree.normalization
! #call-recursive into a #copy of the unchanged values and a
! #call-recursive with trimmed inputs and outputs.
! Collect introductions
SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each
introductions get
] with-scope ;
: introductions+ ( n -- ) introductions [ + ] change ;
M: #introduce count-introductions*
out-d>> length introductions+ ;
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
introductions+ ;
M: #recursive count-introductions*
[ label>> ] [ child>> count-introductions ] bi
>>introductions
drop ;
M: node count-introductions* drop ;
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info
dup label>> (>>return) ;
M: #call-recursive collect-label-info
dup label>> calls>> push ;
M: #recursive collect-label-info
label>> V{ } clone >>calls drop ;
M: node collect-label-info drop ;
! Rename
SYMBOL: rename-map
: rename-value ( value -- value' )
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ , at ] keep or ] map ;
GENERIC: rename-node-values* ( node -- node )
M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
M: #phi rename-node-values*
[ [ rename-values ] map ] change-phi-in-d ;
M: #declare rename-node-values*
[ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
M: #alien-callback rename-node-values* ;
M: node rename-node-values*
[ rename-values ] change-in-d ;
: rename-node-values ( nodes -- nodes' )
dup [ rename-node-values* drop ] each-node ;
! Normalize
GENERIC: normalize* ( node -- node' )
SYMBOL: introduction-stack
@ -125,10 +37,6 @@ SYMBOL: introduction-stack
: pop-introductions ( n -- values )
introduction-stack [ swap cut* swap ] change ;
: add-renamings ( old new -- )
[ rename-values ] dip
rename-map get '[ , set-at ] 2each ;
M: #introduce normalize*
out-d>> [ length pop-introductions ] keep add-renamings f ;
@ -158,7 +66,7 @@ M: #branch normalize*
M: #phi normalize*
remaining-introductions get swap dup terminated>>
'[ , eliminate-phi-introductions ] change-phi-in-d ;
'[ _ eliminate-phi-introductions ] change-phi-in-d ;
: (normalize) ( nodes introductions -- nodes )
introduction-stack [
@ -168,7 +76,7 @@ M: #phi normalize*
M: #recursive normalize*
dup label>> introductions>>
[ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
[ make-values '[ , (normalize) ] change-child ]
[ make-values '[ _ (normalize) ] change-child ]
2bi ;
M: #enter-recursive normalize*
@ -181,14 +89,14 @@ M: #enter-recursive normalize*
: call<return ( #call-recursive n -- nodes )
neg dup make-values [
[ pop-introductions '[ , prepend ] change-in-d ]
[ '[ , prepend ] change-out-d ]
[ pop-introductions '[ _ prepend ] change-in-d ]
[ '[ _ prepend ] change-out-d ]
bi*
] [ introduction-stack [ prepend ] change ] bi ;
: call>return ( #call-recursive n -- #call-recursive )
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
[ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ _ head ] ] bi* bi@ add-renamings ]
[ '[ _ tail ] [ change-in-d ] [ change-out-d ] bi ]
2bi ;
M: #call-recursive normalize*
@ -201,9 +109,8 @@ M: #call-recursive normalize*
M: node normalize* ;
: normalize ( nodes -- nodes' )
H{ } clone rename-map set
dup [ collect-label-info ] each-node
dup count-introductions make-values
H{ } clone rename-map set
[ (normalize) ] [ nip ] 2bi
[ #introduce prefix ] unless-empty
rename-node-values ;

48
basis/compiler/tree/normalization/renaming/renaming.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel accessors sequences fry
compiler.tree compiler.tree.combinators ;
IN: compiler.tree.normalization.renaming
SYMBOL: rename-map
: rename-value ( value -- value' )
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ _ at ] keep or ] map ;
: add-renamings ( old new -- )
[ rename-values ] dip
rename-map get '[ _ set-at ] 2each ;
GENERIC: rename-node-values* ( node -- node )
M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;
M: #phi rename-node-values*
[ [ rename-values ] map ] change-phi-in-d ;
M: #declare rename-node-values*
[ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
M: #alien-callback rename-node-values* ;
M: node rename-node-values*
[ rename-values ] change-in-d ;
: rename-node-values ( nodes -- nodes' )
dup [ rename-node-values* drop ] each-node ;

6
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@ -17,12 +18,13 @@ IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
propagate
cleanup
detect-loops
escape-analysis
unbox-tuples
apply-identities
compute-def-use
remove-dead-code
! strength-reduce

4
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -32,7 +32,7 @@ M: #if live-branches
M: #dispatch live-branches
[ children>> length ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? ] map ;
'[ _ interval-contains? ] map ;
: live-children ( #branch -- children )
[ children>> ] [ live-branches>> ] bi select-children ;
@ -61,7 +61,7 @@ SYMBOL: infer-children-data
infer-children-data get
[
'[
, [
_ [
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind

14
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -6,11 +6,20 @@ classes.algebra classes.union sets quotations assocs combinators
words namespaces
compiler.tree
compiler.tree.builder
compiler.tree.recursive
compiler.tree.combinators
compiler.tree.normalization
compiler.tree.propagation.info
compiler.tree.propagation.nodes ;
IN: compiler.tree.propagation.inlining
! We count nodes up-front; if there are relatively few nodes,
! we are more eager to inline
SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
@ -18,7 +27,7 @@ M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes
build-sub-tree normalize ;
build-sub-tree analyze-recursive normalize ;
: propagate-body ( #call -- )
body>> (propagate) ;
@ -113,12 +122,13 @@ DEFER: (flat-length)
[ classes-known? 2 0 ? ]
[
{
[ drop node-count get 45 swap [-] 8 /i ]
[ flat-length 24 swap [-] 4 /i ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
] bi* + + + + ;
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
inlining-rank 5 >= ;

14
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -118,7 +118,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: binary-op ( word interval-quot post-proc-quot -- )
'[
[ binary-op-class ] [ , binary-op-interval ] 2bi
[ binary-op-class ] [ _ binary-op-interval ] 2bi
@
<class/interval-info>
] "outputs" set-word-prop ;
@ -159,14 +159,14 @@ most-negative-fixnum most-positive-fixnum [a,b]
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
: define-comparison-constraints ( word op -- )
'[ , comparison-constraints ] "constraints" set-word-prop ;
'[ _ comparison-constraints ] "constraints" set-word-prop ;
comparison-ops
[ dup '[ , define-comparison-constraints ] each-derived-op ] each
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
generic-comparison-ops [
dup specific-comparison
'[ , , define-comparison-constraints ] each-derived-op
'[ _ _ define-comparison-constraints ] each-derived-op
] each
! Remove redundant comparisons
@ -179,13 +179,13 @@ generic-comparison-ops [
comparison-ops [
dup '[
[ , fold-comparison ] "outputs" set-word-prop
[ _ fold-comparison ] "outputs" set-word-prop
] each-derived-op
] each
generic-comparison-ops [
dup specific-comparison
'[ , fold-comparison ] "outputs" set-word-prop
'[ _ fold-comparison ] "outputs" set-word-prop
] each
: maybe-or-never ( ? -- info )
@ -221,7 +221,7 @@ generic-comparison-ops [
{ >float float }
} [
'[
,
_
[ nip ] [
[ interval>> ] [ class-interval ] bi*
interval-intersect

3
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation
compiler.tree.propagation compiler.tree.recursive
compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
@ -14,6 +14,7 @@ IN: compiler.tree.propagation.tests
: final-info ( quot -- seq )
build-tree
analyze-recursive
normalize
propagate
compute-def-use

2
basis/compiler/tree/propagation/propagation.factor
View File

@ -6,6 +6,7 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.inlining
compiler.tree.propagation.branches
compiler.tree.propagation.recursive
compiler.tree.propagation.constraints
@ -18,4 +19,5 @@ IN: compiler.tree.propagation
H{ } clone copies set
H{ } clone constraints set
H{ } clone value-infos set
dup count-nodes
dup (propagate) ;

3
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -70,7 +70,8 @@ M: #recursive propagate-around ( #recursive -- )
[ generalize-return-interval ] map ;
: return-infos ( node -- infos )
label>> return>> node-input-infos generalize-return ;
label>> [ return>> node-input-infos ] [ loop?>> ] bi
[ generalize-return ] unless ;
M: #call-recursive propagate-before ( #call-recursive -- )
[ ] [ return-infos ] [ node-output-infos ] tri

4
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -68,8 +68,8 @@ M: #declare propagate-before
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
'[ , , with-datastack [ <literal-info> ] map nip ]
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
'[ _ _ with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;

36
basis/compiler/tree/loop/detection/detection-tests.factor → basis/compiler/tree/recursive/recursive-tests.factor
View File

@ -1,5 +1,5 @@
IN: compiler.tree.loop.detection.tests
USING: compiler.tree.loop.detection tools.test
IN: compiler.tree.recursive.tests
USING: compiler.tree.recursive tools.test
kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
@ -10,7 +10,7 @@ compiler.tree.combinators ;
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
\ detect-loops must-infer
\ analyze-recursive must-infer
: label-is-loop? ( nodes word -- ? )
[
@ -38,22 +38,22 @@ compiler.tree.combinators ;
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree detect-loops
[ loop-test-1 ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] build-tree detect-loops
[ loop-test-1 1 2 3 ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
[ [ loop-test-1 ] each ] build-tree analyze-recursive
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] build-tree detect-loops
[ [ loop-test-1 ] each ] build-tree analyze-recursive
\ (each-integer) label-is-loop?
] unit-test
@ -61,7 +61,7 @@ compiler.tree.combinators ;
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree detect-loops
[ loop-test-2 ] build-tree analyze-recursive
\ loop-test-2 label-is-not-loop?
] unit-test
@ -69,7 +69,7 @@ compiler.tree.combinators ;
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-3 ] build-tree detect-loops
[ loop-test-3 ] build-tree analyze-recursive
\ loop-test-3 label-is-not-loop?
] unit-test
@ -81,7 +81,7 @@ compiler.tree.combinators ;
] if ; inline recursive
[ f ] [
[ [ [ ] map ] map ] build-tree detect-loops
[ [ [ ] map ] map ] build-tree analyze-recursive
[
dup #recursive? [ label>> loop?>> not ] [ drop f ] if
] contains-node?
@ -98,22 +98,22 @@ DEFER: a
blah [ b ] [ a ] if ; inline recursive
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] build-tree detect-loops
[ b ] build-tree analyze-recursive
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] build-tree detect-loops
[ a ] build-tree analyze-recursive
\ b label-is-loop?
] unit-test
@ -126,12 +126,12 @@ DEFER: a'
blah [ b' ] [ a' ] if ; inline recursive
[ f ] [
[ a' ] build-tree detect-loops
[ a' ] build-tree analyze-recursive
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] build-tree detect-loops
[ b' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test
@ -140,11 +140,11 @@ DEFER: a'
! sound.
[ t ] [
[ b' ] build-tree detect-loops
[ b' ] build-tree analyze-recursive
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] build-tree detect-loops
[ a' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test

24
basis/compiler/tree/loop/detection/detection.factor → basis/compiler/tree/recursive/recursive.factor
View File

@ -1,14 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs accessors fry
compiler.tree deques search-deques ;
IN: compiler.tree.loop.detection
USING: kernel assocs namespaces accessors sequences deques
search-deques compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info
dup label>> (>>return) ;
M: #call-recursive collect-label-info
dup label>> calls>> push ;
M: #recursive collect-label-info
label>> V{ } clone >>calls drop ;
M: node collect-label-info drop ;
! A loop is a #recursive which only tail calls itself, and those
! calls are nested inside other loops only. We optimistically
! assume all #recursive nodes are loops, disqualifying them as
! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
@ -84,5 +97,6 @@ M: node collect-loop-info* 2drop ;
] [ drop ] if
] slurp-deque ;
: detect-loops ( nodes -- nodes )
: analyze-recursive ( nodes -- nodes )
dup [ collect-label-info ] each-node
dup collect-loop-info disqualify-loops ;

2
basis/compiler/tree/tree.factor
View File

@ -178,7 +178,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
'[ , at ] map
'[ _ at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )

14
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -1,16 +1,18 @@
IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.escape-analysis compiler.tree.tuple-unboxing
compiler.tree.checker compiler.tree.def-use kernel accessors
sequences math math.private sorting math.order binary-search
sequences.private slots.private ;
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.checker
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
build-tree
analyze-recursive
normalize
propagate
cleanup

7
basis/concurrency/messaging/messaging-tests.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations deques strings math words
match quotations concurrency.messaging concurrency.mailboxes
USING: kernel threads vectors arrays sequences namespaces make
tools.test continuations deques strings math words match
quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests

6
basis/core-foundation/fsevents/fsevents.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces assocs init accessors continuations
combinators core-foundation core-foundation.run-loop
io.encodings.utf8 destructors ;
math sequences namespaces make assocs init accessors
continuations combinators core-foundation
core-foundation.run-loop io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !

4
basis/cpu/architecture/architecture.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays combinators words sets ;
namespaces make sequences layouts system hashtables classes
alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes

2
basis/cpu/ppc/architecture/architecture.factor
View File

@ -5,7 +5,7 @@ cpu.architecture generic kernel kernel.private math memory
namespaces sequences words assocs compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts classes words.private alien combinators
compiler.constants math.order ;
compiler.constants math.order make ;
IN: cpu.ppc.architecture
! PowerPC register assignments

2
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -1,6 +1,6 @@
IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
vocabs sequences ;
make vocabs sequences ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;

2
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces sequences
USING: compiler.generator.fixup kernel namespaces make sequences
words math math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend

3
basis/cpu/x86/32/32.factor
View File

@ -173,6 +173,9 @@ M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
: struct-return@ ( size n -- n )
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
M: x86.32 %box-large-struct ( n size -- )
! Compute destination address
[ swap struct-return@ ] keep

10
basis/cpu/x86/64/64.factor
View File

@ -3,9 +3,10 @@
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts alien alien.accessors
alien.structs slots splitting assocs ;
namespaces make sequences compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts alien alien.accessors alien.structs slots splitting
assocs ;
IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
@ -115,6 +116,9 @@ M: x86.64 %box-small-struct ( size -- )
RDX swap MOV
"box_small_struct" f %alien-invoke ;
: struct-return@ ( size n -- n )
[ ] [ \ stack-frame get swap - ] ?if ;
M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2
RSI over MOV

9
basis/cpu/x86/architecture/architecture.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces sequences words compiler.generator
math memory namespaces make sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
IN: cpu.x86.architecture
@ -141,13 +141,6 @@ M: x86 small-enough? ( n -- ? )
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
: struct-return@ ( size n -- n )
[
stack-frame* cell + +
] [
\ stack-frame get swap -
] ?if ;
HOOK: %unbox-struct-1 cpu ( -- )
HOOK: %unbox-struct-2 cpu ( -- )

2
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,4 +1,4 @@
USING: cpu.x86.assembler kernel tools.test namespaces ;
USING: cpu.x86.assembler kernel tools.test namespaces make ;
IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays compiler.generator.fixup io.binary kernel
combinators kernel.private math namespaces sequences
combinators kernel.private math namespaces make sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler

3
basis/csv/csv.factor
View File

@ -4,7 +4,8 @@
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces combinators unicode.categories ;
USING: kernel sequences io namespaces make
combinators unicode.categories ;
IN: csv
SYMBOL: delimiter

4
basis/db/db-docs.factor
View File

@ -12,11 +12,11 @@ HELP: new-db
{ $description "Creates a new database object from a given class." } ;
HELP: make-db*
{ $values { "seq" sequence } { "db" object } { "db" object } }
{ $values { "object" object } { "db" object } { "db" object } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: make-db
{ $values { "seq" sequence } { "class" class } { "db" db } }
{ $values { "object" object } { "class" class } { "db" db } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: db-open

2
basis/db/postgresql/postgresql.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker

8
basis/db/queries/queries.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random strings
math.parser math.intervals combinators math.bitwise nmake db
db.tuples db.types db.sql classes words shuffle arrays destructors
continuations ;
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types db.sql classes words shuffle arrays
destructors continuations ;
IN: db.queries
GENERIC: where ( specs obj -- )

2
basis/db/tuples/tuples-docs.factor
View File

@ -154,7 +154,7 @@ T{ book
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
'[ "book-tutorial.db" temp-file sqlite-db , with-db ] call ;
'[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
[
book recreate-table

4
basis/db/tuples/tuples-tests.factor
View File

@ -201,10 +201,10 @@ TUPLE: annotation n paste-id summary author mode contents ;
! ] with-db
: test-sqlite ( quot -- )
[ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
[ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
: test-postgresql ( quot -- )
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test

12
basis/debugger/debugger.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces prettyprint prettyprint.config sequences
assocs sequences.private strings io.styles io.files vectors
words system splitting math.parser classes.tuple continuations
continuations.private combinators generic.math classes.builtin
classes compiler.units generic.standard vocabs init
kernel.private io.encodings accessors math.order
kernel math namespaces make prettyprint prettyprint.config
sequences assocs sequences.private strings io.styles io.files
vectors words system splitting math.parser classes.tuple
continuations continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
init kernel.private io.encodings accessors math.order
destructors source-files parser classes.tuple.parser
effects.parser lexer compiler.errors generic.parser
strings.parser ;

2
basis/debugger/threads/threads.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors debugger continuations threads threads.private
io io.styles prettyprint kernel math.parser namespaces ;
io io.styles prettyprint kernel math.parser namespaces make ;
IN: debugger.threads
: error-in-thread. ( thread -- )

2
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces ;
prettyprint math hashtables sets macros namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )

8
basis/disjoint-sets/disjoint-sets.factor
View File

@ -64,7 +64,7 @@ M: disjoint-set add-atom
[ 1 -rot counts>> set-at ]
2tri ;
: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
@ -89,7 +89,7 @@ M:: disjoint-set equate ( a b disjoint-set -- )
] if ;
: equate-all-with ( seq a disjoint-set -- )
'[ , , equate ] each ;
'[ _ _ equate ] each ;
: equate-all ( seq disjoint-set -- )
over empty? [ 2drop ] [
@ -102,7 +102,7 @@ M: disjoint-set clone
: assoc>disjoint-set ( assoc -- disjoint-set )
<disjoint-set>
[ '[ drop , add-atom ] assoc-each ]
[ '[ , equate ] assoc-each ]
[ '[ drop _ add-atom ] assoc-each ]
[ '[ _ equate ] assoc-each ]
[ nip ]
2tri ;

2
basis/documents/documents.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
math.order ;
IN: documents

55
basis/fry/fry-docs.factor
View File

@ -1,15 +1,12 @@
USING: help.markup help.syntax quotations kernel ;
IN: fry
HELP: ,
HELP: _
{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;
HELP: @
{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;
HELP: _
{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ;
HELP: fry
{ $values { "quot" quotation } { "quot'" quotation } }
{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
@ -19,7 +16,7 @@ HELP: fry
HELP: '[
{ $syntax "code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
@ -27,69 +24,50 @@ ARTICLE: "fry.examples" "Examples of fried quotations"
$nl
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
{ $code "{ 10 20 30 } '[ . ] each" }
"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ , + ] map"
"{ 10 20 30 } 5 '[ _ + ] map"
"{ 10 20 30 } 5 [ + ] curry map"
"{ 10 20 30 } [ 5 + ] map"
}
"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
{ $code
"{ 10 20 30 } 5 '[ 3 , / ] map"
"{ 10 20 30 } 5 '[ 3 _ / ] map"
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
"{ 10 20 30 } [ 3 5 / ] map"
}
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ call . ] curry each"
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed:"
{ $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? dup 5 ? ] map"
}
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"
{ $code
"{ 10 20 30 } 1 '[ , _ / ] map"
"{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"
"{ 10 20 30 } 1 [ swap / ] curry map"
"{ 10 20 30 } [ 1 swap / ] map"
}
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"
{ $code
"[ [ X ] dip ]"
"'[ X _ ]"
}
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ , ] ;" } }
{ { $link slip } { $snippet ": slip '[ @ , ] call ;" } }
{ { $link dip } { $snippet ": dip '[ @ _ ] call ;" } }
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } }
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
{ { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
{ { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
} ;
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
{ $code
"'[ [ , key? ] all? ] filter"
"'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 , + 4 , / ]"
"'[ 3 _ + 4 _ / ]"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
}
"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:"
{ $code
"'[ , 2 + , * _ / ]"
"[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]"
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
@ -101,9 +79,8 @@ $nl
"Fried quotations are denoted with a special parsing word:"
{ $subsection POSTPONE: '[ }
"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
{ $subsection , }
{ $subsection @ }
{ $subsection _ }
{ $subsection @ }
"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }

34
basis/fry/fry-tests.factor
View File

@ -2,63 +2,59 @@ IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
sequences ;
[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ]
[ "a" "b" '[ , write , print ] ] unit-test
[ "a" "b" '[ _ write _ print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [
1 '[ , _ / ] 2 swap call
1 '[ [ _ ] dip / ] 2 swap call
] unit-test
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
1 '[ , _ _ 3array ]
1 '[ [ _ ] 2dip 3array ]
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
] unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
'[ 1 _ 2array ]
'[ [ 1 ] dip 2array ]
{ "a" "b" "c" } swap map
] unit-test
[ 1 2 ] [
1 2 '[ _ , ] call
] unit-test
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
1 2 '[ , _ , 3array ]
1 2 '[ [ _ ] dip _ 3array ]
{ "a" "b" "c" } swap map
] unit-test
: funny-dip '[ @ _ ] call ; inline
: funny-dip '[ [ @ ] dip ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
3 1 '[ , [ , + ] map ] call
3 1 '[ _ [ _ + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
1 2 3 '[ _ [ _ [ _ 1array ] call 2array ] call 2array ] call
] unit-test
{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
{ 1 1 } [ '[ [ [ _ ] ] ] ] must-infer-as
[ { { { 3 } } } ] [
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ { { { 3 } } } ] [
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test

49
basis/fry/fry.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
quotations arrays namespaces qualified ;
QUALIFIED: namespaces
quotations arrays make qualified words ;
IN: fry
: , ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ;
: _ ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ;
<PRIVATE
DEFER: (shallow-fry)
DEFER: shallow-fry
@ -19,48 +19,33 @@ DEFER: shallow-fry
] unless-empty ; inline
: (shallow-fry) ( accum quot -- result )
[
1quotation
] [
[ 1quotation ] [
unclip {
{ \ , [ [ curry ] ((shallow-fry)) ] }
{ \ _ [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
! to avoid confusion, remove if fry goes core
{ \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
[ swap >r suffix r> (shallow-fry) ]
} case
] if-empty ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: deep-fry ( quot -- quot )
{ _ } last-split1 dup [
shallow-fry [ >r ] rot
deep-fry [ [ dip ] curry r> compose ] 4array concat
] [
drop shallow-fry
] if ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
GENERIC: count-inputs ( quot -- n )
M: callable count-inputs [ count-inputs ] sigma ;
M: fry-specifier count-inputs drop 1 ;
M: object count-inputs drop 0 ;
PRIVATE>
: count-inputs ( quot -- n )
[
{
{ [ dup callable? ] [ count-inputs ] }
{ [ dup fry-specifier? ] [ drop 1 ] }
[ drop 0 ]
} cond
] map sum ;
: fry ( quot -- quot' )
[
[
dup callable? [
[ count-inputs \ , <repetition> % ] [ fry % ] bi
] [ namespaces:, ] if
[ count-inputs \ _ <repetition> % ] [ fry % ] bi
] [ , ] if
] each
] [ ] make deep-fry ;
] [ ] make shallow-fry ;
: '[ \ ] parse-until fry over push-all ; parsing

6
basis/furnace/actions/actions.factor
View File

@ -60,7 +60,7 @@ TUPLE: action rest authorize init display validate submit ;
: handle-get ( action -- response )
'[
, dup display>> [
_ dup display>> [
{
[ init>> call ]
[ authorize>> call ]
@ -90,7 +90,7 @@ TUPLE: action rest authorize init display validate submit ;
: handle-post ( action -- response )
'[
, dup submit>> [
_ dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
@ -133,4 +133,4 @@ TUPLE: page-action < action template ;
: <page-action> ( -- page )
page-action new-action
dup '[ , template>> <chloe-content> ] >>display ;
dup '[ _ template>> <chloe-content> ] >>display ;

4
basis/furnace/alloy/alloy.factor
View File

@ -14,7 +14,7 @@ IN: furnace.alloy
'[
<conversations>
<sessions>
, , <db-persistence>
_ _ <db-persistence>
<check-form-submissions>
] call ;
@ -26,5 +26,5 @@ IN: furnace.alloy
: start-expiring ( db params -- )
'[
, , [ state-classes [ expire-state ] each ] with-db
_ _ [ state-classes [ expire-state ] each ] with-db
] 5 minutes every drop ;

2
basis/furnace/auth/auth.factor
View File

@ -125,7 +125,7 @@ TUPLE: secure-realm-only < filter-responder ;
C: <secure-realm-only> secure-realm-only
M: secure-realm-only call-responder*
'[ , , call-next-method ] if-secure-realm ;
'[ _ _ call-next-method ] if-secure-realm ;
TUPLE: protected < filter-responder description capabilities ;

2
basis/furnace/auth/basic/basic.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel splitting base64 namespaces strings
USING: accessors kernel splitting base64 namespaces make strings
http http.server.responses furnace.auth ;
IN: furnace.auth.basic

6
basis/furnace/auth/features/recover-password/recover-password.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors kernel assocs arrays io.sockets threads
fry urls smtp validators html.forms present
USING: namespaces make accessors kernel assocs arrays io.sockets
threads fry urls smtp validators html.forms present
http http.server.responses http.server.redirection
http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
@ -43,7 +43,7 @@ SYMBOL: lost-password-from
] "" make >>body ;
: send-password-email ( user -- )
'[ , password-email send-email ]
'[ _ password-email send-email ]
"E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action )

4
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -56,7 +56,7 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
attrs>> '[ [ , _ link-attr ] each-responder ] [code] ;
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ compile-link-attrs ] [ compile-a-url ] bi
@ -72,7 +72,7 @@ CHLOE: a
: compile-hidden-form-fields ( for -- )
'[
, [ "," split [ hidden render ] each ] when*
_ [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
] [code] ;

4
basis/furnace/conversations/conversations.factor
View File

@ -109,8 +109,8 @@ M: conversations call-responder*
: restore-conversation ( seq -- )
conversation get dup [
namespace>>
[ '[ , key? ] filter ]
[ '[ [ , at ] keep set ] each ]
[ '[ _ key? ] filter ]
[ '[ [ _ at ] keep set ] each ]
bi
] [ 2drop ] if ;

2
basis/furnace/furnace.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences kernel classes splitting
USING: namespaces make assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements

2
basis/furnace/redirection/redirection.factor
View File

@ -42,4 +42,4 @@ C: <secure-only> secure-only
} cond ; inline
M: secure-only call-responder*
'[ , , call-next-method ] if-secure ;
'[ _ _ call-next-method ] if-secure ;

11
basis/furnace/sessions/sessions-tests.factor
View File

@ -1,10 +1,9 @@
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
math namespaces kernel accessors io.sockets io.servers.connection
prettyprint io.streams.string io.files splitting destructors
sequences db db.tuples db.sqlite continuations urls math.parser
furnace ;
USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers.connection prettyprint
io.streams.string io.files splitting destructors sequences db
db.tuples db.sqlite continuations urls math.parser furnace ;
: with-session
[

2
basis/furnace/syndication/syndication.factor
View File

@ -44,7 +44,7 @@ TUPLE: feed-action < action title url entries ;
feed-action new-action
dup '[
feed new
,
_
[ title>> call >>title ]
[ url>> call adjust-url relative-to-request >>url ]
[ entries>> call process-entries >>entries ]

20
basis/generalizations/generalizations.factor
View File

@ -6,24 +6,24 @@ math.ranges combinators macros quotations fry arrays ;
IN: generalizations
MACRO: nsequence ( n seq -- quot )
[ drop <reversed> ] [ '[ , , new-sequence ] ] 2bi
[ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;
MACRO: narray ( n -- quot )
'[ , { } nsequence ] ;
'[ _ { } nsequence ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ , _ nth-unsafe ] ] map ]
[ 1- '[ , _ bounds-check 2drop ] ]
bi prefix '[ , cleave ]
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ]
] if ;
MACRO: npick ( n -- )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- )
dup '[ , npick ] n*quot ;
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
1- dup saver swap [ r> swap ] n*quot append ;
@ -41,7 +41,7 @@ MACRO: ntuck ( n -- )
2 + [ dupd -nrot ] curry ;
MACRO: nrev ( n -- quot )
1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- )
dup saver -rot restorer 3append ;
@ -51,7 +51,7 @@ MACRO: nslip ( n -- )
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
'[ [ , ndup ] dip , -nrot , nslip ] ;
'[ [ _ ndup ] dip _ -nrot _ nslip ] ;
MACRO: ncurry ( n -- )
[ curry ] n*quot ;
@ -61,5 +61,5 @@ MACRO: nwith ( n -- )
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] keep '[ , ntuck , nslip ] ]
[ [ 1- ] keep '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;

1
basis/help/handbook/handbook.factor
View File

@ -108,6 +108,7 @@ USE: io.buffers
ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsection "sequences" }
{ $subsection "namespaces-make" }
"Fixed-length sequences:"
{ $subsection "arrays" }
{ $subsection "quotations" }

4
basis/help/help.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io io.styles kernel namespaces parser
prettyprint sequences words assocs definitions generic
USING: accessors arrays io io.styles kernel namespaces make
parser prettyprint sequences words assocs definitions generic
quotations effects slots continuations classes.tuple debugger
combinators vocabs help.stylesheet help.topics help.crossref
help.markup sorting classes vocabs.loader ;

8
basis/help/lint/lint.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
help.topics words strings classes tools.vocabs namespaces make
io io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval ;
@ -39,7 +39,7 @@ IN: help.lint
$predicate
$class-description
$error-description
} swap '[ , elements empty? not ] contains? ;
} swap '[ _ elements empty? not ] contains? ;
: check-values ( word element -- )
{
@ -110,7 +110,7 @@ M: help-error error.
H{ } clone [
'[
dup >link where dup
[ first , at , push-at ] [ 2drop ] if
[ first _ at _ push-at ] [ 2drop ] if
] each
] keep ;

2
basis/help/markup/markup.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces parser prettyprint sequences strings
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
vocabs help.stylesheet help.topics vocabs.loader alias ;
IN: help.markup

2
basis/help/topics/topics.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.x
USING: accessors arrays definitions generic assocs
io kernel namespaces prettyprint prettyprint.sections
io kernel namespaces make prettyprint prettyprint.sections
sequences words summary classes strings vocabs ;
IN: help.topics

8
basis/hints/hints.factor
View File

@ -21,7 +21,7 @@ IN: hints
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
'[ _ declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
@ -30,7 +30,7 @@ IN: hints
bi prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
method-declaration '[ _ declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
@ -91,7 +91,7 @@ IN: hints
\ >string { sbuf } "specializer" set-word-prop
\ >array { { string } { vector } } "specializer" set-word-prop
\ >array { { vector } } "specializer" set-word-prop
\ >vector { { array } { vector } } "specializer" set-word-prop
@ -101,7 +101,7 @@ IN: hints
\ memq? { array } "specializer" set-word-prop
\ member? { fixnum string } "specializer" set-word-prop
\ member? { array } "specializer" set-word-prop
\ assoc-stack { vector } "specializer" set-word-prop

2
basis/html/components/components.factor
View File

@ -88,7 +88,7 @@ TUPLE: choice size multiple choices ;
</option> ;
: render-options ( options selected -- )
'[ dup , member? render-option ] each ;
'[ dup _ member? render-option ] each ;
M: choice render*
<select

10
basis/html/elements/elements.factor
View File

@ -70,7 +70,7 @@ SYMBOL: html
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
dup <foo> swap '[ , <foo> write-html ]
dup <foo> swap '[ _ <foo> write-html ]
(( -- )) html-word ;
: <foo ( str -- <str ) "<" prepend ;
@ -78,7 +78,7 @@ SYMBOL: html
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
<foo dup '[ , write-html ]
<foo dup '[ _ write-html ]
(( -- )) html-word ;
: foo> ( str -- foo> ) ">" append ;
@ -93,14 +93,14 @@ SYMBOL: html
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup '[ , write-html ] (( -- )) html-word ;
</foo> dup '[ _ write-html ] (( -- )) html-word ;
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
dup <foo/> swap '[ , <foo/> write-html ]
dup <foo/> swap '[ _ <foo/> write-html ]
(( -- )) html-word ;
: foo/> ( str -- str/> ) "/>" append ;
@ -134,7 +134,7 @@ SYMBOL: html
: define-attribute-word ( name -- )
dup "=" prepend swap
'[ , write-attr ] (( string -- )) html-word ;
'[ _ write-attr ] (( string -- )) html-word ;
! Define some closed HTML tags
[

4
basis/html/forms/forms.factor
View File

@ -63,7 +63,7 @@ SYMBOL: nested-forms
: with-form ( name quot -- )
'[
,
_
[ nested-forms [ swap prefix ] change ]
[ value form set ]
bi
@ -103,4 +103,4 @@ C: <validation-error> validation-error
swap set-value ;
: validate-values ( assoc validators -- assoc' )
swap '[ dup , at _ validate-value ] assoc-each ;
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;

11
basis/html/streams/streams.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators generic assocs help http io io.styles io.files
continuations io.streams.string kernel math math.order math.parser
namespaces quotations assocs sequences strings words html.elements
xml.entities sbufs continuations destructors accessors arrays ;
USING: combinators generic assocs help http io io.styles
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
accessors arrays ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )

7
basis/html/templates/chloe/chloe.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel fry
namespaces classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml xml.data
namespaces make classes.tuple assocs splitting words arrays
memoize io io.files io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
xml.data
html.forms
html.elements
html.components

7
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces kernel sequences accessors combinators
strings splitting io io.streams.string present xml.writer
xml.data xml.entities html.forms html.templates.chloe.syntax ;
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
xml.writer xml.data xml.entities html.forms
html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )

6
basis/html/templates/chloe/components/components.factor
View File

@ -14,13 +14,13 @@ IN: html.templates.chloe.components
: CHLOE-SINGLETON:
scan-word
[ name>> ] [ '[ , singleton-component-tag ] ] bi
[ name>> ] [ '[ _ singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> , at compile-attr ] each ]
[ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
@ -30,6 +30,6 @@ IN: html.templates.chloe.components
: CHLOE-TUPLE:
scan-word
[ name>> ] [ '[ , tuple-component-tag ] ] bi
[ name>> ] [ '[ _ tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

Some files were not shown because too many files have changed in this diff Show More