Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: basis/cocoa/types/types.factordb4
commit
eb77923e09
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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>> , ]
|
||||
|
|
|
@ -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,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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 >= ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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,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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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] ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
[
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -108,6 +108,7 @@ USE: io.buffers
|
|||
ARTICLE: "collections" "Collections"
|
||||
{ $heading "Sequences" }
|
||||
{ $subsection "sequences" }
|
||||
{ $subsection "namespaces-make" }
|
||||
"Fixed-length sequences:"
|
||||
{ $subsection "arrays" }
|
||||
{ $subsection "quotations" }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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' )
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue