From 83814f2ce4ec0bb5d4e21c0d77b5da678daa7187 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 10 May 2009 20:42:20 -0500 Subject: [PATCH 001/228] moving md5 state to a tuple, redoing hmac --- .../checksums}/hmac/authors.txt | 0 .../checksums}/hmac/hmac-tests.factor | 20 ++-- basis/checksums/hmac/hmac.factor | 49 +++++++++ basis/checksums/md5/md5.factor | 102 +++++++++++------- extra/crypto/hmac/hmac.factor | 55 ---------- 5 files changed, 125 insertions(+), 101 deletions(-) rename {extra/crypto => basis/checksums}/hmac/authors.txt (100%) rename {extra/crypto => basis/checksums}/hmac/hmac-tests.factor (56%) create mode 100755 basis/checksums/hmac/hmac.factor delete mode 100755 extra/crypto/hmac/hmac.factor diff --git a/extra/crypto/hmac/authors.txt b/basis/checksums/hmac/authors.txt similarity index 100% rename from extra/crypto/hmac/authors.txt rename to basis/checksums/hmac/authors.txt diff --git a/extra/crypto/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor similarity index 56% rename from extra/crypto/hmac/hmac-tests.factor rename to basis/checksums/hmac/hmac-tests.factor index 274e99d2f6..9541ca2f26 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,38 +1,42 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser crypto.hmac tools.test ; -IN: crypto.hmac.tests +parser checksums.hmac tools.test checksums.md5 checksums.sha1 +checksums.sha2 ; +IN: checksums.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ - 16 11 "Hi There" sequence>md5-hmac >string ] unit-test + 16 11 "Hi There" md5 hmac-bytes >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] -[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test +[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test [ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa - 50 HEX: dd sequence>md5-hmac >string + 50 HEX: dd md5 hmac-bytes >string ] unit-test [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ - 16 11 "Hi There" sequence>sha1-hmac >string + 16 11 "Hi There" sha1 hmac-bytes >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ - "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string + "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa - 50 HEX: dd sequence>sha1-hmac >string + 50 HEX: dd sha1 hmac-bytes >string ] unit-test + +[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] +[ HEX: b 20 sha-256 hmac-bytes >string ] unit-test diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor new file mode 100755 index 0000000000..7350a02573 --- /dev/null +++ b/basis/checksums/hmac/hmac.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays checksums checksums.md5 checksums.md5.private +checksums.sha1 combinators fry io io.binary io.encodings.binary +io.files io.streams.byte-array kernel math math.vectors memoize +sequences ; +IN: checksums.hmac + +sha1 get-sha1 + initialize-sha1 + [ process-sha1-block ] + [ process-sha1-block ] bi* get-sha1 ; + +: md5-hmac ( Ko Ki stream -- hmac ) + initialize-md5 process-md5-block + stream>md5 get-md5 + initialize-md5 + [ process-md5-block ] + [ process-md5-block ] bi* get-md5 ; + +: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ; + +MEMO: opad ( -- seq ) 64 HEX: 5c ; + +MEMO: ipad ( -- seq ) 64 HEX: 36 ; + +: init-K ( K -- o i ) + 64 0 pad-tail + [ opad seq-bitxor ] + [ ipad seq-bitxor ] bi ; + +PRIVATE> + +: hmac ( K stream checksum -- value ) + ; + +:: hmac-stream ( K stream checksum -- value ) + K init-K :> i :> o + stream checksum checksum-stream ; + +: hmac-file ( K path checksum -- value ) + [ binary ] dip hmac-stream ; + +: hmac-bytes ( K path checksum -- value ) + [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 29620b089d..eda977203a 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -3,57 +3,53 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry -io.encodings.binary math.bitwise checksums -checksums.common checksums.stream combinators ; +io.encodings.binary math.bitwise checksums accessors +checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 -! See http://www.faqs.org/rfcs/rfc1321.html +TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ; + +: ( -- md5-state ) + md5-state new + 0 >>bytes-read + HEX: 67452301 [ >>a ] [ >>old-a ] bi + HEX: efcdab89 [ >>b ] [ >>old-b ] bi + HEX: 98badcfe [ >>c ] [ >>old-c ] bi + HEX: 10325476 [ >>d ] [ >>old-d ] bi ; > ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ] + [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ] + [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ] + [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ] + [ ] + } cleave ; + +: md5-state>bytes ( md5-state -- str ) + [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array + [ 4 >le ] map B{ } concat-as ; : T ( N -- Y ) sin abs 32 2^ * >integer ; foldable -: initialize-md5 ( -- ) - 0 bytes-read set - HEX: 67452301 dup a set old-a set - HEX: efcdab89 dup b set old-b set - HEX: 98badcfe dup c set old-c set - HEX: 10325476 dup d set old-d set ; - -: update-md ( -- ) - old-a a update-old-new - old-b b update-old-new - old-c c update-old-new - old-d d update-old-new ; - -:: (ABCD) ( x a b c d k s i func -- ) - #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a [ - b get c get d get func call w+ - k x nth-unsafe w+ - i T w+ - s bitroll-32 - b get w+ - ] change ; inline - -: F ( X Y Z -- FXYZ ) +:: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z - pick bitnot bitand [ bitand ] [ bitor ] bi* ; + X Y bitand X bitnot Z bitand bitor ; -: G ( X Y Z -- GXYZ ) +:: G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - dup bitnot rot bitand [ bitand ] [ bitor ] bi* ; + X Z bitand Y Z bitnot bitand bitor ; : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z bitxor bitxor ; -: I ( X Y Z -- IXYZ ) +:: I ( X Y Z -- IXYZ ) #! I(X,Y,Z) = Y xor (X v not(Z)) - rot swap bitnot bitor bitxor ; + Z bitnot X bitor Y bitxor ; CONSTANT: S11 7 CONSTANT: S12 12 @@ -72,6 +68,35 @@ CONSTANT: S42 10 CONSTANT: S43 15 CONSTANT: S44 21 + + + +SYMBOLS: a b c d old-a old-b old-c old-d ; + +: initialize-md5 ( -- ) + 0 bytes-read set + HEX: 67452301 dup a set old-a set + HEX: efcdab89 dup b set old-b set + HEX: 98badcfe dup c set old-c set + HEX: 10325476 dup d set old-d set ; + +: update-md ( -- ) + old-a a update-old-new + old-b b update-old-new + old-c c update-old-new + old-d d update-old-new ; + + +:: (ABCD) ( x a b c d k s i func -- ) + #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) + a [ + b get c get d get func call w+ + k x nth-unsafe w+ + i T w+ + s bitroll-32 + b get w+ + ] change ; inline + MACRO: with-md5-round ( ops func -- ) '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ; @@ -173,9 +198,10 @@ MACRO: with-md5-round ( ops func -- ) [ (process-md5-block) ] each ] if ; -: stream>md5 ( -- ) - 64 read [ process-md5-block ] keep - length 64 = [ stream>md5 ] when ; +: stream>md5 ( stream -- ) + 64 over stream-read + [ process-md5-block ] [ length 64 = ] bi + [ stream>md5 ] [ drop ] if ; : get-md5 ( -- str ) [ a b c d ] [ get 4 >le ] map concat >byte-array ; @@ -186,5 +212,5 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum -M: md5 checksum-stream ( stream -- byte-array ) - drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ; +M: md5 checksum-stream + drop initialize-md5 stream>md5 get-md5 ; diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor deleted file mode 100755 index 9a668aa23a..0000000000 --- a/extra/crypto/hmac/hmac.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators checksums checksums.md5 -checksums.sha1 checksums.md5.private io io.binary io.files -io.streams.byte-array kernel math math.vectors memoize sequences -io.encodings.binary ; -IN: crypto.hmac - -sha1 get-sha1 - initialize-sha1 - [ process-sha1-block ] - [ process-sha1-block ] bi* get-sha1 ; - -: md5-hmac ( Ko Ki -- hmac ) - initialize-md5 process-md5-block - stream>md5 get-md5 - initialize-md5 - [ process-md5-block ] - [ process-md5-block ] bi* get-md5 ; - -: seq-bitxor ( seq seq -- seq ) - [ bitxor ] 2map ; - -MEMO: ipad ( -- seq ) 64 HEX: 36 ; - -MEMO: opad ( -- seq ) 64 HEX: 5c ; - -: init-hmac ( K -- o i ) - 64 0 pad-tail - [ opad seq-bitxor ] - [ ipad seq-bitxor ] bi ; - -PRIVATE> - -: stream>sha1-hmac ( K stream -- hmac ) - [ init-hmac sha1-hmac ] with-input-stream ; - -: file>sha1-hmac ( K path -- hmac ) - binary stream>sha1-hmac ; - -: sequence>sha1-hmac ( K sequence -- hmac ) - binary stream>sha1-hmac ; - -: stream>md5-hmac ( K stream -- hmac ) - [ init-hmac md5-hmac ] with-input-stream ; - -: file>md5-hmac ( K path -- hmac ) - binary stream>md5-hmac ; - -: sequence>md5-hmac ( K sequence -- hmac ) - binary stream>md5-hmac ; From 90a00dac80e0e29d99fb4879e0789b09288423be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 23:06:33 -0500 Subject: [PATCH 002/228] md5 stores state in a tuple now --- basis/checksums/md5/md5.factor | 132 ++++++++++++++------------------- 1 file changed, 57 insertions(+), 75 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index eda977203a..bf43805df2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -7,49 +7,40 @@ io.encodings.binary math.bitwise checksums accessors checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 -TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ; +TUPLE: md5-state bytes-read state old-state ; : ( -- md5-state ) md5-state new 0 >>bytes-read - HEX: 67452301 [ >>a ] [ >>old-a ] bi - HEX: efcdab89 [ >>b ] [ >>old-b ] bi - HEX: 98badcfe [ >>c ] [ >>old-c ] bi - HEX: 10325476 [ >>d ] [ >>old-d ] bi ; + { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + [ clone >>state ] [ clone >>old-state ] bi ; > ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ] - [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ] - [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ] - [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ] - [ ] - } cleave ; +: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ; -: md5-state>bytes ( md5-state -- str ) - [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array - [ 4 >le ] map B{ } concat-as ; +: update-md5-state ( md5-state -- ) + [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri + [ (>>old-state) ] [ (>>state) ] bi ; : T ( N -- Y ) sin abs 32 2^ * >integer ; foldable :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z - X Y bitand X bitnot Z bitand bitor ; + X Y bitand X bitnot Z bitand bitor ; inline :: G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - X Z bitand Y Z bitnot bitand bitor ; + X Z bitand Y Z bitnot bitand bitor ; inline : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z - bitxor bitxor ; + bitxor bitxor ; inline :: I ( X Y Z -- IXYZ ) #! I(X,Y,Z) = Y xor (X v not(Z)) - Z bitnot X bitor Y bitxor ; + Z bitnot X bitor Y bitxor ; inline CONSTANT: S11 7 CONSTANT: S12 12 @@ -68,39 +59,27 @@ CONSTANT: S42 10 CONSTANT: S43 15 CONSTANT: S44 21 +CONSTANT: a 0 +CONSTANT: b 1 +CONSTANT: c 2 +CONSTANT: d 3 - - -SYMBOLS: a b c d old-a old-b old-c old-d ; - -: initialize-md5 ( -- ) - 0 bytes-read set - HEX: 67452301 dup a set old-a set - HEX: efcdab89 dup b set old-b set - HEX: 98badcfe dup c set old-c set - HEX: 10325476 dup d set old-d set ; - -: update-md ( -- ) - old-a a update-old-new - old-b b update-old-new - old-c c update-old-new - old-d d update-old-new ; - - -:: (ABCD) ( x a b c d k s i func -- ) +:: (ABCD) ( x V a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a [ - b get c get d get func call w+ + a V [ + b V nth-unsafe + c V nth-unsafe + d V nth-unsafe quot call w+ k x nth-unsafe w+ i T w+ s bitroll-32 - b get w+ - ] change ; inline + b V nth-unsafe w+ + ] change-nth ; inline -MACRO: with-md5-round ( ops func -- ) - '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ; +MACRO: with-md5-round ( ops quot -- ) + '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; -: (process-md5-block-F) ( block -- ) +: (process-md5-block-F) ( block v -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -118,9 +97,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 13 S12 14 ] [ c d a b 14 S13 15 ] [ b c d a 15 S14 16 ] - } [ F ] with-md5-round ; + } [ F ] with-md5-round ; inline -: (process-md5-block-G) ( block -- ) +: (process-md5-block-G) ( block v -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -138,9 +117,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 2 S22 30 ] [ c d a b 7 S23 31 ] [ b c d a 12 S24 32 ] - } [ G ] with-md5-round ; + } [ G ] with-md5-round ; inline -: (process-md5-block-H) ( block -- ) +: (process-md5-block-H) ( block v -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -158,9 +137,9 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 12 S32 46 ] [ c d a b 15 S33 47 ] [ b c d a 2 S34 48 ] - } [ H ] with-md5-round ; + } [ H ] with-md5-round ; inline -: (process-md5-block-I) ( block -- ) +: (process-md5-block-I) ( block v -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -178,33 +157,36 @@ MACRO: with-md5-round ( ops func -- ) [ d a b c 11 S42 62 ] [ c d a b 2 S43 63 ] [ b c d a 9 S44 64 ] - } [ I ] with-md5-round ; + } [ I ] with-md5-round ; inline -: (process-md5-block) ( block -- ) - 4 [ le> ] map { - [ (process-md5-block-F) ] - [ (process-md5-block-G) ] - [ (process-md5-block-H) ] - [ (process-md5-block-I) ] - } cleave - - update-md ; - -: process-md5-block ( str -- ) - dup length [ bytes-read [ + ] change ] keep 64 = [ - (process-md5-block) +: (process-md5-block) ( block state -- ) + [ + [ 4 [ le> ] map ] [ state>> ] bi* { + [ (process-md5-block-F) ] + [ (process-md5-block-G) ] + [ (process-md5-block-H) ] + [ (process-md5-block-I) ] + } 2cleave ] [ - f bytes-read get pad-last-block - [ (process-md5-block) ] each + nip update-md5-state + ] 2bi ; + +:: process-md5-block ( block state -- ) + block length + [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [ + block state (process-md5-block) + ] [ + block f state bytes-read>> pad-last-block + [ state (process-md5-block) ] each ] if ; -: stream>md5 ( stream -- ) - 64 over stream-read - [ process-md5-block ] [ length 64 = ] bi - [ stream>md5 ] [ drop ] if ; +:: stream>md5 ( stream state -- ) + 64 stream stream-read + [ state process-md5-block ] [ length 64 = ] bi + [ stream state stream>md5 ] when ; -: get-md5 ( -- str ) - [ a b c d ] [ get 4 >le ] map concat >byte-array ; +: get-md5 ( md5-state -- bytes ) + state>> [ 4 >le ] map B{ } concat-as ; PRIVATE> @@ -213,4 +195,4 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum M: md5 checksum-stream - drop initialize-md5 stream>md5 get-md5 ; + drop [ stream>md5 ] [ get-md5 ] bi ; From 449259630ff8eea81cd0ae4a242e7fb64cd25215 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 May 2009 11:37:21 -0500 Subject: [PATCH 003/228] working on checksums --- basis/checksums/hmac/hmac.factor | 16 ++++++++++------ basis/checksums/md5/md5.factor | 31 ++++++++++++++++++++++--------- 2 files changed, 32 insertions(+), 15 deletions(-) diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 7350a02573..fd7f6ef3a1 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -8,6 +8,7 @@ IN: checksums.hmac sha1 get-sha1 @@ -15,12 +16,13 @@ IN: checksums.hmac [ process-sha1-block ] [ process-sha1-block ] bi* get-sha1 ; -: md5-hmac ( Ko Ki stream -- hmac ) + : md5-hmac ( Ko Ki stream -- hmac ) initialize-md5 process-md5-block stream>md5 get-md5 initialize-md5 [ process-md5-block ] [ process-md5-block ] bi* get-md5 ; +*/ : seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ; @@ -35,12 +37,14 @@ MEMO: ipad ( -- seq ) 64 HEX: 36 ; PRIVATE> -: hmac ( K stream checksum -- value ) - ; - :: hmac-stream ( K stream checksum -- value ) - K init-K :> i :> o - stream checksum checksum-stream ; + K init-K :> Ki :> Ko + checksum initialize-checksum + Ki add-bytes + stream add-stream finish-checksum + checksum initialize-checksum + Ko add-bytes swap add-bytes + finish-checksum ; : hmac-file ( K path checksum -- value ) [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index bf43805df2..abdc3504cc 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -13,7 +13,7 @@ TUPLE: md5-state bytes-read state old-state ; md5-state new 0 >>bytes-read { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } - [ clone >>state ] [ clone >>old-state ] bi ; + [ clone >>state ] [ >>old-state ] bi ; > ] [ old-state>> v-w+ dup clone ] [ ] tri - [ (>>old-state) ] [ (>>state) ] bi ; + [ (>>old-state) ] [ (>>state) ] bi ; inline : T ( N -- Y ) - sin abs 32 2^ * >integer ; foldable + sin abs 32 2^ * >integer ; inline :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -179,15 +179,15 @@ MACRO: with-md5-round ( ops quot -- ) block f state bytes-read>> pad-last-block [ state (process-md5-block) ] each ] if ; - -:: stream>md5 ( stream state -- ) - 64 stream stream-read - [ state process-md5-block ] [ length 64 = ] bi - [ stream state stream>md5 ] when ; : get-md5 ( md5-state -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; +:: stream>md5 ( state stream -- ) + 64 stream stream-read + [ state process-md5-block ] [ length 64 = ] bi + [ state stream stream>md5 ] when ; + PRIVATE> SINGLETON: md5 @@ -195,4 +195,17 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum M: md5 checksum-stream - drop [ stream>md5 ] [ get-md5 ] bi ; + drop [ ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ; + +GENERIC: initialize-checksum ( checksum -- state ) +GENERIC# add-bytes 1 ( state bytes -- state ) +GENERIC# add-stream 1 ( state stream -- state ) +GENERIC: finish-checksum ( state -- bytes ) + +M: md5 initialize-checksum drop ; + +M: md5-state finish-checksum get-md5 ; + +M: md5-state add-bytes over [ binary stream>md5 ] dip ; + +M: md5-state add-stream over [ stream>md5 ] dip ; From 093faf60e65f39d68d6695a1cdd924002f24622b Mon Sep 17 00:00:00 2001 From: Alec Berryman Date: Tue, 12 May 2009 19:50:19 -0400 Subject: [PATCH 004/228] bloom-filters: fix tests on 64-bit machines Lose the test that might actually create a very large bit-array and use a number of elements that will be big enough, whatever the platform. Now tested on a 64-bit machine. --- extra/bloom-filters/bloom-filters-tests.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/bloom-filters/bloom-filters-tests.factor b/extra/bloom-filters/bloom-filters-tests.factor index 6dce1c2ca9..9b5bf48912 100644 --- a/extra/bloom-filters/bloom-filters-tests.factor +++ b/extra/bloom-filters/bloom-filters-tests.factor @@ -24,10 +24,7 @@ IN: bloom-filters.tests [ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test ! This is a lot of bits. -: oversized-filter-params ( -- error-rate n-objects ) - 0.00000001 400000000000000 ; -! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with -! [ oversized-filter-params ] [ capacity-error? ] must-fail-with +[ 0.00000001 max-array-capacity size-bloom-filter ] [ capacity-error? ] must-fail-with ! Other error conditions. [ 1.0 2000 ] [ invalid-error-rate? ] must-fail-with From 608f1405b347dbc2b4bcd40077c5dc467fb508a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 17:29:14 -0500 Subject: [PATCH 005/228] mason.common: fix git-id word on Windows --- extra/mason/common/common.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index bc1b182734..a33e3c5831 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -79,8 +79,8 @@ SYMBOL: stamp with-directory ; : git-id ( -- id ) - { "git" "show" } utf8 [ readln ] with-process-reader - " " split second ; + { "git" "show" } utf8 [ lines ] with-process-reader + first " " split second ; : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; From b047ad72528cebd283a3c70225e927bae3928496 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 18:19:30 -0500 Subject: [PATCH 006/228] New mason.notify.server tool, and fix failure report --- extra/mason/notify/notify.factor | 6 +- extra/mason/notify/server/authors.txt | 1 + extra/mason/notify/server/server.factor | 82 +++++++++++++++++++++++++ extra/mason/report/report.factor | 2 +- 4 files changed, 88 insertions(+), 3 deletions(-) create mode 100644 extra/mason/notify/server/authors.txt create mode 100644 extra/mason/notify/server/server.factor diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 30da0c8286..ccabccdf8b 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -42,8 +42,10 @@ IN: mason.notify : notify-report ( status -- ) [ "Build finished with status: " write . flush ] [ - [ "report" utf8 file-contents ] dip email-report - "report" { "report" } status-notify + [ "report" ] dip + [ [ utf8 file-contents ] dip email-report ] + [ "report" swap name>> 2array status-notify ] + 2bi ] bi ; : notify-release ( archive-name -- ) diff --git a/extra/mason/notify/server/authors.txt b/extra/mason/notify/server/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor new file mode 100644 index 0000000000..57c6d04300 --- /dev/null +++ b/extra/mason/notify/server/server.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.smart command-line db +db.sqlite db.tuples db.types io kernel namespaces sequences ; +IN: mason.notify.server + +CONSTANT: +starting+ "starting" +CONSTANT: +make-vm+ "make-vm" +CONSTANT: +boot+ "boot" +CONSTANT: +test+ "test" +CONSTANT: +clean+ "clean" +CONSTANT: +dirty+ "dirty" + +TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ; + +builder "BUILDERS" { + { "host-name" "HOST_NAME" TEXT +user-assigned-id+ } + { "os" "OS" TEXT +user-assigned-id+ } + { "cpu" "CPU" TEXT +user-assigned-id+ } + { "clean-git-id" "CLEAN_GIT_ID" TEXT } + { "last-git-id" "LAST_GIT_ID" TEXT } + { "last-report" "LAST_REPORT" TEXT } + { "current-git-id" "CURRENT_GIT_ID" TEXT } + { "status" "STATUS" TEXT } +} define-persistent + +SYMBOLS: host-name target-os target-cpu message message-arg ; + +: parse-args ( command-line -- ) + dup peek message-arg set + [ + { + [ host-name set ] + [ target-os set ] + [ target-cpu set ] + [ message set ] + } spread + ] input>host-name + target-os get >>os + target-cpu get >>cpu + dup select-tuple [ ] [ dup insert-tuple ] ?if ; + +: git-id ( builder id -- ) + >>current-git-id +starting+ >>status drop ; + +: make-vm ( builder -- ) +make-vm+ >>status drop ; + +: boot ( report -- ) +boot+ >>status drop ; + +: test ( report -- ) +test+ >>status drop ; + +: report ( builder status content -- ) + [ >>status ] [ >>last-report ] bi* + dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when + dup current-git-id>> >>last-git-id + drop ; + +: update-builder ( builder -- ) + message get { + { "git-id" [ message-arg get git-id ] } + { "make-vm" [ make-vm ] } + { "boot" [ boot ] } + { "test" [ test ] } + { "report" [ message-arg get contents report ] } + } case ; + +: mason-db ( -- db ) "resource:mason.db" ; + +: handle-update ( command-line -- ) + mason-db [ + parse-args find-builder + [ update-builder ] [ update-tuple ] bi + ] with-db ; + +: main ( -- ) + command-line get handle-update ; + +MAIN: main diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 6e48e7cf04..1b5aaf39ec 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -34,7 +34,7 @@ IN: mason.report :: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error - file utf8 file-contents 400 short tail* :> output + file utf8 file-lines 400 short tail* :> output [XML

<-what->

From 31e2788a8dff454d978a090c812134c472a71ef9 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Wed, 13 May 2009 19:21:27 -0500 Subject: [PATCH 007/228] terrain demo allows looking around with keyboard now. used ${ in a few places --- extra/terrain/terrain.factor | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 411d34f44c..d5ae2df48a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -100,10 +100,13 @@ M: terrain-world tick-length : forward-vector ( player -- v ) yaw>> 0.0 - { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; + ${ 0.0 0.0 MOVEMENT-SPEED } vneg eye-rotate ; : rightward-vector ( player -- v ) yaw>> 0.0 - { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; +: clamp-pitch ( pitch -- pitch' ) + 90.0 min -90.0 max ; + : walk-forward ( player -- ) dup forward-vector [ v+ ] curry change-velocity drop ; @@ -114,15 +117,20 @@ M: terrain-world tick-length : walk-rightward ( player -- ) dup rightward-vector [ v+ ] curry change-velocity drop ; : jump ( player -- ) - [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ; + [ ${ 0.0 JUMP 0.0 } v+ ] change-velocity drop ; +: rotate-leftward ( player x -- ) + [ - ] curry change-yaw drop ; +: rotate-rightward ( player x -- ) + [ + ] curry change-yaw drop ; +: look-horizontally ( player x -- ) + [ + ] curry change-yaw drop ; +: look-vertically ( player x -- ) + [ - clamp-pitch ] curry change-pitch drop ; -: clamp-pitch ( pitch -- pitch' ) - 90.0 min -90.0 max ; : rotate-with-mouse ( player mouse -- ) - [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] - [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi - drop ; + [ dx>> MOUSE-SCALE * look-horizontally ] + [ dy>> MOUSE-SCALE * look-vertically ] 2bi ; :: handle-input ( world -- ) world player>> :> player @@ -131,6 +139,10 @@ M: terrain-world tick-length key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when key-d keys nth [ player walk-rightward ] when + key-left-arrow keys nth [ player -1 look-horizontally ] when + key-right-arrow keys nth [ player 1 look-horizontally ] when + key-down-arrow keys nth [ player -1 look-vertically ] when + key-up-arrow keys nth [ player 1 look-vertically ] when key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when player read-mouse rotate-with-mouse From f9d8a094398762f4354d51b9d7fb72e574abd157 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Wed, 13 May 2009 19:26:08 -0500 Subject: [PATCH 008/228] unbassackwardsify the mouse, q and e rotate too --- extra/terrain/terrain.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d5ae2df48a..e459f19e40 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -125,7 +125,7 @@ M: terrain-world tick-length : look-horizontally ( player x -- ) [ + ] curry change-yaw drop ; : look-vertically ( player x -- ) - [ - clamp-pitch ] curry change-pitch drop ; + [ + clamp-pitch ] curry change-pitch drop ; : rotate-with-mouse ( player mouse -- ) @@ -139,10 +139,12 @@ M: terrain-world tick-length key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when key-d keys nth [ player walk-rightward ] when + key-q keys nth [ player -1 look-horizontally ] when + key-e keys nth [ player 1 look-horizontally ] when key-left-arrow keys nth [ player -1 look-horizontally ] when key-right-arrow keys nth [ player 1 look-horizontally ] when - key-down-arrow keys nth [ player -1 look-vertically ] when - key-up-arrow keys nth [ player 1 look-vertically ] when + key-down-arrow keys nth [ player 1 look-vertically ] when + key-up-arrow keys nth [ player -1 look-vertically ] when key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when player read-mouse rotate-with-mouse From ddbe884504582d3827c7f45bcbc20071c01dcbf4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 19:31:58 -0500 Subject: [PATCH 009/228] rotate-circular word --- basis/circular/circular-docs.factor | 6 ++++++ basis/circular/circular-tests.factor | 1 + basis/circular/circular.factor | 3 +++ 3 files changed, 10 insertions(+) diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index c7af57c1fe..235d5db2c7 100644 --- a/basis/circular/circular-docs.factor +++ b/basis/circular/circular-docs.factor @@ -43,6 +43,11 @@ HELP: push-growing-circular { "elt" object } { "circular" circular } } { $description "Pushes an element onto a " { $link growing-circular } " object." } ; +HELP: rotate-circular +{ $values + { "circular" circular } } +{ $description "Advances the start index of a circular object by one." } ; + ARTICLE: "circular" "Circular sequences" "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl "Creating a new circular object:" @@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences" { $subsection } "Changing the start index:" { $subsection change-circular-start } +{ $subsection rotate-circular } "Pushing new elements:" { $subsection push-circular } { $subsection push-growing-circular } ; diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 105e3790aa..3a94e14640 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -12,6 +12,7 @@ circular strings ; [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test +[ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9f3a71f2a8..909b2ed713 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ; #! change start to (start + n) mod length circular-wrap (>>start) ; +: rotate-circular ( circular -- ) + [ start>> 1 + ] keep circular-wrap (>>start) ; + : push-circular ( elt circular -- ) [ set-first ] [ 1 swap change-circular-start ] bi ; From 574d885a7feb8a098e8970b438134aff622ec776 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:33:57 -0500 Subject: [PATCH 010/228] mason.notify.server: parameters were wrong way around --- extra/mason/notify/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor index 57c6d04300..cc055e38d8 100644 --- a/extra/mason/notify/server/server.factor +++ b/extra/mason/notify/server/server.factor @@ -31,8 +31,8 @@ SYMBOLS: host-name target-os target-cpu message message-arg ; [ { [ host-name set ] - [ target-os set ] [ target-cpu set ] + [ target-os set ] [ message set ] } spread ] input Date: Wed, 13 May 2009 19:35:46 -0500 Subject: [PATCH 011/228] in game-worlds, open game-input before starting game-loop and close after. otherwise there's a chance the game-loop might tick without game-input available --- extra/game-worlds/game-worlds.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index c9ea03e333..2fb115b5d0 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -12,12 +12,12 @@ M: game-world draw* swap >>tick-slice draw-world ; M: game-world begin-world + open-game-input dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop - drop - open-game-input ; - -M: game-world end-world - close-game-input - [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world end-world + [ [ stop-loop ] when* f ] change-game-loop + close-game-input drop ; From 7308968e9dadbf3582a6a33fe99e6d197d28b621 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 19:36:06 -0500 Subject: [PATCH 012/228] redundant math is redundant --- extra/terrain/shaders/shaders.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index e5b517ad59..108856e1dd 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -8,10 +8,10 @@ varying vec3 direction; void main() { - vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0); + vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); gl_Position = v; - vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1); + vec4 p = gl_ProjectionMatrixInverse * v; float s = sin(sky_theta), c = cos(sky_theta); direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) From efd62847838cff4a358d1b5bb39cdfd5e6910742 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:39:26 -0500 Subject: [PATCH 013/228] webapps.mason: preliminary checkin --- extra/webapps/mason/authors.txt | 1 + extra/webapps/mason/mason.factor | 74 ++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+) create mode 100644 extra/webapps/mason/authors.txt create mode 100644 extra/webapps/mason/mason.factor diff --git a/extra/webapps/mason/authors.txt b/extra/webapps/mason/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/mason/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor new file mode 100644 index 0000000000..63b042077e --- /dev/null +++ b/extra/webapps/mason/mason.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators db db.tuples furnace.actions +http.server.responses kernel mason.platform mason.notify.server +math.order sequences sorting splitting xml.syntax xml.writer ; +IN: webapps.mason + +: git-link ( id -- link ) + [ "http://github.com/slavapestov/factor/commit/" prepend ] keep + [XML ><-> XML] ; + +: building ( builder string -- xml ) + swap current-git-id>> git-link + [XML <-> for <-> XML] ; + +: current-status ( builder -- xml ) + dup status>> { + { "dirty" [ drop "Dirty" ] } + { "clean" [ drop "Clean" ] } + { "starting" [ "Starting" building ] } + { "make-vm" [ "Compiling VM" building ] } + { "boot" [ "Bootstrapping" building ] } + { "test" [ "Testing" building ] } + [ 2drop "Unknown" ] + } case ; + +: binaries-link ( builder -- link ) + [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend + dup [XML ><-> XML] ; + +: clean-image-link ( builder -- link ) + [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend + dup [XML ><-> XML] ; + +: machine-table ( builder -- xml ) + { + [ os>> ] + [ cpu>> ] + [ host-name>> "." split1 drop ] + [ current-status ] + [ last-git-id>> dup [ git-link ] when ] + [ clean-git-id>> dup [ git-link ] when ] + [ binaries-link ] + [ clean-image-link ] + } cleave + [XML +

<-> / <->

+ + + + + + + +
Host name:<->
Current status:<->
Last build:<->
Last clean build:<->
Binaries:<->
Clean images:<->
+ XML] ; + +: machine-report ( builders -- xml ) + [ machine-table ] map + [XML +

Build farm status

+ <-> + XML] ; + +: ( -- action ) + + [ + mason-db [ + builder new select-tuples + [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort + machine-report xml>string + ] with-db + "text/html" + ] >>display ; \ No newline at end of file From 5192d7865fb89d68803ac70acbbf39711da0fde5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:47:00 -0500 Subject: [PATCH 014/228] Update mason.platform for webapps.mason --- extra/mason/platform/platform.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index 59c525f5ea..d6be8654c5 100644 --- a/extra/mason/platform/platform.factor +++ b/extra/mason/platform/platform.factor @@ -1,11 +1,14 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel system accessors namespaces splitting sequences -mason.config bootstrap.image ; +mason.config bootstrap.image assocs ; IN: mason.platform +: (platform) ( os cpu -- string ) + { { CHAR: . CHAR: - } } substitute "-" glue ; + : platform ( -- string ) - target-os get "-" target-cpu get "." split "-" join 3append ; + target-os get target-cpu get (platform) ; : gnu-make ( -- string ) target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ; From 7e2d5b4ac2ac8b489247b06446db79d15dc64f20 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:53:52 -0500 Subject: [PATCH 015/228] webapps.mason: work on it some more --- extra/webapps/mason/mason.factor | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 63b042077e..6cb24a5f9a 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -2,9 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators db db.tuples furnace.actions http.server.responses kernel mason.platform mason.notify.server -math.order sequences sorting splitting xml.syntax xml.writer ; +math.order sequences sorting splitting xml.syntax xml.writer +io.pathnames io.encodings.utf8 io.files ; IN: webapps.mason +: log-file ( -- path ) home "mason.log" append-path ; + +: recent-events ( -- xml ) + log-file utf8 file-lines 10 short tail* "\n" join [XML 
<->
XML] ; + : git-link ( id -- link ) [ "http://github.com/slavapestov/factor/commit/" prepend ] keep [XML ><-> XML] ; @@ -55,20 +61,24 @@ IN: webapps.mason XML] ; -: machine-report ( builders -- xml ) - [ machine-table ] map +: machine-report ( -- xml ) + builder new select-tuples + [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort + [ machine-table ] map ; + +: build-farm-report ( -- xml ) + recent-events + machine-report [XML -

Build farm status

- <-> + + Factor build farm +

Recent events

<->

Machine status

<-> + XML] ; : ( -- action ) [ - mason-db [ - builder new select-tuples - [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort - machine-report xml>string - ] with-db + mason-db [ build-farm-report xml>string ] with-db "text/html" ] >>display ; \ No newline at end of file From 57e92e5fde15fd938005f9d825c947a18adbbb52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 19:55:33 -0500 Subject: [PATCH 016/228] Rename a word --- extra/webapps/mason/mason.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 6cb24a5f9a..ea7040ac6e 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -76,7 +76,7 @@ IN: webapps.mason XML] ; -: ( -- action ) +: ( -- action ) [ mason-db [ build-farm-report xml>string ] with-db From cc35bb1311f893df8c815f2dcdd2caa93d523936 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:05:22 -0500 Subject: [PATCH 017/228] rename set-fullscreen? to set-fullscreen, add a toggle-fullscreen word, fix windows backend for fullscreen* --- basis/ui/backend/windows/windows.factor | 5 +++++ basis/ui/ui-docs.factor | 4 ++-- basis/ui/ui.factor | 5 ++++- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index afed121fb6..3fc9e66769 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -761,6 +761,11 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) M: windows-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: windows-ui-backend fullscreen* ( world -- ? ) + [ handle>> hWnd>> hwnd>RECT ] + [ handle>> hWnd>> fullscreen-RECT ] bi + [ get-RECT-dimensions 2array 2nip ] bi@ = ; + windows-ui-backend ui-backend set-global [ "ui.tools" ] main-vocab-hook set-global diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index e206c7d408..a4bcb8bcdf 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -25,7 +25,7 @@ HELP: world-attributes { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } } ; -HELP: set-fullscreen? +HELP: set-fullscreen { $values { "?" "a boolean" } { "gadget" gadget } } { $description "Sets and unsets fullscreen mode for the gadget's world." } ; @@ -33,7 +33,7 @@ HELP: fullscreen? { $values { "gadget" gadget } { "?" "a boolean" } } { $description "Queries the gadget's world to see if it is running in fullscreen mode." } ; -{ fullscreen? set-fullscreen? } related-words +{ fullscreen? set-fullscreen } related-words HELP: find-window { $values { "quot" { $quotation "( world -- ? )" } } { "world" { $maybe world } } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0a6f26fd5b..e4cf725add 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -209,12 +209,15 @@ PRIVATE> : open-window ( gadget title/attributes -- ) ?attributes open-world-window ; -: set-fullscreen? ( ? gadget -- ) +: set-fullscreen ( ? gadget -- ) find-world set-fullscreen* ; : fullscreen? ( gadget -- ? ) find-world fullscreen* ; +: toggle-fullscreen ( gadget -- ) + [ fullscreen? not ] keep set-fullscreen ; + : raise-window ( gadget -- ) find-world raise-window* ; From 57f461b5b7063002ff396e99309f6f6036d31662 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:06:13 -0500 Subject: [PATCH 018/228] add a velocity-modifier to terrain demo for left shift. alt-enter toggles fullscreen mode --- extra/terrain/terrain.factor | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index e459f19e40..d6905144bb 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -6,7 +6,7 @@ opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game-worlds method-chains -math.affine-transforms noise ; +math.affine-transforms noise ui.gestures ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -18,7 +18,7 @@ CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] -CONSTANT: FRICTION 0.95 +CONSTANT: FRICTION { 0.95 0.99 0.95 } CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 } CONSTANT: SKY-PERIOD 1200 CONSTANT: SKY-SPEED 0.0005 @@ -28,7 +28,7 @@ CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player - location yaw pitch velocity ; + location yaw pitch velocity velocity-modifier ; TUPLE: terrain-world < game-world player @@ -132,9 +132,21 @@ M: terrain-world tick-length [ dx>> MOUSE-SCALE * look-horizontally ] [ dy>> MOUSE-SCALE * look-vertically ] 2bi ; + +terrain-world H{ + { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } +} set-gestures + :: handle-input ( world -- ) world player>> :> player read-keyboard keys>> :> keys + key-left-shift keys nth [ + { 2.0 1.0 2.0 } player (>>velocity-modifier) + ] when + key-left-shift keys nth [ + { 1.0 1.0 1.0 } player (>>velocity-modifier) + ] unless + key-w keys nth [ player walk-forward ] when key-s keys nth [ player walk-backward ] when key-a keys nth [ player walk-leftward ] when @@ -151,7 +163,7 @@ M: terrain-world tick-length reset-mouse ; : apply-friction ( velocity -- velocity' ) - FRICTION v*n ; + FRICTION v* ; : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; @@ -184,9 +196,12 @@ M: terrain-world tick-length [ [ 1 ] 2dip [ max ] with change-nth ] [ ] tri ; +: scaled-velocity ( player -- velocity ) + [ velocity>> ] [ velocity-modifier>> ] bi v* ; + : tick-player ( world player -- ) [ apply-friction apply-gravity ] change-velocity - dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location + dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location drop ; M: terrain-world tick* @@ -211,7 +226,7 @@ BEFORE: terrain-world begin-world GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player + PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player 0.01 0.01 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture From 97fe0103d0898f8c5a963622103e3b1ab0f9dcf7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 20:15:58 -0500 Subject: [PATCH 019/228] fix the sky --- extra/terrain/shaders/shaders.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 108856e1dd..630163c724 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -8,7 +8,7 @@ varying vec3 direction; void main() { - vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0); + vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0); gl_Position = v; vec4 p = gl_ProjectionMatrixInverse * v; From 075f7ac4d5aadcb0e7eb32b11df2ff53ee4a90a9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 13 May 2009 21:28:12 -0500 Subject: [PATCH 020/228] MacOS X glFrustum generates -0.0 in W column of projection matrix; Windows glFrustum generates 0.0. This causes sign differences in the gl_ProjectionMatrixInverse between platforms. manually force the z coordinate sign in terrain sky projection to be negative like it ought to be --- extra/terrain/shaders/shaders.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 630163c724..9233ab3f36 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -12,6 +12,7 @@ void main() gl_Position = v; vec4 p = gl_ProjectionMatrixInverse * v; + p.z = -abs(p.z); float s = sin(sky_theta), c = cos(sky_theta); direction = mat3(1, 0, 0, 0, c, s, 0, -s, c) From 627d3a0baacaae9b07170dc2b59be86e3063e779 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 22:02:45 -0500 Subject: [PATCH 021/228] toggle-screen is in the ui now --- extra/jamshred/jamshred.factor | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index fd683e3bc4..262b7a8ca6 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -26,15 +26,6 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) [ 100 milliseconds sleep jamshred-loop ] tri ] if ; -: fullscreen ( gadget -- ) - find-world t swap set-fullscreen* ; - -: no-fullscreen ( gadget -- ) - find-world f swap set-fullscreen* ; - -: toggle-fullscreen ( world -- ) - [ fullscreen? not ] keep set-fullscreen* ; - M: jamshred-gadget graft* ( gadget -- ) [ find-gl-context init-graphics ] [ [ jamshred-loop ] curry in-thread ] bi ; @@ -78,7 +69,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } { T{ key-down f f " " } [ jamshred>> toggle-running ] } - { T{ key-down f f "f" } [ find-world toggle-fullscreen ] } + { T{ key-down f f "f" } [ toggle-fullscreen ] } { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] } { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] } { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] } From b1bcc44dd5d035a5a2f864e7b19fa4ed49e0fc16 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 22:15:48 -0500 Subject: [PATCH 022/228] Rename use+ to add-use, move search to vocabs.parser, EXCLUDE: bombs out if word doesn't exist --- basis/interpolate/interpolate.factor | 2 +- basis/io/sockets/sockets.factor | 2 +- basis/io/sockets/unix/unix.factor | 2 +- basis/listener/listener-tests.factor | 2 +- basis/opengl/gl/extensions/extensions.factor | 2 +- basis/peg/ebnf/ebnf.factor | 2 +- basis/see/see-docs.factor | 2 +- basis/tools/test/test.factor | 8 ++-- .../pixel-formats/pixel-formats-docs.factor | 2 +- basis/ui/tools/operations/operations.factor | 2 +- core/parser/parser-docs.factor | 45 +------------------ core/parser/parser-tests.factor | 40 ++++++++++++++++- core/parser/parser.factor | 15 +------ core/syntax/syntax.factor | 4 +- core/vocabs/parser/parser-docs.factor | 39 +++++++++++++++- core/vocabs/parser/parser.factor | 35 ++++++++++----- core/words/words-docs.factor | 2 +- extra/fuel/eval/eval.factor | 2 +- extra/sandbox/syntax/syntax.factor | 2 +- 19 files changed, 121 insertions(+), 89 deletions(-) diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 1de65fa91f..ea965aac5b 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel macros make multiline namespaces parser +USING: io kernel macros make multiline namespaces vocabs.parser present sequences strings splitting fry accessors ; IN: interpolate diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a0beb1f421..0671247ade 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -12,7 +12,7 @@ IN: io.sockets << { { [ os windows? ] [ "windows.winsock" ] } { [ os unix? ] [ "unix" ] } -} cond use+ >> +} cond add-use >> ! Addressing GENERIC: protocol-family ( addrspec -- af ) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 799dfa78d5..68c7d5c196 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -7,7 +7,7 @@ io.backend io.ports io.pathnames io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors destructors unix locals init ; -EXCLUDE: io => read write close ; +EXCLUDE: io => read write ; EXCLUDE: io.sockets => accept ; IN: io.sockets.unix diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 7ed082234a..9ae5250416 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -15,7 +15,7 @@ SYNTAX: hello "Hi" print ; ] with-file-vocabs [ - "debugger" use+ + "debugger" add-use [ [ \ + 1 2 3 4 ] ] [ diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index ccd3f5fad7..8878e1904a 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -9,7 +9,7 @@ ERROR: unknown-gl-platform ; { [ os macosx? ] [ "opengl.gl.macosx" ] } { [ os unix? ] [ "opengl.gl.unix" ] } [ unknown-gl-platform ] -} cond use+ >> +} cond add-use >> SYMBOL: +gl-function-number-counter+ SYMBOL: +gl-function-pointers+ diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index b50ba685b8..fafb846147 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs continuations peg peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker -io combinators parser summary ; +io combinators parser vocabs.parser summary ; IN: peg.ebnf : rule ( name word -- parser ) diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index b2e99843c7..2423950d86 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -25,7 +25,7 @@ HELP: see-methods { $contract "Prettyprints the methods defined on a generic word or class." } ; HELP: definer -{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } } +{ $values { "defspec" "a definition specifier" } { "start" word } { "end" { $maybe word } } } { $contract "Outputs the parsing words which delimit the definition." } { $examples { $example "USING: definitions prettyprint ;" diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 3dc7b8740b..7b07311ded 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -2,11 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators compiler.units continuations debugger effects fry generalizations io io.files -io.styles kernel lexer locals macros math.parser namespaces -parser prettyprint quotations sequences source-files splitting +io.styles kernel lexer locals macros math.parser namespaces parser +vocabs.parser prettyprint quotations sequences source-files splitting stack-checker summary unicode.case vectors vocabs vocabs.loader -vocabs.files words tools.errors source-files.errors -io.streams.string make compiler.errors ; +vocabs.files words tools.errors source-files.errors io.streams.string +make compiler.errors ; IN: tools.test TUPLE: test-failure < source-file-error continuation ; diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 003b205c3d..53e44ec18e 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -6,7 +6,7 @@ IN: ui.pixel-formats << "ui.gadgets.worlds" create-vocab drop "world" "ui.gadgets.worlds" create drop - "ui.gadgets.worlds" (use+) + "ui.gadgets.worlds" (add-use) >> ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 650d751ee2..49bb74d18c 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -137,7 +137,7 @@ M: word com-stack-effect 1quotation com-stack-effect ; { +listener+ t } } define-operation -: com-use-vocab ( vocab -- ) vocab-name use+ ; +: com-use-vocab ( vocab -- ) vocab-name add-use ; [ vocab-spec? ] \ com-use-vocab H{ { +secondary+ t } diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 98f41ae39a..d6c69f08c2 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -119,45 +119,7 @@ HELP: parser-notes? HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; -HELP: use -{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; - -{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words - -HELP: in -{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ; - -HELP: current-vocab -{ $values { "str" "a vocabulary" } } -{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ; - -HELP: (use+) -{ $values { "vocab" "an assoc mapping strings to words" } } -{ $description "Adds an assoc at the front of the search path." } -$parsing-note ; - -HELP: use+ -{ $values { "vocab" string } } -{ $description "Adds a new vocabulary at the front of the search path after loading it if necessary. Subsequent word lookups by the parser will search this vocabulary first." } -$parsing-note -{ $errors "Throws an error if the vocabulary does not exist." } ; - -HELP: set-use -{ $values { "seq" "a sequence of strings" } } -{ $description "Sets the vocabulary search path. Later vocabularies take precedence." } -{ $errors "Throws an error if one of the vocabularies does not exist." } -$parsing-note ; - -HELP: add-use -{ $values { "seq" "a sequence of strings" } } -{ $description "Adds multiple vocabularies to the search path, with later vocabularies taking precedence." } -{ $errors "Throws an error if one of the vocabularies does not exist." } -$parsing-note ; - -HELP: set-in -{ $values { "name" string } } -{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." } -$parsing-note ; +{ use in add-use (add-use) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words HELP: create-in { $values { "str" "a word name" } { "word" "a new word" } } @@ -178,11 +140,6 @@ HELP: no-word { $values { "name" string } { "newword" word } } { $description "Throws a " { $link no-word-error } "." } ; -HELP: search -{ $values { "str" string } { "word/f" "a word or " { $link f } } } -{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." } -$parsing-note ; - HELP: scan-word { $values { "word/number/f" "a word, number or " { $link f } } } { $description "Reads the next token from parser input. If the token is a valid number literal, it is converted to a number, otherwise the dictionary is searched for a word named by the token. Outputs " { $link f } " if the end of the input has been reached." } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index e944ecc6f2..4474ed45c4 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -4,7 +4,7 @@ sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer vocabs.parser words.symbol multiline source-files.errors -tools.crossref ; +tools.crossref grouping ; IN: parser.tests [ @@ -583,3 +583,41 @@ EXCLUDE: qualified.tests.bar => x ; [ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test [ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test + +! Forward-reference resolution case iterated using list in the wrong direction +[ [ ] ] [ + "IN: parser.tests.forward-ref-1 DEFER: x DEFER: y" + "forward-ref-1" parse-stream +] unit-test + +[ [ ] ] [ + "IN: parser.tests.forward-ref-2 DEFER: x DEFER: y" + "forward-ref-2" parse-stream +] unit-test + +[ [ ] ] [ + "IN: parser.tests.forward-ref-3 USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; : z ( -- ) x y ;" + "forward-ref-3" parse-stream +] unit-test + +[ t ] [ + "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal? +] unit-test + +[ [ ] ] [ + "USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; IN: parser.tests.forward-ref-3 : x ( -- ) ; : z ( -- ) x y ;" + "forward-ref-3" parse-stream +] unit-test + +[ f ] [ + "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal? +] unit-test + +[ [ ] ] [ + "IN: parser.tests.forward-ref-3 USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; : z ( -- ) x y ;" + "forward-ref-3" parse-stream +] unit-test + +[ t ] [ + "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal? +] unit-test \ No newline at end of file diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 01e0b18887..d802fd72fa 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -55,7 +55,7 @@ SYMBOL: auto-use? : no-word-restarted ( restart-value -- word ) dup word? [ dup vocabulary>> - [ (use+) ] + [ (add-use) ] [ amended-use get dup [ push ] [ 2drop ] if ] [ "Added \"" "\" vocabulary to search path" surround note. ] tri @@ -68,19 +68,6 @@ SYMBOL: auto-use? [ throw-restarts no-word-restarted ] if ; -: check-forward ( str word -- word/f ) - dup forward-reference? [ - drop - use get - [ at ] with map sift - [ forward-reference? not ] find nip - ] [ - nip - ] if ; - -: search ( str -- word/f ) - dup use get assoc-stack check-forward ; - : scan-word ( -- word/number/f ) scan dup [ dup search [ ] [ diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7d710717aa..8d52a2c786 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -49,9 +49,9 @@ IN: bootstrap.syntax POSTPONE: PRIVATE> in get ".private" append set-in ] define-core-syntax - "USE:" [ scan use+ ] define-core-syntax + "USE:" [ scan add-use ] define-core-syntax - "USING:" [ ";" parse-tokens add-use ] define-core-syntax + "USING:" [ ";" parse-tokens [ add-use ] each ] define-core-syntax "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index 71862402cd..d61c998725 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax parser ; +USING: help.markup help.syntax parser strings words ; IN: vocabs.parser ARTICLE: "vocabulary-search-shadow" "Shadowing word names" @@ -78,3 +78,40 @@ $nl { $see-also "words" } ; ABOUT: "vocabulary-search" + +HELP: use +{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; + +HELP: in +{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ; + +HELP: current-vocab +{ $values { "str" "a vocabulary" } } +{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ; + +HELP: (add-use) +{ $values { "vocab" "an assoc mapping strings to words" } } +{ $description "Adds an assoc at the front of the search path." } +$parsing-note ; + +HELP: add-use +{ $values { "vocab" string } } +{ $description "Adds a new vocabulary at the front of the search path after loading it if necessary. Subsequent word lookups by the parser will search this vocabulary first." } +$parsing-note +{ $errors "Throws an error if the vocabulary does not exist." } ; + +HELP: set-use +{ $values { "seq" "a sequence of strings" } } +{ $description "Sets the vocabulary search path. Later vocabularies take precedence." } +{ $errors "Throws an error if one of the vocabularies does not exist." } +$parsing-note ; + +HELP: set-in +{ $values { "name" string } } +{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." } +$parsing-note ; + +HELP: search +{ $values { "str" string } { "word/f" { $maybe word } } } +{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." } +$parsing-note ; diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index e8783c0dbe..d5978270dc 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -2,7 +2,7 @@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences -sets strings vocabs sorting accessors arrays ; +sets strings vocabs sorting accessors arrays compiler.units ; IN: vocabs.parser ERROR: no-word-error name ; @@ -19,13 +19,11 @@ ERROR: no-word-error name ; SYMBOL: use SYMBOL: in -: (use+) ( vocab -- ) +: (add-use) ( vocab -- ) vocab-words use get push ; -: use+ ( vocab -- ) - load-vocab (use+) ; - -: add-use ( seq -- ) [ use+ ] each ; +: add-use ( vocab -- ) + load-vocab (add-use) ; : set-use ( seq -- ) [ vocab-words ] V{ } map-as sift use set ; @@ -35,15 +33,17 @@ SYMBOL: in [ swap [ prepend ] dip ] curry assoc-map use get push ; -: partial-vocab ( words vocab -- assoc ) - load-vocab vocab-words +: words-named-in ( words assoc -- assoc' ) [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ; +: partial-vocab-including ( words vocab -- assoc ) + load-vocab vocab-words words-named-in ; + : add-words-from ( words vocab -- ) - partial-vocab use get push ; + partial-vocab-including use get push ; : partial-vocab-excluding ( words vocab -- assoc ) - load-vocab [ vocab-words keys swap diff ] keep partial-vocab ; + load-vocab vocab-words [ nip ] [ words-named-in ] 2bi assoc-diff ; : add-words-excluding ( words vocab -- ) partial-vocab-excluding use get push ; @@ -56,4 +56,17 @@ SYMBOL: in dup string? [ "Vocabulary name must be a string" throw ] unless ; : set-in ( name -- ) - check-vocab-string dup in set create-vocab (use+) ; \ No newline at end of file + check-vocab-string dup in set create-vocab (add-use) ; + +: check-forward ( str word -- word/f ) + dup forward-reference? [ + drop + use get + [ at ] with map sift + [ forward-reference? not ] find-last nip + ] [ + nip + ] if ; + +: search ( str -- word/f ) + dup use get assoc-stack check-forward ; \ No newline at end of file diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 3725086f70..a04b95bcfd 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -237,7 +237,7 @@ HELP: set-word { $description "Sets the recently defined word." } ; HELP: lookup -{ $values { "name" string } { "vocab" string } { "word" "a word or " { $link f } } } +{ $values { "name" string } { "vocab" string } { "word" { $maybe word } } } { $description "Looks up a word in the dictionary. If the vocabulary or the word is not defined, outputs " { $link f } "." } ; HELP: reveal diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index 3f7ce863c7..9f0b6fc0a3 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -60,7 +60,7 @@ t fuel-eval-res-flag set-global [ print-error ] recover ; : (fuel-eval-usings) ( usings -- ) - [ [ use+ ] curry [ drop ] recover ] each + [ [ add-use ] curry [ drop ] recover ] each fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) diff --git a/extra/sandbox/syntax/syntax.factor b/extra/sandbox/syntax/syntax.factor index 2ff5f070c7..f04b05acd8 100644 --- a/extra/sandbox/syntax/syntax.factor +++ b/extra/sandbox/syntax/syntax.factor @@ -9,7 +9,7 @@ IN: sandbox.syntax ERROR: sandbox-error vocab ; : sandbox-use+ ( alias -- ) - dup whitelist get at [ use+ ] [ sandbox-error ] ?if ; + dup whitelist get at [ add-use ] [ sandbox-error ] ?if ; PRIVATE> From 73f4b0d781c5979459d8ebae9592d08da240e2c8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 May 2009 22:28:33 -0500 Subject: [PATCH 023/228] fullscreen* -> (fullscreen?), set-fullscreen* -> (set-fullscreen), fix jamshred screen toggling --- basis/ui/backend/backend.factor | 4 ++-- basis/ui/backend/cocoa/cocoa.factor | 6 +++--- basis/ui/backend/windows/windows.factor | 6 +++--- basis/ui/backend/x11/x11.factor | 10 ++++++---- basis/ui/ui-docs.factor | 2 +- basis/ui/ui.factor | 8 ++++---- extra/jamshred/jamshred.factor | 2 +- 7 files changed, 20 insertions(+), 18 deletions(-) diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 63d551798c..3d38439f69 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -7,9 +7,9 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) -HOOK: set-fullscreen* ui-backend ( ? world -- ) +HOOK: (set-fullscreen) ui-backend ( world ? -- ) -HOOK: fullscreen* ui-backend ( world -- ? ) +HOOK: (fullscreen?) ui-backend ( world -- ? ) HOOK: (open-window) ui-backend ( world -- ) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 47a3bfc1a6..c6f4c6def0 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -101,10 +101,10 @@ M: cocoa-ui-backend set-title ( string world -- ) : exit-fullscreen ( world -- ) handle>> view>> f -> exitFullScreenModeWithOptions: ; -M: cocoa-ui-backend set-fullscreen* ( ? world -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) + [ enter-fullscreen ] [ exit-fullscreen ] if ; -M: cocoa-ui-backend fullscreen* ( world -- ? ) +M: cocoa-ui-backend (fullscreen?) ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; M:: cocoa-ui-backend (open-window) ( world -- ) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 3fc9e66769..ade5ba0e7d 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -758,10 +758,10 @@ M: windows-ui-backend (ungrab-input) ( handle -- ) [ SW_RESTORE ShowWindow win32-error=0/f ] } cleave ; -M: windows-ui-backend set-fullscreen* ( ? world -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: windows-ui-backend (set-fullscreen) ( ? world -- ) + [ enter-fullscreen ] [ exit-fullscreen ] if ; -M: windows-ui-backend fullscreen* ( world -- ? ) +M: windows-ui-backend (fullscreen?) ( world -- ? ) [ handle>> hWnd>> hwnd>RECT ] [ handle>> hWnd>> fullscreen-RECT ] bi [ get-RECT-dimensions 2array 2nip ] bi@ = ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 76fd9fa30c..aca80cbc96 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -268,10 +268,12 @@ M: x11-ui-backend set-title ( string world -- ) handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; -M: x11-ui-backend set-fullscreen* ( ? world -- ) - handle>> window>> "XClientMessageEvent" - [ set-XClientMessageEvent-window ] keep - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? +M: x11-ui-backend (set-fullscreen) ( world ? -- ) + [ + handle>> window>> "XClientMessageEvent" + [ set-XClientMessageEvent-window ] keep + ] dip + _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? over set-XClientMessageEvent-data0 ClientMessage over set-XClientMessageEvent-type dpy get over set-XClientMessageEvent-display diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index a4bcb8bcdf..7e83265926 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -26,7 +26,7 @@ HELP: world-attributes } ; HELP: set-fullscreen -{ $values { "?" "a boolean" } { "gadget" gadget } } +{ $values { "gadget" gadget } { "?" "a boolean" } } { $description "Sets and unsets fullscreen mode for the gadget's world." } ; HELP: fullscreen? diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index e4cf725add..b1bfce26e6 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -209,14 +209,14 @@ PRIVATE> : open-window ( gadget title/attributes -- ) ?attributes open-world-window ; -: set-fullscreen ( ? gadget -- ) - find-world set-fullscreen* ; +: set-fullscreen ( gadget ? -- ) + [ find-world ] dip (set-fullscreen) ; : fullscreen? ( gadget -- ? ) - find-world fullscreen* ; + find-world (fullscreen?) ; : toggle-fullscreen ( gadget -- ) - [ fullscreen? not ] keep set-fullscreen ; + dup fullscreen? not set-fullscreen ; : raise-window ( gadget -- ) find-world raise-window* ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 262b7a8ca6..ae981ae1b3 100644 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -64,7 +64,7 @@ M: jamshred-gadget ungraft* ( gadget -- ) [ second mouse-scroll-y ] 2bi ; : quit ( gadget -- ) - [ no-fullscreen ] [ close-window ] bi ; + [ f set-fullscreen ] [ close-window ] bi ; jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } From 2f4215a499bf23b51a46474f294426b03e02c806 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 22:41:42 -0500 Subject: [PATCH 024/228] ui.backend.windows: create-window can now be called even when the UI is not running. Fixes game-input deploy test --- basis/ui/backend/windows/windows.factor | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index ade5ba0e7d..1ca3e85232 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -556,11 +556,9 @@ M: windows-ui-backend do-events [ DispatchMessage drop ] bi ] if ; -: register-wndclassex ( -- class ) - "WNDCLASSEX" - f GetModuleHandle - class-name-ptr get-global - pick GetClassInfoEx zero? [ +:: register-window-class ( class-name-ptr -- ) + "WNDCLASSEX" f GetModuleHandle + class-name-ptr pick GetClassInfoEx 0 = [ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style ui-wndproc over set-WNDCLASSEX-lpfnWndProc @@ -571,9 +569,9 @@ M: windows-ui-backend do-events over set-WNDCLASSEX-hIcon f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor - class-name-ptr get-global over set-WNDCLASSEX-lpszClassName - RegisterClassEx dup win32-error=0/f - ] when ; + class-name-ptr over set-WNDCLASSEX-lpszClassName + RegisterClassEx win32-error=0/f + ] [ drop ] if ; : adjust-RECT ( RECT -- ) style 0 ex-style AdjustWindowRectEx win32-error=0/f ; @@ -594,9 +592,16 @@ M: windows-ui-backend do-events dup adjust-RECT swap [ dup default-position-RECT ] when ; +: get-window-class ( -- class-name ) + class-name-ptr [ + dup expired? [ drop "Factor-window" utf16n malloc-string ] when + dup register-window-class + dup + ] change-global ; + : create-window ( rect -- hwnd ) make-adjusted-RECT - [ class-name-ptr get-global f ] dip + [ get-window-class f ] dip [ [ ex-style ] 2dip { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags @@ -611,8 +616,6 @@ M: windows-ui-backend do-events : init-win32-ui ( -- ) V{ } clone nc-buttons set-global "MSG" malloc-object msg-obj set-global - "Factor-window" utf16n malloc-string class-name-ptr set-global - register-wndclassex drop GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) From 73e3f576c92fd4f3730cafb909ceb1463aa8e69c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 May 2009 22:42:38 -0500 Subject: [PATCH 025/228] ui.tools.debugger: don't throw an error if world has no children --- basis/ui/tools/debugger/debugger.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index f3f533e681..2c653266e5 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -60,7 +60,8 @@ M: debugger focusable-child* GENERIC: error-in-debugger? ( error -- ? ) -M: world-error error-in-debugger? world>> gadget-child debugger? ; +M: world-error error-in-debugger? + world>> children>> [ f ] [ first debugger? ] if-empty ; M: object error-in-debugger? drop f ; From accc1e018e1698f68f035708c97d24f3568c9d85 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 10:08:57 -0500 Subject: [PATCH 026/228] don't assume world has children in debugger --- basis/ui/tools/debugger/debugger.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index f3f533e681..4d6960306c 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -60,7 +60,7 @@ M: debugger focusable-child* GENERIC: error-in-debugger? ( error -- ? ) -M: world-error error-in-debugger? world>> gadget-child debugger? ; +M: world-error error-in-debugger? world>> children>> [ f ] [ first debugger? ] if-empty ; M: object error-in-debugger? drop f ; From a8a4c9fa17c2e4f8f0196345916ebc926d1945da Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 14:08:51 -0500 Subject: [PATCH 027/228] handle resize on key-down instead of key-up --- extra/terrain/terrain.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d6905144bb..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -134,7 +134,7 @@ M: terrain-world tick-length terrain-world H{ - { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } + { T{ key-down { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } } set-gestures :: handle-input ( world -- ) From a229ec788abfd7fa74f8daf949dea8aac34b4029 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 15:01:21 -0500 Subject: [PATCH 028/228] flip cursor warp point for cocoa mouse grab into y-goes-down space --- basis/core-graphics/core-graphics.factor | 2 ++ basis/ui/backend/cocoa/cocoa.factor | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 924f7130f0..e9158be47d 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -110,6 +110,8 @@ FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ; FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ; FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ; +FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ; + FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index c6f4c6def0..e952de659e 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -126,7 +126,9 @@ M: cocoa-ui-backend (grab-input) ( handle -- ) 0 CGAssociateMouseAndMouseCursorPosition drop CGMainDisplayID CGDisplayHideCursor drop window>> -> frame CGRect>rect rect-center - first2 CGWarpMouseCursorPosition drop ; + NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h + [ drop first ] [ swap second - ] 2bi + CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) drop From 681d5253c49e2baaf17698846ec5ff0825495c6d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 15:36:18 -0500 Subject: [PATCH 029/228] spin on GetCurrentButtonState before warping cursor when grabbing cocoa input. this keeps the window from jumping if you click on its titlebar to focus --- basis/core-graphics/core-graphics.factor | 2 ++ basis/ui/backend/cocoa/cocoa.factor | 1 + 2 files changed, 3 insertions(+) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index e9158be47d..6612a43dca 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -116,6 +116,8 @@ FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; +FUNCTION: uint GetCurrentButtonState ( ) ; + > -> frame CGRect>rect rect-center NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h [ drop first ] [ swap second - ] 2bi + [ GetCurrentButtonState zero? not ] [ yield ] while CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) From 569e6b457d71e5de7085b0f9deac20cf91b59124 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:43:51 -0500 Subject: [PATCH 030/228] larger default window size for gesture-logger --- extra/gesture-logger/gesture-logger.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index e03204dc35..0dc0f05205 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -25,6 +25,7 @@ M: gesture-logger user-input* : gesture-logger ( -- ) [ t >>scrolls? dup + { 450 500 } >>pref-dim "Gesture log" open-window "Gesture input" open-window From 2891c5d13de68d48451a7c5ed18505ac679eacfb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:44:57 -0500 Subject: [PATCH 031/228] replace my bitstream-reader with marc's bitstreams. implement a minimal bit-writer --- basis/bitstreams/bitstreams.factor | 217 ++++++++++++++++++----------- basis/compression/lzw/lzw.factor | 26 ++-- 2 files changed, 149 insertions(+), 94 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..d7d13cf17c 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -1,96 +1,147 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays destructors fry io kernel locals -math sequences ; +USING: accessors alien.accessors assocs byte-arrays combinators +constructors destructors fry io io.binary io.encodings.binary +io.streams.byte-array kernel locals macros math math.ranges +multiline sequences sequences.private vectors byte-vectors +combinators.short-circuit math.bitwise ; IN: bitstreams -TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; -TUPLE: bitstream-reader < bitstream ; +TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; -: reset-bitstream ( stream -- stream ) - 0 >>#bits 0 >>current-bits ; inline +ERROR: invalid-widthed bits #bits ; -: new-bitstream ( stream class -- bitstream ) - new - swap >>stream - reset-bitstream ; inline +: check-widthed ( bits #bits -- bits #bits ) + dup 0 < [ invalid-widthed ] when + 2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when + over 0 = [ + 2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when + ] unless ; -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: zero-widthed ( -- widthed ) 0 0 ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +TUPLE: bit-reader + { bytes byte-array } + { byte-pos array-capacity initial: 0 } + { bit-pos array-capacity initial: 0 } ; + +TUPLE: bit-writer + { bytes byte-vector } + { widthed widthed } ; + +TUPLE: msb0-bit-reader < bit-reader ; +TUPLE: lsb0-bit-reader < bit-reader ; +CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ; +CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; + +TUPLE: msb0-bit-writer < bit-writer ; +TUPLE: lsb0-bit-writer < bit-writer ; +CONSTRUCTOR: msb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; +CONSTRUCTOR: lsb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; + +! interface + +GENERIC: peek ( n bitstream -- value ) +GENERIC: poke ( value n bitstream -- ) + +: seek ( n bitstream -- ) + { + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] + [ (>>byte-pos) ] + } cleave ; inline + +: read ( n bitstream -- value ) + [ peek ] [ seek ] 2bi ; inline + + +! reading + +quot ; + +GENERIC: fetch3-le-unsafe ( n byte-array -- value ) +GENERIC: fetch3-be-unsafe ( n byte-array -- value ) + +: fetch3-unsafe ( byte-array n offsets -- value ) + multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline + +M: byte-array fetch3-le-unsafe ( n byte-array -- value ) + swap { 0 1 2 } fetch3-unsafe ; inline +M: byte-array fetch3-be-unsafe ( n byte-array -- value ) + swap { 2 1 0 } fetch3-unsafe ; inline + +: fetch3 ( n byte-array -- value ) + [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; + +: fetch3-le ( n byte-array -- value ) fetch3 le> ; +: fetch3-be ( n byte-array -- value ) fetch3 be> ; + +GENERIC: peek16 ( n bitstream -- value ) + +M:: lsb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-le + bs bit-pos>> 2^ /i + n 2^ mod ; + +M:: msb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-be + 24 n bs bit-pos>> + - 2^ /i + n 2^ mod ; + +PRIVATE> + +M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; +M: msb0-bit-reader peek ( n bs -- v ) peek16 ; + +! writing + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] if* ; - -: maybe-read-next-byte ( bitstream -- bitstream ) - dup #bits>> 0 = [ read-next-byte ] when ; inline - -: shift-one-bit ( bitstream -- n ) - [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline - -: next-bit ( bitstream -- n/f ? ) - maybe-read-next-byte - dup end-of-stream?>> [ - drop f - ] [ - [ shift-one-bit ] - [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi - ] if dup >boolean ; - -: read-bit ( bitstream -- n ? ) - dup #bits>> 1 = [ - [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi t - ] [ - next-bit - ] if ; inline - -: bits>integer ( seq -- n ) - 0 [ [ 1 shift ] dip bitor ] reduce ; inline - -: read-bits ( width bitstream -- n width ? ) - [ - '[ _ read-bit drop ] replicate - [ f = ] trim-tail - [ bits>integer ] [ length ] bi - ] 2keep drop over = ; - -TUPLE: bitstream-writer < bitstream ; - -: ( stream -- bitstream ) - bitstream-writer new-bitstream ; inline - -: write-bit ( n bitstream -- ) - [ 1 shift bitor ] change-current-bits - [ 1+ ] change-#bits - dup #bits>> 8 = [ - [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] - [ reset-bitstream drop ] bi - ] [ - drop - ] if ; inline - -ERROR: invalid-bit-width n ; - -:: write-bits ( n width bitstream -- ) - n 0 < [ n invalid-bit-width ] when - n 0 = [ - width [ 0 bitstream write-bit ] times - ] [ - width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times - n-length [ - n-length swap - 1- neg n swap shift 1 bitand - bitstream write-bit - ] each + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] if ; -: flush-bits ( bitstream -- ) stream>> stream-flush ; +: widthed>bytes ( widthed -- bytes widthed ) + [ 8 split-widthed dup zero-widthed? not ] + [ swap bits>> ] B{ } produce-as nip swap ; -: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> widthed + widthed + bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte + + byte #bits>> 8 = [ + byte bits>> bs bytes>> push + zero-widthed bs (>>widthed) + remainder widthed>bytes + [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + ] [ + byte bs (>>widthed) + ] if ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..592a0efb6c 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bitstreams byte-vectors combinators io -io.encodings.binary io.streams.byte-array kernel math sequences -vectors ; -IN: compression.lzw +USING: accessors alien.accessors byte-arrays combinators +constructors destructors fry io io.binary kernel locals macros +math math.ranges multiline sequences sequences.private ; +IN: bitstreams + +QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 @@ -52,7 +54,8 @@ ERROR: index-too-big n ; : ( input -- obj ) lzw new swap >>input - binary >>output + ! binary >>output + V{ } clone >>output ! TODO reset-lzw-compress ; : ( input -- obj ) @@ -76,7 +79,7 @@ ERROR: not-in-table value ; [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless ] [ [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] bi ; : omega-k>omega ( lzw -- lzw ) @@ -114,18 +117,18 @@ ERROR: not-in-table value ; [ [ clear-code ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ (lzw-compress-chars) ] [ [ k>> ] [ lzw-bit-width-compress ] - [ output>> write-bits ] tri + [ output>> bs:poke ] tri ] [ [ end-of-information ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -152,7 +155,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -200,5 +203,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - binary + + ! binary ! [ lzw-uncompress-char ] [ output>> ] bi ; From 3901427128d81ae5820ddec883216598be6110e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:46:10 -0500 Subject: [PATCH 032/228] check in marc's jpeg loader, png decoder, huffman, inflate, and image-processing vocabularies --- basis/compression/huffman/huffman.factor | 88 +++++++ basis/compression/inflate/inflate.factor | 209 +++++++++++++++ basis/images/jpeg/jpeg.factor | 304 ++++++++++++++++++++++ basis/images/loader/loader.factor | 6 +- basis/images/png/png.factor | 21 +- basis/images/processing/processing.factor | 40 +++ 6 files changed, 665 insertions(+), 3 deletions(-) create mode 100755 basis/compression/huffman/huffman.factor create mode 100755 basis/compression/inflate/inflate.factor create mode 100755 basis/images/jpeg/jpeg.factor create mode 100755 basis/images/processing/processing.factor diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor new file mode 100755 index 0000000000..60b3a1d5a1 --- /dev/null +++ b/basis/compression/huffman/huffman.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alt.bitstreams arrays assocs constructors fry +hashtables io kernel locals math math.order math.parser +math.ranges multiline sequences ; +IN: compression.huffman + +QUALIFIED-WITH: alt.bitstreams bs + + ( -- code ) 0 0 0 huffman-code boa ; +: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ; +: next-code ( code -- ) [ 1+ ] change-code drop ; + +:: all-patterns ( huff n -- seq ) + n log2 huff size>> - :> free-bits + free-bits 0 > + [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ] + [ huff code>> free-bits neg 2^ /i 1array ] if ; + +:: huffman-each ( tdesc quot: ( huff -- ) -- ) + :> code + tdesc + [ + code next-size + [ code (>>value) code clone quot call code next-code ] each + ] each ; inline + +: update-reverse-table ( huff n table -- ) + [ drop all-patterns ] + [ nip '[ _ swap _ set-at ] each ] 3bi ; + +:: reverse-table ( tdesc n -- rtable ) + n f :> table + tdesc [ n table update-reverse-table ] huffman-each + table seq>> ; + +:: huffman-table ( tdesc max -- table ) + max f :> table + tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each + table ; + +PRIVATE> + +! decoder + +TUPLE: huffman-decoder + { bs } + { tdesc } + { rtable } + { bits/level } ; + +CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder ) + 16 >>bits/level + [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; + +: read1-huff ( decoder -- elt ) + 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +! %remove +: reverse-bits ( value bits -- value' ) + [ >bin ] [ CHAR: 0 pad-head bin> ] bi* ; + +: read1-huff2 ( decoder -- elt ) + 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +/* +: huff>string ( code -- str ) + [ value>> number>string ] + [ [ code>> ] [ size>> bits>string ] bi ] bi + " = " glue ; + +: huff. ( code -- ) huff>string print ; + +:: rtable. ( rtable -- ) + rtable length>> log2 :> n + rtable [ swap n bits. [ huff. ] each ] assoc-each ; +*/ diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor new file mode 100755 index 0000000000..a828718f75 --- /dev/null +++ b/basis/compression/inflate/inflate.factor @@ -0,0 +1,209 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs byte-arrays +byte-vectors combinators constructors fry grouping hashtables +compression.huffman images io.binary kernel locals +math math.bitwise math.order math.ranges multiline sequences +sorting ; +IN: compression.inflate + +QUALIFIED-WITH: alt.bitstreams bs + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ swap _ set-nth ] assoc-each ] keep ; + +ERROR: zlib-unimplemented ; +ERROR: bad-zlib-data ; +ERROR: bad-zlib-header ; + +:: check-zlib-header ( data -- ) + 16 data bs:peek 2 >le be> 31 mod ! checksum + 0 assert= + 4 data bs:read 8 assert= ! compression method: deflate + 4 data bs:read ! log2(max length)-8, 32K max + 7 <= [ bad-zlib-header ] unless + 5 data bs:seek ! drop check bits + 1 data bs:read 0 assert= ! dictionnary - not allowed in png + 2 data bs:seek ! compression level; ignore + ; + +:: default-table ( -- table ) + 0 :> table + 0 143 [a,b] 280 287 [a,b] append 8 table set-at + 144 255 [a,b] >array 9 table set-at + 256 279 [a,b] >array 7 table set-at + table enum>seq 1 tail ; + +CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } + +: get-table ( values size -- table ) + 16 f clone + [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; + +:: decode-huffman-tables ( bitstream -- tables ) + 5 bitstream bs:read 257 + + 5 bitstream bs:read 1 + + 4 bitstream bs:read 4 + + clen-shuffle swap head + dup [ drop 3 bitstream bs:read ] map + get-table + bitstream swap + [ 2dup + ] dip swap :> k! + '[ + _ read1-huff2 + { + { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] } + { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] } + { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] } + [ ] + } cond + dup array? [ dup second ] [ 1 ] if + k swap - dup k! 0 > + ] + [ ] produce swap suffix + { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 1array ] if ] map concat + nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; + +CONSTANT: length-table + { + 3 4 5 6 7 8 9 10 + 11 13 15 17 + 19 23 27 31 + 35 43 51 59 + 67 83 99 115 + 131 163 195 227 + } + +CONSTANT: dist-table + { 1 2 3 4 + 5 7 9 13 + 17 25 33 49 + 65 97 129 193 + 257 385 513 769 + 1025 1537 2049 3073 + 4097 6145 8193 12289 + 16385 24577 } + +: nth* ( n seq -- elt ) + [ length 1- swap - ] [ nth ] bi ; + +:: inflate-lz77 ( seq -- bytes ) + 1000 :> bytes + seq + [ + dup array? + [ first2 '[ _ 1- bytes nth* bytes push ] times ] + [ bytes push ] if + ] each + bytes ; + +:: inflate-dynamic ( bitstream -- bytes ) + bitstream decode-huffman-tables + bitstream '[ _ swap ] map :> tables + [ + tables first read1-huff2 + dup 256 > + [ + dup 285 = + [ ] + [ + dup 264 > + [ + dup 261 - 4 /i dup 5 > + [ bad-zlib-data ] when + bitstream bs:read 2array + ] + when + ] if + ! 5 bitstream read-bits ! distance + tables second read1-huff2 + dup 3 > + [ + dup 2 - 2 /i dup 13 > + [ bad-zlib-data ] when + bitstream bs:read 2array + ] + when + 2array + ] + when + dup 256 = not + ] + [ ] produce nip + [ + dup array? [ + first2 + [ + dup array? [ first2 ] [ 0 ] if + [ 257 - length-table nth ] [ + ] bi* + ] + [ + dup array? [ first2 ] [ 0 ] if + [ dist-table nth ] [ + ] bi* + ] bi* + 2array + ] when + ] map ; + +: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ; +: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; + +:: inflate-loop ( bitstream -- bytes ) + [ 1 bitstream bs:read 0 = ] + [ + bitstream + 2 bitstream bs:read ! B + { + { 0 [ inflate-raw ] } + { 1 [ inflate-static ] } + { 2 [ inflate-dynamic ] } + { 3 [ bad-zlib-data f ] } + } + case + ] + [ produce ] keep call suffix concat ; + + ! [ produce ] keep dip swap suffix + +:: paeth ( a b c -- p ) + a b + c - { a b c } [ [ - abs ] keep 2array ] with map + sort-keys first second ; + +:: png-unfilter-line ( prev curr filter -- curr' ) + prev :> c + prev 3 tail-slice :> b + curr :> a + curr 3 tail-slice :> x + x length [0,b) + filter + { + { 0 [ drop ] } + { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } + { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } + { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } + { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } + + } case + curr 3 tail ; + +PRIVATE> + +! for debug -- shows residual values +: reverse-png-filter' ( lines -- filtered ) + [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip + concat [ 128 + 256 wrap ] map ; + +: reverse-png-filter ( lines -- filtered ) + dup first [ 0 ] replicate prefix + [ { 0 0 } prepend ] map + 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; + +: zlib-inflate ( bytes -- bytes ) + bs: + [ check-zlib-header ] + [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor new file mode 100755 index 0000000000..0588e5c365 --- /dev/null +++ b/basis/images/jpeg/jpeg.factor @@ -0,0 +1,304 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators +constructors grouping compression.huffman images +images.processing io io.binary io.encodings.binary io.files +io.streams.byte-array kernel locals math math.bitwise +math.constants math.functions math.matrices math.order +math.ranges math.vectors memoize multiline namespaces +sequences sequences.deep ; +IN: images.jpeg + +QUALIFIED-WITH: alt.bitstreams bs + +TUPLE: jpeg-image < image + { headers } + { bitstream } + { color-info initial: { f f f f } } + { quant-tables initial: { f f } } + { huff-tables initial: { f f f f } } + { components } ; + +marker ( byte -- marker ) + byte + { + { [ dup HEX: CC = ] [ { DAC } ] } + { [ dup HEX: C4 = ] [ { DHT } ] } + { [ dup HEX: C9 = ] [ { JPG } ] } + { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] } + + { [ dup HEX: D8 = ] [ { SOI } ] } + { [ dup HEX: D9 = ] [ { EOI } ] } + { [ dup HEX: DA = ] [ { SOS } ] } + { [ dup HEX: DB = ] [ { DQT } ] } + { [ dup HEX: DC = ] [ { DNL } ] } + { [ dup HEX: DD = ] [ { DRI } ] } + { [ dup HEX: DE = ] [ { DHP } ] } + { [ dup HEX: DF = ] [ { EXP } ] } + { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] } + + { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] } + { [ dup HEX: FE = ] [ { COM } ] } + { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] } + + { [ dup HEX: 01 = ] [ { TEM } ] } + [ { RES } ] + } + cond nip ; + +TUPLE: jpeg-chunk length type data ; + +CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ; + +TUPLE: jpeg-color-info + h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ; + +CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; + +: jpeg> ( -- jpeg-image ) jpeg-image get ; + +: apply-diff ( dc color -- dc' ) + [ diff>> + dup ] [ (>>diff) ] bi ; + +: fetch-tables ( component -- ) + [ [ jpeg> quant-tables>> nth ] change-quant-table drop ] + [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ] + [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ; + +: read4/4 ( -- a b ) read1 16 /mod ; + + +! headers + +: decode-frame ( header -- ) + data>> + binary + [ + read1 8 assert= + 2 read be> + 2 read be> + swap 2array jpeg> (>>dim) + read1 + [ + read1 read4/4 read1 + swap [ >>id ] keep jpeg> color-info>> set-nth + ] times + ] with-byte-reader ; + +: decode-quant-table ( chunk -- ) + dup data>> + binary + [ + length>> + 2 - 65 / + [ + read4/4 [ 0 assert= ] dip + 64 read + swap jpeg> quant-tables>> set-nth + ] times + ] with-byte-reader ; + +: decode-huff-table ( chunk -- ) + data>> + binary + [ + 1 ! %fixme: Should handle multiple tables at once + [ + read4/4 swap 2 * + + 16 read + dup [ ] [ + ] map-reduce read + binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader + swap jpeg> huff-tables>> set-nth + ] times + ] with-byte-reader ; + +: decode-scan ( chunk -- ) + data>> + binary + [ + read1 [0,b) + [ drop + read1 jpeg> color-info>> nth clone + read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* + ] map jpeg> (>>components) + read1 0 assert= + read1 63 assert= + read1 16 /mod [ 0 assert= ] bi@ + ] with-byte-reader ; + +: singleton-first ( seq -- elt ) + [ length 1 assert= ] [ first ] bi ; + +: baseline-parse ( -- ) + jpeg> headers>> + { + [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ] + [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ] + [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ] + [ [ type>> { SOS } = ] filter singleton-first decode-scan ] + } cleave ; + +: parse-marker ( -- marker ) + read1 HEX: FF assert= + read1 >marker ; + +: parse-headers ( -- chunks ) + [ parse-marker dup { SOS } = not ] + [ + 2 read be> + dup 2 - read + ] [ produce ] keep dip swap suffix ; + +MEMO: zig-zag ( -- zz ) + { + { 0 1 5 6 14 15 27 28 } + { 2 4 7 13 16 26 29 42 } + { 3 8 12 17 25 30 41 43 } + { 9 11 18 24 31 40 44 53 } + { 10 19 23 32 39 45 52 54 } + { 20 22 33 38 46 51 55 60 } + { 21 34 37 47 50 56 59 61 } + { 35 36 48 49 57 58 62 63 } + } flatten ; + +MEMO: yuv>bgr-matrix ( -- m ) + { + { 1 2.03211 0 } + { 1 -0.39465 -0.58060 } + { 1 0 1.13983 } + } ; + +: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ; + +:: dct-vect ( u v -- basis ) + { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2 + 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ; + +MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ; + +: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; + +: all-macroblocks ( quot: ( mb -- ) -- ) + [ + jpeg> + [ dim>> 8 v/n ] + [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi + [ ceiling ] map + coord-matrix flip concat + ] + [ each ] bi* ; inline + +: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ; + +: idct-factor ( b -- b' ) dct-matrix v.m ; + +USE: math.blas.vectors +USE: math.blas.matrices + +MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; +: V.M ( x A -- x.A ) Mtranspose swap M.V ; +: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ; + +: idct ( b -- b' ) idct-blas ; + +:: draw-block ( block x,y color jpeg-image -- ) + block dup length>> sqrt >fixnum group flip + dup matrix-dim coord-matrix flip + [ + [ first2 spin nth nth ] + [ x,y v+ color id>> 1- jpeg-image draw-color ] bi + ] with each^2 ; + +: sign-extend ( bits v -- v' ) + swap [ ] [ 1- 2^ < ] 2bi + [ -1 swap shift 1+ + ] [ drop ] if ; + +: read1-jpeg-dc ( decoder -- dc ) + [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; + +: read1-jpeg-ac ( decoder -- run/ac ) + [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ; + +:: decode-block ( pos color -- ) + color dc-huff-table>> read1-jpeg-dc color apply-diff + 64 0 :> coefs + 0 coefs set-nth + 0 :> k! + [ + color ac-huff-table>> read1-jpeg-ac + [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri + { 0 0 } = not + k 63 < and + ] loop + coefs color quant-table>> v* + reverse-zigzag idct + ! %fixme: color hack + ! this eat 50% cpu time + color h>> 2 = + [ 8 group 2 matrix-zoom concat ] unless + pos { 8 8 } v* color jpeg> draw-block ; + +: decode-macroblock ( mb -- ) + jpeg> components>> + [ + [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ] + [ [ decode-block ] curry each ] bi + ] with each ; + +: cleanup-bitstream ( bytes -- bytes' ) + binary [ + [ + { HEX: FF } read-until + read1 tuck HEX: 00 = and + ] + [ drop ] produce + swap >marker { EOI } assert= + swap suffix + { HEX: FF } join + ] with-byte-reader ; + +: setup-bitmap ( image -- ) + dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim + BGR >>component-order + f >>upside-down? + dup dim>> first2 * 3 * 0 >>bitmap + drop ; + +: baseline-decompress ( -- ) + jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append + >byte-array bs: jpeg> (>>bitstream) + jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi + jpeg> components>> [ fetch-tables ] each + jpeg> setup-bitmap + [ decode-macroblock ] all-macroblocks ; + +! this eats ~25% cpu time +: color-transform ( yuv -- rgb ) + { 128 0 0 } v+ yuv>bgr-matrix swap m.v + [ 0 max 255 min >fixnum ] map ; + +PRIVATE> + +: load-jpeg ( path -- image ) + binary [ + parse-marker { SOI } assert= + parse-headers + contents + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> [ >byte-array ] change-bitmap drop + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index fe33cc8f00..27b726f3c0 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames +images.jpeg images.png ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ; { "bmp" [ bitmap-image ] } { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } + { "jpg" [ jpeg-image ] } + { "jpeg" [ jpeg-image ] } + { "png" [ png-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b027362977..bf13c43546 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -3,7 +3,7 @@ USING: accessors constructors images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.files io.files.info kernel sequences io.streams.limited fry combinators arrays math -checksums checksums.crc32 ; +checksums checksums.crc32 compression.inflate grouping byte-arrays ; IN: images.png TUPLE: png-image < image chunks @@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ; CONSTRUCTOR: png-chunk ( -- png-chunk ) ; -CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } +CONSTANT: png-header + B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } ERROR: bad-png-header header ; @@ -61,6 +62,18 @@ ERROR: bad-checksum ; : fill-image-data ( image -- image ) dup [ width>> ] [ height>> ] bi 2array >>dim ; +: zlib-data ( png-image -- bytes ) + chunks>> [ type>> "IDAT" = ] find nip data>> ; + +: decode-png ( image -- image ) + { + [ zlib-data zlib-inflate ] + [ dim>> first 3 * 1 + group reverse-png-filter ] + [ swap >byte-array >>bitmap drop ] + [ RGB >>component-order drop ] + [ ] + } cleave ; + : load-png ( path -- image ) [ binary ] [ file-info size>> ] bi stream-throws [ @@ -69,4 +82,8 @@ ERROR: bad-checksum ; read-png-chunks parse-ihdr-chunk fill-image-data + decode-png ] with-input-stream ; + +M: png-image load-image* + drop load-png ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor new file mode 100755 index 0000000000..2304c56171 --- /dev/null +++ b/basis/images/processing/processing.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators grouping images +images.loader images.viewer kernel locals math math.order +math.ranges math.vectors sequences sequences.deep fry ; +IN: images.processing + +: coord-matrix ( dim -- m ) + [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ; + +: map^2 ( m quot -- m' ) '[ _ map ] map ; inline +: each^2 ( m quot -- m' ) '[ _ each ] each ; inline + +: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ; + +: matrix>image ( m -- image ) + over matrix-dim >>dim + swap flip flatten + [ 128 * 128 + 0 max 255 min >fixnum ] map + >byte-array >>bitmap L >>component-order ; + +:: matrix-zoom ( m f -- m' ) + m matrix-dim f v*n coord-matrix + [ [ f /i ] map first2 swap m nth nth ] map^2 ; + +:: image-offset ( x,y image -- xy ) + image dim>> first + x,y second * x,y first + ; + +:: draw-grey ( value x,y image -- ) + x,y image image-offset 3 * { 0 1 2 } + [ + + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth + ] with each ; + +:: draw-color ( value x,y color-id image -- ) + x,y image image-offset 3 * color-id + value >fixnum + swap image bitmap>> set-nth ; + +! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ; From d7db5edadcfb3754ec711eaf25a4f58c81afc21c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 May 2009 16:54:16 -0500 Subject: [PATCH 033/228] Cleaning up USING: lists for new strict semantics --- basis/alien/c-types/c-types.factor | 10 +++++----- basis/bootstrap/compiler/compiler.factor | 9 +++++---- basis/bootstrap/image/image.factor | 2 +- basis/calendar/format/format.factor | 2 +- basis/compiler/cfg/rpo/rpo.factor | 2 +- basis/compiler/compiler.factor | 2 +- basis/compiler/tree/debugger/debugger.factor | 1 + basis/compiler/tree/def-use/def-use.factor | 2 +- .../tree/normalization/normalization.factor | 2 +- basis/compiler/tree/propagation/nodes/nodes.factor | 2 +- basis/concurrency/messaging/messaging-docs.factor | 2 +- basis/documents/documents.factor | 1 + basis/editors/editors.factor | 2 +- basis/environment/unix/unix.factor | 3 +-- basis/help/cookbook/cookbook.factor | 2 +- basis/http/client/client-docs.factor | 2 +- basis/http/client/client.factor | 2 +- basis/http/parsers/parsers.factor | 2 +- basis/images/tesselation/tesselation.factor | 2 +- basis/io/buffers/buffers.factor | 2 +- basis/io/launcher/unix/unix.factor | 5 +---- basis/io/sockets/secure/unix/unix.factor | 1 + basis/io/sockets/sockets.factor | 13 ++++++------- basis/io/sockets/unix/unix.factor | 12 ++++++------ basis/logging/server/server.factor | 8 ++++---- basis/models/range/range.factor | 1 + basis/opengl/textures/textures.factor | 2 +- basis/peg/ebnf/ebnf.factor | 8 +++++--- basis/peg/peg.factor | 2 +- basis/prettyprint/prettyprint-docs.factor | 2 +- .../random/mersenne-twister/mersenne-twister.factor | 2 -- basis/random/random.factor | 2 -- basis/stack-checker/inlining/inlining.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 4 ++-- basis/stack-checker/transforms/transforms.factor | 2 +- basis/ui/commands/commands.factor | 2 +- basis/ui/gadgets/buttons/buttons.factor | 1 + basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/gadgets.factor | 2 +- basis/ui/gadgets/glass/glass.factor | 1 + basis/ui/gadgets/menus/menus.factor | 2 +- basis/ui/gadgets/panes/panes.factor | 1 + basis/ui/gadgets/tables/tables.factor | 2 +- basis/ui/tools/browser/browser.factor | 11 ++++++----- basis/ui/tools/browser/popups/popups.factor | 1 + basis/ui/tools/debugger/debugger-docs.factor | 2 +- basis/ui/tools/debugger/debugger.factor | 2 +- basis/ui/tools/deploy/deploy.factor | 13 ++++++------- basis/ui/tools/error-list/error-list.factor | 2 +- basis/ui/tools/profiler/profiler.factor | 7 +++---- basis/ui/ui.factor | 2 +- basis/unix/debugger/debugger.factor | 3 ++- basis/unix/process/process.factor | 2 +- basis/unix/stat/stat.factor | 4 ---- basis/unix/types/types.factor | 3 +-- basis/unix/unix.factor | 3 ++- core/kernel/kernel-docs.factor | 2 +- core/slots/slots-docs.factor | 9 ++++----- 58 files changed, 98 insertions(+), 101 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index df5a5bbba8..6e398667ec 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private libc math -namespaces make parser sequences strings words assocs splitting -math.parser cpu.architecture alien alien.accessors alien.strings -quotations layouts system compiler.units io io.files -io.encodings.binary io.streams.memory accessors combinators effects -continuations fry classes ; +namespaces make parser sequences strings words splitting math.parser +cpu.architecture alien alien.accessors alien.strings quotations +layouts system compiler.units io io.files io.encodings.binary +io.streams.memory accessors combinators effects continuations fry +classes ; IN: alien.c-types DEFER: diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 3aefdec29f..5e3827efea 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors compiler cpu.architecture vocabs.loader system +USING: accessors cpu.architecture vocabs.loader system sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private growable namespaces.private assocs words command-line vocabs io -io.encodings.string libc splitting math.parser memory -compiler.units math.order compiler.tree.builder -compiler.tree.optimizer compiler.cfg.optimizer ; +io.encodings.string libc splitting math.parser memory compiler.units +math.order compiler.tree.builder compiler.tree.optimizer +compiler.cfg.optimizer ; +FROM: compiler => enable-optimizer compile-word ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 4a7a558703..68c7b23302 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays generic assocs hashtables assocs +USING: alien arrays byte-arrays generic hashtables hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser prettyprint sequences sequences.private strings sbufs vectors words diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index c2e95f2a9e..ad43cc2f1d 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.parser math.functions kernel sequences io accessors arrays io.streams.string splitting -combinators accessors calendar calendar.format.macros present ; +combinators calendar calendar.format.macros present ; IN: calendar.format : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 158903b4bf..bb4153da78 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces make math sequences sets -assocs fry compiler.cfg.instructions ; +assocs fry compiler.cfg compiler.cfg.instructions ; IN: compiler.cfg.rpo SYMBOL: visited diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 01e58461ff..c3d70fdc5b 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -generic.single combinators deques search-deques macros io +generic.single combinators deques search-deques macros source-files.errors stack-checker stack-checker.state stack-checker.inlining stack-checker.errors combinators.short-circuit compiler.errors compiler.units compiler.tree.builder diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 60cab92843..d1a9f5215a 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -16,6 +16,7 @@ compiler.tree.builder compiler.tree.optimizer compiler.tree.combinators compiler.tree.checker ; +FROM: fry => _ ; RENAME: _ match => __ IN: compiler.tree.debugger diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor index 705f44eeb6..fa504919a3 100644 --- a/basis/compiler/tree/def-use/def-use.factor +++ b/basis/compiler/tree/def-use/def-use.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces assocs sequences kernel generic assocs +USING: arrays namespaces sequences kernel generic assocs classes vectors accessors combinators sets stack-checker.state stack-checker.branches diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index ee7bf8672e..7494ed064e 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces sequences math math.order accessors kernel arrays -combinators compiler.utilities assocs +combinators assocs stack-checker.backend stack-checker.branches stack-checker.inlining diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index d676102bde..c3f5312601 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences accessors kernel assocs sequences +USING: sequences accessors kernel assocs compiler.tree compiler.tree.propagation.copy compiler.tree.propagation.info ; diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 41beedb6dc..039e9a53af 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: help.syntax help.markup concurrency.messaging.private -threads kernel arrays quotations threads strings ; +threads kernel arrays quotations strings ; IN: concurrency.messaging HELP: send diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index 451c912779..104dea6b98 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -3,6 +3,7 @@ USING: accessors arrays io kernel math models namespaces make sequences strings splitting combinators unicode.categories math.order math.ranges fry locals ; +FROM: models => change-model ; IN: documents : +col ( loc n -- newloc ) [ first2 ] dip + 2array ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index d5b4b909e3..f81490bcf2 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -4,7 +4,7 @@ USING: parser lexer kernel namespaces sequences definitions io.files io.backend io.pathnames io summary continuations tools.crossref vocabs.hierarchy prettyprint source-files source-files.errors assocs vocabs vocabs.loader splitting -accessors debugger prettyprint help.topics ; +accessors debugger help.topics ; IN: editors TUPLE: no-edit-hook ; diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index 7da19ee47b..84dfbbd43e 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax kernel layouts sequences system unix environment io.encodings.utf8 -unix.utilities vocabs.loader combinators alien.accessors -alien.syntax ; +unix.utilities vocabs.loader combinators alien.accessors ; IN: environment.unix HOOK: environ os ( -- void* ) diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 59486a9c35..8aa0265239 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io kernel math namespaces parser +USING: help.markup help.syntax io kernel math parser prettyprint sequences vocabs.loader namespaces stack-checker help command-line multiline see ; IN: help.cookbook diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index e00f8e2263..890518aa2a 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,5 +1,5 @@ USING: http help.markup help.syntax io.pathnames io.streams.string -io.encodings.8-bit io.encodings.binary kernel strings urls +io.encodings.8-bit io.encodings.binary kernel urls urls.encoding byte-arrays strings assocs sequences destructors http.client.post-data.private ; IN: http.client diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index d1997c73f9..2f6bcfafe9 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel math math.parser namespaces make +USING: assocs kernel math math.parser namespaces make sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 2520c35acb..1810617c56 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit math math.order math.parser kernel sequences sequences.deep peg peg.parsers assocs arrays -hashtables strings unicode.case namespaces make ascii ; +hashtables strings namespaces make ascii ; IN: http.parsers : except ( quot -- parser ) diff --git a/basis/images/tesselation/tesselation.factor b/basis/images/tesselation/tesselation.factor index 694041a28d..cbdf396b48 100644 --- a/basis/images/tesselation/tesselation.factor +++ b/basis/images/tesselation/tesselation.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences kernel math grouping fry columns locals accessors -images math math.vectors arrays ; +images math.vectors arrays ; IN: images.tesselation : group-rows ( bitmap bitmap-dim -- rows ) diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 49b5357d98..c9396dd081 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.accessors alien.c-types alien.syntax kernel libc math sequences byte-arrays strings -hints accessors math.order destructors combinators ; +hints math.order destructors combinators ; IN: io.buffers TUPLE: buffer diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index 5d7502f681..5424ab4238 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -4,13 +4,10 @@ USING: accessors alien.c-types arrays assocs combinators continuations environment io io.backend io.backend.unix io.files io.files.private io.files.unix io.launcher io.launcher.unix.parser io.pathnames io.ports kernel math -namespaces sequences strings system threads unix unix +namespaces sequences strings system threads unix unix.process ; IN: io.launcher.unix -! Search unix first -USE: unix - : get-arguments ( process -- seq ) command>> dup string? [ tokenize-command ] when ; diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index f1f39a0559..6580af891d 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -7,6 +7,7 @@ openssl.libcrypto openssl.libssl io io.files io.ports io.backend.unix io.sockets.unix io.encodings.ascii io.buffers io.sockets io.sockets.secure io.sockets.secure.openssl io.timeouts system summary fry ; +FROM: io.ports => shutdown ; IN: io.sockets.secure.unix M: ssl-handle handle-fd file>> handle-fd ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 0671247ade..d6a8d1b54e 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -1,18 +1,17 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman, ! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings io.ports io.streams.duplex -io.encodings.ascii alien.strings io.binary accessors destructors -classes byte-arrays system combinators parser -alien.c-types math.parser splitting grouping math assocs summary -system vocabs.loader combinators present fry vocabs.parser ; +USING: generic kernel io.backend namespaces continuations sequences +arrays io.encodings io.ports io.streams.duplex io.encodings.ascii +alien.strings io.binary accessors destructors classes byte-arrays +parser alien.c-types math.parser splitting grouping math assocs +summary system vocabs.loader combinators present fry vocabs.parser ; IN: io.sockets << { { [ os windows? ] [ "windows.winsock" ] } { [ os unix? ] [ "unix" ] } -} cond add-use >> +} cond add-ambiguous-use >> ! Addressing GENERIC: protocol-family ( addrspec -- af ) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 68c7d5c196..6ba7ca2322 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings generic kernel math -namespaces threads sequences byte-arrays io.ports -io.binary io.backend.unix io.streams.duplex -io.backend io.ports io.pathnames io.files.private -io.encodings.utf8 math.parser continuations libc combinators -system accessors destructors unix locals init ; +USING: alien alien.c-types alien.strings generic kernel math threads +sequences byte-arrays io.ports io.binary io.backend.unix +io.streams.duplex io.backend io.ports io.pathnames io.files.private +io.encodings.utf8 math.parser continuations libc combinators system +accessors destructors unix locals init ; +EXCLUDE: namespaces => bind ; EXCLUDE: io => read write ; EXCLUDE: io.sockets => accept ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 7dced852fd..8374ab421b 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel io io.files io.pathnames io.directories -io.sockets io.encodings.utf8 -calendar calendar.format sequences continuations destructors -prettyprint assocs math.parser words debugger math combinators -concurrency.messaging threads arrays init math.ranges strings ; +io.encodings.utf8 calendar calendar.format sequences continuations +destructors prettyprint assocs math.parser words debugger math +combinators concurrency.messaging threads arrays init math.ranges +strings ; IN: logging.server : log-root ( -- string ) diff --git a/basis/models/range/range.factor b/basis/models/range/range.factor index a1abd9aeea..c8bc8d8e54 100644 --- a/basis/models/range/range.factor +++ b/basis/models/range/range.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel models arrays sequences math math.order models.product ; +FROM: models.product => product ; IN: models.range TUPLE: range < product ; diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 49725d2242..f0edab23a3 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs cache colors.constants destructors fry kernel +USING: accessors assocs cache colors.constants destructors kernel opengl opengl.gl opengl.capabilities combinators images images.tesselation grouping specialized-arrays.float sequences math math.vectors math.matrices generalizations fry arrays namespaces diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index fafb846147..94df4ca209 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel compiler.units words arrays strings math.parser +USING: kernel words arrays strings math.parser sequences quotations vectors namespaces make math assocs continuations peg peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker -io combinators parser vocabs.parser summary ; +io combinators parser summary ; +FROM: compiler.units => with-compilation-unit ; +FROM: vocabs.parser => search ; IN: peg.ebnf : rule ( name word -- parser ) @@ -441,7 +443,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) drop ] [ [ - "USING: locals sequences ; [let* | " % + "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " % dup length swap [ dup ebnf-var? [ name>> % diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index dda36432e7..c76ca7ac9c 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces make math assocs -io vectors arrays math.parser math.order vectors combinators +io vectors arrays math.parser math.order combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting combinators.short-circuit generalizations ; diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index f938ab30f7..1af921d4f3 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -1,5 +1,5 @@ USING: prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections prettyprint.private help.markup help.syntax +prettyprint.sections help.markup help.syntax io kernel words definitions quotations strings generic classes prettyprint.private ; IN: prettyprint diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 361ba7719e..a02abbb8ac 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -69,8 +69,6 @@ M: mersenne-twister random-32* ( mt -- r ) [ seq>> nth-unsafe mt-temper ] [ [ 1+ ] change-i drop ] tri ; -USE: init - [ [ 32 random-bits ] with-system-random random-generator set-global diff --git a/basis/random/random.factor b/basis/random/random.factor index 661e771258..1962857d57 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -86,8 +86,6 @@ PRIVATE> [ 1.0 swap - log -2.0 * sqrt ] bi* * * + ; -USE: vocabs.loader - { { [ os windows? ] [ "random.windows" require ] } { [ os unix? ] [ "random.unix" require ] } diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 23283fb6e3..c99e0f0252 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry namespaces assocs kernel sequences words accessors definitions math math.order effects classes arrays combinators -vectors arrays hints +vectors hints stack-checker.state stack-checker.errors stack-checker.values diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 56ef67d2a8..70382c0829 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors alien alien.accessors arrays byte-arrays classes -sequences.private continuations.private effects generic hashtables +continuations.private effects generic hashtables hashtables.private io io.backend io.files io.files.private io.streams.c kernel kernel.private math math.private math.parser.private memory memory.private namespaces @@ -11,7 +11,7 @@ strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions assocs summary compiler.units system.private combinators combinators.short-circuit locals locals.backend locals.types -quotations.private combinators.private stack-checker.values +combinators.private stack-checker.values generic.single generic.single.private alien.libraries stack-checker.alien diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 8113a662d6..a85cd44a47 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: fry accessors arrays kernel kernel.private combinators.private words sequences generic math math.order namespaces quotations assocs combinators combinators.short-circuit classes.tuple -classes.tuple.private effects summary hashtables classes generic sets +classes.tuple.private effects summary hashtables classes sets definitions generic.standard slots.private continuations locals sequences.private generalizations stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index 28529b013b..f45c3f8b05 100644 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel sequences strings -math assocs words generic namespaces make assocs quotations +math assocs words generic namespaces make quotations splitting ui.gestures unicode.case unicode.categories tr fry ; IN: ui.commands diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 0504231972..ec11bac2d3 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -7,6 +7,7 @@ ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid ui.pens.image ui.pens.tile math.rectangles locals fry combinators.smart ; +FROM: models => change-model ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 9461b2348f..aa2b9ca58c 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -3,7 +3,7 @@ USING: accessors arrays documents documents.elements kernel math math.ranges models models.arrow namespaces locals fry make opengl opengl.gl sequences strings math.vectors math.functions sorting colors -colors.constants combinators assocs math.order fry calendar alarms +colors.constants combinators assocs math.order calendar alarms continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 5dd1710cdd..6a289ec1d6 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays hashtables kernel models math namespaces +USING: accessors arrays hashtables kernel math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads concurrency.flags math.order math.rectangles fry locals ; diff --git a/basis/ui/gadgets/glass/glass.factor b/basis/ui/gadgets/glass/glass.factor index 945e16150d..d6b87193ca 100644 --- a/basis/ui/gadgets/glass/glass.factor +++ b/basis/ui/gadgets/glass/glass.factor @@ -3,6 +3,7 @@ USING: accessors kernel namespaces ui.gadgets ui.gadgets.worlds ui.gadgets.wrappers ui.gestures math.rectangles math.rectangles.positioning combinators vectors ; +FROM: ui.gadgets.wrappers => wrapper ; IN: ui.gadgets.glass GENERIC: hide-glass-hook ( gadget -- ) diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 734190e7e7..159da59be5 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -3,7 +3,7 @@ USING: colors.constants kernel locals math.rectangles namespaces sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds -ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations +ui.gadgets.corners ui.gestures ui.operations ui.render ui.pens ui.pens.solid opengl math.vectors words accessors math math.order sorting ; IN: ui.gadgets.menus diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 6f6e7ee95f..eb741f13b6 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -11,6 +11,7 @@ ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment colors io.styles ; +FROM: io.styles => foreground background ; IN: ui.gadgets.panes TUPLE: pane < track diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index ba3b5a2f78..390e652ac6 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -5,7 +5,7 @@ math.functions math.rectangles math.order math.vectors namespaces opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support -math.rectangles models math.ranges sequences combinators +models math.ranges combinators combinators.short-circuit fonts locals strings ; IN: ui.gadgets.tables diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 1b8af1dd03..21d827da9b 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger classes help help.topics help.crossref help.home kernel models -compiler.units assocs words vocabs accessors fry arrays -combinators.short-circuit namespaces sequences models help.apropos +USING: debugger classes help help.topics help.crossref help.home +kernel models compiler.units assocs words vocabs accessors fry arrays +combinators.short-circuit namespaces sequences help.apropos combinators ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels -ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports -ui.tools.common ui.tools.browser.popups ui.tools.browser.history ; +ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders +ui.gadgets.viewports ui.tools.common ui.tools.browser.popups +ui.tools.browser.history ; IN: ui.tools.browser TUPLE: browser-gadget < tool history pane scroller search-field popup ; diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 2cd90ab335..ac4318fa92 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -6,6 +6,7 @@ sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ui.images ; +FROM: ui.gadgets.wrappers => wrapper ; IN: ui.tools.browser.popups SINGLETON: link-renderer diff --git a/basis/ui/tools/debugger/debugger-docs.factor b/basis/ui/tools/debugger/debugger-docs.factor index b68b349774..21a0e95eb4 100644 --- a/basis/ui/tools/debugger/debugger-docs.factor +++ b/basis/ui/tools/debugger/debugger-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets help.markup help.syntax kernel quotations -continuations debugger ui continuations ; +continuations debugger ui ; IN: ui.tools.debugger HELP: diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 2c653266e5..cf86ce4223 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables io kernel math models -colors.constants namespaces sequences sequences words continuations +colors.constants namespaces sequences words continuations debugger prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets ui.pens.solid ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index d3c1278bf5..cf6f1c066d 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: colors kernel namespaces models tools.deploy.config -tools.deploy.config.editor tools.deploy vocabs -namespaces models.mapping sequences system accessors fry -ui.gadgets ui.render ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.labels ui.gadgets.editors ui.gadgets.borders ui.gestures -ui.commands assocs ui.gadgets.tracks ui ui.tools.listener -ui.tools.browser ; +USING: colors kernel models tools.deploy.config +tools.deploy.config.editor tools.deploy vocabs namespaces +models.mapping sequences system accessors fry ui.gadgets ui.render +ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels +ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands assocs +ui.gadgets.tracks ui ui.tools.listener ui.tools.browser ; IN: ui.tools.deploy TUPLE: deploy-gadget < pack vocab settings ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 704ae112e5..e9d4b50bac 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -8,7 +8,7 @@ models.arrow.smart models.search models.mapping debugger namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers -ui.tools.inspector ui.gadgets.status-bar ui.operations +ui.tools.inspector ui.gadgets.status-bar ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels ui.baseline-alignment ui.images compiler.errors tools.errors tools.errors.model ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 5fef64ea88..8be357b409 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -6,10 +6,9 @@ vocabs tools.profiler words prettyprint combinators.smart definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled -ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels -ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders -ui.tools.browser ui.tools.common ui.baseline-alignment -ui.operations ui.images ; +ui.gadgets.packs ui.gadgets.labels ui.gadgets.tabbed +ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser +ui.tools.common ui.baseline-alignment ui.operations ui.images ; FROM: models.arrow => ; FROM: models.arrow.smart => ; FROM: models.product => ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index b1bfce26e6..144530399c 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make dlists -deques sequences threads sequences words continuations init +deques sequences threads words continuations init combinators combinators.short-circuit hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render diff --git a/basis/unix/debugger/debugger.factor b/basis/unix/debugger/debugger.factor index e059e1a184..4e276373e1 100644 --- a/basis/unix/debugger/debugger.factor +++ b/basis/unix/debugger/debugger.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger prettyprint accessors unix io kernel ; +USING: debugger prettyprint accessors unix kernel ; +FROM: io => write print nl ; IN: unix.debugger M: unix-error error. diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 22757cdbe1..9819e50843 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,5 +1,5 @@ USING: kernel alien.c-types alien.strings sequences math alien.syntax unix -vectors kernel namespaces continuations threads assocs vectors +vectors namespaces continuations threads assocs vectors io.backend.unix io.encodings.utf8 unix.utilities fry ; IN: unix.process diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 156be96190..c3ab099d38 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -15,10 +15,6 @@ CONSTANT: S_IFLNK OCT: 120000 ! Symbolic link. CONSTANT: S_IFSOCK OCT: 140000 ! Socket. CONSTANT: S_IFWHT OCT: 160000 ! Whiteout. -FUNCTION: int chmod ( char* path, mode_t mode ) ; -FUNCTION: int fchmod ( int fd, mode_t mode ) ; -FUNCTION: int mkdir ( char* path, mode_t mode ) ; - C-STRUCT: fsid { { "int" 2 } "__val" } ; diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index f7ce6406fe..4ca2c4368a 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -1,5 +1,4 @@ -USING: kernel system alien.syntax combinators vocabs.loader -system ; +USING: kernel system alien.syntax combinators vocabs.loader ; IN: unix.types TYPEDEF: char int8_t diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 95dca2cb34..9c4251dd1e 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader accessors stack-checker macros locals generalizations unix.types -io vocabs vocabs.loader ; +io vocabs ; IN: unix CONSTANT: PROT_NONE 0 @@ -132,6 +132,7 @@ FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int listen ( int s, int backlog ) ; FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ; +FUNCTION: int mkdir ( char* path, mode_t mode ) ; FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ; FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 22e0e76451..b617544084 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax math memory namespaces sequences kernel.private layouts classes -kernel.private vectors combinators quotations strings words +vectors combinators quotations strings words assocs arrays math.order ; IN: kernel diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 1e5f9bf1dd..348e2ec2b2 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,8 +1,7 @@ -USING: help.markup help.syntax generic kernel.private parser -words kernel quotations namespaces sequences words arrays -effects generic.standard classes.builtin -slots.private classes strings math assocs byte-arrays alien -math classes.tuple ; +USING: help.markup help.syntax generic kernel.private parser words +kernel quotations namespaces sequences words arrays effects +generic.standard classes.builtin slots.private classes strings math +assocs byte-arrays alien classes.tuple ; IN: slots ARTICLE: "accessors" "Slot accessors" From 88b91de39878bc5f282a278b7f55470f83ca0f23 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 17:26:54 -0500 Subject: [PATCH 034/228] no reason not to use bit-array for game-input key state --- basis/game-input/iokit/iokit.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 5f09a054f9..32440e92b2 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs vectors arrays combinators hints alien core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input vectors ; +alien.c-types math parser game-input vectors bit-arrays ; IN: game-input.iokit SINGLETON: iokit-game-input-backend @@ -186,7 +186,7 @@ HINTS: record-controller { controller-state alien } ; rot ?set-nth ] [ 3drop ] if ; -HINTS: record-keyboard { array alien } ; +HINTS: record-keyboard { bit-array alien } ; : record-mouse ( mouse-state value -- ) dup IOHIDValueGetElement { @@ -285,7 +285,7 @@ M: iokit-game-input-backend reset-mouse 4 +controller-states+ set-global 0 0 0 0 2 mouse-state boa +mouse-state+ set-global - 256 f +keyboard-state+ set-global ; + 256 +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) hid-manager-matching-game-devices { From fc59ee2e4a44eb0e8810f2366ebf16c7704f92bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 17:29:25 -0500 Subject: [PATCH 035/228] set first responder on cocoa view back when returning from fullscreen mode. un-fullscreen the view if window is closed while view is fullscreen --- basis/ui/backend/cocoa/cocoa.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 73eff25240..b6c9b43271 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -99,7 +99,9 @@ M: cocoa-ui-backend set-title ( string world -- ) drop ; : exit-fullscreen ( world -- ) - handle>> view>> f -> exitFullScreenModeWithOptions: ; + handle>> + [ view>> f -> exitFullScreenModeWithOptions: ] + [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ; M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) [ enter-fullscreen ] [ exit-fullscreen ] if ; @@ -120,7 +122,11 @@ M:: cocoa-ui-backend (open-window) ( world -- ) window f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) - window>> -> release ; + [ + view>> dup -> isInFullScreenMode zero? + [ drop ] + [ f -> exitFullScreenModeWithOptions: ] if + ] [ window>> -> release ] bi ; M: cocoa-ui-backend (grab-input) ( handle -- ) 0 CGAssociateMouseAndMouseCursorPosition drop From 01801c39c8baa2f080aac4d024f709684943aab8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 May 2009 17:36:07 -0500 Subject: [PATCH 036/228] copy-tree now preserves file permissions on Unix --- basis/io/directories/hierarchy/hierarchy.factor | 2 +- basis/io/files/info/info.factor | 6 +++++- basis/io/files/info/unix/unix.factor | 5 ++++- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor index 555f001bfc..4a2955ccaf 100644 --- a/basis/io/directories/hierarchy/hierarchy.factor +++ b/basis/io/directories/hierarchy/hierarchy.factor @@ -20,7 +20,7 @@ DEFER: copy-tree-into { { +symbolic-link+ [ copy-link ] } { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] } - [ drop copy-file ] + [ drop copy-file-and-info ] } case ; : copy-tree-into ( from to -- ) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index f16db428a8..60a9308f38 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel system sequences combinators -vocabs.loader io.files.types math ; +vocabs.loader io.files.types io.directories math ; IN: io.files.info ! File info @@ -29,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info ) { [ os unix? ] [ "io.files.info.unix." os name>> append ] } { [ os windows? ] [ "io.files.info.windows" ] } } cond require + +HOOK: copy-file-and-info os ( from to -- ) + +M: object copy-file-and-info copy-file ; diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 80f4b74ac8..94cb60a2c6 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -3,7 +3,7 @@ USING: accessors kernel system math math.bitwise strings arrays sequences combinators combinators.short-circuit alien.c-types vocabs.loader calendar calendar.unix io.files.info -io.files.types io.backend unix unix.stat unix.time unix.users +io.files.types io.backend io.directories unix unix.stat unix.time unix.users unix.groups ; IN: io.files.info.unix @@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001 : file-permissions ( path -- n ) normalize-path file-info permissions>> ; +M: unix copy-file-and-info ( from to -- ) + [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ; + Date: Thu, 14 May 2009 17:37:14 -0500 Subject: [PATCH 037/228] don't unfocus the world if cocoa view has gone fullscreen; the original window isn't really associated with the view while fullscreen --- basis/ui/backend/cocoa/views/views.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index aab851c783..a9568d4f75 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -391,7 +391,10 @@ CLASS: { { "windowDidResignKey:" "void" { "id" "SEL" "id" } [ forget-rollover - 2nip -> object -> contentView window unfocus-world + 2nip -> object -> contentView + dup -> isInFullScreenMode zero? + [ window unfocus-world ] + [ drop ] if ] } From 3ebd4594e853b884d7187820eb2b46315949d187 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 May 2009 22:31:29 -0500 Subject: [PATCH 038/228] Implement stricter vocab search path semantics, with a new API for vocabs.parser. Add map-find-last to sequences vocab --- basis/alien/complex/functor/functor.factor | 2 +- basis/alien/syntax/syntax.factor | 2 +- basis/command-line/command-line.factor | 2 - basis/functors/functors.factor | 4 +- basis/help/syntax/syntax.factor | 2 +- basis/io/sockets/sockets.factor | 2 +- basis/listener/listener-tests.factor | 2 +- basis/listener/listener.factor | 4 +- basis/locals/parser/parser.factor | 14 +- basis/opengl/gl/extensions/extensions.factor | 2 +- .../pixel-formats/pixel-formats-docs.factor | 4 +- basis/ui/tools/listener/listener.factor | 19 +- basis/ui/tools/operations/operations.factor | 4 +- core/bootstrap/stage1.factor | 14 +- core/classes/parser/parser.factor | 2 +- core/init/init.factor | 3 +- core/io/backend/backend.factor | 2 +- core/parser/parser.factor | 22 +- core/sbufs/sbufs.factor | 2 +- core/sequences/sequences.factor | 15 +- core/slots/slots.factor | 2 +- core/sorting/sorting.factor | 6 +- core/syntax/syntax.factor | 18 +- core/vocabs/parser/parser.factor | 213 +++++++++++++----- core/vocabs/vocabs.factor | 6 + core/words/words.factor | 8 +- extra/infix/infix.factor | 8 +- 27 files changed, 240 insertions(+), 144 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 31af0291b4..fc9e594be5 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -23,7 +23,7 @@ WHERE : *T ( alien -- z ) [ T-real ] [ T-imaginary ] bi rect> ; inline -T in get +T current-vocab { { N "real" } { N "imaginary" } } define-struct diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 0cc6d51446..d479e6d498 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -22,7 +22,7 @@ SYNTAX: TYPEDEF: scan scan typedef ; SYNTAX: C-STRUCT: - scan in get parse-definition define-struct ; + scan current-vocab parse-definition define-struct ; SYNTAX: C-UNION: scan parse-definition define-union ; diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index f2da4ebdf5..19421359a3 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -69,6 +69,4 @@ SYMBOL: main-vocab-hook : ignore-cli-args? ( -- ? ) os macosx? "run" get "ui" = and ; -: script-mode ( -- ) ; - [ default-cli-args ] "command-line" add-init-hook diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index edd4932c66..e5eb50e82f 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -146,10 +146,10 @@ DEFER: ;FUNCTOR delimiter } ; : push-functor-words ( -- ) - functor-words use get push ; + functor-words use-words ; : pop-functor-words ( -- ) - functor-words use get delq ; + functor-words unuse-words ; : parse-functor-body ( -- form ) push-functor-words diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 1844d18d94..af4b9e5e12 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -16,4 +16,4 @@ SYNTAX: ARTICLE: ] dip remember-definition ; SYNTAX: ABOUT: - in get vocab scan-object >>help changed-definition ; + current-vocab scan-object >>help changed-definition ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index d6a8d1b54e..98b9a2ce23 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -11,7 +11,7 @@ IN: io.sockets << { { [ os windows? ] [ "windows.winsock" ] } { [ os unix? ] [ "unix" ] } -} cond add-ambiguous-use >> +} cond use-vocab >> ! Addressing GENERIC: protocol-family ( addrspec -- af ) diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 9ae5250416..ccdd0be8c8 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -15,7 +15,7 @@ SYNTAX: hello "Hi" print ; ] with-file-vocabs [ - "debugger" add-use + "debugger" add-ambiguous-use [ [ \ + 1 2 3 4 ] ] [ diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 68777f2f73..4563f61ab7 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -10,7 +10,7 @@ IN: listener GENERIC: stream-read-quot ( stream -- quot/f ) : parse-lines-interactive ( lines -- quot/f ) - [ parse-lines in get ] with-compilation-unit in set ; + [ parse-lines ] with-compilation-unit ; : read-quot-step ( lines -- quot/f ) [ parse-lines-interactive ] [ @@ -98,7 +98,7 @@ t error-summary? set-global ] [ drop ] if ; : prompt. ( -- ) - in get auto-use? get [ " - auto" append ] when "( " " )" surround + current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; :: (listener) ( datastack -- ) diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 5e9bdfbed6..8cfe45d1ba 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -25,12 +25,6 @@ SYMBOL: in-lambda? [ [ dup name>> set ] [ ] [ ] tri ] dip "local-word-def" set-word-prop ; -: push-locals ( assoc -- ) - use get push ; - -: pop-locals ( assoc -- ) - use get delq ; - SINGLETON: lambda-parser SYMBOL: locals @@ -39,7 +33,9 @@ SYMBOL: locals '[ in-lambda? on lambda-parser quotation-parser set - [ locals set ] [ push-locals @ ] [ pop-locals ] tri + [ locals set ] + [ use-words @ ] + [ unuse-words ] tri ] with-scope ; inline : (parse-lambda) ( assoc -- quot ) @@ -81,9 +77,9 @@ M: lambda-parser parse-quotation ( -- quotation ) : parse-bindings* ( end -- words assoc ) [ - namespace push-locals + namespace use-words (parse-bindings) - namespace pop-locals + namespace unuse-words ] with-bindings ; : parse-let* ( -- form ) diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 8878e1904a..9aa4ee429d 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/basis/opengl/gl/extensions/extensions.factor @@ -9,7 +9,7 @@ ERROR: unknown-gl-platform ; { [ os macosx? ] [ "opengl.gl.macosx" ] } { [ os unix? ] [ "opengl.gl.unix" ] } [ unknown-gl-platform ] -} cond add-use >> +} cond use-vocab >> SYMBOL: +gl-function-number-counter+ SYMBOL: +gl-function-pointers+ diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 53e44ec18e..b1ab1bc398 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -1,12 +1,12 @@ USING: destructors help.markup help.syntax kernel math multiline sequences -vocabs vocabs.parser words ; +vocabs vocabs.parser words namespaces ; IN: ui.pixel-formats ! break circular dependency << "ui.gadgets.worlds" create-vocab drop "world" "ui.gadgets.worlds" create drop - "ui.gadgets.worlds" (add-use) + "ui.gadgets.worlds" vocab-words use-words >> ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6ed3577a06..19328b0b31 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -38,13 +38,12 @@ output history flag mailbox thread waiting token-model word-model popup ; [ thread>> dup [ thread-registered? ] when ] } 1&& not ; -SLOT: vocabs +SLOT: manifest -M: interactor vocabs>> +M: interactor manifest>> dup interactor-busy? [ drop f ] [ - use swap interactor-continuation name>> - assoc-stack + manifest swap assoc-stack ] if ; : vocab-exists? ( name -- ? ) @@ -56,7 +55,7 @@ M: vocab-completion (word-at-caret) drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ; M: word-completion (word-at-caret) - vocabs>> assoc-stack ; + manifest>> search-manifest ; M: char-completion (word-at-caret) 2drop f ; @@ -300,15 +299,15 @@ M: listener-operation invoke-command ( target command -- ) : clear-stack ( listener -- ) [ [ clear ] \ clear ] dip (call-listener) ; -: use-if-necessary ( word seq -- ) +: use-if-necessary ( word manifest -- ) 2dup [ vocabulary>> ] dip and [ - 2dup [ assoc-stack ] keep = [ 2drop ] [ - [ vocabulary>> vocab-words ] dip push - ] if + manifest [ + vocabulary>> use-vocab + ] with-variable ] [ 2drop ] if ; M: word accept-completion-hook - interactor>> vocabs>> use-if-necessary ; + interactor>> manifest>> use-if-necessary ; M: object accept-completion-hook 2drop ; diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 49bb74d18c..4944cba1d6 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -131,13 +131,13 @@ M: quotation com-stack-effect infer. ; M: word com-stack-effect 1quotation com-stack-effect ; -: com-enter-in ( vocab -- ) vocab-name set-in ; +: com-enter-in ( vocab -- ) vocab-name set-current-vocab ; [ vocab? ] \ com-enter-in H{ { +listener+ t } } define-operation -: com-use-vocab ( vocab -- ) vocab-name add-use ; +: com-use-vocab ( vocab -- ) vocab-name use-vocab ; [ vocab-spec? ] \ com-use-vocab H{ { +secondary+ t } diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 1da2dfee59..088a8a6320 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays debugger generic hashtables io assocs -kernel.private kernel math memory namespaces make parser -prettyprint sequences vectors words system splitting -init io.files bootstrap.image bootstrap.image.private vocabs -vocabs.loader system debugger continuations ; +USING: arrays debugger generic hashtables io assocs kernel.private +kernel math memory namespaces make parser prettyprint sequences +vectors words system splitting init io.files vocabs vocabs.loader +debugger continuations ; +QUALIFIED: bootstrap.image.private IN: bootstrap.stage1 "Bootstrap stage 1..." print flush @@ -51,4 +51,4 @@ load-help? off ] if ] % ] [ ] make -bootstrap-boot-quot set +bootstrap.image.private:bootstrap-boot-quot set diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor index 17a7b23552..bd2e6ea4a0 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser words kernel classes compiler.units lexer ; +USING: parser vocabs.parser words kernel classes compiler.units lexer ; IN: classes.parser : save-class-location ( class -- ) diff --git a/core/init/init.factor b/core/init/init.factor index 0140fcc0e8..5d8e88b85f 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations continuations.private kernel -kernel.private sequences assocs namespaces namespaces.private -continuations continuations.private ; +kernel.private sequences assocs namespaces namespaces.private ; IN: init SYMBOL: init-hooks diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index ac3fbef8d0..84d1f52b9c 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting alien ; +io.encodings.utf8 assocs splitting alien ; IN: io.backend SYMBOL: io-backend diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d802fd72fa..31b5286c18 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -31,16 +31,6 @@ t parser-notes set-global M: parsing-word stack-effect drop (( parsed -- parsed )) ; -TUPLE: no-current-vocab ; - -: no-current-vocab ( -- vocab ) - \ no-current-vocab boa - { { "Define words in scratchpad vocabulary" "scratchpad" } } - throw-restarts dup set-in ; - -: current-vocab ( -- str ) - in get [ no-current-vocab ] unless* ; - : create-in ( str -- word ) current-vocab create dup set-word dup save-location ; @@ -55,7 +45,7 @@ SYMBOL: auto-use? : no-word-restarted ( restart-value -- word ) dup word? [ dup vocabulary>> - [ (add-use) ] + [ use-vocab ] [ amended-use get dup [ push ] [ 2drop ] if ] [ "Added \"" "\" vocabulary to search path" surround note. ] tri @@ -134,8 +124,9 @@ SYMBOL: bootstrap-syntax : with-file-vocabs ( quot -- ) [ - f in set { "syntax" } set-use - bootstrap-syntax get [ use get push ] when* + manifest set + "syntax" use-vocab + bootstrap-syntax get [ use-words ] when* call ] with-scope ; inline @@ -195,8 +186,9 @@ SYMBOL: interactive-vocabs : with-interactive-vocabs ( quot -- ) [ - "scratchpad" in set - interactive-vocabs get set-use + manifest set + "scratchpad" set-current-vocab + interactive-vocabs get only-use-vocabs call ] with-scope ; inline diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 5590432ef4..0b2c170c1e 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math strings sequences.private sequences +USING: accessors kernel math sequences.private sequences strings growable strings.private ; IN: sbufs diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index dd48501fa0..99dddb8aed 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -834,11 +834,20 @@ PRIVATE> [ [ 2unclip-slice ] dip [ call ] keep ] dip compose 2reduce ; inline -: map-find ( seq quot -- result elt ) - [ f ] 2dip - [ [ nip ] dip call dup ] curry find + + +: map-find ( seq quot -- result elt ) + [ find ] (map-find) ; inline + +: map-find-last ( seq quot -- result elt ) + [ find-last ] (map-find) ; inline + : unclip-last-slice ( seq -- butlast-slice last ) [ but-last-slice ] [ peek ] bi ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 6bb854daf6..304ded0adb 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays byte-arrays kernel kernel.private math namespaces -make sequences strings words effects generic generic.standard +make sequences strings effects generic generic.standard classes classes.algebra slots.private combinators accessors words sequences.private assocs alien quotations hashtables ; IN: slots diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index f2fa6b8771..0c0951bbce 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel math sequences vectors math.order -sequences sequences.private math.order ; +USING: accessors arrays kernel math vectors math.order +sequences sequences.private ; IN: sorting ! Optimized merge-sort: diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8d52a2c786..b29c20850b 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -41,28 +41,26 @@ IN: bootstrap.syntax "#!" [ POSTPONE: ! ] define-core-syntax - "IN:" [ scan set-in ] define-core-syntax + "IN:" [ scan set-current-vocab ] define-core-syntax - "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-core-syntax + " in get ".private" append set-in - ] define-core-syntax + "PRIVATE>" [ end-private ] define-core-syntax - "USE:" [ scan add-use ] define-core-syntax + "USE:" [ scan use-vocab ] define-core-syntax - "USING:" [ ";" parse-tokens [ add-use ] each ] define-core-syntax + "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax "FROM:" [ - scan "=>" expect ";" parse-tokens swap add-words-from + scan "=>" expect ";" parse-tokens add-words-from ] define-core-syntax "EXCLUDE:" [ - scan "=>" expect ";" parse-tokens swap add-words-excluding + scan "=>" expect ";" parse-tokens add-words-excluding ] define-core-syntax "RENAME:" [ @@ -227,7 +225,7 @@ IN: bootstrap.syntax "))" parse-effect parsed ] define-core-syntax - "MAIN:" [ scan-word in get vocab (>>main) ] define-core-syntax + "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax "<<" [ [ diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index d5978270dc..426894794e 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -2,11 +2,167 @@ ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences -sets strings vocabs sorting accessors arrays compiler.units ; +sets strings vocabs sorting accessors arrays compiler.units +combinators vectors splitting continuations ; IN: vocabs.parser ERROR: no-word-error name ; +TUPLE: manifest +current-vocab +{ search-vocabs vector } +{ qualified-vocabs vector } +{ extra-words vector } ; + +: ( -- manifest ) + manifest new + V{ } clone >>search-vocabs + V{ } clone >>qualified-vocabs + V{ } clone >>extra-words ; + +M: manifest clone + call-next-method + [ clone ] change-search-vocabs + [ clone ] change-qualified-vocabs + [ clone ] change-extra-words ; + +> delete-all ] + [ qualified-vocabs>> delete-all ] + [ extra-words>> delete-all ] + tri ; + +: (use-vocab) ( vocab -- vocab seq ) + load-vocab manifest get search-vocabs>> ; + +: (add-qualified) ( qualified -- ) + manifest get qualified-vocabs>> push ; + +: (from) ( vocab words -- vocab words words' assoc ) + 2dup swap load-vocab words>> ; + +: (use-words) ( assoc -- assoc seq ) + manifest get extra-words>> ; + +: extract-words ( seq assoc -- assoc' ) + extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ; + +: (lookup) ( name assoc -- word/f ) + at dup forward-reference? [ drop f ] when ; + +PRIVATE> + +: set-current-vocab ( name -- ) + create-vocab manifest get + [ (>>current-vocab) ] + [ [ words>> ] dip extra-words>> push ] + 2bi ; + +TUPLE: no-current-vocab ; + +: no-current-vocab ( -- vocab ) + \ no-current-vocab boa + { { "Define words in scratchpad vocabulary" "scratchpad" } } + throw-restarts dup set-current-vocab ; + +: current-vocab ( -- vocab ) + manifest get current-vocab>> [ no-current-vocab ] unless* ; + +: begin-private ( -- ) + manifest get current-vocab>> vocab-name ".private" ?tail + [ drop ] [ ".private" append set-current-vocab ] if ; + +: end-private ( -- ) + manifest get current-vocab>> vocab-name ".private" ?tail + [ set-current-vocab ] [ drop ] if ; + +: use-vocab ( vocab -- ) (use-vocab) push ; + +: unuse-vocab ( vocab -- ) (use-vocab) delq ; + +: only-use-vocabs ( vocabs -- ) + clear-manifest + [ vocab ] V{ } map-as sift + manifest get search-vocabs>> push-all ; + +TUPLE: qualified vocab prefix words ; + +: ( vocab prefix -- qualified ) + 2dup + [ load-vocab words>> ] [ CHAR: : suffix ] bi* + [ swap [ prepend ] dip ] curry assoc-map + qualified boa ; + +: add-qualified ( vocab prefix -- ) + (add-qualified) ; + +TUPLE: from vocab names words ; + +: ( vocab words -- from ) + (from) extract-words from boa ; + +: add-words-from ( vocab words -- ) + (add-qualified) ; + +TUPLE: exclude vocab names words ; + +: ( vocab words -- from ) + (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ; + +: add-words-excluding ( vocab words -- ) + (add-qualified) ; + +TUPLE: rename word vocab words ; + +: ( word vocab new-name -- rename ) + [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip + associate rename boa ; + +: add-renamed-word ( word vocab new-name -- ) + (add-qualified) ; + +: use-words ( words -- ) (use-words) push ; + +: unuse-words ( words -- ) (use-words) delq ; + +ERROR: ambiguous-use-error words ; + +> (lookup) ] with map + sift dup length ; + +: vocab-search ( name manifest -- word/f ) + search-vocabs>> + (vocab-search) { + { 0 [ drop f ] } + { 1 [ first ] } + [ drop ambiguous-use-error ] + } case ; + +: qualified-search ( name manifest -- word/f ) + qualified-vocabs>> + (vocab-search) 0 = [ drop f ] [ peek ] if ; + +: word-search ( name manifest -- word/f ) + extra-words>> [ (lookup) ] with map-find-last drop ; + +PRIVATE> + +: search-manifest ( name manifest -- word/f ) + 2dup word-search dup [ 2nip ] [ + drop 2dup qualified-search dup [ 2nip ] [ + drop vocab-search + ] if + ] if ; + +: search ( name -- word/f ) + manifest get search-manifest ; + : word-restarts ( name possibilities -- restarts ) natural-sort [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc @@ -15,58 +171,3 @@ ERROR: no-word-error name ; : ( name possibilities -- error restarts ) [ drop \ no-word-error boa ] [ word-restarts ] 2bi ; - -SYMBOL: use -SYMBOL: in - -: (add-use) ( vocab -- ) - vocab-words use get push ; - -: add-use ( vocab -- ) - load-vocab (add-use) ; - -: set-use ( seq -- ) - [ vocab-words ] V{ } map-as sift use set ; - -: add-qualified ( vocab prefix -- ) - [ load-vocab vocab-words ] [ CHAR: : suffix ] bi* - [ swap [ prepend ] dip ] curry assoc-map - use get push ; - -: words-named-in ( words assoc -- assoc' ) - [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ; - -: partial-vocab-including ( words vocab -- assoc ) - load-vocab vocab-words words-named-in ; - -: add-words-from ( words vocab -- ) - partial-vocab-including use get push ; - -: partial-vocab-excluding ( words vocab -- assoc ) - load-vocab vocab-words [ nip ] [ words-named-in ] 2bi assoc-diff ; - -: add-words-excluding ( words vocab -- ) - partial-vocab-excluding use get push ; - -: add-renamed-word ( word vocab new-name -- ) - [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip - associate use get push ; - -: check-vocab-string ( name -- name ) - dup string? [ "Vocabulary name must be a string" throw ] unless ; - -: set-in ( name -- ) - check-vocab-string dup in set create-vocab (add-use) ; - -: check-forward ( str word -- word/f ) - dup forward-reference? [ - drop - use get - [ at ] with map sift - [ forward-reference? not ] find-last nip - ] [ - nip - ] if ; - -: search ( str -- word/f ) - dup use get assoc-stack check-forward ; \ No newline at end of file diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 6c12b7b325..914f1cd601 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -78,7 +78,13 @@ GENERIC: vocabs-changed ( obj -- ) : notify-vocab-observers ( -- ) vocab-observers get [ vocabs-changed ] each ; +ERROR: bad-vocab-name name ; + +: check-vocab-name ( name -- name ) + dup string? [ bad-vocab-name ] unless ; + : create-vocab ( name -- vocab ) + check-vocab-name dictionary get [ ] cache notify-vocab-observers ; diff --git a/core/words/words.factor b/core/words/words.factor index c01cf13bcd..2ebdb8b7a8 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays definitions graphs assocs kernel -kernel.private kernel.private slots.private math namespaces sequences +USING: accessors arrays definitions graphs kernel +kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting vocabs math.order sets ; IN: words @@ -180,12 +180,12 @@ M: word reset-word ERROR: bad-create name vocab ; : check-create ( name vocab -- name vocab ) - 2dup [ string? ] both? + 2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and [ bad-create ] unless ; : create ( name vocab -- word ) check-create 2dup lookup - dup [ 2nip ] [ drop dup reveal ] if ; + dup [ 2nip ] [ drop vocab-name dup reveal ] if ; : constructor-word ( name vocab -- word ) [ "<" ">" surround ] dip create ; diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor index 5597422898..09f1b0e4b1 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -85,12 +85,10 @@ SYNTAX: [infix "infix]" [infix-parse parsed \ call parsed ; SYNTAX: [infix| From daec1548171ebe89cd66aff361e99bede4055651 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 May 2009 23:23:06 -0500 Subject: [PATCH 039/228] Updating code in basis and extra for stricter vocab search path semantics --- basis/alien/fortran/fortran.factor | 2 +- basis/channels/channels.factor | 2 +- basis/checksums/sha1/sha1.factor | 2 +- basis/db/errors/postgresql/postgresql.factor | 3 ++- basis/db/tester/tester.factor | 2 +- basis/db/tuples/tuples.factor | 2 +- basis/formatting/formatting.factor | 8 ++++---- basis/furnace/sessions/sessions-docs.factor | 2 +- basis/game-input/iokit/iokit.factor | 2 +- basis/help/html/html.factor | 2 +- basis/html/templates/chloe/chloe-docs.factor | 3 ++- basis/html/templates/chloe/chloe.factor | 4 ++-- basis/html/templates/chloe/syntax/syntax.factor | 12 +++++------- basis/html/templates/fhtml/fhtml.factor | 2 +- basis/http/server/server.factor | 4 +--- basis/inverse/inverse.factor | 2 +- basis/io/encodings/gb18030/gb18030.factor | 5 +++-- basis/io/mmap/mmap.factor | 2 +- basis/locals/locals-tests.factor | 8 -------- basis/peg/ebnf/ebnf.factor | 2 +- basis/random/dummy/dummy.factor | 2 +- basis/regexp/classes/classes.factor | 3 ++- basis/soundex/soundex.factor | 2 +- basis/tools/files/unix/unix.factor | 2 +- .../ui/tools/listener/completion/completion.factor | 8 ++++---- basis/ui/tools/listener/listener.factor | 2 +- basis/unicode/collation/collation.factor | 11 +++++------ basis/xml/syntax/syntax.factor | 4 ++-- basis/xmode/code2html/code2html.factor | 6 +++--- basis/xmode/marker/marker.factor | 3 +-- extra/4DNav/turtle/turtle.factor | 9 +++------ extra/4DNav/window3D/window3D.factor | 1 - extra/benchmark/backtrack/backtrack.factor | 2 +- extra/bunny/outlined/outlined.factor | 1 + extra/fjsc/fjsc.factor | 3 +-- extra/fuel/eval/eval.factor | 14 +++++++------- extra/fuel/xref/xref.factor | 6 +++++- extra/google-tech-talk/google-tech-talk.factor | 2 +- extra/hashcash/hashcash.factor | 7 +++---- extra/html/parser/analyzer/analyzer.factor | 2 +- extra/id3/id3.factor | 2 +- extra/infix/infix.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 1 + extra/koszul/koszul.factor | 2 +- extra/mason/common/common.factor | 2 +- extra/mason/mason.factor | 5 +++-- extra/mason/release/release.factor | 2 +- extra/mongodb/benchmark/benchmark.factor | 4 ++-- extra/mongodb/tuple/tuple.factor | 2 ++ extra/otug-talk/otug-talk.factor | 2 +- extra/peg/javascript/parser/parser.factor | 3 ++- extra/project-euler/common/common.factor | 2 +- extra/spheres/spheres.factor | 1 + extra/tetris/tetris.factor | 1 + extra/ui/gadgets/book-extras/book-extras.factor | 1 + extra/vpri-talk/vpri-talk.factor | 2 +- extra/webapps/site-watcher/site-watcher.factor | 2 +- extra/webapps/wiki/wiki.factor | 2 +- {extra => unmaintained}/sandbox/authors.txt | 0 .../sandbox/sandbox-tests.factor | 0 {extra => unmaintained}/sandbox/sandbox.factor | 0 {extra => unmaintained}/sandbox/summary.txt | 0 .../sandbox/syntax/syntax.factor | 0 63 files changed, 98 insertions(+), 101 deletions(-) rename {extra => unmaintained}/sandbox/authors.txt (100%) rename {extra => unmaintained}/sandbox/sandbox-tests.factor (100%) rename {extra => unmaintained}/sandbox/sandbox.factor (100%) rename {extra => unmaintained}/sandbox/summary.txt (100%) rename {extra => unmaintained}/sandbox/syntax/syntax.factor (100%) diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index b27c62b9a1..54b799f675 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -421,7 +421,7 @@ PRIVATE> : define-fortran-record ( name vocab fields -- ) [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ; -SYNTAX: RECORD: scan in get parse-definition define-fortran-record ; +SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ; : set-fortran-abi ( library -- ) library-fortran-abis get-global at fortran-abi set ; diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 9b8c418634..0eb7881f95 100644 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -3,7 +3,7 @@ ! ! Channels - based on ideas from newsqueak USING: kernel sequences threads continuations -random math accessors random ; +random math accessors ; IN: channels TUPLE: channel receivers senders ; diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index e7aee0dd09..707aa66ba6 100644 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! 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 +io.streams.byte-array math.vectors strings namespaces make math parser sequences assocs grouping vectors io.binary hashtables math.bitwise checksums checksums.common checksums.stream ; diff --git a/basis/db/errors/postgresql/postgresql.factor b/basis/db/errors/postgresql/postgresql.factor index 02b43ecd88..3cd0909288 100644 --- a/basis/db/errors/postgresql/postgresql.factor +++ b/basis/db/errors/postgresql/postgresql.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: kernel db.errors peg.ebnf strings sequences math -combinators.short-circuit accessors math.parser quoting ; +combinators.short-circuit accessors math.parser quoting +locals ; IN: db.errors.postgresql EBNF: parse-postgresql-sql-error diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 56bac7efcd..19140259bf 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.combinators db.pools db.sqlite db.tuples db.types kernel math random threads tools.test db sequences -io prettyprint db.postgresql db.sqlite accessors io.files.temp +io prettyprint db.postgresql accessors io.files.temp namespaces fry system math.parser ; IN: db.tester diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 19d4be5fc8..388c9ba47e 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors -math.parser io prettyprint db.types continuations +math.parser io prettyprint continuations destructors mirrors sets db.types db.private fry combinators.short-circuit db.errors ; IN: db.tuples diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 5a517e4ac4..f8b9ba501b 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors arrays ascii assocs calendar combinators fry kernel -generalizations io io.encodings.ascii io.files io.streams.string -macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors combinators.smart ; +USING: accessors arrays assocs calendar combinators fry kernel +generalizations io io.streams.string macros math math.functions +math.parser peg.ebnf quotations sequences splitting strings +unicode.categories unicode.case vectors combinators.smart ; IN: formatting diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor index 7a4de18eaf..5c1ceecbf0 100644 --- a/basis/furnace/sessions/sessions-docs.factor +++ b/basis/furnace/sessions/sessions-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io.streams.string quotations -strings calendar serialize kernel furnace.db words words.symbol +strings calendar serialize furnace.db words words.symbol kernel ; IN: furnace.sessions diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 5f09a054f9..c42d48d569 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -1,7 +1,7 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads -namespaces assocs vectors arrays combinators hints alien +namespaces assocs arrays combinators hints alien core-foundation.run-loop accessors sequences.private alien.c-types math parser game-input vectors ; IN: game-input.iokit diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 348fcbbbfb..09208749b9 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -4,7 +4,7 @@ USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs vocabs.hierarchy help.vocabs namespaces prettyprint io -vocabs.loader serialize fry memoize ascii unicode.case math.order +vocabs.loader serialize fry memoize unicode.case math.order sorting debugger html xml.syntax xml.writer math.parser ; IN: help.html diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index fcfd454478..9716407de8 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -1,8 +1,9 @@ IN: html.templates.chloe -USING: xml.data help.markup help.syntax html.components html.forms +USING: help.markup help.syntax html.components html.forms html.templates html.templates.chloe.syntax html.templates.chloe.compiler html.templates.chloe.components math strings quotations namespaces ; +FROM: xml.data => tag ; HELP: { $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } } diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 1fe90b08d3..f42a5c3bde 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences combinators kernel fry +USING: accessors kernel sequences combinators fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging -xml.data xml.writer xml.syntax strings +xml.writer xml.syntax strings html.forms html html.components diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 7c47a44d9e..f7da0fe277 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: html.templates.chloe.syntax -USING: accessors kernel sequences combinators kernel namespaces -classes.tuple assocs splitting words arrays memoize parser lexer -io io.files io.encodings.utf8 io.streams.string -unicode.case mirrors fry math urls -multiline xml xml.data xml.writer xml.syntax -html.components +USING: accessors sequences combinators kernel namespaces classes.tuple +assocs splitting words arrays memoize parser lexer io io.files +io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls +multiline xml xml.data xml.writer xml.syntax html.components html.templates ; +IN: html.templates.chloe.syntax SYMBOL: tags diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 21e9f8352d..34783a0b4a 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -60,7 +60,7 @@ SYNTAX: %> lexer get parse-%> ; [ "quiet" on parser-notes off - "html.templates.fhtml" use+ + "html.templates.fhtml" use-vocab string-lines parse-template-lines ] with-file-vocabs ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 3beb730499..c838471e3f 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -17,7 +17,6 @@ io.servers.connection io.timeouts io.crlf fry logging logging.insomniac calendar urls urls.encoding -mime.multipart unicode.categories http http.parsers @@ -27,6 +26,7 @@ html.templates html.streams html xml.writer ; +FROM: mime.multipart => parse-multipart ; IN: http.server : check-absolute ( url -- url ) @@ -283,8 +283,6 @@ M: http-server handle-client* : http-insomniac ( -- ) "http.server" { "httpd-hit" } schedule-insomniac ; -USE: vocabs.loader - "http.server.filters" require "http.server.dispatchers" require "http.server.redirection" require diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 4e807bd992..7690b34410 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel words summary slots quotations -sequences assocs math arrays stack-checker effects generalizations +sequences assocs math arrays stack-checker effects continuations debugger classes.tuple namespaces make vectors bit-arrays byte-arrays strings sbufs math.functions macros sequences.private combinators mirrors splitting combinators.smart diff --git a/basis/io/encodings/gb18030/gb18030.factor b/basis/io/encodings/gb18030/gb18030.factor index cecf103162..2be709dbc9 100644 --- a/basis/io/encodings/gb18030/gb18030.factor +++ b/basis/io/encodings/gb18030/gb18030.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml xml.data kernel io io.encodings interval-maps splitting fry math.parser sequences combinators assocs locals accessors math arrays -byte-arrays values io.encodings.ascii ascii io.files biassocs -math.order combinators.short-circuit io.binary io.encodings.iana ; +byte-arrays values ascii io.files biassocs math.order +combinators.short-circuit io.binary io.encodings.iana ; +FROM: io.encodings.ascii => ascii ; IN: io.encodings.gb18030 SINGLETON: gb18030 diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index e03d5fb30b..9a4443e8e5 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations destructors io.files io.files.info io.backend kernel quotations system alien alien.accessors -accessors system vocabs.loader combinators alien.c-types +accessors vocabs.loader combinators alien.c-types math ; IN: io.mmap diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 1549a77663..414b2da45c 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -126,14 +126,6 @@ write-test-2 "q" set [ 9 ] [ 4 write-test-5 ] unit-test -SYMBOL: a - -:: use-test ( a b c -- a b c ) - USE: kernel - a b c ; - -[ t ] [ a symbol? ] unit-test - :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ; [ 13 ] [ 10 let-let-test ] unit-test diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index 94df4ca209..d4ad62fbea 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -461,7 +461,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) M: ebnf-var build-locals ( code ast -- ) [ - "USING: locals kernel ; [let* | " % + "FROM: locals => [let* ; FROM: kernel => dup ; [let* | " % name>> % " [ dup ] " % " | " % % diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index e0cb83c330..dadf93fd43 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -1,4 +1,4 @@ -USING: kernel random math accessors random ; +USING: kernel math accessors random ; IN: random.dummy TUPLE: random-dummy i ; diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index a1c4e3ca2a..e3e2f0bcf3 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math math.order words combinators locals -ascii unicode.categories combinators.short-circuit sequences +unicode.categories combinators.short-circuit sequences fry macros arrays assocs sets classes mirrors unicode.script unicode.data ; +FROM: ascii => ascii? ; IN: regexp.classes SINGLETONS: dot letter-class LETTER-class Letter-class digit-class diff --git a/basis/soundex/soundex.factor b/basis/soundex/soundex.factor index 2fd928252f..37eaf08822 100644 --- a/basis/soundex/soundex.factor +++ b/basis/soundex/soundex.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences grouping assocs kernel ascii ascii tr ; +USING: sequences grouping assocs kernel ascii tr ; IN: soundex TR: soundex-tr diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index 90e91529a1..d5fdd6c889 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -4,7 +4,7 @@ USING: accessors combinators kernel system unicode.case io.files io.files.info io.files.info.unix generalizations strings arrays sequences math.parser unix.groups unix.users tools.files.private unix.stat math fry macros combinators.smart -io.files.info.unix io tools.files math.order prettyprint ; +io tools.files math.order prettyprint ; IN: tools.files.unix > { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc ; -TUPLE: word-completion vocabs ; +TUPLE: word-completion manifest ; C: word-completion SINGLETONS: vocab-completion char-completion history-completion ; @@ -62,8 +62,8 @@ M: definition-completion row-columns 2array ; M: word-completion row-color - [ vocabulary>> ] [ vocabs>> ] bi* { - { [ 2dup [ vocab-words ] dip memq? ] [ COLOR: black ] } + [ vocabulary>> ] [ manifest>> ] bi* { + { [ 2dup search-vocabs>> memq? ] [ COLOR: black ] } { [ over ".private" tail? ] [ COLOR: dark-red ] } [ COLOR: dark-gray ] } cond 2nip ; @@ -87,7 +87,7 @@ M: vocab-completion row-color [ { 0 0 } ] 2dip doc-range ; : completion-mode ( interactor -- symbol ) - [ vocabs>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split + [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split { { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] } { [ dup complete-CHAR:? ] [ 2drop char-completion ] } diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 19328b0b31..2e89482c3d 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -55,7 +55,7 @@ M: vocab-completion (word-at-caret) drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ; M: word-completion (word-at-caret) - manifest>> search-manifest ; + manifest>> dup [ search-manifest ] [ 2drop f ] if ; M: char-completion (word-at-caret) 2drop f ; diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index b6eddccae0..f8beca3c60 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit sequences io.files -io.encodings.ascii kernel values splitting accessors math.parser -ascii io assocs strings math namespaces make sorting combinators -math.order arrays unicode.normalize unicode.data locals -macros sequences.deep words unicode.breaks -quotations combinators.short-circuit simple-flat-file ; +USING: sequences io.files io.encodings.ascii kernel values splitting +accessors math.parser ascii io assocs strings math namespaces make +sorting combinators math.order arrays unicode.normalize unicode.data +locals macros sequences.deep words unicode.breaks quotations +combinators.short-circuit simple-flat-file ; IN: unicode.collation rect-vertices ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index bc6b8a092f..b6b5ff3b08 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel peg strings sequences math math.parser namespaces make words quotations arrays hashtables io -io.streams.string assocs ascii peg.parsers accessors -words.symbol ; +io.streams.string assocs ascii peg.parsers words.symbol ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index 9f0b6fc0a3..7c83fc6e90 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -6,7 +6,7 @@ vectors vocabs.parser ; IN: fuel.eval -TUPLE: fuel-status in use restarts ; +TUPLE: fuel-status manifest restarts ; SYMBOL: fuel-status-stack V{ } clone fuel-status-stack set-global @@ -24,7 +24,7 @@ t fuel-eval-res-flag set-global fuel-eval-res-flag get-global ; : fuel-push-status ( -- ) - in get use get clone restarts get-global clone + manifest get clone restarts get-global clone fuel-status boa fuel-status-stack get push ; @@ -34,9 +34,9 @@ t fuel-eval-res-flag set-global : fuel-pop-status ( -- ) fuel-status-stack get empty? [ fuel-status-stack get pop - [ in>> in set ] - [ use>> clone use set ] - [ restarts>> fuel-pop-restarts ] tri + [ manifest>> clone manifest set ] + [ restarts>> fuel-pop-restarts ] + bi ] unless ; : fuel-forget-error ( -- ) f error set-global ; @@ -60,11 +60,11 @@ t fuel-eval-res-flag set-global [ print-error ] recover ; : (fuel-eval-usings) ( usings -- ) - [ [ add-use ] curry [ drop ] recover ] each + [ [ use-vocab ] curry [ drop ] recover ] each fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ in set ] when* ; + [ set-current-vocab ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 160b7212c4..3dfa129a7f 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -35,7 +35,11 @@ MEMO: (vocab-words) ( name -- seq ) >vocab-link words [ name>> ] map ; : current-words ( -- seq ) - use get [ keys ] map concat ; inline + manifest get + [ search-vocabs>> [ words>> ] map ] + [ qualified-vocabs>> [ words>> ] map ] + [ extra-words>> ] + tri 3append assoc-combine keys ; inline : vocabs-words ( names -- seq ) prune [ (vocab-words) ] map concat ; inline diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor index 8e2eeeb1a7..5f33af04fe 100644 --- a/extra/google-tech-talk/google-tech-talk.factor +++ b/extra/google-tech-talk/google-tech-talk.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize io.encodings.binary +kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor index 1eb690b20f..a77ebf2577 100755 --- a/extra/hashcash/hashcash.factor +++ b/extra/hashcash/hashcash.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2009 Diego Martinelli. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays calendar calendar.format -checksums checksums.openssl classes.tuple -fry kernel make math math.functions math.parser math.ranges -present random sequences splitting strings syntax ; +USING: accessors byte-arrays calendar calendar.format checksums +checksums.openssl classes.tuple fry kernel make math math.functions +math.parser math.ranges present random sequences splitting strings ; IN: hashcash ! Hashcash implementation diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 2196f1baaa..02b45ee939 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: assocs html.parser kernel math sequences strings ascii -arrays generalizations shuffle unicode.case namespaces make +arrays generalizations shuffle namespaces make splitting http accessors io combinators http.client urls urls.encoding fry prettyprint sets ; IN: html.parser.analyzer diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 6acace8582..6d9b778ee8 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: sequences io io.encodings.binary io.files io.pathnames -strings kernel math io.mmap io.mmap.uchar accessors syntax +strings kernel math io.mmap io.mmap.uchar accessors combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor index 09f1b0e4b1..ce19780058 100644 --- a/extra/infix/infix.factor +++ b/extra/infix/infix.factor @@ -3,7 +3,7 @@ USING: accessors assocs combinators combinators.short-circuit effects fry infix.parser infix.ast kernel locals.parser locals.types math multiline namespaces parser quotations -sequences summary words ; +sequences summary words vocabs.parser ; IN: infix distance ; IN: jamshred.tunnel CONSTANT: n-segments 5000 diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 4ba8e2f66b..1ecd56d416 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs hashtables assocs io kernel math +USING: accessors arrays hashtables assocs io kernel math math.vectors math.matrices math.matrices.elimination namespaces parser prettyprint sequences words combinators math.parser splitting sorting shuffle sets math.order ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index a33e3c5831..4ac5767009 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,7 +4,7 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system debugger fry +calendar.format arrays mason.config locals debugger fry continuations strings ; IN: mason.common diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index d425985e76..8818e1cc94 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors calendar continuations debugger debugger io -io.directories io.files kernel mason.build mason.common +USING: accessors calendar continuations debugger io +io.directories io.files kernel mason.common mason.email mason.updates namespaces threads ; +FROM: mason.build => build ; IN: mason : build-loop-error ( error -- ) diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor index fc4ad0b08a..a593f000f3 100644 --- a/extra/mason/release/release.factor +++ b/extra/mason/release/release.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel debugger namespaces sequences splitting combinators +USING: kernel debugger namespaces sequences splitting combinators io io.files io.launcher prettyprint bootstrap.image mason.common mason.release.branch mason.release.tidy mason.release.archive mason.release.upload mason.notify ; diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor index 02dfa8add9..a977224d66 100644 --- a/extra/mongodb/benchmark/benchmark.factor +++ b/extra/mongodb/benchmark/benchmark.factor @@ -1,7 +1,7 @@ USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary -accessors words mongodb.driver strings math.parser tools.walker bson.writer -tools.continuations ; +accessors words mongodb.driver strings math.parser bson.writer ; +FROM: mongodb.driver => find ; IN: mongodb.benchmark diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 677fa09bf9..ce76a37ff4 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -2,6 +2,8 @@ USING: accessors assocs classes.mixin classes.tuple classes.tuple.parser compiler.units fry kernel sequences mongodb.driver mongodb.msg mongodb.tuple.collection mongodb.tuple.persistent mongodb.tuple.state strings ; +FROM: mongodb.driver => update delete find count ; +FROM: mongodb.tuple.persistent => assoc>tuple ; IN: mongodb.tuple diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index 35a83a63de..0e7702512f 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize io.encodings.binary +kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer fry diff --git a/extra/peg/javascript/parser/parser.factor b/extra/peg/javascript/parser/parser.factor index 7ace528150..82b50c454a 100644 --- a/extra/peg/javascript/parser/parser.factor +++ b/extra/peg/javascript/parser/parser.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ; +USING: kernel accessors sequences +peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ; IN: peg.javascript.parser #! Grammar for JavaScript. Based on OMeta-JS example from: diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 84291f2ce8..497fc31de7 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -143,6 +143,6 @@ PRIVATE> SYNTAX: SOLUTION: scan-word [ name>> "-main" append create-in ] keep - [ drop in get vocab (>>main) ] + [ drop current-vocab (>>main) ] [ [ . ] swap prefix (( -- )) define-declared ] 2bi ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 710c953ed1..1a8f41b4a2 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -3,6 +3,7 @@ opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays generalizations combinators ui.gadgets.worlds literals ui.pixel-formats ; +FROM: opengl.demo-support => rect-vertices ; IN: spheres STRING: plane-vertex-shader diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 66f69bb053..dbdb666e4a 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006, 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ; +FROM: tetris.game => level>> ; IN: tetris TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ; diff --git a/extra/ui/gadgets/book-extras/book-extras.factor b/extra/ui/gadgets/book-extras/book-extras.factor index b9d859962f..9e94747919 100644 --- a/extra/ui/gadgets/book-extras/book-extras.factor +++ b/extra/ui/gadgets/book-extras/book-extras.factor @@ -1,4 +1,5 @@ USING: accessors kernel fry math models ui.gadgets ui.gadgets.books ui.gadgets.buttons ; +FROM: models => change-model ; IN: ui.gadgets.book-extras : ( pages -- book ) 0 ; : |<< ( book -- ) 0 swap set-control-value ; diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 4ee499bf50..518462d7bb 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize io.encodings.binary +kernel sequences parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer compiler.cfg.optimizer diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index f82eb6dcd8..5ecd3bc6a8 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -37,7 +37,7 @@ IN: webapps.site-watcher "twitter" value >>twitter "sms" value >>sms update-tuple - site-list-url + f ] >>submit "update notification details" >>description ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 2341b020a8..5689f23d4e 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -15,7 +15,7 @@ furnace.auth.login furnace.boilerplate furnace.syndication validators -db.types db.tuples lcs farkup urls ; +db.types db.tuples lcs urls ; IN: webapps.wiki : wiki-url ( rest path -- url ) diff --git a/extra/sandbox/authors.txt b/unmaintained/sandbox/authors.txt similarity index 100% rename from extra/sandbox/authors.txt rename to unmaintained/sandbox/authors.txt diff --git a/extra/sandbox/sandbox-tests.factor b/unmaintained/sandbox/sandbox-tests.factor similarity index 100% rename from extra/sandbox/sandbox-tests.factor rename to unmaintained/sandbox/sandbox-tests.factor diff --git a/extra/sandbox/sandbox.factor b/unmaintained/sandbox/sandbox.factor similarity index 100% rename from extra/sandbox/sandbox.factor rename to unmaintained/sandbox/sandbox.factor diff --git a/extra/sandbox/summary.txt b/unmaintained/sandbox/summary.txt similarity index 100% rename from extra/sandbox/summary.txt rename to unmaintained/sandbox/summary.txt diff --git a/extra/sandbox/syntax/syntax.factor b/unmaintained/sandbox/syntax/syntax.factor similarity index 100% rename from extra/sandbox/syntax/syntax.factor rename to unmaintained/sandbox/syntax/syntax.factor From 44721b48ff53d8b7dfb20e31187e001bb3ae3437 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 23:33:00 -0500 Subject: [PATCH 040/228] remove all the compress code from lzw until it works, fix bitstreams --- basis/bitstreams/bitstreams-tests.factor | 58 +++++++--- basis/bitstreams/bitstreams.factor | 128 ++++++++++++---------- basis/compression/lzw/lzw.factor | 117 ++------------------ basis/images/processing/processing.factor | 2 +- 4 files changed, 123 insertions(+), 182 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 769efcbb04..a5b1b43acd 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests -[ 1 t ] -[ B{ 254 } binary read-bit ] unit-test -[ 254 8 t ] -[ B{ 254 } binary 8 swap read-bits ] unit-test - -[ 4095 12 t ] -[ B{ 255 255 } binary 12 swap read-bits ] unit-test - -[ B{ 254 } ] +[ BIN: 1111111111 ] [ - binary 254 8 rot - [ write-bits ] keep stream>> >byte-array + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 10 swap peek ] unit-test -[ 255 8 t ] -[ B{ 255 } binary 8 swap read-bits ] unit-test +[ BIN: 111111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 9 swap peek +] unit-test -[ 255 8 f ] -[ B{ 255 } binary 9 swap read-bits ] unit-test +[ BIN: 11111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 8 swap peek +] unit-test + +[ BIN: 1111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 7 swap peek +] unit-test + +[ BIN: 111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 6 swap peek +] unit-test + +[ BIN: 11111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 5 swap peek +] unit-test + +[ B{ } 5 swap peek ] must-fail +[ B{ } 1 swap peek ] must-fail +[ B{ } 8 swap peek ] must-fail + +[ 0 ] [ B{ } 0 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index d7d13cf17c..997daa2c5d 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -23,7 +23,7 @@ ERROR: invalid-widthed bits #bits ; widthed boa ; : zero-widthed ( -- widthed ) 0 0 ; -: zero-widthed? ( widthed -- ? ) zero-widthed = ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; TUPLE: bit-reader { bytes byte-array } @@ -41,73 +41,32 @@ CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; TUPLE: msb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ; -CONSTRUCTOR: msb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -CONSTRUCTOR: lsb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -! interface +: new-bit-writer ( class -- bs ) + new + BV{ } clone >>bytes + 0 0 >>widthed ; inline + +: ( -- bs ) + msb0-bit-writer new-bit-writer ; + +: ( -- bs ) + lsb0-bit-writer new-bit-writer ; GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) : seek ( n bitstream -- ) { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] [ (>>byte-pos) ] } cleave ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline - -! reading - -quot ; - -GENERIC: fetch3-le-unsafe ( n byte-array -- value ) -GENERIC: fetch3-be-unsafe ( n byte-array -- value ) - -: fetch3-unsafe ( byte-array n offsets -- value ) - multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline - -M: byte-array fetch3-le-unsafe ( n byte-array -- value ) - swap { 0 1 2 } fetch3-unsafe ; inline -M: byte-array fetch3-be-unsafe ( n byte-array -- value ) - swap { 2 1 0 } fetch3-unsafe ; inline - -: fetch3 ( n byte-array -- value ) - [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; - -: fetch3-le ( n byte-array -- value ) fetch3 le> ; -: fetch3-be ( n byte-array -- value ) fetch3 be> ; - -GENERIC: peek16 ( n bitstream -- value ) - -M:: lsb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-le - bs bit-pos>> 2^ /i - n 2^ mod ; - -M:: msb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-be - 24 n bs bit-pos>> + - 2^ /i - n 2^ mod ; - -PRIVATE> - -M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; -M: msb0-bit-reader peek ( n bs -- v ) peek16 ; - -! writing - > ] B{ } produce-as nip swap ; +:: |widthed ( widthed1 widthed2 -- widthed3 ) + widthed1 bits>> :> bits1 + widthed1 #bits>> :> #bits1 + widthed2 bits>> :> bits2 + widthed2 #bits>> :> #bits2 + bits1 #bits2 shift bits2 bitor + #bits1 #bits2 + ; + PRIVATE> M:: lsb0-bit-writer poke ( value n bs -- ) value n :> widthed widthed bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte - - byte #bits>> 8 = [ - byte bits>> bs bytes>> push + byte bs widthed>> |widthed :> new-byte + new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [ + new-byte bits>> bs bytes>> push zero-widthed bs (>>widthed) remainder widthed>bytes - [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + [ bs bytes>> push-all ] [ bs (>>widthed) ] bi* ] [ byte bs (>>widthed) ] if ; + +: enough-bits? ( n bs -- ? ) + [ bytes>> length ] + [ byte-pos>> - 8 * ] + [ bit-pos>> - ] tri <= ; + +ERROR: not-enough-bits n bit-reader ; + +: #bits>#bytes ( #bits -- #bytes ) + 8 /mod 0 = [ 1 + ] unless ; inline + +:: subseq>bits ( bignum n bs -- bits ) + bignum + 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when + neg shift n bits ; + +:: adjust-bits ( n bs -- ) + n 8 /mod :> #bits :> #bytes + bs [ #bytes + ] change-byte-pos + bit-pos>> #bits + dup 8 >= [ + 8 - bs (>>bit-pos) + bs [ 1 + ] change-byte-pos drop + ] [ + bs (>>bit-pos) + ] if ; + +:: (peek) ( n bs word -- bits ) + n bs enough-bits? [ n bs not-enough-bits ] unless + bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd + + bs bytes>> subseq word execute( seq -- x ) :> bignum + bignum n bs subseq>bits ; + +M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ; + +M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ; + +:: bit-writer-bytes ( writer -- bytes ) + writer widthed>> #bits>> :> n + n 0 = [ + writer widthed>> bits>> 8 n - shift + writer bytes>> swap push + ] unless + writer bytes>> ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 592a0efb6c..46a319662e 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,22 +1,19 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors byte-arrays combinators -constructors destructors fry io io.binary kernel locals macros -math math.ranges multiline sequences sequences.private ; -IN: bitstreams +USING: accessors alien.accessors assocs byte-arrays combinators +io.encodings.binary io.streams.byte-array kernel math sequences +vectors ; +IN: compression.lzw QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 -TUPLE: lzw input output end-of-input? table count k omega omega-k #bits -code old-code ; +TUPLE: lzw input output table code old-code ; SYMBOL: table-full -ERROR: index-too-big n ; - : lzw-bit-width ( n -- n' ) { { [ dup 510 <= ] [ drop 9 ] } @@ -26,37 +23,14 @@ ERROR: index-too-big n ; [ drop table-full ] } cond ; -: lzw-bit-width-compress ( lzw -- n ) - count>> lzw-bit-width ; - : lzw-bit-width-uncompress ( lzw -- n ) table>> length lzw-bit-width ; -: initial-compress-table ( -- assoc ) - 258 iota [ [ 1vector ] keep ] H{ } map>assoc ; - : initial-uncompress-table ( -- seq ) 258 iota [ 1vector ] V{ } map-as ; -: reset-lzw ( lzw -- lzw ) - 257 >>count - V{ } clone >>omega - V{ } clone >>omega-k - 9 >>#bits ; - -: reset-lzw-compress ( lzw -- lzw ) - f >>k - initial-compress-table >>table reset-lzw ; - : reset-lzw-uncompress ( lzw -- lzw ) - initial-uncompress-table >>table reset-lzw ; - -: ( input -- obj ) - lzw new - swap >>input - ! binary >>output - V{ } clone >>output ! TODO - reset-lzw-compress ; + initial-uncompress-table >>table ; : ( input -- obj ) lzw new @@ -64,79 +38,8 @@ ERROR: index-too-big n ; BV{ } clone >>output reset-lzw-uncompress ; -: push-k ( lzw -- lzw ) - [ ] - [ k>> ] - [ omega>> clone [ push ] keep ] tri >>omega-k ; - -: omega-k-in-table? ( lzw -- ? ) - [ omega-k>> ] [ table>> ] bi key? ; - ERROR: not-in-table value ; -: write-output ( lzw -- ) - [ - [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless - ] [ - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] bi ; - -: omega-k>omega ( lzw -- lzw ) - dup omega-k>> clone >>omega ; - -: k>omega ( lzw -- lzw ) - dup k>> 1vector >>omega ; - -: add-omega-k ( lzw -- ) - [ [ 1+ ] change-count count>> ] - [ omega-k>> clone ] - [ table>> ] tri set-at ; - -: lzw-compress-char ( lzw k -- ) - >>k push-k dup omega-k-in-table? [ - omega-k>omega drop - ] [ - [ write-output ] - [ add-omega-k ] - [ k>omega drop ] tri - ] if ; - -: (lzw-compress-chars) ( lzw -- ) - dup lzw-bit-width-compress table-full = [ - drop - ] [ - dup input>> stream-read1 - [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ] - [ t >>end-of-input? drop ] if* - ] if ; - -: lzw-compress-chars ( lzw -- ) - { - ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ] - [ - [ clear-code ] dip - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] - [ (lzw-compress-chars) ] - [ - [ k>> ] - [ lzw-bit-width-compress ] - [ output>> bs:poke ] tri - ] - [ - [ end-of-information ] dip - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] - [ ] - } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; - -: lzw-compress ( byte-array -- seq ) - binary - [ lzw-compress-chars ] [ output>> stream>> ] bi ; - : lookup-old-code ( lzw -- vector ) [ old-code>> ] [ table>> ] bi nth ; @@ -155,7 +58,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -203,6 +106,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - - ! binary ! - [ lzw-uncompress-char ] [ output>> ] bi ; + bs: + + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index 2304c56171..fc463731b3 100755 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators grouping images -images.loader images.viewer kernel locals math math.order +kernel locals math math.order math.ranges math.vectors sequences sequences.deep fry ; IN: images.processing From 6aab540e45fff70dc23ad77302e8e88c0c3b9090 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 01:27:00 -0500 Subject: [PATCH 041/228] oops, i was using alt.bitstreams in some places --- basis/compression/huffman/huffman.factor | 4 ++-- basis/compression/inflate/inflate.factor | 4 ++-- basis/images/jpeg/jpeg.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 60b3a1d5a1..6ef9c2fabc 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alt.bitstreams arrays assocs constructors fry +USING: accessors arrays assocs constructors fry hashtables io kernel locals math math.order math.parser math.ranges multiline sequences ; IN: compression.huffman -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; : zlib-inflate ( bytes -- bytes ) - bs: + bs: [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 0588e5c365..648923704a 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -9,7 +9,7 @@ math.ranges math.vectors memoize multiline namespaces sequences sequences.deep ; IN: images.jpeg -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs TUPLE: jpeg-image < image { headers } @@ -274,7 +274,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : baseline-decompress ( -- ) jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) + >byte-array bs: jpeg> (>>bitstream) jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi jpeg> components>> [ fetch-tables ] each jpeg> setup-bitmap From 69c7a268a16e83a614ea009559aa921526c441d4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 11:00:39 -0500 Subject: [PATCH 042/228] add some more opengl extension bindings: GL_EXT_framebuffer_blit GL_EXT_framebuffer_multisample GL_EXT_gpu_shader4 GL_EXT_geometry_shader4 GL_EXT_transform_feedback --- basis/opengl/framebuffers/framebuffers.factor | 13 +- basis/opengl/gl/gl.factor | 242 ++++++++++++++++++ 2 files changed, 254 insertions(+), 1 deletion(-) diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor index 346789e1c5..f3ed8d320d 100644 --- a/basis/opengl/framebuffers/framebuffers.factor +++ b/basis/opengl/framebuffers/framebuffers.factor @@ -28,6 +28,7 @@ IN: opengl.framebuffers { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] } [ drop gl-error "unknown framebuffer error" ] } case throw ; @@ -35,9 +36,19 @@ IN: opengl.framebuffers framebuffer-incomplete? [ framebuffer-error ] when* ; : with-framebuffer ( id quot -- ) - GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline +: with-draw-read-framebuffers ( draw-id read-id quot -- ) + [ + [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] + [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi* + ] dip + [ + GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT + GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT + ] [ ] cleanup ; inline + : framebuffer-attachment ( attachment -- id ) GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 6181a72ffc..39a8a2c4fe 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -1774,6 +1774,33 @@ GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ; GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ; +! GL_EXT_framebuffer_blit + + +GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1, + GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1, + GLbitfield mask, GLenum filter ) ; + +CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8 +CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9 + +ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT +CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA + + +! GL_EXT_framebuffer_multisample + + +GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } ( + GLenum target, GLsizei samples, + GLenum internalformat, + GLsizei width, GLsizei height ) ; + +CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56 +CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57 + + ! GL_ARB_texture_float @@ -1798,3 +1825,218 @@ CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15 CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16 CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17 + +! GL_EXT_gpu_shader4 + + +GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ; +GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ; +GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ; +GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ; + +GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ; +GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ; +GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ; +GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ; + +GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ; + +GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ; + +GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ; + +GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ; + +GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ; + +GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ; +GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ; +GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ; +GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ; + +GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; + +GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ; + +GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ; +GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; + +CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD +CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0 +CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1 +CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2 +CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3 +CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4 +CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5 +CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6 +CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7 +CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8 +CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9 +CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA +CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB +CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC +CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD +CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE +CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF +CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8 +CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904 +CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905 + + +! GL_EXT_geometry_shader4 + + +GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ; +GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level, GLint layer ) ; +GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level, GLenum face ) ; + +CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9 +CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA +CONSTANT: GL_GEOMETRY_INPUT_TYPE_EXT HEX: 8DDB +CONSTANT: GL_GEOMETRY_OUTPUT_TYPE_EXT HEX: 8DDC +CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29 +CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD +CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE +CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B +CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF +CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0 +CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1 +CONSTANT: GL_LINES_ADJACENCY_EXT HEX: A +CONSTANT: GL_LINE_STRIP_ADJACENCY_EXT HEX: B +CONSTANT: GL_TRIANGLES_ADJACENCY_EXT HEX: C +CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY_EXT HEX: D +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8 +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9 +CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7 +ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT +CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642 + + +! GL_EXT_texture_integer + + +GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ; +GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ; +GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ; +GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ; + +CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E + +CONSTANT: GL_RGBA32UI_EXT HEX: 8D70 +CONSTANT: GL_RGB32UI_EXT HEX: 8D71 +CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72 +CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73 +CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74 +CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75 + +CONSTANT: GL_RGBA16UI_EXT HEX: 8D76 +CONSTANT: GL_RGB16UI_EXT HEX: 8D77 +CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78 +CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79 +CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A +CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B + +CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C +CONSTANT: GL_RGB8UI_EXT HEX: 8D7D +CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E +CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F +CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80 +CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81 + +CONSTANT: GL_RGBA32I_EXT HEX: 8D82 +CONSTANT: GL_RGB32I_EXT HEX: 8D83 +CONSTANT: GL_ALPHA32I_EXT HEX: 8D84 +CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85 +CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86 +CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87 + +CONSTANT: GL_RGBA16I_EXT HEX: 8D88 +CONSTANT: GL_RGB16I_EXT HEX: 8D89 +CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A +CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B +CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C +CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D + +CONSTANT: GL_RGBA8I_EXT HEX: 8D8E +CONSTANT: GL_RGB8I_EXT HEX: 8D8F +CONSTANT: GL_ALPHA8I_EXT HEX: 8D90 +CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91 +CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92 +CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93 + +CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94 +CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95 +CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96 +CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97 +CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98 +CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99 +CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A +CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B +CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C +CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D + + +! GL_EXT_transform_feedback + + +GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer, + GLintptr offset, GLsizeiptr size ) ; +GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer, + GLintptr offset ) ; +GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ; + +GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ; +GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ; + +GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count, + GLchar** varyings, GLenum bufferMode ) ; +GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index, + GLsizei bufSize, GLsizei* length, + GLsizei* size, GLenum* type, GLchar* name ) ; + +GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ; +GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ; + +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F +CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C +CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D +CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87 +CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88 +CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89 +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80 +CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F +CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76 + From 5801b2ae693f5f7a1bd07bb5792d30c9c65d1236 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 11:04:11 -0500 Subject: [PATCH 043/228] cocoa doesn't send key-up gestures for cmd+keys --- extra/terrain/terrain.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d6905144bb..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -134,7 +134,7 @@ M: terrain-world tick-length terrain-world H{ - { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } + { T{ key-down { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] } } set-gestures :: handle-input ( world -- ) From 67164321a6ee878d702016999e63f4b7b4595822 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 14:08:56 -0500 Subject: [PATCH 044/228] fix inflate --- basis/bitstreams/bitstreams.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 997daa2c5d..300ab5c1bf 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -123,7 +123,10 @@ ERROR: not-enough-bits n bit-reader ; : #bits>#bytes ( #bits -- #bytes ) 8 /mod 0 = [ 1 + ] unless ; inline -:: subseq>bits ( bignum n bs -- bits ) +:: subseq>bits-le ( bignum n bs -- bits ) + bignum bs bit-pos>> neg shift n bits ; + +:: subseq>bits-be ( bignum n bs -- bits ) bignum 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when neg shift n bits ; @@ -138,15 +141,15 @@ ERROR: not-enough-bits n bit-reader ; bs (>>bit-pos) ] if ; -:: (peek) ( n bs word -- bits ) +:: (peek) ( n bs endian> subseq-endian -- bits ) n bs enough-bits? [ n bs not-enough-bits ] unless bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd + - bs bytes>> subseq word execute( seq -- x ) :> bignum - bignum n bs subseq>bits ; + bs bytes>> subseq endian> execute( seq -- x ) :> bignum + bignum n bs subseq-endian execute( bignum n bs -- bits ) ; -M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ; +M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ; -M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ; +M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ; :: bit-writer-bytes ( writer -- bytes ) writer widthed>> #bits>> :> n From 2b0f6442d93d1c5ce84844fb2ef17c491b37db9e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 14:59:26 -0500 Subject: [PATCH 045/228] remove debugging code from bitstreams --- basis/bitstreams/bitstreams.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 300ab5c1bf..cb6a753735 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -104,7 +104,7 @@ M:: lsb0-bit-writer poke ( value n bs -- ) widthed bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte byte bs widthed>> |widthed :> new-byte - new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [ + new-byte #bits>> 8 = [ new-byte bits>> bs bytes>> push zero-widthed bs (>>widthed) remainder widthed>bytes From 9a83423a180212909b37cf80203ad1ba1c182fc6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 15:26:41 -0500 Subject: [PATCH 046/228] move IOHIDManagerSetDeviceMatching call after IOHIDManagerOpen. this prevents IOHIDManagerOpen from failing if it would match an exclusive-opened device --- basis/game-input/iokit/iokit.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 32440e92b2..68ecaecc29 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; iokit-game-input-backend game-input-backend set-global -: hid-manager-matching ( matching-seq -- alien ) - f 0 IOHIDManagerCreate - [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ] - keep ; +: make-hid-manager ( -- alien ) + f 0 IOHIDManagerCreate ; + +: set-hid-manager-matching ( alien matching-seq -- ) + >plist IOHIDManagerSetDeviceMatchingMultiple ; : devices-from-hid-manager ( manager -- vector ) [ @@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash : ?hat-switch ( device -- ? ) hat-switch-matching-hash ?axis ; -: hid-manager-matching-game-devices ( -- alien ) - game-devices-matching-seq hid-manager-matching ; - : device-property ( device key -- value ) IOHIDDeviceGetProperty [ plist> ] [ f ] if* ; : element-property ( element key -- value ) @@ -288,12 +286,13 @@ M: iokit-game-input-backend reset-mouse 256 +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) - hid-manager-matching-game-devices { + make-hid-manager { [ initialize-variables ] [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ] [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ] [ device-input-callback f IOHIDManagerRegisterInputValueCallback ] [ 0 IOHIDManagerOpen mach-error ] + [ game-devices-matching-seq set-hid-manager-matching ] [ CFRunLoopGetMain CFRunLoopDefaultMode IOHIDManagerScheduleWithRunLoop From 829e7c41d96231f7fccd9a1b2ca2cc0040a91e56 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 16:06:48 -0500 Subject: [PATCH 047/228] call vim with run-detached instead of try-process. clean up vim code. --- basis/editors/gvim/gvim.factor | 5 ++++- basis/editors/macvim/macvim.factor | 8 +++----- basis/editors/vim/vim-docs.factor | 2 +- basis/editors/vim/vim.factor | 12 ++++++------ 4 files changed, 14 insertions(+), 13 deletions(-) diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor index 15fd52f5ee..277cd734cc 100644 --- a/basis/editors/gvim/gvim.factor +++ b/basis/editors/gvim/gvim.factor @@ -11,7 +11,10 @@ SINGLETON: gvim HOOK: gvim-path io-backend ( -- path ) M: gvim vim-command ( file line -- string ) - [ gvim-path , "+" swap number>string append , , ] { } make ; + [ + gvim-path , + number>string "+" prepend , , + ] { } make ; gvim vim-editor set-global diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor index b5f864dcd0..c178207e49 100644 --- a/basis/editors/macvim/macvim.factor +++ b/basis/editors/macvim/macvim.factor @@ -3,11 +3,9 @@ namespaces prettyprint editors make ; IN: editors.macvim -: macvim-location ( file line -- ) +: macvim ( file line -- ) drop [ "open" , "-a" , "MacVim", , ] { } make - try-process ; - -[ macvim-location ] edit-hook set-global - + run-detached drop ; +[ macvim ] edit-hook set-global diff --git a/basis/editors/vim/vim-docs.factor b/basis/editors/vim/vim-docs.factor index 7f527bf18f..1ec3a37061 100644 --- a/basis/editors/vim/vim-docs.factor +++ b/basis/editors/vim/vim-docs.factor @@ -3,7 +3,7 @@ USING: definitions editors help help.markup help.syntax io io.files IN: editors.vim ARTICLE: { "vim" "vim" } "Vim support" -"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." +"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." $nl "If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":" { $code diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor index f07f257888..88c8b8051e 100644 --- a/basis/editors/vim/vim.factor +++ b/basis/editors/vim/vim.factor @@ -4,7 +4,6 @@ make ; IN: editors.vim SYMBOL: vim-path - SYMBOL: vim-editor HOOK: vim-command vim-editor ( file line -- array ) @@ -12,12 +11,13 @@ SINGLETON: vim M: vim vim-command [ - vim-path get , swap , "+" swap number>string append , + vim-path get , + [ , ] [ number>string "+" prepend , ] bi* ] { } make ; -: vim-location ( file line -- ) - vim-command try-process ; +: vim ( file line -- ) + vim-command run-detached drop ; "vim" vim-path set-global -[ vim-location ] edit-hook set-global -vim vim-editor set-global +[ vim ] edit-hook set-global +\ vim vim-editor set-global From d0430ef4cf1cded24d1cef142b8a8ad98010002f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 16:12:13 -0500 Subject: [PATCH 048/228] launch editors with run-detached. the naming convention foo-location doesn't make sense with some text editors, so rename the edit words to the text editor name --- basis/editors/scite/scite.factor | 4 ++-- basis/editors/textedit/textedit.factor | 6 +++--- basis/editors/textmate/textmate.factor | 7 +++---- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 7e8a540b73..605b4d53aa 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -25,7 +25,7 @@ IN: editors.scite number>string "-goto:" prepend , ] { } make ; -: scite-location ( file line -- ) +: scite ( file line -- ) scite-command run-detached drop ; -[ scite-location ] edit-hook set-global +[ scite ] edit-hook set-global diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index cccc94b539..4b5f2c6886 100644 --- a/basis/editors/textedit/textedit.factor +++ b/basis/editors/textedit/textedit.factor @@ -2,9 +2,9 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; IN: editors.textedit -: textedit-location ( file line -- ) +: textedit ( file line -- ) drop [ "open" , "-a" , "TextEdit", , ] { } make - try-process ; + run-detached drop ; -[ textedit-location ] edit-hook set-global +[ textedit ] edit-hook set-global diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 8bea085c7f..65395bd590 100644 --- a/basis/editors/textmate/textmate.factor +++ b/basis/editors/textmate/textmate.factor @@ -1,10 +1,9 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; - IN: editors.textmate -: textmate-location ( file line -- ) +: textmate ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - try-process ; + run-detached drop ; -[ textmate-location ] edit-hook set-global +[ textmate ] edit-hook set-global From 344f3668e437fb2fa93011e521bb40df22792257 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 May 2009 17:18:38 -0500 Subject: [PATCH 049/228] Fix escape analysis bug reported by Doug --- .../escape-analysis/escape-analysis-tests.factor | 6 ++++++ .../tree/escape-analysis/simple/simple.factor | 12 ++++-------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 3d9d77ae56..708992f918 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -322,3 +322,9 @@ C: ro-box [ 0 ] [ [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations ] unit-test + +! Doug found a regression + +TUPLE: empty-tuple ; + +[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index 729d6a0490..c0b3982c0e 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -49,14 +49,10 @@ M: #push escape-analysis* : slot-offset ( #call -- n/f ) dup in-d>> - [ first node-value-info class>> ] - [ second node-value-info literal>> ] 2bi - dup fixnum? [ - { - { [ over tuple class<= ] [ 2 - ] } - { [ over complex class<= ] [ 1 - ] } - [ drop f ] - } cond nip + [ second node-value-info literal>> ] + [ first node-value-info class>> ] 2bi + 2dup [ fixnum? ] [ tuple class<= ] bi* and [ + over 2 >= [ drop 2 - ] [ 2drop f ] if ] [ 2drop f ] if ; : record-slot-call ( #call -- ) From 824cb1ed230e8adfb92169aa491c5670cb56ca4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 May 2009 17:18:56 -0500 Subject: [PATCH 050/228] serialize: Remove code for handling complex and ratio values since those are tuples now --- basis/serialize/serialize.factor | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 4a0d3777b8..4e94b6a51d 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -90,16 +90,6 @@ M: float (serialize) ( obj -- ) CHAR: F write1 double>bits serialize-cell ; -M: complex (serialize) ( obj -- ) - CHAR: c write1 - [ real-part (serialize) ] - [ imaginary-part (serialize) ] bi ; - -M: ratio (serialize) ( obj -- ) - CHAR: r write1 - [ numerator (serialize) ] - [ denominator (serialize) ] bi ; - : serialize-seq ( obj code -- ) [ write1 @@ -205,12 +195,6 @@ SYMBOL: deserialized : deserialize-float ( -- float ) deserialize-cell bits>double ; -: deserialize-ratio ( -- ratio ) - (deserialize) (deserialize) / ; - -: deserialize-complex ( -- complex ) - (deserialize) (deserialize) rect> ; - : (deserialize-string) ( -- string ) deserialize-cell read utf8 decode ; @@ -279,7 +263,6 @@ SYMBOL: deserialized { CHAR: T [ deserialize-tuple ] } { CHAR: W [ deserialize-wrapper ] } { CHAR: a [ deserialize-array ] } - { CHAR: c [ deserialize-complex ] } { CHAR: h [ deserialize-hashtable ] } { CHAR: m [ deserialize-negative-integer ] } { CHAR: n [ deserialize-false ] } @@ -287,7 +270,6 @@ SYMBOL: deserialized { CHAR: o [ deserialize-unknown ] } { CHAR: p [ deserialize-positive-integer ] } { CHAR: q [ deserialize-quotation ] } - { CHAR: r [ deserialize-ratio ] } { CHAR: s [ deserialize-string ] } { CHAR: w [ deserialize-word ] } { CHAR: G [ deserialize-word ] } From 8c7418e74a7b9e52aa5bd8dd2a82ca2ef590aa5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 19:36:36 -0500 Subject: [PATCH 051/228] add reverse time to terrain demo and refactored it a bit --- extra/terrain/terrain.factor | 59 +++++++++++++++++++++++++++++------- 1 file changed, 48 insertions(+), 11 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index fb326ef534..cfacfeb700 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -6,13 +6,15 @@ opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game-worlds method-chains -math.affine-transforms noise ui.gestures ; +math.affine-transforms noise ui.gestures combinators.short-circuit ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] CONSTANT: FAR-PLANE 2.0 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } +CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 } +CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 } CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] @@ -28,13 +30,23 @@ CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player - location yaw pitch velocity velocity-modifier ; + location yaw pitch velocity velocity-modifier + reverse-time ; TUPLE: terrain-world < game-world player sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program - terrain-vertex-buffer ; + terrain-vertex-buffer + history ; + +: ( -- player ) + player new + PLAYER-START-LOCATION >>location + 0.0 >>yaw + 0.0 >>pitch + { 0.0 0.0 0.0 } >>velocity + VELOCITY-MODIFIER-NORMAL >>velocity-modifier ; M: terrain-world tick-length drop 1000 30 /i ; @@ -140,12 +152,17 @@ terrain-world H{ :: handle-input ( world -- ) world player>> :> player read-keyboard keys>> :> keys - key-left-shift keys nth [ - { 2.0 1.0 2.0 } player (>>velocity-modifier) - ] when - key-left-shift keys nth [ - { 1.0 1.0 1.0 } player (>>velocity-modifier) - ] unless + + key-left-shift keys nth + VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier) + + { + [ key-1 keys nth 1 f ? ] + [ key-2 keys nth 2 f ? ] + [ key-3 keys nth 3 f ? ] + [ key-4 keys nth 4 f ? ] + [ key-5 keys nth 10000 f ? ] + } 0|| player (>>reverse-time) key-w keys nth [ player walk-forward ] when key-s keys nth [ player walk-backward ] when @@ -199,11 +216,30 @@ terrain-world H{ : scaled-velocity ( player -- velocity ) [ velocity>> ] [ velocity-modifier>> ] bi v* ; -: tick-player ( world player -- ) +: save-history ( world player -- ) + clone swap history>> push ; + +:: tick-player-reverse ( world player -- ) + player reverse-time>> :> reverse-time + world history>> :> history + history length 0 > [ + history length reverse-time 1 - - 1 max history set-length + history pop world (>>player) + ] when ; + +: tick-player-forward ( world player -- ) + 2dup save-history [ apply-friction apply-gravity ] change-velocity dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location drop ; +: tick-player ( world player -- ) + dup reverse-time>> [ + tick-player-reverse + ] [ + tick-player-forward + ] if ; + M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; @@ -226,7 +262,8 @@ BEFORE: terrain-world begin-world GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player + >>player + V{ } clone >>history 0.01 0.01 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture From a1d77bb0c1d529bc90fc6b78bc8976e073b0388c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 22:31:50 -0500 Subject: [PATCH 052/228] call link-info instead of file-info, fix wonky spacing, name a constant --- basis/tools/files/files.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 146a119a63..29d3674b60 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -74,9 +74,9 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ - [ dup name>> file-info file-listing boa ] map - _ [ sort-by ] when* - [ _ [ file-spec>string ] with map ] map + [ dup name>> link-info file-listing boa ] map + _ [ sort-by ] when* + [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline : list-files ( listing-tool -- array ) @@ -115,11 +115,14 @@ SYMBOLS: +device-name+ +mount-point+ +type+ [ file-systems-info ] [ [ unparse ] map ] bi prefix simple-table. ; -: file-systems. ( -- ) +CONSTANT: default-file-systems-spec { +device-name+ +available-space+ +free-space+ +used-space+ +total-space+ +percent-used+ +mount-point+ - } print-file-systems ; + } + +: file-systems. ( -- ) + default-file-systems-spec print-file-systems ; { { [ os unix? ] [ "tools.files.unix" ] } From ba04d5af1e3c0127380788b971fe0c0b9beadaff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 00:29:21 -0500 Subject: [PATCH 053/228] Update documentation for stricter vocabulary search path semantics --- basis/checksums/openssl/openssl-docs.factor | 4 +- basis/compiler/tests/alien.factor | 11 +- basis/compiler/tests/codegen.factor | 12 +- basis/compiler/tests/intrinsics.factor | 4 +- .../tree/propagation/info/info-tests.factor | 2 +- .../tuple-unboxing-tests.factor | 2 +- .../distributed/distributed-tests.factor | 1 + .../exchangers/exchangers-tests.factor | 3 +- .../messaging/messaging-docs.factor | 2 +- .../cpu/ppc/assembler/assembler-tests.factor | 1 + basis/db/tuples/tuples-tests.factor | 3 +- basis/ftp/server/server-tests.factor | 1 + basis/help/cookbook/cookbook.factor | 5 +- basis/help/handbook/handbook.factor | 6 +- basis/help/tutorial/tutorial.factor | 2 +- basis/html/components/components-tests.factor | 1 + basis/html/forms/forms-tests.factor | 1 + basis/html/streams/streams-tests.factor | 2 +- basis/html/templates/chloe/chloe-tests.factor | 2 +- basis/http/http-tests.factor | 8 +- basis/io/files/info/info-tests.factor | 2 +- basis/listener/listener-tests.factor | 2 - .../lists/lazy/examples/examples-tests.factor | 2 +- basis/lists/lazy/lazy-docs.factor | 16 +- basis/lists/lazy/lazy.factor | 6 - basis/lists/lists-docs.factor | 46 ++-- basis/lists/lists-tests.factor | 39 +--- basis/literals/literals-docs.factor | 2 +- basis/math/complex/complex-docs.factor | 4 +- basis/opengl/textures/textures-tests.factor | 3 +- basis/peg/ebnf/ebnf.factor | 2 +- basis/peg/peg-tests.factor | 2 +- basis/prettyprint/prettyprint-tests.factor | 4 +- basis/regexp/regexp-docs.factor | 2 +- basis/serialize/serialize-tests.factor | 2 +- .../call-effect/call-effect-tests.factor | 2 +- .../struct-arrays/struct-arrays-tests.factor | 3 +- basis/ui/gadgets/gadgets-tests.factor | 9 +- basis/ui/tools/listener/listener-tests.factor | 4 +- basis/xml/syntax/syntax-docs.factor | 4 +- basis/xml/syntax/syntax-tests.factor | 2 - core/assocs/assocs-docs.factor | 2 +- core/bootstrap/syntax.factor | 1 + core/classes/algebra/algebra-tests.factor | 2 +- core/classes/classes-tests.factor | 2 +- core/classes/mixin/mixin-tests.factor | 11 +- core/classes/predicate/predicate-tests.factor | 2 +- core/combinators/combinators-docs.factor | 2 - core/make/make-docs.factor | 2 +- core/parser/parser-docs.factor | 11 +- core/parser/parser-tests.factor | 18 +- core/syntax/syntax-docs.factor | 52 +++-- core/syntax/syntax.factor | 2 + core/vocabs/parser/parser-docs.factor | 219 +++++++++++------- core/vocabs/parser/parser.factor | 33 ++- core/words/words-docs.factor | 2 +- extra/bank/bank-tests.factor | 1 + extra/fuel/xref/xref.factor | 6 +- extra/infix/infix-docs.factor | 8 +- .../floating-point-tests.factor | 4 +- extra/monads/monads-tests.factor | 1 + extra/roles/roles-tests.factor | 1 + extra/tetris/game/game-tests.factor | 1 + 63 files changed, 307 insertions(+), 307 deletions(-) diff --git a/basis/checksums/openssl/openssl-docs.factor b/basis/checksums/openssl/openssl-docs.factor index 234e032406..b0cc8f9e53 100644 --- a/basis/checksums/openssl/openssl-docs.factor +++ b/basis/checksums/openssl/openssl-docs.factor @@ -30,8 +30,8 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums" "An error thrown if the digest name is unrecognized:" { $subsection unknown-digest } "An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:" -{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } +{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } "If we use the Factor implementation, we get the same result, just slightly slower:" -{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; +{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; ABOUT: "checksums.openssl" diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index f7f24433d7..91215baf19 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -1,9 +1,8 @@ -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 combinators -specialized-arrays.float alien.libraries io.pathnames +USING: alien alien.c-types alien.syntax compiler kernel namespaces +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 +combinators specialized-arrays.float alien.libraries io.pathnames io.backend ; IN: compiler.tests.alien diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 8fbe13ce51..e0bc917f1c 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -1,9 +1,9 @@ -USING: generalizations accessors arrays compiler kernel -kernel.private math hashtables.private math.private namespaces -sequences sequences.private tools.test namespaces.private -slots.private sequences.private byte-arrays alien +USING: generalizations accessors arrays compiler kernel kernel.private +math hashtables.private math.private namespaces sequences tools.test +namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make ; +QUALIFIED: namespaces.private IN: compiler.tests.codegen ! Originally, this file did black box testing of templating @@ -48,7 +48,7 @@ unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global >n get ndrop ] compile-call + \ foo [ global >n get namespaces.private:ndrop ] compile-call ] unit-test : blech ( x -- ) drop ; @@ -62,7 +62,7 @@ unit-test [ 3 ] [ global [ 3 \ foo set ] bind - \ foo [ global [ get ] swap >n call ndrop ] compile-call + \ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call ] unit-test [ 3 ] diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 5ca0f3f109..d0cfc127e3 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -1,10 +1,10 @@ USING: accessors arrays compiler.units kernel kernel.private math math.constants math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays -strings.private system random layouts vectors +system random layouts vectors sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings -namespaces libc sequences.private io.encodings.ascii +namespaces libc io.encodings.ascii classes compiler ; IN: compiler.tests.intrinsics diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 2c3314994b..72c08dbf1c 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -1,5 +1,5 @@ USING: accessors math math.intervals sequences classes.algebra -math kernel tools.test compiler.tree.propagation.info arrays ; +kernel tools.test compiler.tree.propagation.info arrays ; IN: compiler.tree.propagation.info.tests [ f ] [ 0.0 -0.0 eql? ] unit-test diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 0d5f05fab0..a96fc0501d 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -1,5 +1,5 @@ IN: compiler.tree.tuple-unboxing.tests -USING: tools.test compiler.tree.tuple-unboxing compiler.tree +USING: tools.test compiler.tree compiler.tree.builder compiler.tree.recursive compiler.tree.normalization compiler.tree.propagation compiler.tree.cleanup compiler.tree.escape-analysis diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 996e3db4c0..6c0d882cac 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -3,6 +3,7 @@ USING: tools.test concurrency.distributed kernel io.files io.files.temp io.directories arrays io.sockets system combinators threads math sequences concurrency.messaging continuations accessors prettyprint ; +FROM: concurrency.messaging => receive send ; : test-node ( -- addrspec ) { diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index 3b5b014fe3..7ec9db8ad9 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -1,7 +1,8 @@ IN: concurrency.exchangers.tests -USING: sequences tools.test concurrency.exchangers +USING: tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; +FROM: sequences => 3append ; :: exchanger-test ( -- string ) [let | diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 039e9a53af..d58df3519b 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -53,7 +53,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" { $subsection reply-synchronous } "An example:" { $example - "USING: concurrency.messaging kernel prettyprint threads ;" + "USING: concurrency.messaging threads ;" "IN: scratchpad" ": pong-server ( -- )" " receive [ \"pong\" ] dip reply-synchronous ;" diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index 14327d08b8..23b1d1e6f4 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -1,6 +1,7 @@ IN: cpu.ppc.assembler.tests USING: cpu.ppc.assembler tools.test arrays kernel namespaces make vocabs sequences ; +FROM: cpu.ppc.assembler => B ; : test-assembler ( expected quot -- ) [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index afdee3e89f..6bf8dd3075 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files io.files.temp kernel tools.test db db.tuples classes -db.types continuations namespaces math math.ranges +db.types continuations namespaces math prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitwise system math.ranges strings urls fry db.tuples.private db.private db.tester ; +FROM: math.ranges => [a,b] ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor index d7d9d8384d..3484fb4474 100644 --- a/basis/ftp/server/server-tests.factor +++ b/basis/ftp/server/server-tests.factor @@ -2,6 +2,7 @@ USING: calendar ftp.server io.encodings.ascii io.files io.files.unique namespaces threads tools.test kernel io.servers.connection ftp.client accessors urls io.pathnames io.directories sequences fry ; +FROM: ftp.client => ftp-get ; IN: ftp.server.tests : test-file-contents ( -- string ) diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 8aa0265239..ff385f9a65 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -136,7 +136,7 @@ ARTICLE: "cookbook-variables" "Dynamic variables cookbook" } ; ARTICLE: "cookbook-vocabs" "Vocabularies cookbook" -"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches the " { $emphasis "vocabulary search path" } ". When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported." +"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches through vocabularies. When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported." $nl "For example, a source file containing the following code will print a parse error if you try loading it:" { $code "\"Hello world\" print" } @@ -161,7 +161,7 @@ $nl "You would have to place the first definition after the two others for the parser to accept the file." { $references { } - "vocabulary-search" + "word-search" "words" "parser" } ; @@ -286,7 +286,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { $list "Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM." "Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail." - { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." } { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index b83fb22ccf..a18dcd03f7 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -248,14 +248,14 @@ ARTICLE: "handbook-language-reference" "The language" { $subsection "namespaces-global" } { $subsection "values" } { $heading "Abstractions" } -{ $subsection "errors" } +{ $subsection "fry" } { $subsection "objects" } +{ $subsection "errors" } { $subsection "destructors" } -{ $subsection "continuations" } { $subsection "memoize" } { $subsection "parsing-words" } { $subsection "macros" } -{ $subsection "fry" } +{ $subsection "continuations" } { $heading "Program organization" } { $subsection "vocabs.loader" } "Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ; diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 7686022b70..a46e577357 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -38,7 +38,7 @@ $nl $nl "Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor listener and press " { $command tool "common" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them." $nl -"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain." +"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "word-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain." $nl "To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary." $nl diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index da2e5b5991..c901e35e3e 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -3,6 +3,7 @@ USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; +FROM: html.components => inspector ; [ ] [ begin-form ] unit-test diff --git a/basis/html/forms/forms-tests.factor b/basis/html/forms/forms-tests.factor index d2dc3ed3a3..006a435cf0 100644 --- a/basis/html/forms/forms-tests.factor +++ b/basis/html/forms/forms-tests.factor @@ -1,6 +1,7 @@ IN: html.forms.tests USING: kernel sequences tools.test assocs html.forms validators accessors namespaces ; +FROM: html.forms => values ; : with-validation ( quot -- messages ) [ diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 835874cbb7..79e8027489 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -1,6 +1,6 @@ USING: html.streams html.streams.private accessors io io.streams.string io.styles kernel namespaces tools.test -xml.writer sbufs sequences inspector colors xml.writer +sbufs sequences inspector colors xml.writer classes.predicate prettyprint ; IN: html.streams.tests diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index fd786d355d..8003d71d36 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -1,7 +1,7 @@ USING: html.templates html.templates.chloe tools.test io.streams.string kernel sequences ascii boxes namespaces xml html.components html.forms -splitting unicode.categories furnace accessors +splitting furnace accessors html.templates.chloe.compiler ; IN: html.templates.chloe.tests diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 5c73377cbe..f11aa9eaa2 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -173,10 +173,10 @@ Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes ] unit-test ! Live-fire exercise -USING: http.server http.server.static furnace.sessions furnace.alloy -furnace.actions furnace.auth furnace.auth.login furnace.db http.client -io.servers.connection io.files io.files.temp io.directories io io.encodings.ascii -accessors namespaces threads +USING: http.server.static furnace.sessions furnace.alloy +furnace.actions furnace.auth furnace.auth.login furnace.db +io.servers.connection io.files io.files.temp io.directories io +threads http.server.responses http.server.redirection furnace.redirection http.server.dispatchers db.tuples ; diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor index 7b19f56b10..d494e87dd7 100644 --- a/basis/io/files/info/info-tests.factor +++ b/basis/io/files/info/info-tests.factor @@ -1,4 +1,4 @@ -USING: io.files.info io.pathnames io.encodings.utf8 io.files +USING: io.files.info io.encodings.utf8 io.files io.directories kernel io.pathnames accessors tools.test sequences io.files.temp ; IN: io.files.info.tests diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index ccdd0be8c8..907c45360d 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -15,8 +15,6 @@ SYNTAX: hello "Hi" print ; ] with-file-vocabs [ - "debugger" add-ambiguous-use - [ [ \ + 1 2 3 4 ] ] [ [ diff --git a/basis/lists/lazy/examples/examples-tests.factor b/basis/lists/lazy/examples/examples-tests.factor index 04886e2c1c..f21775bd9b 100644 --- a/basis/lists/lazy/examples/examples-tests.factor +++ b/basis/lists/lazy/examples/examples-tests.factor @@ -1,4 +1,4 @@ -USING: lists.lazy.examples lists.lazy tools.test ; +USING: lists.lazy.examples lists.lazy lists tools.test ; IN: lists.lazy.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index c46d3251a9..706431d0a2 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -93,22 +93,12 @@ HELP: luntil { $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: list>vector -{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } } -{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." } -{ $see-also list>array } ; - -HELP: list>array -{ $values { "list" "a cons object" } { "array" "the list converted to an array" } } -{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." } -{ $see-also list>vector } ; - HELP: lappend { $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } } { $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ; HELP: lfrom-by -{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "lazy-from-by" "a lazy list of integers" } } +{ $values { "n" "an integer" } { "quot" { $quotation "( -- n )" } } { "lazy-from-by" "a lazy list of integers" } } { $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ; HELP: lfrom @@ -117,7 +107,7 @@ HELP: lfrom HELP: seq>list { $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } } -{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." } +{ $description "Convert the sequence into a list, starting from " { $snippet "index" } "." } { $see-also >list } ; HELP: >list @@ -154,7 +144,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lists lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 64a3f099a0..49aee471bf 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -178,12 +178,6 @@ M: lazy-filter nil? ( lazy-filter -- bool ) ] if ] if ; -: list>vector ( list -- vector ) - [ [ , ] leach ] V{ } make ; - -: list>array ( list -- array ) - [ [ , ] leach ] { } make ; - TUPLE: lazy-append list1 list2 ; C: lazy-append diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 8782c3d9b4..3fac05affe 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -54,21 +54,21 @@ ARTICLE: { "lists" "manipulation" } "Manipulating lists" { $subsection lcut } ; HELP: cons -{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } } +{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" list } } { $description "Constructs a cons cell." } ; HELP: swons -{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } } +{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" list } } { $description "Constructs a cons cell." } ; { cons swons uncons unswons } related-words HELP: car -{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } +{ $values { "cons" list } { "car" "the first item in the list" } } { $description "Returns the first item in the list." } ; HELP: cdr -{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } +{ $values { "cons" list } { "cdr" list } } { $description "Returns the tail of the list." } ; { car cdr } related-words @@ -86,51 +86,51 @@ HELP: nil? { 1list 2list 3list } related-words HELP: 1list -{ $values { "obj" "an object" } { "cons" "a cons object" } } +{ $values { "obj" "an object" } { "cons" list } } { $description "Create a list with 1 element." } ; HELP: 2list -{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } +{ $values { "a" "an object" } { "b" "an object" } { "cons" list } } { $description "Create a list with 2 elements." } ; HELP: 3list -{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } +{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" list } } { $description "Create a list with 3 elements." } ; HELP: lnth -{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } +{ $values { "n" "an integer index" } { "list" list } { "elt" "the element at the nth index" } } { $description "Outputs the nth element of the list." } { $see-also llength cons car cdr } ; HELP: llength -{ $values { "list" "a cons object" } { "n" "a non-negative integer" } } +{ $values { "list" list } { "n" "a non-negative integer" } } { $description "Outputs the length of the list. This should not be called on an infinite list." } { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; HELP: unswons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; { leach foldl lmap>array } related-words HELP: leach -{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } } +{ $values { "list" list } { "quot" { $quotation "( obj -- )" } } } { $description "Call the quotation for each item in the list." } ; HELP: foldl -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ; HELP: foldr -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ; HELP: lmap -{ $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } +{ $values { "list" list } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; HELP: lreverse @@ -138,23 +138,15 @@ HELP: lreverse { $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ; HELP: list>array -{ $values { "list" "a cons object" } { "array" array } } -{ $description "Turns the given cons object into an array, maintaing order." } ; - -HELP: sequence>cons -{ $values { "sequence" sequence } { "list" cons } } -{ $description "Turns the given array into a cons object, maintaing order." } ; +{ $values { "list" list } { "array" array } } +{ $description "Convert a list into an array." } ; HELP: deep-list>array { $values { "list" list } { "array" array } } -{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; - -HELP: deep-sequence>cons -{ $values { "sequence" sequence } { "cons" cons } } -{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; +{ $description "Recursively turns the given cons object into an array, maintaining order and also converting nested lists." } ; HELP: traverse -{ $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } } +{ $values { "list" list } { "pred" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" " returns true for with the result of applying quot to." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 13d2e03e0f..69daa39e41 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math kernel ; +USING: tools.test lists lists.lazy math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ @@ -23,49 +23,24 @@ IN: lists.tests +nil+ } } } } 0 [ + ] foldl ] unit-test -{ T{ cons f - 1 - T{ cons f - 2 - T{ cons f - T{ cons f - 3 - T{ cons f - 4 - T{ cons f - T{ cons f 5 +nil+ } - +nil+ } } } - +nil+ } } } -} [ - { 1 2 { 3 4 { 5 } } } deep-sequence>cons -] unit-test - -{ { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array -] unit-test - { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } sequence>cons [ 1+ ] lmap + { 1 2 3 4 } seq>list [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr + { 1 2 3 4 5 } seq>list 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } sequence>cons lreverse list>array + { 1 2 3 4 5 } seq>list lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } sequence>cons llength -] unit-test - -{ { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array + { 1 2 3 4 5 } seq>list llength ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array + { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>array ] unit-test -[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test +[ { 1 } { 2 } ] [ { 1 2 } seq>list 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 9dd398d962..9ec8e30133 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -65,7 +65,7 @@ ${ five six 7 } . ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." { $example <" -USING: kernel literals math prettyprint ; +USE: literals IN: scratchpad CONSTANT: five 5 diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index a51b86ff0b..9cb80447e5 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -4,9 +4,9 @@ IN: math.complex ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers" "Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:" -{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" } +{ $example "C{ 1 2 } C{ 3 -2 } + ." "4" } "Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:" -{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" } +{ $example "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" } "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ; ARTICLE: "complex-numbers" "Complex numbers" diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 3efdb43cd8..24f43c52ac 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test opengl.textures opengl.textures.private -opengl.textures.private images kernel namespaces accessors -sequences ; +images kernel namespaces accessors sequences ; IN: opengl.textures.tests [ diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index d4ad62fbea..f3d555d5a1 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -461,7 +461,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) M: ebnf-var build-locals ( code ast -- ) [ - "FROM: locals => [let* ; FROM: kernel => dup ; [let* | " % + "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " % name>> % " [ dup ] " % " | " % % diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index cae1e05dc8..501b8ed856 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test strings namespaces make arrays sequences - peg peg.private peg.parsers accessors words math accessors ; + peg peg.private peg.parsers words math accessors ; IN: peg.tests [ ] [ reset-pegs ] unit-test diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 25ee83985e..cd10278760 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -91,15 +91,13 @@ unit-test : check-see ( expect name -- ? ) [ - use [ clone ] change - [ [ parse-fresh drop ] with-compilation-unit [ "prettyprint.tests" lookup see ] with-string-writer "\n" split but-last ] keep = - ] with-scope ; + ] with-interactive-vocabs ; GENERIC: method-layout ( a -- b ) diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index 2ff31f0cec..3eb4e8a9bf 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -31,7 +31,7 @@ ARTICLE: { "regexp" "intro" } "A quick introduction to regular expressions" "To search a file for all lines that match a given regular expression, you could use code like this:" { $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> } "To test if a string in its entirety matches a regular expression, the following can be used:" -{ $example <" USING: regexp prettyprint ; "fooo" R/ (b|f)oo+/ matches? . "> "t" } +{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" } "Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ; ARTICLE: { "regexp" "construction" } "Constructing regular expressions" diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index d23c8be84b..b6a4b1a86f 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: tools.test kernel serialize io io.streams.byte-array math +USING: tools.test kernel serialize io io.streams.byte-array alien arrays byte-arrays bit-arrays specialized-arrays.double sequences math prettyprint parser classes math.constants io.encodings.binary random assocs serialize.private ; diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor index b222cbbcf7..0ad64cace3 100644 --- a/basis/stack-checker/call-effect/call-effect-tests.factor +++ b/basis/stack-checker/call-effect/call-effect-tests.factor @@ -1,4 +1,4 @@ -USING: stack-checker.call-effect tools.test math kernel math effects ; +USING: stack-checker.call-effect tools.test kernel math effects ; IN: stack-checker.call-effect.tests [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index a8ce98888c..8ce45ccc15 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -1,7 +1,6 @@ IN: struct-arrays.tests USING: struct-arrays tools.test kernel math sequences -alien.syntax alien.c-types destructors libc accessors -destructors ; +alien.syntax alien.c-types destructors libc accessors ; C-STRUCT: test-struct { "int" "x" } diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 77860ba5b5..ade5c8101e 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -1,8 +1,7 @@ -USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs -ui.gadgets.worlds tools.test namespaces models kernel dlists deques -math sets math.parser ui sequences hashtables assocs io arrays -prettyprint io.streams.string math.rectangles ui.gadgets.private -sets generic ; +USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds +tools.test namespaces models kernel dlists deques math +math.parser ui sequences hashtables assocs io arrays prettyprint +io.streams.string math.rectangles ui.gadgets.private sets generic ; IN: ui.gadgets.tests [ { 300 300 } ] diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index e06e17374f..fbbac8f3fa 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words ui.gadgets.debug slots.private -threads arrays generic threads accessors listener math +arrays generic threads accessors listener math calendar concurrency.promises io ui.tools.common ; IN: ui.tools.listener.tests @@ -146,7 +146,7 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget -[ ] [ \ + vocabs>> use-if-necessary ] unit-test +[ ] [ \ + manifest>> use-if-necessary ] unit-test [ ] [ "l" set ] unit-test [ ] [ "l" get com-scroll-up ] unit-test diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor index 34473fecfc..0f04f1b7b2 100644 --- a/basis/xml/syntax/syntax-docs.factor +++ b/basis/xml/syntax/syntax-docs.factor @@ -50,7 +50,7 @@ ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax" $nl "These forms can be used where a tag might go, as in " { $snippet "[XML <-> XML]" } " or where an attribute might go, as in " { $snippet "[XML /> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" { $example -{" USING: splitting sequences xml.writer xml.syntax ; +{" USING: splitting xml.writer xml.syntax ; "one two three" " " split [ [XML <-> XML] ] map <-> XML> pprint-xml"} @@ -86,7 +86,7 @@ $nl {" "} } "XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:" -{ $example {" USING: sequences xml.syntax inverse ; +{ $example {" USING: xml.syntax inverse ; : dispatch ( xml -- string ) { { [ [XML <-> XML] ] [ "a" prepend ] } diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 6fcaf780cc..06ba2028a6 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -100,8 +100,6 @@ XML-NS: foo http://blah.com [ "" ] [ [XML XML] concat ] unit-test -USE: inverse - [ "foo" ] [ [XML foo XML] [ [XML <-> XML] ] undo ] unit-test [ "foo" ] [ [XML XML] [ [XML /> XML] ] undo ] unit-test [ "foo" "baz" ] [ [XML baz XML] [ [XML ><-> XML] ] undo ] unit-test diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index d4046a4dcf..e56fedbd26 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -21,7 +21,7 @@ ARTICLE: "enums" "Enumerations" { $subsection enum } { $subsection } "Inverting a permutation using enumerations:" -{ $example "USING: assocs sorting prettyprint ;" "IN: scratchpad" ": invert ( perm -- perm' )" " >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; +{ $example "IN: scratchpad" ": invert ( perm -- perm' )" " >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; HELP: enum { $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 55b92df215..f5182a0210 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -51,6 +51,7 @@ IN: bootstrap.syntax "UNION:" "INTERSECTION:" "USE:" + "UNUSE:" "USING:" "QUALIFIED:" "QUALIFIED-WITH:" diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 3069c4b555..a1e83ff72c 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -1,6 +1,6 @@ USING: alien arrays definitions generic assocs hashtables io kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes classes.algebra +tools.test words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable random stack-checker effects kernel.private sbufs math.order diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 61d153f064..d7fba97977 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -1,4 +1,4 @@ -USING: alien arrays definitions generic assocs hashtables io +USING: alien arrays generic assocs hashtables io io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index f44642fdd5..a9a7952c51 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -1,9 +1,8 @@ -USING: alien arrays definitions generic assocs hashtables io -kernel math namespaces parser prettyprint sequences strings -tools.test vectors words quotations classes -classes.private classes.union classes.mixin classes.predicate -classes.algebra vectors definitions source-files -compiler.units kernel.private sorting vocabs eval ; +USING: alien arrays definitions generic assocs hashtables io kernel +math namespaces parser prettyprint sequences strings tools.test words +quotations classes classes.private classes.union classes.mixin +classes.predicate classes.algebra vectors source-files compiler.units +kernel.private sorting vocabs eval ; IN: classes.mixin.tests ! Test mixins diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index 80613f4f2e..951608931b 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -29,6 +29,6 @@ PREDICATE: tuple-c < tuple-b slot>> ; GENERIC: ptest ( tuple -- ) M: tuple-a ptest drop ; -IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ; +M: tuple-c ptest drop ; [ ] [ tuple-b new ptest ] unit-test diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 1a17e8c1fb..72602c25b9 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -152,7 +152,6 @@ ARTICLE: "compositional-examples" "Examples of compositional combinator usage" { $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" } "Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":" { $example - "USING: kernel math prettyprint sequences ;" ": subtract-n ( seq n -- seq' ) [ - ] curry map ;" "{ 10 20 30 } 5 subtract-n ." "{ 5 15 25 }" @@ -163,7 +162,6 @@ $nl { $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" } "Since this pattern comes up often, " { $link with } " encapsulates it:" { $example - "USING: kernel math prettyprint sequences ;" ": n-subtract ( n seq -- seq' ) [ - ] with map ;" "30 { 10 20 30 } n-subtract ." "{ 20 10 0 }" diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor index d3ec6c3e57..7808872588 100644 --- a/core/make/make-docs.factor +++ b/core/make/make-docs.factor @@ -48,7 +48,7 @@ $nl "The accumulator sequence can be accessed directly from inside a " { $link make } ":" { $subsection building } { $example - "USING: make math.parser io ;" + "USING: make math.parser ;" "[ \"Language #\" % CHAR: \\s , 5 # ] \"\" make print" "Language # 5" } diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d6c69f08c2..ea6a136b95 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel sequences words math strings vectors quotations generic effects classes vocabs.loader definitions io vocabs source-files -quotations namespaces compiler.units assocs lexer +namespaces compiler.units assocs lexer words.symbol words.alias words.constant vocabs.parser ; IN: parser @@ -70,7 +70,8 @@ $nl { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } { $subsection "defining-words" } -{ $subsection "parsing-tokens" } ; +{ $subsection "parsing-tokens" } +{ $subsection "word-search-parsing" } ; ARTICLE: "parser-files" "Parsing source files" "The parser can run source files:" @@ -84,7 +85,7 @@ $nl ARTICLE: "top-level-forms" "Top level forms" "Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file." $nl -"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word." +"Top-level forms cannot access the parse-time manifest (" { $link "word-search-parsing" } "), nor do they run inside " { $link with-compilation-unit } "; as a result, meta-programming might require extra work in a top-level form compared with a parsing word." $nl "Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ; @@ -119,8 +120,6 @@ HELP: parser-notes? HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; -{ use in add-use (add-use) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words - HELP: create-in { $values { "str" "a word name" } { "word" "a new word" } } { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } @@ -247,4 +246,4 @@ HELP: staging-violation HELP: auto-use? { $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." } -{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ; +{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 4474ed45c4..16f08d474a 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -87,18 +87,6 @@ IN: parser.tests [ "OCT: 999" eval( -- obj ) ] must-fail [ "BIN: --0" eval( -- obj ) ] must-fail - ! Another funny bug - [ t ] [ - [ - "scratchpad" in set - { "scratchpad" "arrays" } set-use - [ - ! This shouldn't modify in/use in the outer scope! - ] with-file-vocabs - - use get { "scratchpad" "arrays" } set-use use get = - ] with-scope - ] unit-test DEFER: foo "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- ) @@ -596,7 +584,7 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ [ ] ] [ - "IN: parser.tests.forward-ref-3 USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; : z ( -- ) x y ;" + "IN: parser.tests.forward-ref-3 FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; : z ( -- ) x y ;" "forward-ref-3" parse-stream ] unit-test @@ -605,7 +593,7 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ [ ] ] [ - "USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; IN: parser.tests.forward-ref-3 : x ( -- ) ; : z ( -- ) x y ;" + "FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; IN: parser.tests.forward-ref-3 : x ( -- ) ; : z ( -- ) x y ;" "forward-ref-3" parse-stream ] unit-test @@ -614,7 +602,7 @@ EXCLUDE: qualified.tests.bar => x ; ] unit-test [ [ ] ] [ - "IN: parser.tests.forward-ref-3 USING: parser.tests.forward-ref-1 parser.tests.forward-ref-2 ; : z ( -- ) x y ;" + "IN: parser.tests.forward-ref-3 FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; : z ( -- ) x y ;" "forward-ref-3" parse-stream ] unit-test diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index fff355fb95..cd5a325b52 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,8 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math generic.standard generic.single arrays io.pathnames vocabs.loader io -sequences assocs words.symbol words.alias words.constant combinators ; +sequences assocs words.symbol words.alias words.constant combinators +vocabs.parser ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -179,7 +180,7 @@ $nl ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." { $subsection "parser-algorithm" } -{ $subsection "vocabulary-search" } +{ $subsection "word-search" } { $subsection "top-level-forms" } { $subsection "syntax-comments" } { $subsection "syntax-literals" } @@ -427,18 +428,33 @@ HELP: FORGET: HELP: USE: { $syntax "USE: vocabulary" } { $values { "vocabulary" "a vocabulary name" } } -{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." } +{ $description "Adds a new vocabulary to the search path, loading it first if necessary." } +{ $notes "If adding the vocabulary introduces ambiguity, referencing the ambiguous names will throw a " { $link ambiguous-use-error } "." } +{ $errors "Throws an error if the vocabulary does not exist or could not be loaded." } ; + +HELP: UNUSE: +{ $syntax "UNUSE: vocabulary" } +{ $values { "vocabulary" "a vocabulary name" } } +{ $description "Removes a vocabulary from the search path." } { $errors "Throws an error if the vocabulary does not exist." } ; HELP: USING: { $syntax "USING: vocabularies... ;" } { $values { "vocabularies" "a list of vocabulary names" } } -{ $description "Adds a list of vocabularies to the front of the search path, with later vocabularies taking precedence." } +{ $description "Adds a list of vocabularies to the search path." } +{ $notes "If adding the vocabularies introduces ambiguity, referencing the ambiguous names will throw a " { $link ambiguous-use-error } "." } { $errors "Throws an error if one of the vocabularies does not exist." } ; HELP: QUALIFIED: { $syntax "QUALIFIED: vocab" } -{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." } +{ $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." } +{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "finishing" } ". Then, the following will call the latter word:" + { $code + "USE: fish" + "QUALIFIED: go" + "go:fishing" + } +} { $examples { $example "USING: prettyprint ;" "QUALIFIED: math" @@ -447,7 +463,7 @@ HELP: QUALIFIED: HELP: QUALIFIED-WITH: { $syntax "QUALIFIED-WITH: vocab word-prefix" } -{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." } +{ $description "Like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." } { $examples { $code "USING: prettyprint ;" "QUALIFIED-WITH: math m" @@ -457,19 +473,25 @@ HELP: QUALIFIED-WITH: HELP: FROM: { $syntax "FROM: vocab => words ... ;" } -{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." } -{ $examples { $code - "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ; +{ $description "Adds " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." } +{ $notes "If adding the words introduces ambiguity, the words will take precedence when resolving any ambiguous names." } +{ $examples + "Both the " { $vocab-link "vocabs.parser" } " and " { $vocab-link "binary-search" } " vocabularies define a word named " { $snippet "search" } ". The following will throw an " { $link ambiguous-use-error } ":" + { $code "USING: vocabs.parser binary-search ;" "... search ..." } + "Because " { $link POSTPONE: FROM: } " takes precedence over a " { $link POSTPONE: USING: } ", the ambiguity can be resolved explicitly. Suppose you wanted the " { $vocab-link "binary-search" } " vocabulary's " { $snippet "search" } " word:" + { $code "USING: vocabs.parser binary-search ;" "FROM: binary-search => search ;" "... search ..." } + } ; HELP: EXCLUDE: { $syntax "EXCLUDE: vocab => words ... ;" } -{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." } +{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." } { $examples { $code - "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ; + "EXCLUDE: math.parser => bin> hex> ;" "! imports everything but bin> and hex>" } } ; HELP: RENAME: -{ $syntax "RENAME: word vocab => newname" } -{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." } +{ $syntax "RENAME: word vocab => new-name" } +{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "new-name" } "." } +{ $notes "If adding the words introduces ambiguity, the words will take precedence when resolving any ambiguous names." } { $examples { $example "USING: prettyprint ;" "RENAME: + math => -" @@ -740,7 +762,7 @@ HELP: MAIN: HELP: " } -{ $description "Marks the start of a block of private word definitions. Private word definitions are placed in a vocabulary named by suffixing the current vocabulary with " { $snippet ".private" } "." } +{ $description "Begins a block of private word definitions. Private word definitions are placed in the current vocabulary name, suffixed with " { $snippet ".private" } "." } { $notes "The following is an example of usage:" { $code @@ -770,7 +792,7 @@ HELP: { $syntax "" } -{ $description "Marks the end of a block of private word definitions." } ; +{ $description "Ends a block of private word definitions." } ; { POSTPONE: } related-words diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index b29c20850b..56ac9fa36e 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -49,6 +49,8 @@ IN: bootstrap.syntax "USE:" [ scan use-vocab ] define-core-syntax + "UNUSE:" [ scan unuse-vocab ] define-core-syntax + "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor index d61c998725..e54993b6eb 100644 --- a/core/vocabs/parser/parser-docs.factor +++ b/core/vocabs/parser/parser-docs.factor @@ -1,43 +1,7 @@ -USING: help.markup help.syntax parser strings words ; +USING: help.markup help.syntax parser strings words assocs vocabs ; IN: vocabs.parser -ARTICLE: "vocabulary-search-shadow" "Shadowing word names" -"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "." -$nl -"Here is an example where shadowing occurs:" -{ $code - "IN: foe" - "USING: sequences io ;" - "" - ": append" - " \"foe::append calls sequences:append\" print append ;" - "" - "IN: fee" - "" - ": append" - " \"fee::append calls fee:append\" print append ;" - "" - "IN: fox" - "USE: foe" - "" - ": append" - " \"fox::append calls foe:append\" print append ;" - "" - "\"1234\" \"5678\" append print" - "" - "USE: fox" - "\"1234\" \"5678\" append print" -} -"When placed in a source file and run, the above code produces the following output:" -{ $code - "foe:append calls sequences:append" - "12345678" - "fee:append calls foe:append" - "foe:append calls sequences:append" - "12345678" -} ; - -ARTICLE: "vocabulary-search-errors" "Word lookup errors" +ARTICLE: "word-search-errors" "Word lookup errors" "If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies." $nl "If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used." @@ -47,71 +11,154 @@ $nl "If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file." { $subsection auto-use? } ; -ARTICLE: "vocabulary-search" "Vocabulary search path" -"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order." -$nl -"For a source file the vocabulary search path starts off with one vocabulary:" -{ $code "syntax" } -"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words." -$nl -"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error." -$nl -"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "." -$nl -"Three parsing words deal with the vocabulary search path:" -{ $subsection POSTPONE: IN: } +ARTICLE: "word-search-syntax" "Syntax to control word lookup" +"Parsing words which make all words in a vocabulary available:" { $subsection POSTPONE: USE: } { $subsection POSTPONE: USING: } -"There are some additional parsing words give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } ":" { $subsection POSTPONE: QUALIFIED: } { $subsection POSTPONE: QUALIFIED-WITH: } +"Parsing words which make a subset of all words in a vocabulary available:" { $subsection POSTPONE: FROM: } { $subsection POSTPONE: EXCLUDE: } { $subsection POSTPONE: RENAME: } -"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file." +"Removing vocabularies from the search path:" +{ $subsection POSTPONE: UNUSE: } +"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. In source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error." +{ $subsection POSTPONE: IN: } ; + +ARTICLE: "word-search-semantics" "Resolution of ambiguous word names" +"There is a distinction between parsing words which perform “open” imports versus “closed” imports. An open import introduces all words from a vocabulary as identifiers, except possibly a finite set of exclusions. The " { $link POSTPONE: USE: } ", " { $link POSTPONE: USING: } " and " { $link POSTPONE: EXCLUDE: } " words perform open imports. A closed import only adds a fixed set of identifiers. The " { $link POSTPONE: FROM: } ", " { $link POSTPONE: RENAME: } ", " { $link POSTPONE: QUALIFIED: } " and " { $link POSTPONE: QUALIFIED-WITH: } " words perform closed imports. Note that the latter two are considered as closed imports, due to the fact that all identifiers they introduce are unambiguously qualified with a prefix. The " { $link POSTPONE: IN: } " parsing word also performs a closed import of the newly-created vocabulary." $nl -"Private words can be defined; note that this is just a convention and they can be called from other vocabularies anyway:" +"When the parser encounters a reference to a word, it first searches the closed imports, in order. Closed imports are searched from the most recent to least recent. If the word could not be found this way, it searches open imports. Unlike closed imports, with open imports, the order does not matter -- instead, if more than one vocabulary defines a word with this name, an error is thrown." +{ $subsection ambiguous-use-error } +"To resolve the error, add a closed import, using " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } ". The closed import will then take precedence over the open imports, and the ambiguity will be resolved." +$nl +"The rationale for this behavior is as follows. Open imports are named such because they are open to future extension; if a future version of a vocabulary that you use adds new words, those new words will now be in scope in your source file, too. To avoid problems, any references to the new word have to be resolved since the parser cannot safely determine which vocabulary was meant. This problem can be avoided entirely by using only closed imports, but this leads to additional verbosity." +$nl +"In practice, a small set of guidelines helps avoid name clashes:" +{ $list + "Keep vocabularies small" + { "Hide internal words using " { $link POSTPONE: } -{ $subsection "vocabulary-search-errors" } -{ $subsection "vocabulary-search-shadow" } +{ $subsection POSTPONE: PRIVATE> } ; + +ARTICLE: "word-search" "Parse-time word lookup" +"When the parser reads a word name, it resolves the word at parse-time, looking up the " { $link word } " instance in the right vocabulary and adding it to the parse tree." +$nl +"Initially, only words from the " { $vocab-link "syntax" } " vocabulary are available in source files. Since most files will use words in other vocabularies, they will need to make those words available using a set of parsing words." +{ $subsection "word-search-syntax" } +{ $subsection "word-search-private" } +{ $subsection "word-search-semantics" } +{ $subsection "word-search-errors" } { $see-also "words" } ; -ABOUT: "vocabulary-search" +ARTICLE: "word-search-parsing" "Word lookup in parsing words" +"The parsing words described in " { $link "word-search-syntax" } " are implemented using the below words, which you can also call from your own parsing words." +$nl +"The current state used for word search is stored in a " { $emphasis "manifest" } ":" +{ $subsection manifest } +"Words for working with the current manifest:" +{ $subsection use-vocab } +{ $subsection unuse-vocab } +{ $subsection only-use-vocabs } +{ $subsection add-qualified } +{ $subsection add-words-from } +{ $subsection add-words-excluding } +"Words used to implement " { $link POSTPONE: IN: } ":" +{ $subsection current-vocab } +{ $subsection set-current-vocab } +"Words used to implement " { $link "word-search-private" } ":" +{ $subsection begin-private } +{ $subsection end-private } ; -HELP: use -{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; +ABOUT: "word-search" -HELP: in -{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ; +HELP: manifest +{ $var-description "The current manifest. Only set at parse time." } +{ $class-description "Encapsulates the current vocabulary, as well as the vocabulary search path." } ; -HELP: current-vocab -{ $values { "str" "a vocabulary" } } -{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ; +HELP: +{ $values { "manifest" manifest } } +{ $description "Creates a new manifest." } ; -HELP: (add-use) -{ $values { "vocab" "an assoc mapping strings to words" } } -{ $description "Adds an assoc at the front of the search path." } -$parsing-note ; - -HELP: add-use -{ $values { "vocab" string } } -{ $description "Adds a new vocabulary at the front of the search path after loading it if necessary. Subsequent word lookups by the parser will search this vocabulary first." } -$parsing-note -{ $errors "Throws an error if the vocabulary does not exist." } ; - -HELP: set-use -{ $values { "seq" "a sequence of strings" } } -{ $description "Sets the vocabulary search path. Later vocabularies take precedence." } -{ $errors "Throws an error if one of the vocabularies does not exist." } -$parsing-note ; - -HELP: set-in +HELP: set-current-vocab { $values { "name" string } } { $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." } -$parsing-note ; +{ $notes "This word is used to implement " { $link POSTPONE: IN: } "." } ; + +HELP: no-current-vocab +{ $error-description "Thrown when a new word is defined in a source file that does not have an " { $link POSTPONE: IN: } " form." } ; + +HELP: current-vocab +{ $values { "vocab" vocab } } +{ $description "Returns the current vocabulary, where new words will be defined." } +{ $errors "Throws an error if the current vocabulary has not been set." } ; + +HELP: begin-private +{ $description "Begins a block of private word definitions. Private word definitions are placed in the current vocabulary name, suffixed with " { $snippet ".private" } "." } +{ $notes "This word is used to implement " { $link POSTPONE: } "." } ; + +HELP: use-vocab +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Adds a vocabulary to the current manifest." } +{ $notes "This word is used to implement " { $link POSTPONE: USE: } "." } ; + +HELP: unuse-vocab +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Removes a vocabulary from the current manifest." } +{ $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ; + +HELP: only-use-vocabs +{ $values { "vocabs" "a sequence of vocabulary specifiers" } } +{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ; + +HELP: add-qualified +{ $values { "vocab" "a vocabulary specifier" } { "prefix" string } } +{ $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." } +{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. See the example in " { $link POSTPONE: QUALIFIED: } " for further explanation." } ; + +HELP: add-words-from +{ $values { "vocab" "a vocabulary specifier" } { "words" "a sequence of word names" } } +{ $description "Adds " { $snippet "words" } " from " { $snippet "vocab" } " to the current manifest." } +{ $notes "This word is used to implement " { $link POSTPONE: FROM: } "." } ; + +HELP: add-words-excluding +{ $values { "vocab" "a vocabulary specifier" } { "words" "a sequence of word names" } } +{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the manifest." } +{ $notes "This word is used to implement " { $link POSTPONE: EXCLUDE: } "." } ; + +HELP: add-renamed-word +{ $values { "word" string } { "vocab" "a vocabulary specifier" } { "new-name" string } } +{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "new-name" } "." } +{ $notes "This word is used to implement " { $link POSTPONE: RENAME: } "." } ; + +HELP: use-words +{ $values { "assoc" assoc } } +{ $description "Adds an assoc mapping word names to words to the current manifest." } +{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ; + +HELP: unuse-words +{ $values { "assoc" assoc } } +{ $description "Removes an assoc mapping word names to words from the current manifest." } +{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ; + +HELP: ambiguous-use-error +{ $error-description "Thrown when a word name referenced in source file is available in more than one vocabulary in the manifest. Such cases must be explicitly disambiguated using " { $link POSTPONE: FROM: } ", " { $link POSTPONE: EXCLUDE: } ", " { $link POSTPONE: QUALIFIED: } ", or " { $link POSTPONE: QUALIFIED-WITH: } "." } ; + +HELP: search-manifest +{ $values { "name" string } { "manifest" manifest } { "word/f" { $maybe word } } } +{ $description "Searches for a word by name in the given manifest. If no such word could be found, outputs " { $link f } "." } ; HELP: search -{ $values { "str" string } { "word/f" { $maybe word } } } -{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." } +{ $values { "name" string } { "word/f" { $maybe word } } } +{ $description "Searches for a word by name in the current manifest. If no such word could be found, outputs " { $link f } "." } $parsing-note ; diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 426894794e..f6c14cead9 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -32,8 +32,7 @@ M: manifest clone manifest get [ search-vocabs>> delete-all ] [ qualified-vocabs>> delete-all ] - [ extra-words>> delete-all ] - tri ; + bi ; : (use-vocab) ( vocab -- vocab seq ) load-vocab manifest get search-vocabs>> ; @@ -44,22 +43,25 @@ M: manifest clone : (from) ( vocab words -- vocab words words' assoc ) 2dup swap load-vocab words>> ; -: (use-words) ( assoc -- assoc seq ) - manifest get extra-words>> ; - : extract-words ( seq assoc -- assoc' ) extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ; : (lookup) ( name assoc -- word/f ) at dup forward-reference? [ drop f ] when ; +TUPLE: extra-words words ; + +C: extra-words + +: (use-words) ( assoc -- extra-words seq ) + manifest get qualified-vocabs>> ; + PRIVATE> : set-current-vocab ( name -- ) - create-vocab manifest get - [ (>>current-vocab) ] - [ [ words>> ] dip extra-words>> push ] - 2bi ; + create-vocab + [ manifest get (>>current-vocab) ] + [ words>> (add-qualified) ] bi ; TUPLE: no-current-vocab ; @@ -124,9 +126,9 @@ TUPLE: rename word vocab words ; : add-renamed-word ( word vocab new-name -- ) (add-qualified) ; -: use-words ( words -- ) (use-words) push ; +: use-words ( assoc -- ) (use-words) push ; -: unuse-words ( words -- ) (use-words) delq ; +: unuse-words ( assoc -- ) (use-words) delq ; ERROR: ambiguous-use-error words ; @@ -148,17 +150,10 @@ ERROR: ambiguous-use-error words ; qualified-vocabs>> (vocab-search) 0 = [ drop f ] [ peek ] if ; -: word-search ( name manifest -- word/f ) - extra-words>> [ (lookup) ] with map-find-last drop ; - PRIVATE> : search-manifest ( name manifest -- word/f ) - 2dup word-search dup [ 2nip ] [ - drop 2dup qualified-search dup [ 2nip ] [ - drop vocab-search - ] if - ] if ; + 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ; : search ( name -- word/f ) manifest get search-manifest ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index a04b95bcfd..574f8afe81 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "interned-words" "Looking up and creating words" $nl "Words whose names are known at parse time -- that is, most words making up your program -- can be referenced in source code by stating their name. However, the parser itself, and sometimes code you write, will need to create look up words dynamically." $nl -"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")." +"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "word-search" } ")." { $subsection create } { $subsection create-in } { $subsection lookup } ; diff --git a/extra/bank/bank-tests.factor b/extra/bank/bank-tests.factor index 5014d53019..0d11b11acf 100644 --- a/extra/bank/bank-tests.factor +++ b/extra/bank/bank-tests.factor @@ -1,5 +1,6 @@ USING: accessors arrays bank calendar kernel math math.functions namespaces make tools.test tools.walker ; +FROM: bank => balance>> ; IN: bank.tests SYMBOL: my-account diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 3dfa129a7f..3e3279ece7 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -36,10 +36,8 @@ MEMO: (vocab-words) ( name -- seq ) : current-words ( -- seq ) manifest get - [ search-vocabs>> [ words>> ] map ] - [ qualified-vocabs>> [ words>> ] map ] - [ extra-words>> ] - tri 3append assoc-combine keys ; inline + [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@ + assoc-union keys ; inline : vocabs-words ( names -- seq ) prune [ (vocab-words) ] map concat ; inline diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor index 4a2ec963ee..74831af7fb 100644 --- a/extra/infix/infix-docs.factor +++ b/extra/infix/infix-docs.factor @@ -54,7 +54,7 @@ $nl } "The standard precedence rules apply: Grouping with parentheses before " { $snippet "*" } ", " { $snippet "/" } "and " { $snippet "%" } " before " { $snippet "+" } " and " { $snippet "-" } "." { $example - "USING: infix prettyprint ;" + "USE: infix" "[infix 5-40/10*2 infix] ." "-3" } @@ -65,7 +65,7 @@ $nl "The word name must consist of the letters a-z, A-Z, _ or 0-9, and the first character can't be a number." } { $example - "USING: infix locals math math.functions prettyprint ;" + "USING: infix locals math.functions ;" ":: binary_entropy ( p -- h )" " [infix -(p*log(p) + (1-p)*log(1-p)) / log(2) infix] ;" "[infix binary_entropy( sqrt(0.25) ) infix] ." @@ -74,13 +74,13 @@ $nl $nl "You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation." { $example - "USING: arrays infix prettyprint ;" + "USING: arrays infix ;" "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ." "9" } "Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:" { $example - "USING: arrays infix locals prettyprint ;" + "USING: arrays infix locals ;" ":: add-2nd-element ( x y -- res )" " [infix x[1] + y[1] infix] ;" "{ 1 2 3 } 5 add-2nd-element ." diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor index 9e5b5c67aa..2f13237c9d 100644 --- a/extra/math/floating-point/floating-point-tests.factor +++ b/extra/math/floating-point/floating-point-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test math.floating-point math.constants kernel -math.constants fry sequences kernel math ; +USING: tools.test math.floating-point kernel +math.constants fry sequences math ; IN: math.floating-point.tests [ t ] [ pi >double< >double pi = ] unit-test diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index ee63b14f3c..0f1eb8edda 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -1,4 +1,5 @@ USING: tools.test math kernel sequences lists promises monads ; +FROM: monads => do ; IN: monads.tests [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor index fcbc20db16..95c2fe1138 100644 --- a/extra/roles/roles-tests.factor +++ b/extra/roles/roles-tests.factor @@ -1,6 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors classes.tuple compiler.units kernel qw roles sequences tools.test ; +FROM: roles => TUPLE: ; IN: roles.tests ROLE: fork tines ; diff --git a/extra/tetris/game/game-tests.factor b/extra/tetris/game/game-tests.factor index 047c20d053..e505691c3a 100644 --- a/extra/tetris/game/game-tests.factor +++ b/extra/tetris/game/game-tests.factor @@ -1,5 +1,6 @@ USING: accessors kernel tetris.game tetris.board tetris.piece tools.test sequences ; +FROM: tetris.game => level>> ; [ t ] [ [ current-piece ] [ next-piece ] bi and t f ? ] unit-test [ t ] [ { 1 1 } can-move? ] unit-test From aabdad5efad5f9f73e2181ad85f07a503858cf51 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 02:32:55 -0500 Subject: [PATCH 054/228] Auto-use now prints out USING: forms again --- .../prettyprint/sections/sections-docs.factor | 7 +- basis/prettyprint/sections/sections.factor | 16 ++++ basis/vocabs/prettyprint/authors.txt | 1 + .../prettyprint/prettyprint-tests.factor | 47 ++++++++++ basis/vocabs/prettyprint/prettyprint.factor | 86 +++++++++++++++++++ core/vocabs/parser/parser.factor | 8 +- 6 files changed, 159 insertions(+), 6 deletions(-) create mode 100644 basis/vocabs/prettyprint/authors.txt create mode 100644 basis/vocabs/prettyprint/prettyprint-tests.factor create mode 100644 basis/vocabs/prettyprint/prettyprint.factor diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index ce7430d040..f0d369297c 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -1,6 +1,6 @@ USING: prettyprint io kernel help.markup help.syntax prettyprint.config words hashtables math -strings definitions ; +strings definitions quotations ; IN: prettyprint.sections HELP: position @@ -13,7 +13,6 @@ HELP: line-limit? { $values { "?" "a boolean" } } { $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ; - HELP: do-indent { $description "Outputs the current indent nesting to " { $link output-stream } "." } ; @@ -211,3 +210,7 @@ $prettyprinting-note ; HELP: do-pprint { $values { "block" block } } { $description "Recursively output all children of the given block. The continuation is restored and output terminates if the line length is exceeded; this test is performed in " { $link fresh-line } "." } ; + +HELP: with-pprint +{ $values { "obj" object } { "quot" quotation } } +{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index faa254be69..f72c426533 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -326,3 +326,19 @@ M: block long-section ( block -- ) ] each ] each ] if-nonempty ; + +: make-pprint ( obj quot -- block in use ) + [ + 0 position set + H{ } clone pprinter-use set + V{ } clone recursion-check set + V{ } clone pprinter-stack set + over > "> ; + +[ +<" USING: kernel namespaces syntax vocabs.parser +vocabs.prettyprint ;"> +] +[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test + +: manifest-test-2 ( -- string ) + <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; + IN: vocabs.prettyprint.tests + + << manifest get pprint-manifest >> "> ; + +[ +<" USING: kernel namespaces syntax vocabs.parser +vocabs.prettyprint ; +IN: vocabs.prettyprint.tests"> +] +[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test + +: manifest-test-3 ( -- string ) + <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; + FROM: math => + - ; + QUALIFIED: system + QUALIFIED-WITH: assocs a + EXCLUDE: parser => run-file ; + IN: vocabs.prettyprint.tests + + << manifest get pprint-manifest >> "> ; + +[ +<" USING: kernel namespaces syntax vocabs.parser +vocabs.prettyprint ; +FROM: math => + - ; +QUALIFIED: system +QUALIFIED-WITH: assocs a +EXCLUDE: parser => run-file ; +IN: vocabs.prettyprint.tests"> +] +[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test \ No newline at end of file diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..d491acd33b --- /dev/null +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -0,0 +1,86 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs +namespaces sets parser colors prettyprint.backend prettyprint.sections +vocabs.parser make fry math.order ; +IN: vocabs.prettyprint + +: pprint-vocab ( vocab -- ) + [ vocab-name ] [ vocab ] bi present-text ; + +: pprint-in ( vocab -- ) + [ \ IN: pprint-word pprint-vocab ] with-pprint ; + +> vocab-name ] [ prefix>> ] bi = [ + \ QUALIFIED: pprint-word + vocab>> pprint-vocab + ] [ + \ QUALIFIED-WITH: pprint-word + [ vocab>> pprint-vocab ] [ prefix>> text ] bi + ] if + ] with-pprint ; + +M: from pprint-qualified ( from -- ) + [ + \ FROM: pprint-word + [ vocab>> pprint-vocab "=>" text ] + [ names>> [ text ] each ] bi + \ ; pprint-word + ] with-pprint ; + +M: exclude pprint-qualified ( exclude -- ) + [ + \ EXCLUDE: pprint-word + [ vocab>> pprint-vocab "=>" text ] + [ names>> [ text ] each ] bi + \ ; pprint-word + ] with-pprint ; + +M: rename pprint-qualified ( rename -- ) + [ + \ RENAME: pprint-word + [ word>> text ] + [ vocab>> text "=>" text ] + [ words>> >alist first first text ] + tri + ] with-pprint ; + +PRIVATE> + +: pprint-manifest ( manifest -- ) + [ + [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ] + [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ] + [ current-vocab>> [ '[ _ pprint-in ] , ] when* ] + tri + ] { } make + [ nl ] [ call( -- ) ] interleave ; + +[ + nl + { { font-style bold } { font-name "sans-serif" } } [ + "Restarts were invoked adding vocabularies to the search path." print + "To avoid doing this in the future, add the following USING:" print + "and IN: forms at the top of the source file:" print nl + ] with-style + { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } + [ manifest get pprint-manifest ] with-nesting + nl nl +] print-use-hook set-global \ No newline at end of file diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index f6c14cead9..c76890e845 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -26,6 +26,10 @@ M: manifest clone [ clone ] change-qualified-vocabs [ clone ] change-extra-words ; +TUPLE: extra-words words ; + +C: extra-words + extra-words - : (use-words) ( assoc -- extra-words seq ) manifest get qualified-vocabs>> ; From 83219eb21c0108b656f24d679935e54cff8d48b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 04:26:45 -0500 Subject: [PATCH 055/228] More work on auto-use --- basis/help/markup/markup.factor | 3 +-- .../prettyprint/prettyprint-tests.factor | 9 +++----- basis/vocabs/prettyprint/prettyprint.factor | 4 ++-- core/parser/parser.factor | 11 +++------- core/vocabs/parser/parser.factor | 21 ++++++++++++++----- extra/fuel/fuel.factor | 4 ++-- 6 files changed, 27 insertions(+), 25 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 04b6d90883..6f82a6f50b 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -5,6 +5,7 @@ hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots fry sets vocabs help.stylesheet help.topics vocabs.loader quotations combinators see present ; +FROM: prettyprint.sections => with-pprint ; IN: help.markup PREDICATE: simple-element < array @@ -348,8 +349,6 @@ M: f ($instance) drop "Throws an error if the I/O operation fails." $errors ; -FROM: prettyprint.private => with-pprint ; - : $prettyprinting-note ( children -- ) drop { "This word should only be called from inside the " diff --git a/basis/vocabs/prettyprint/prettyprint-tests.factor b/basis/vocabs/prettyprint/prettyprint-tests.factor index 151e5d1782..9ad0aae59d 100644 --- a/basis/vocabs/prettyprint/prettyprint-tests.factor +++ b/basis/vocabs/prettyprint/prettyprint-tests.factor @@ -7,8 +7,7 @@ USING: vocabs.prettyprint tools.test io.streams.string multiline eval ; << manifest get pprint-manifest >> "> ; [ -<" USING: kernel namespaces syntax vocabs.parser -vocabs.prettyprint ;"> +<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;"> ] [ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test @@ -19,8 +18,7 @@ vocabs.prettyprint ;"> << manifest get pprint-manifest >> "> ; [ -<" USING: kernel namespaces syntax vocabs.parser -vocabs.prettyprint ; +<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; IN: vocabs.prettyprint.tests"> ] [ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test @@ -36,8 +34,7 @@ IN: vocabs.prettyprint.tests"> << manifest get pprint-manifest >> "> ; [ -<" USING: kernel namespaces syntax vocabs.parser -vocabs.prettyprint ; +<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ; FROM: math => + - ; QUALIFIED: system QUALIFIED-WITH: assocs a diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index d491acd33b..2ada653af1 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -77,8 +77,8 @@ PRIVATE> nl { { font-style bold } { font-name "sans-serif" } } [ "Restarts were invoked adding vocabularies to the search path." print - "To avoid doing this in the future, add the following USING:" print - "and IN: forms at the top of the source file:" print nl + "To avoid doing this in the future, add the following forms" print + "at the top of the source file:" print nl ] with-style { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ manifest get pprint-manifest ] with-nesting diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 31b5286c18..eb8d77959e 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -38,17 +38,13 @@ M: parsing-word stack-effect drop (( parsed -- parsed )) ; : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -SYMBOL: amended-use - SYMBOL: auto-use? : no-word-restarted ( restart-value -- word ) dup word? [ dup vocabulary>> - [ use-vocab ] - [ amended-use get dup [ push ] [ 2drop ] if ] - [ "Added \"" "\" vocabulary to search path" surround note. ] - tri + [ auto-use-vocab ] + [ "Added \"" "\" vocabulary to search path" surround note. ] bi ] [ create-in ] if ; : no-word ( name -- newword ) @@ -198,9 +194,8 @@ print-use-hook [ [ ] ] initialize : parse-fresh ( lines -- quot ) [ - V{ } clone amended-use set parse-lines - amended-use get empty? [ print-use-hook get call( -- ) ] unless + auto-used? [ print-use-hook get call( -- ) ] when ] with-file-vocabs ; : parsing-file ( file -- ) diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index c76890e845..43451b4c86 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences sets strings vocabs sorting accessors arrays compiler.units -combinators vectors splitting continuations ; +combinators vectors splitting continuations math ; IN: vocabs.parser ERROR: no-word-error name ; @@ -12,22 +12,28 @@ TUPLE: manifest current-vocab { search-vocabs vector } { qualified-vocabs vector } -{ extra-words vector } ; +{ extra-words vector } +{ auto-used vector } ; : ( -- manifest ) manifest new V{ } clone >>search-vocabs V{ } clone >>qualified-vocabs - V{ } clone >>extra-words ; + V{ } clone >>extra-words + V{ } clone >>auto-used ; M: manifest clone call-next-method [ clone ] change-search-vocabs [ clone ] change-qualified-vocabs - [ clone ] change-extra-words ; + [ clone ] change-extra-words + [ clone ] change-auto-used ; TUPLE: extra-words words ; +M: extra-words equal? + over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ; + C: extra-words > push ] bi ; + +: auto-used? ( -- ? ) manifest get auto-used>> length 0 > ; + : unuse-vocab ( vocab -- ) (use-vocab) delq ; : only-use-vocabs ( vocabs -- ) @@ -128,7 +139,7 @@ TUPLE: rename word vocab words ; : use-words ( assoc -- ) (use-words) push ; -: unuse-words ( assoc -- ) (use-words) delq ; +: unuse-words ( assoc -- ) (use-words) delete ; ERROR: ambiguous-use-error words ; diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index a9ed17877e..5d4149867b 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -3,7 +3,7 @@ USING: accessors assocs compiler.units continuations fuel.eval fuel.help fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser -sequences tools.scaffold vocabs.loader words ; +sequences tools.scaffold vocabs.loader vocabs.parser words ; IN: fuel @@ -46,7 +46,7 @@ SYMBOL: :uses-suggestions dup length 1 = [ first restart ] [ drop ] if ; : fuel-set-use-hook ( -- ) - [ amended-use get clone :uses prefix fuel-eval-set-result ] + [ manifest get auto-used>> clone :uses prefix fuel-eval-set-result ] print-use-hook set ; : (fuel-get-uses) ( lines -- ) From 223a47c8d95b79deeab39a228745a1fea9867c4d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 08:46:41 -0500 Subject: [PATCH 056/228] throw exceptions on png types we dont support --- basis/compression/inflate/inflate.factor | 4 ++- basis/images/png/png.factor | 32 ++++++++++++++++++++++-- 2 files changed, 33 insertions(+), 3 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 3e67b11cc7..3fe07b5994 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -200,7 +200,9 @@ PRIVATE> : reverse-png-filter ( lines -- filtered ) dup first [ 0 ] replicate prefix [ { 0 0 } prepend ] map - 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; + 2 clump [ + first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line + ] map concat ; : zlib-inflate ( bytes -- bytes ) bs: diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index bf13c43546..c5b84de221 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -65,14 +65,42 @@ ERROR: bad-checksum ; : zlib-data ( png-image -- bytes ) chunks>> [ type>> "IDAT" = ] find nip data>> ; -: decode-png ( image -- image ) +ERROR: unknown-color-type n ; +ERROR: unimplemented-color-type image ; + +: inflate-data ( image -- bytes ) + zlib-data zlib-inflate ; + +: decode-greyscale ( image -- image ) + unimplemented-color-type ; + +: decode-truecolor ( image -- image ) { - [ zlib-data zlib-inflate ] + [ inflate-data ] [ dim>> first 3 * 1 + group reverse-png-filter ] [ swap >byte-array >>bitmap drop ] [ RGB >>component-order drop ] [ ] } cleave ; + +: decode-indexed-color ( image -- image ) + unimplemented-color-type ; + +: decode-greyscale-alpha ( image -- image ) + unimplemented-color-type ; + +: decode-truecolor-alpha ( image -- image ) + unimplemented-color-type ; + +: decode-png ( image -- image ) + dup color-type>> { + { 0 [ decode-greyscale ] } + { 2 [ decode-truecolor ] } + { 3 [ decode-indexed-color ] } + { 4 [ decode-greyscale-alpha ] } + { 6 [ decode-truecolor-alpha ] } + [ unknown-color-type ] + } case ; : load-png ( path -- image ) [ binary ] [ file-info size>> ] bi From 4ef0ed75b1ff49181f5648e9d7545477ee8dfcd1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 08:54:14 -0500 Subject: [PATCH 057/228] Clean up pprint-use and related code to use manifests --- basis/prettyprint/prettyprint-docs.factor | 9 --- basis/prettyprint/prettyprint.factor | 70 ++------------------- basis/prettyprint/sections/sections.factor | 28 ++++++--- basis/see/see-docs.factor | 4 +- basis/see/see.factor | 4 +- basis/vocabs/prettyprint/prettyprint.factor | 9 ++- 6 files changed, 36 insertions(+), 88 deletions(-) diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 1af921d4f3..fbbece4602 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -161,10 +161,6 @@ $nl ABOUT: "prettyprint" -HELP: with-pprint -{ $values { "obj" object } { "quot" quotation } } -{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ; - HELP: pprint { $values { "obj" object } } { $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } @@ -225,8 +221,3 @@ HELP: .r HELP: .s { $description "Displays the contents of the data stack, with the top of the stack printed first." } ; - -HELP: in. -{ $values { "vocab" "a vocabulary specifier" } } -{ $description "Prettyprints a " { $snippet "IN:" } " declaration." } -$prettyprinting-note ; \ No newline at end of file diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 2286417dd1..99913a803a 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -4,78 +4,16 @@ USING: arrays accessors assocs colors combinators grouping io io.streams.string io.styles kernel make math math.parser namespaces parser prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections quotations sequences sorting strings vocabs -vocabs.parser words sets ; +vocabs.prettyprint words sets ; IN: prettyprint -> eq? nip ] with assoc-find 2drop ] curry map sift ; - -: prelude. ( -- ) - in get use get vocab-names prune in get ".private" append swap remove use/in. ; - -[ - nl - { { font-style bold } { font-name "sans-serif" } } [ - "Restarts were invoked adding vocabularies to the search path." print - "To avoid doing this in the future, add the following USING:" print - "and IN: forms at the top of the source file:" print nl - ] with-style - { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting - nl nl -] print-use-hook set-global - -PRIVATE> - : with-use ( obj quot -- ) - make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi + make-pprint (pprint-manifest + [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi do-pprint ; inline : with-in ( obj quot -- ) - make-pprint drop [ write-in bl ] when* do-pprint ; inline + make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline : pprint ( obj -- ) [ pprint* ] with-pprint ; diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index f72c426533..b4eb40757d 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables io kernel math assocs namespaces make sequences strings io.styles vectors words prettyprint.config splitting classes continuations -accessors sets ; +accessors sets vocabs.parser combinators vocabs ; IN: prettyprint.sections ! State @@ -19,8 +19,16 @@ TUPLE: pprinter last-newline line-count indent ; : ( -- pprinter ) 0 1 0 pprinter boa ; +: (record-vocab) ( vocab -- ) + dup pprinter-in get dup [ vocab-name ] when = + [ drop ] [ pprinter-use get conjoin ] if ; + : record-vocab ( word -- ) - vocabulary>> [ pprinter-use get conjoin ] when* ; + vocabulary>> { + { f [ ] } + { "syntax" [ ] } + [ (record-vocab) ] + } case ; ! Utility words : line-limit? ( -- ? ) @@ -327,7 +335,14 @@ M: block long-section ( block -- ) ] each ] if-nonempty ; -: make-pprint ( obj quot -- block in use ) +: pprinter-manifest ( -- manifest ) + + [ [ pprinter-use get keys >vector ] dip (>>search-vocabs) ] + [ [ pprinter-in get ] dip (>>current-vocab) ] + [ ] + tri ; + +: make-pprint ( obj quot -- block manifest ) [ 0 position set H{ } clone pprinter-use set @@ -336,9 +351,8 @@ M: block long-section ( block -- ) over with-pprint ; IN: see -USING: help.markup help.syntax strings prettyprint.private -definitions generic words classes ; HELP: synopsis { $values { "defspec" "a definition specifier" } { "str" string } } diff --git a/basis/see/see.factor b/basis/see/see.factor index 37153b5229..d2515a2e81 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -7,7 +7,7 @@ generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections sequences sets sorting strings summary words -words.symbol words.constant words.alias ; +words.symbol words.constant words.alias vocabs ; IN: see GENERIC: synopsis* ( defspec -- ) @@ -44,7 +44,7 @@ M: word print-stack-effect? drop t ; > pprinter-in set ; + vocabulary>> vocab pprinter-in set ; : word-synopsis ( word -- ) { diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 2ada653af1..0e150ef07a 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -64,15 +64,20 @@ M: rename pprint-qualified ( rename -- ) PRIVATE> -: pprint-manifest ( manifest -- ) +: (pprint-manifest ( manifest -- quots ) [ [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ] [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ] [ current-vocab>> [ '[ _ pprint-in ] , ] when* ] tri - ] { } make + ] { } make ; + +: pprint-manifest) ( quots -- ) [ nl ] [ call( -- ) ] interleave ; +: pprint-manifest ( manifest -- ) + (pprint-manifest pprint-manifest) ; + [ nl { { font-style bold } { font-name "sans-serif" } } [ From 9faf277ee627e5fb0385141f645a144e2611c9a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 08:56:09 -0500 Subject: [PATCH 058/228] Change how byte-vectors prettyprint --- basis/prettyprint/backend/backend.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 3dcd7fb0ed..ee8d2dfea3 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -188,6 +188,7 @@ M: tuple >pprint-sequence [ 1array ] [ [ f 2array ] dip append ] if-empty ; M: object pprint-narrow? drop f ; +M: byte-vector pprint-narrow? drop f ; M: array pprint-narrow? drop t ; M: vector pprint-narrow? drop t ; M: hashtable pprint-narrow? drop t ; From 514956537f4a1abdc43239bbfb8dc22ab4588927 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 08:58:10 -0500 Subject: [PATCH 059/228] Fix cpu.ppc for strict vocabulary search path semantics --- basis/cpu/ppc/bootstrap.factor | 1 + basis/cpu/ppc/ppc.factor | 1 + 2 files changed, 2 insertions(+) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index b09938f4b9..cbb914121e 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -4,6 +4,7 @@ USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units compiler.constants math math.private layouts words vocabs slots.private locals.backend ; +FROM: cpu.ppc.assembler => B ; IN: bootstrap.ppc 4 \ cell set diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index dc7108b3a1..617a7c5141 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -7,6 +7,7 @@ cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame compiler.units ; +FROM: cpu.ppc.assembler => B ; IN: cpu.ppc ! PowerPC register assignments: From 836c5e07e7351c2f969def2ae1f528b40ea32311 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 09:34:42 -0500 Subject: [PATCH 060/228] Better presentation for ambiguous-use-error, fix ui.tools.listener now that 'search' can throw, make USE: and UNUSE: ignore dupes --- basis/debugger/debugger.factor | 11 ++++- basis/ui/tools/listener/listener.factor | 4 +- core/parser/parser-tests.factor | 14 +++++- core/vocabs/parser/parser.factor | 64 +++++++++++++++++-------- 4 files changed, 69 insertions(+), 24 deletions(-) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index bb0268f048..7994c3ed96 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -251,8 +251,15 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ; M: no-current-vocab summary drop "Not in a vocabulary; IN: form required" ; -M: no-word-error error. - "No word named ``" write name>> write "'' found in current vocabulary search path" print ; +M: no-word-error summary + name>> "No word named ``" "'' found in current vocabulary search path" surround ; + +M: no-word-error error. summary print ; + +M: ambiguous-use-error summary + words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ; + +M: ambiguous-use-error error. summary print ; M: staging-violation summary drop diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 2e89482c3d..e12e59d259 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -55,7 +55,9 @@ M: vocab-completion (word-at-caret) drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ; M: word-completion (word-at-caret) - manifest>> dup [ search-manifest ] [ 2drop f ] if ; + manifest>> dup [ + '[ _ _ search-manifest ] [ drop f ] recover + ] [ 2drop f ] if ; M: char-completion (word-at-caret) 2drop f ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 16f08d474a..5cbcc14184 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -608,4 +608,16 @@ EXCLUDE: qualified.tests.bar => x ; [ t ] [ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal? -] unit-test \ No newline at end of file +] unit-test + +[ [ dup ] ] [ + "USE: kernel dup" "unuse-test" parse-stream +] unit-test + +[ + "dup" "unuse-test" parse-stream +] [ error>> error>> error>> no-word-error? ] must-fail-with + +[ + "USE: kernel UNUSE: kernel dup" "unuse-test" parse-stream +] [ error>> error>> error>> no-word-error? ] must-fail-with \ No newline at end of file diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 43451b4c86..ba4fb265c3 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -8,8 +8,21 @@ IN: vocabs.parser ERROR: no-word-error name ; +: word-restarts ( possibilities -- restarts ) + natural-sort + [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ; + +: word-restarts-with-defer ( name possibilities -- restarts ) + word-restarts + swap "Defer word in current vocabulary" swap 2array + suffix ; + +: ( name possibilities -- error restarts ) + [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ; + TUPLE: manifest current-vocab +{ search-vocab-names hashtable } { search-vocabs vector } { qualified-vocabs vector } { extra-words vector } @@ -17,6 +30,7 @@ current-vocab : ( -- manifest ) manifest new + H{ } clone >>search-vocab-names V{ } clone >>search-vocabs V{ } clone >>qualified-vocabs V{ } clone >>extra-words @@ -24,6 +38,7 @@ current-vocab M: manifest clone call-next-method + [ clone ] change-search-vocab-names [ clone ] change-search-vocabs [ clone ] change-qualified-vocabs [ clone ] change-extra-words @@ -40,12 +55,10 @@ C: extra-words : clear-manifest ( -- ) manifest get + [ search-vocab-names>> clear-assoc ] [ search-vocabs>> delete-all ] [ qualified-vocabs>> delete-all ] - bi ; - -: (use-vocab) ( vocab -- vocab seq ) - load-vocab manifest get search-vocabs>> ; + tri ; : (add-qualified) ( qualified -- ) manifest get qualified-vocabs>> push ; @@ -87,19 +100,33 @@ TUPLE: no-current-vocab ; manifest get current-vocab>> vocab-name ".private" ?tail [ set-current-vocab ] [ drop ] if ; -: use-vocab ( vocab -- ) (use-vocab) push ; +: using-vocab? ( vocab -- ? ) + vocab-name manifest get search-vocab-names>> key? ; + +: use-vocab ( vocab -- ) + dup using-vocab? + [ drop ] [ + manifest get + [ [ vocab-name ] dip search-vocab-names>> conjoin ] + [ [ load-vocab ] dip search-vocabs>> push ] + 2bi + ] if ; : auto-use-vocab ( vocab -- ) [ use-vocab ] [ manifest get auto-used>> push ] bi ; : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ; -: unuse-vocab ( vocab -- ) (use-vocab) delq ; +: unuse-vocab ( vocab -- ) + dup using-vocab? [ + manifest get + [ [ vocab-name ] dip search-vocab-names>> delete-at ] + [ [ load-vocab ] dip search-vocabs>> delq ] + 2bi + ] [ drop ] if ; : only-use-vocabs ( vocabs -- ) - clear-manifest - [ vocab ] V{ } map-as sift - manifest get search-vocabs>> push-all ; + clear-manifest [ vocab ] filter [ use-vocab ] each ; TUPLE: qualified vocab prefix words ; @@ -141,7 +168,10 @@ TUPLE: rename word vocab words ; : unuse-words ( assoc -- ) (use-words) delete ; -ERROR: ambiguous-use-error words ; +TUPLE: ambiguous-use-error words ; + +: ( words -- error restarts ) + [ \ ambiguous-use-error boa ] [ word-restarts ] bi ; throw-restarts + dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from + ] } case ; : qualified-search ( name manifest -- word/f ) @@ -168,12 +201,3 @@ PRIVATE> : search ( name -- word/f ) manifest get search-manifest ; - -: word-restarts ( name possibilities -- restarts ) - natural-sort - [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc - swap "Defer word in current vocabulary" swap 2array - suffix ; - -: ( name possibilities -- error restarts ) - [ drop \ no-word-error boa ] [ word-restarts ] 2bi ; From 02d6c7ca1733f0d272865f6287d0585683a99653 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 09:40:17 -0500 Subject: [PATCH 061/228] Factor out parser note code into parser.notes vocabulary, and print a note if a using list contains duplicates --- core/classes/tuple/parser/parser.factor | 2 +- core/parser/notes/authors.txt | 1 + core/parser/notes/notes.factor | 18 ++++++++++++++++++ core/parser/parser.factor | 16 +--------------- core/vocabs/parser/parser.factor | 5 +++-- 5 files changed, 24 insertions(+), 18 deletions(-) create mode 100644 core/parser/notes/authors.txt create mode 100644 core/parser/notes/notes.factor diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 85a6249dd3..efb77e3274 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sets namespaces make sequences parser lexer combinators words classes.parser classes.tuple arrays -slots math assocs ; +slots math assocs parser.notes ; IN: classes.tuple.parser : slot-names ( slots -- seq ) diff --git a/core/parser/notes/authors.txt b/core/parser/notes/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/parser/notes/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/parser/notes/notes.factor b/core/parser/notes/notes.factor new file mode 100644 index 0000000000..3f702d375d --- /dev/null +++ b/core/parser/notes/notes.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel source-files lexer accessors io math.parser ; +IN: parser.notes + +SYMBOL: parser-notes + +t parser-notes set-global + +: parser-notes? ( -- ? ) + parser-notes get "quiet" get not and ; + +: note. ( str -- ) + parser-notes? [ + file get [ path>> write ":" write ] when* + lexer get [ line>> number>string write ": " write ] when* + "Note:" print dup print + ] when drop ; \ No newline at end of file diff --git a/core/parser/parser.factor b/core/parser/parser.factor index eb8d77959e..8d52dcaa2c 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,7 @@ sequences strings vectors words words.symbol quotations io combinators sorting splitting math.parser effects continuations io.files vocabs io.encodings.utf8 source-files classes hashtables compiler.units accessors sets lexer vocabs.parser -effects.parser slots ; +effects.parser slots parser.notes ; IN: parser : location ( -- loc ) @@ -15,20 +15,6 @@ IN: parser : save-location ( definition -- ) location remember-definition ; -SYMBOL: parser-notes - -t parser-notes set-global - -: parser-notes? ( -- ? ) - parser-notes get "quiet" get not and ; - -: note. ( str -- ) - parser-notes? [ - file get [ path>> write ":" write ] when* - lexer get [ line>> number>string write ": " write ] when* - "Note:" print dup print - ] when drop ; - M: parsing-word stack-effect drop (( parsed -- parsed )) ; : create-in ( str -- word ) diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index ba4fb265c3..45084ae8ff 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -3,7 +3,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel namespaces sequences sets strings vocabs sorting accessors arrays compiler.units -combinators vectors splitting continuations math ; +combinators vectors splitting continuations math +parser.notes ; IN: vocabs.parser ERROR: no-word-error name ; @@ -105,7 +106,7 @@ TUPLE: no-current-vocab ; : use-vocab ( vocab -- ) dup using-vocab? - [ drop ] [ + [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [ manifest get [ [ vocab-name ] dip search-vocab-names>> conjoin ] [ [ load-vocab ] dip search-vocabs>> push ] From 6f9a0aabdd3eeddfe15db64904eb1c8665612c40 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 09:43:01 -0500 Subject: [PATCH 062/228] help.lint: don't use mutable vocab tuple as key in lint-failures hash --- basis/help/lint/lint.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 7a5b482270..08cf4b2cd4 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -66,11 +66,12 @@ PRIVATE> ] check-something ; : check-about ( vocab -- ) - dup '[ _ vocab-help [ article drop ] when* ] check-something ; + vocab-link boa dup + '[ _ vocab-help [ article drop ] when* ] check-something ; : check-vocab ( vocab -- ) "Checking " write dup write "..." print - [ vocab check-about ] + [ check-about ] [ words [ check-word ] each ] [ vocab-articles get at [ check-article ] each ] tri ; From 49930178c3fde6f441edcc676057b9cbe836916b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 09:48:58 -0500 Subject: [PATCH 063/228] Fix more usings --- basis/eval/eval.factor | 2 +- basis/prettyprint/backend/backend.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor index 4c5b9e8cf9..c4eab2d6ab 100644 --- a/basis/eval/eval.factor +++ b/basis/eval/eval.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting parser compiler.units kernel namespaces +USING: splitting parser parser.notes compiler.units kernel namespaces debugger io.streams.string fry combinators effects.parser ; IN: eval diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index ee8d2dfea3..27416e0f89 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays byte-vectors generic hashtables io +USING: accessors arrays byte-arrays byte-vectors generic hashtables assocs kernel math namespaces make sequences strings sbufs vectors words prettyprint.config prettyprint.custom prettyprint.sections quotations io io.pathnames io.styles math.parser effects classes.tuple From 319d0b96dd027a7fd073663101cb6bd8e6f96c2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 09:56:09 -0500 Subject: [PATCH 064/228] Docs for parser.notes --- core/parser/notes/notes-docs.factor | 10 ++++++++++ core/parser/parser-docs.factor | 7 ------- 2 files changed, 10 insertions(+), 7 deletions(-) create mode 100644 core/parser/notes/notes-docs.factor diff --git a/core/parser/notes/notes-docs.factor b/core/parser/notes/notes-docs.factor new file mode 100644 index 0000000000..f9a86c6934 --- /dev/null +++ b/core/parser/notes/notes-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax io ; +IN: parser.notes + +HELP: parser-notes +{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; + +HELP: parser-notes? +{ $values { "?" "a boolean" } } +{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ; + diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index ea6a136b95..ec0810509b 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -110,13 +110,6 @@ HELP: save-location { $values { "definition" "a definition specifier" } } { $description "Saves the location of a definition and associates this definition with the current source file." } ; -HELP: parser-notes -{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; - -HELP: parser-notes? -{ $values { "?" "a boolean" } } -{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ; - HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; From 2f5b706b12dc70e27096b78c3089b70faabba55f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 10:02:48 -0500 Subject: [PATCH 065/228] Comment out JPEG code until we figure out if we want default bootstrap to depend on BLAS or not --- basis/images/loader/loader.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 27b726f3c0..d86b275635 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators accessors images.bitmap images.tiff images io.pathnames -images.jpeg images.png ; +images.png ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -12,8 +12,8 @@ ERROR: unknown-image-extension extension ; { "bmp" [ bitmap-image ] } { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } - { "jpg" [ jpeg-image ] } - { "jpeg" [ jpeg-image ] } + ! { "jpg" [ jpeg-image ] } + ! { "jpeg" [ jpeg-image ] } { "png" [ png-image ] } [ unknown-image-extension ] } case ; From 80d62339132cc7d9d662a108e919298b8871f359 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 10:45:17 -0500 Subject: [PATCH 066/228] Fix even more usings --- basis/alien/structs/structs-docs.factor | 5 ++--- basis/bootstrap/image/image.factor | 19 +++++++++---------- basis/cocoa/messages/messages.factor | 4 ++-- basis/core-foundation/data/data.factor | 3 +-- basis/io/sockets/unix/unix.factor | 8 ++++---- basis/peg/peg.factor | 2 +- basis/tools/memory/memory.factor | 4 ++-- basis/ui/text/text.factor | 2 +- basis/ui/tools/debugger/debugger.factor | 11 +++++------ basis/unicode/data/data.factor | 2 +- basis/unix/process/process.factor | 6 +++--- core/classes/classes-docs.factor | 4 ++-- .../intersection/intersection-docs.factor | 2 +- core/classes/union/union-docs.factor | 4 ++-- core/slots/slots-docs.factor | 4 ++-- core/syntax/syntax-docs.factor | 7 +++---- 16 files changed, 41 insertions(+), 46 deletions(-) diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 62b8510d17..2f7a7eadc8 100644 --- a/basis/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,6 +1,5 @@ -USING: accessors alien.c-types strings help.markup help.syntax -alien.syntax sequences io arrays kernel words assocs namespaces -accessors ; +USING: alien.c-types strings help.markup help.syntax alien.syntax +sequences io arrays kernel words assocs namespaces ; IN: alien.structs ARTICLE: "c-structs" "C structure types" diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 68c7b23302..d76588e4e4 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays byte-arrays generic hashtables -hashtables.private io io.binary io.files io.encodings.binary -io.pathnames 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 classes.tuple.private vocabs -vocabs.loader source-files definitions debugger quotations.private -sequences.private combinators math.order math.private accessors -slots.private generic.single.private compiler.units compiler.constants -fry bootstrap.image.syntax ; +USING: alien arrays byte-arrays generic hashtables hashtables.private +io io.binary io.files io.encodings.binary io.pathnames kernel +kernel.private math namespaces make parser prettyprint sequences +strings sbufs vectors words quotations assocs system layouts splitting +grouping growable classes classes.builtin classes.tuple +classes.tuple.private vocabs vocabs.loader source-files definitions +debugger quotations.private combinators math.order math.private +accessors slots.private generic.single.private compiler.units +compiler.constants fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index fdd4ba81d7..a3fa788f20 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.strings arrays assocs continuations combinators compiler compiler.alien stack-checker kernel -math namespaces make parser quotations sequences strings words +math namespaces make quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc -libc.private parser lexer init core-foundation fry generalizations +libc.private lexer init core-foundation fry generalizations specialized-arrays.direct.alien ; IN: cocoa.messages diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor index c708eacecc..ef5973888e 100644 --- a/basis/core-foundation/data/data.factor +++ b/basis/core-foundation/data/data.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax core-foundation.numbers kernel math -sequences core-foundation.numbers ; +USING: alien.c-types alien.syntax kernel math sequences ; IN: core-foundation.data TYPEDEF: void* CFDataRef diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 6ba7ca2322..fe136cd887 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings generic kernel math threads -sequences byte-arrays io.ports io.binary io.backend.unix -io.streams.duplex io.backend io.ports io.pathnames io.files.private -io.encodings.utf8 math.parser continuations libc combinators system -accessors destructors unix locals init ; +sequences byte-arrays io.binary io.backend.unix io.streams.duplex +io.backend io.pathnames io.files.private io.encodings.utf8 math.parser +continuations libc combinators system accessors destructors unix +locals init ; EXCLUDE: namespaces => bind ; EXCLUDE: io => read write ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index c76ca7ac9c..12e6d59fc0 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings fry namespaces make math assocs io vectors arrays math.parser math.order combinators classes sets unicode.categories compiler.units parser words -quotations effects memoize accessors locals effects splitting +quotations memoize accessors locals splitting combinators.short-circuit generalizations ; IN: peg diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 3d9166aafa..81785f7ea4 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences vectors arrays generic assocs io math -namespaces parser prettyprint strings io.styles vectors words +USING: kernel sequences arrays generic assocs io math +namespaces parser prettyprint strings io.styles words system sorting splitting grouping math.parser classes memory combinators fry ; IN: tools.memory diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index c1f05182e6..6d5c7e56a6 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -73,7 +73,7 @@ M: array draw-text ] with each ] do-matrix ; -USING: vocabs.loader namespaces system combinators ; +USING: vocabs.loader system combinators ; { { [ os macosx? ] [ "core-text" ] } diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index cf86ce4223..024442a264 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables io kernel math models -colors.constants namespaces sequences words continuations -debugger prettyprint help editors fonts ui ui.commands ui.gestures -ui.gadgets ui.pens.solid ui.gadgets.worlds ui.gadgets.packs -ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes -ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes +colors.constants namespaces sequences words continuations debugger +prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets +ui.pens.solid ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons +ui.gadgets.labels ui.gadgets.presentations ui.gadgets.viewports +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback ui.tools.inspector ui.tools.browser ui.debugger ; IN: ui.tools.debugger diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 779ae64d48..318a56627b 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit assocs math kernel sequences io.files hashtables quotations splitting grouping arrays io -math.parser hash2 math.order byte-arrays words namespaces words +math.parser hash2 math.order byte-arrays namespaces compiler.units parser io.encodings.ascii values interval-maps ascii sets combinators locals math.ranges sorting make strings.parser io.encodings.utf8 memoize simple-flat-file ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 9819e50843..da8b1e63e3 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ -USING: kernel alien.c-types alien.strings sequences math alien.syntax unix -vectors namespaces continuations threads assocs vectors -io.backend.unix io.encodings.utf8 unix.utilities fry ; +USING: kernel alien.c-types alien.strings sequences math alien.syntax +unix namespaces continuations threads assocs io.backend.unix +io.encodings.utf8 unix.utilities fry ; IN: unix.process ! Low-level Unix process launching utilities. These are used diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index f8a2ff415c..109a3b8089 100644 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private -namespaces sequences words arrays layouts effects math -layouts classes.private classes.union classes.mixin +namespaces sequences words arrays effects math +classes.private classes.union classes.mixin classes.predicate quotations ; IN: classes diff --git a/core/classes/intersection/intersection-docs.factor b/core/classes/intersection/intersection-docs.factor index e9ca706d63..fbd41f5407 100644 --- a/core/classes/intersection/intersection-docs.factor +++ b/core/classes/intersection/intersection-docs.factor @@ -1,5 +1,5 @@ USING: generic help.markup help.syntax kernel kernel.private -namespaces sequences words arrays layouts help effects math +namespaces sequences words arrays help effects math layouts classes.private classes compiler.units ; IN: classes.intersection diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index 3d7312a889..4117010fff 100644 --- a/core/classes/union/union-docs.factor +++ b/core/classes/union/union-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel kernel.private -namespaces sequences words arrays layouts help effects math -layouts classes.private classes compiler.units ; +namespaces sequences words arrays help effects math +classes.private classes compiler.units ; IN: classes.union ARTICLE: "unions" "Union classes" diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 348e2ec2b2..eb0e07c71d 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax generic kernel.private parser words -kernel quotations namespaces sequences words arrays effects +USING: help.markup help.syntax generic kernel.private parser +kernel quotations namespaces sequences arrays effects generic.standard classes.builtin slots.private classes strings math assocs byte-arrays alien classes.tuple ; IN: slots diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index cd5a325b52..d408da4bc7 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,8 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words -effects classes generic.standard classes.tuple generic.math -generic.standard generic.single arrays io.pathnames vocabs.loader io -sequences assocs words.symbol words.alias words.constant combinators -vocabs.parser ; +effects classes classes.tuple generic.math generic.single arrays +io.pathnames vocabs.loader io sequences assocs words.symbol +words.alias words.constant combinators vocabs.parser ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" From 4121dbe932943fd1f4f9bda32e0b7358ddcc8923 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 11:50:16 -0400 Subject: [PATCH 067/228] Fix usings on X11 --- basis/io/files/info/unix/linux/linux.factor | 1 + basis/io/monitors/linux/linux.factor | 2 +- basis/x11/xlib/xlib.factor | 3 --- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 72401004ae..a8eb9b65a0 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -6,6 +6,7 @@ io.files.unix kernel math.order namespaces sequences sorting system unix unix.statfs.linux unix.statvfs.linux io.files.links specialized-arrays.direct.uint arrays io.files.info.unix assocs io.pathnames unix.types ; +FROM: csv => delimiter ; IN: io.files.info.unix.linux TUPLE: linux-file-system-info < unix-file-system-info diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index e914f32a48..9097e7e864 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.monitors.recursive -io.files io.pathnames io.buffers io.monitors io.ports io.timeouts +io.files io.pathnames io.buffers io.ports io.timeouts io.backend.unix io.encodings.utf8 unix.linux.inotify assocs namespaces make threads continuations init math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 638f5c8d56..65338dc88b 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -447,9 +447,6 @@ X-FUNCTION: Status XDrawString ( ! 8.7 - Transferring Images between Client and Server -CONSTANT: XYBitmap 0 -CONSTANT: XYPixmap 1 -CONSTANT: ZPixmap 2 CONSTANT: AllPlanes -1 C-STRUCT: XImage-funcs From 52ea03a311d5ceae9ea022f44c3cdb186588f036 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 11:20:08 -0500 Subject: [PATCH 068/228] Fix windows bootstrap --- basis/io/sockets/windows/nt/nt.factor | 2 +- basis/ui/backend/windows/windows.factor | 4 ++-- basis/windows/gdi32/gdi32.factor | 1 + basis/windows/kernel32/kernel32.factor | 2 -- basis/windows/opengl32/opengl32.factor | 30 ------------------------- 5 files changed, 4 insertions(+), 35 deletions(-) mode change 100644 => 100755 basis/io/sockets/windows/nt/nt.factor diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor old mode 100644 new mode 100755 index 49a1b2ae63..6d082f953c --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -1,6 +1,6 @@ USING: alien alien.accessors alien.c-types byte-arrays continuations destructors io.ports io.timeouts io.sockets -io.sockets io namespaces io.streams.duplex io.backend.windows +io namespaces io.streams.duplex io.backend.windows io.sockets.windows io.backend.windows.nt windows.winsock kernel libc math sequences threads system combinators accessors ; IN: io.sockets.windows.nt diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 1ca3e85232..e28776a51c 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -8,8 +8,8 @@ math.vectors namespaces make sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.offscreen windows.nt threads libc combinators fry combinators.short-circuit continuations -command-line shuffle opengl ui.render ascii math.bitwise locals -accessors math.rectangles math.order ascii calendar +command-line shuffle opengl ui.render math.bitwise locals +accessors math.rectangles math.order calendar ascii io.encodings.utf16n windows.errors literals ui.pixel-formats ui.pixel-formats.private memoize classes struct-arrays ; IN: ui.backend.windows diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 0699c92be3..5187c3f660 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -233,6 +233,7 @@ CONSTANT: PFD_DRAW_TO_WINDOW 4 CONSTANT: PFD_DRAW_TO_BITMAP 8 CONSTANT: PFD_SUPPORT_GDI 16 CONSTANT: PFD_SUPPORT_OPENGL 32 +CONSTANT: PFD_SUPPORT_DIRECTDRAW 8192 CONSTANT: PFD_GENERIC_FORMAT 64 CONSTANT: PFD_NEED_PALETTE 128 CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index e654b68bdc..38c63abc72 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -180,8 +180,6 @@ CONSTANT: SEC_COMMIT HEX: 08000000 CONSTANT: SEC_NOCACHE HEX: 10000000 ALIAS: MEM_IMAGE SEC_IMAGE -CONSTANT: ERROR_ALREADY_EXISTS 183 - CONSTANT: FILE_MAP_ALL_ACCESS HEX: f001f CONSTANT: FILE_MAP_READ 4 CONSTANT: FILE_MAP_WRITE 2 diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index 4173332dc3..63f705263c 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -5,36 +5,6 @@ math math.bitwise windows.types init assocs splitting sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ; IN: windows.opengl32 -! PIXELFORMATDESCRIPTOR flags -CONSTANT: PFD_DOUBLEBUFFER HEX: 00000001 -CONSTANT: PFD_STEREO HEX: 00000002 -CONSTANT: PFD_DRAW_TO_WINDOW HEX: 00000004 -CONSTANT: PFD_DRAW_TO_BITMAP HEX: 00000008 -CONSTANT: PFD_SUPPORT_GDI HEX: 00000010 -CONSTANT: PFD_SUPPORT_OPENGL HEX: 00000020 -CONSTANT: PFD_GENERIC_FORMAT HEX: 00000040 -CONSTANT: PFD_NEED_PALETTE HEX: 00000080 -CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 -CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200 -CONSTANT: PFD_SWAP_COPY HEX: 00000400 -CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800 -CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000 -CONSTANT: PFD_SUPPORT_DIRECTDRAW HEX: 00002000 - -! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only -CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000 -CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 -CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000 - -! pixel types -CONSTANT: PFD_TYPE_RGBA 0 -CONSTANT: PFD_TYPE_COLORINDEX 1 - -! layer types -CONSTANT: PFD_MAIN_PLANE 0 -CONSTANT: PFD_OVERLAY_PLANE 1 -CONSTANT: PFD_UNDERLAY_PLANE -1 - CONSTANT: LPD_TYPE_RGBA 0 CONSTANT: LPD_TYPE_COLORINDEX 1 From 78ba8616b326448f727440e9fc83317766725cb2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 13:03:09 -0500 Subject: [PATCH 069/228] working on checksums --- basis/checksums/hmac/hmac.factor | 2 +- basis/checksums/md5/md5.factor | 48 +++++++------------------------- core/checksums/checksums.factor | 34 ++++++++++++++++++++-- 3 files changed, 43 insertions(+), 41 deletions(-) diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index fd7f6ef3a1..17b391f215 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -49,5 +49,5 @@ PRIVATE> : hmac-file ( K path checksum -- value ) [ binary ] dip hmac-stream ; -: hmac-bytes ( K path checksum -- value ) +: hmac-bytes ( K seq checksum -- value ) [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index abdc3504cc..ee00817ea5 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -7,11 +7,13 @@ io.encodings.binary math.bitwise checksums accessors checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 -TUPLE: md5-state bytes-read state old-state ; +SINGLETON: md5 +INSTANCE: md5 stream-checksum + +TUPLE: md5-state < checksum-state state old-state ; : ( -- md5-state ) - md5-state new - 0 >>bytes-read + 64 md5-state new-checksum-state { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; @@ -159,7 +161,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 9 S44 64 ] } [ I ] with-md5-round ; inline -: (process-md5-block) ( block state -- ) +M: md5-state checksum-block ( block state -- ) [ [ 4 [ le> ] map ] [ state>> ] bi* { [ (process-md5-block-F) ] @@ -171,41 +173,11 @@ MACRO: with-md5-round ( ops quot -- ) nip update-md5-state ] 2bi ; -:: process-md5-block ( block state -- ) - block length - [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [ - block state (process-md5-block) - ] [ - block f state bytes-read>> pad-last-block - [ state (process-md5-block) ] each - ] if ; - -: get-md5 ( md5-state -- bytes ) +: md5-state>checksum ( md5-state -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; -:: stream>md5 ( state stream -- ) - 64 stream stream-read - [ state process-md5-block ] [ length 64 = ] bi - [ state stream stream>md5 ] when ; +M: md5-state get-checksum ( md5-state -- bytes ) + clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri + [ [ checksum-block ] curry each ] [ md5-state>checksum ] bi ; PRIVATE> - -SINGLETON: md5 - -INSTANCE: md5 stream-checksum - -M: md5 checksum-stream - drop [ ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ; - -GENERIC: initialize-checksum ( checksum -- state ) -GENERIC# add-bytes 1 ( state bytes -- state ) -GENERIC# add-stream 1 ( state stream -- state ) -GENERIC: finish-checksum ( state -- bytes ) - -M: md5 initialize-checksum drop ; - -M: md5-state finish-checksum get-md5 ; - -M: md5-state add-bytes over [ binary stream>md5 ] dip ; - -M: md5-state add-stream over [ stream>md5 ] dip ; diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 82918b6f81..4f12f5b45d 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,11 +1,41 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math.parser io io.backend io.files -kernel ; +USING: accessors io io.backend io.files kernel math math.parser +sequences vectors io.encodings.binary ; IN: checksums MIXIN: checksum +TUPLE: checksum-state bytes-read block-size bytes ; + +: new-checksum-state ( block-size class -- checksum-state ) + new + swap >>block-size + 0 >>bytes-read + V{ } clone >>bytes ; inline + +GENERIC: checksum-block ( bytes checksum -- ) + +GENERIC: get-checksum ( checksum -- value ) + +: add-checksum-bytes ( checksum-state data -- checksum-state ) + over bytes>> [ push-all ] keep + [ dup length pick block-size>> >= ] + [ + 64 cut-slice [ + over [ checksum-block ] + [ [ 64 + ] change-bytes-read drop ] bi + ] dip + ] while >vector >>bytes ; + +: add-checksum-stream ( checksum-state stream -- checksum-state ) + [ + [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep + ] with-input-stream ; + +: add-checksum-file ( checksum-state path -- checksum-state ) + binary add-checksum-stream ; + GENERIC: checksum-bytes ( bytes checksum -- value ) GENERIC: checksum-stream ( stream checksum -- value ) From fdae2dfaefacaad966e1318e3a0d47f545ccce09 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 13:34:39 -0500 Subject: [PATCH 070/228] lists: slight cleanup --- basis/lists/lazy/examples/examples.factor | 2 +- basis/lists/lazy/lazy-docs.factor | 2 +- basis/lists/lists-docs.factor | 13 +--- basis/lists/lists-tests.factor | 16 ++-- basis/lists/lists.factor | 91 ++++++----------------- basis/wrap/wrap.factor | 3 +- 6 files changed, 36 insertions(+), 91 deletions(-) diff --git a/basis/lists/lazy/examples/examples.factor b/basis/lists/lazy/examples/examples.factor index 1d5bb49f35..11047f3e7c 100644 --- a/basis/lists/lazy/examples/examples.factor +++ b/basis/lists/lazy/examples/examples.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: lists.lazy math kernel sequences quotations ; +USING: lists lists.lazy math kernel sequences quotations ; IN: lists.lazy.examples : naturals ( -- list ) 0 lfrom ; diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index 706431d0a2..0b1bfe2d02 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -14,7 +14,7 @@ ARTICLE: "lists.lazy" "Lazy lists" ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists" "The following combinators create lazy lists from other lazy lists:" -{ $subsection lmap } +{ $subsection lazy-map } { $subsection lfilter } { $subsection luntil } { $subsection lwhile } diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index 3fac05affe..1fdce5d51d 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -14,7 +14,7 @@ ARTICLE: "lists" "Lists" { $vocab-subsection "Lazy lists" "lists.lazy" } ; ARTICLE: { "lists" "protocol" } "The list protocol" -"Lists are instances of a mixin class" +"Lists are instances of a mixin class:" { $subsection list } "Instances of the mixin must implement the following words:" { $subsection car } @@ -25,8 +25,7 @@ ARTICLE: { "lists" "strict" } "Constructing strict lists" "Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:" { $subsection cons } { $subsection swons } -{ $subsection sequence>cons } -{ $subsection deep-sequence>cons } +{ $subsection sequence>list } { $subsection 1list } { $subsection 2list } { $subsection 3list } ; @@ -38,7 +37,6 @@ ARTICLE: { "lists" "combinators" } "Combinators for lists" { $subsection foldl } { $subsection foldr } { $subsection lmap>array } -{ $subsection lmap-as } { $subsection traverse } ; ARTICLE: { "lists" "manipulation" } "Manipulating lists" @@ -141,10 +139,6 @@ HELP: list>array { $values { "list" list } { "array" array } } { $description "Convert a list into an array." } ; -HELP: deep-list>array -{ $values { "list" list } { "array" array } } -{ $description "Recursively turns the given cons object into an array, maintaining order and also converting nested lists." } ; - HELP: traverse { $values { "list" list } { "pred" { $quotation "( list/elt -- ? )" } } { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } } @@ -170,6 +164,3 @@ HELP: lmap>array { $values { "list" list } { "quot" quotation } { "array" array } } { $description "Executes the quotation on each element of the list, collecting the results in an array." } ; -HELP: lmap-as -{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } } -{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ; diff --git a/basis/lists/lists-tests.factor b/basis/lists/lists-tests.factor index 69daa39e41..e34a719c57 100644 --- a/basis/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists lists.lazy math kernel ; +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array + { 1 2 3 4 5 } sequence>list [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -24,23 +24,23 @@ IN: lists.tests ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } seq>list [ 1+ ] lmap + { 1 2 3 4 } sequence>list [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>list 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>array + { 1 2 3 4 5 } sequence>list lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>list llength ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>array + { 1 2 3 } sequence>list { 4 5 6 } sequence>list lappend list>array ] unit-test -[ { 1 } { 2 } ] [ { 1 2 } seq>list 1 lcut [ list>array ] bi@ ] unit-test +[ { 1 } { 2 } ] [ { 1 2 } sequence>list 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index fecb76f1c0..0eedb80889 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 James Cash +! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors math arrays vectors classes words combinators.short-circuit combinators locals ; @@ -14,57 +14,45 @@ TUPLE: cons { car read-only } { cdr read-only } ; C: cons cons -M: cons car ( cons -- car ) - car>> ; +M: cons car ( cons -- car ) car>> ; -M: cons cdr ( cons -- cdr ) - cdr>> ; +M: cons cdr ( cons -- cdr ) cdr>> ; SINGLETON: +nil+ M: +nil+ nil? drop t ; M: object nil? drop f ; -: atom? ( obj -- ? ) - list? not ; +: atom? ( obj -- ? ) list? not ; inline -: nil ( -- symbol ) +nil+ ; +: nil ( -- symbol ) +nil+ ; inline -: uncons ( cons -- car cdr ) - [ car ] [ cdr ] bi ; +: uncons ( cons -- car cdr ) [ car ] [ cdr ] bi ; inline -: swons ( cdr car -- cons ) - swap cons ; +: swons ( cdr car -- cons ) swap cons ; inline -: unswons ( cons -- cdr car ) - uncons swap ; +: unswons ( cons -- cdr car ) uncons swap ; inline -: 1list ( obj -- cons ) - nil cons ; +: 1list ( obj -- cons ) nil cons ; inline -: 1list? ( list -- ? ) - { [ nil? not ] [ cdr nil? ] } 1&& ; +: 1list? ( list -- ? ) { [ nil? not ] [ cdr nil? ] } 1&& ; inline -: 2list ( a b -- cons ) - nil cons cons ; +: 2list ( a b -- cons ) nil cons cons ; inline -: 3list ( a b c -- cons ) - nil cons cons cons ; +: 3list ( a b c -- cons ) nil cons cons cons ; inline -: cadr ( list -- elt ) - cdr car ; +: cadr ( list -- elt ) cdr car ; inline -: 2car ( list -- car caar ) - [ car ] [ cdr car ] bi ; +: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; inline -: 3car ( list -- car cadr caddr ) - [ car ] [ cdr car ] [ cdr cdr car ] tri ; +: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; inline -: lnth ( n list -- elt ) - swap [ cdr ] times car ; +: lnth ( n list -- elt ) swap [ cdr ] times car ; inline : leach ( list quot: ( elt -- ) -- ) @@ -93,49 +81,16 @@ PRIVATE> : lcut ( list index -- before after ) [ nil ] dip - [ [ [ cdr ] [ car ] bi ] dip cons ] times + [ [ unswons ] dip cons ] times lreverse swap ; -: sequence>cons ( sequence -- list ) - nil [ swap cons ] reduce ; - - - -: deep-sequence>cons ( sequence -- cons ) - [ ] keep nil - [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ] - with reduce ; - -vector) ( acc list quot: ( elt -- elt' ) -- acc ) - list nil? [ acc ] [ - list car quot call acc push - acc list cdr quot (lmap>vector) - ] if ; inline recursive - -: lmap>vector ( list quot -- array ) - [ V{ } clone ] 2dip (lmap>vector) ; inline -PRIVATE> - -: lmap-as ( list quot exemplar -- sequence ) - [ lmap>vector ] dip like ; inline +: sequence>list ( sequence -- list ) + nil [ swons ] reduce ; : lmap>array ( list quot -- array ) - { } lmap-as ; inline + accumulator [ leach ] dip { } like ; inline -: deep-list>array ( list -- array ) - [ - { - { [ dup nil? ] [ drop { } ] } - { [ dup list? ] [ deep-list>array ] } - [ ] - } cond - ] lmap>array ; - -: list>array ( list -- array ) +: list>array ( list -- array ) [ ] lmap>array ; :: traverse ( list pred quot: ( list/elt -- result ) -- result ) diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 482d50ab5f..c648f6bd61 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -68,8 +68,7 @@ SYMBOL: line-ideal 0 ; : post-process ( paragraph -- array ) - lines>> deep-list>array - [ [ contents>> ] map ] map ; + lines>> [ [ contents>> ] lmap>array ] lmap>array ; : initialize ( elements -- elements paragraph ) unclip-slice 1paragraph 1array ; From eb91fcfa8d7a36d57d6592f7fabe34c1f6c8dd1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 13:34:47 -0500 Subject: [PATCH 071/228] html.templates.fhtml: fix load error --- basis/html/templates/fhtml/fhtml.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 34783a0b4a..6c5e78e917 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files +assocs fry vocabs.parser parser parser.notes lexer io io.files io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml From 11fd309874bb98fef54033aec8a9190d7a28c370 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 13:41:11 -0500 Subject: [PATCH 072/228] Update unit tests for parser note and lazy list changes --- core/classes/tuple/tuple-tests.factor | 2 +- core/parser/notes/notes-tests.factor | 4 ++++ core/parser/parser-tests.factor | 2 -- extra/parser-combinators/parser-combinators-tests.factor | 2 +- 4 files changed, 6 insertions(+), 4 deletions(-) create mode 100644 core/parser/notes/notes-tests.factor diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 466b221877..e3452194c6 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -5,7 +5,7 @@ generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting summary columns math.order classes.private slots slots.private eval see words.symbol -compiler.errors ; +compiler.errors parser.notes ; IN: classes.tuple.tests TUPLE: rect x y w h ; diff --git a/core/parser/notes/notes-tests.factor b/core/parser/notes/notes-tests.factor new file mode 100644 index 0000000000..78fa9e2b73 --- /dev/null +++ b/core/parser/notes/notes-tests.factor @@ -0,0 +1,4 @@ +USING: lexer namespaces parser.notes source-files tools.test ; +IN: parser.notes.tests + +[ ] [ f lexer set f file set "Hello world" note. ] unit-test \ No newline at end of file diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 5cbcc14184..a9e0bd08ab 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -481,8 +481,6 @@ DEFER: blahy [ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ] [ error>> error>> def>> \ blahy eq? ] must-fail-with -[ ] [ f lexer set f file set "Hello world" note. ] unit-test - [ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail SYMBOLS: a b c ; diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 70698daa0b..062277ec4d 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel lists.lazy tools.test strings math +USING: kernel lists lists.lazy tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; IN: parser-combinators.tests From 2185e487419fa56021db6ad0a5cbaa5821886460 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 15:17:20 -0500 Subject: [PATCH 073/228] dont use fry in core --- core/checksums/checksums.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 4f12f5b45d..27ee6a3435 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors io.encodings.binary ; +sequences vectors io.encodings.binary quotations ; IN: checksums MIXIN: checksum @@ -30,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value ) : add-checksum-stream ( checksum-state stream -- checksum-state ) [ - [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep + [ [ swap add-checksum-bytes drop ] curry each-block ] keep ] with-input-stream ; : add-checksum-file ( checksum-state path -- checksum-state ) From 069a565126cf8741347375df42c9a281cce85d46 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 16:28:24 -0500 Subject: [PATCH 074/228] unix.stat.netbsd: fix code duplication with unix.statvfs.netbsd --- basis/unix/stat/netbsd/netbsd.factor | 30 ---------------------------- 1 file changed, 30 deletions(-) diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index b60a0b1adc..3b145d8af5 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -6,33 +6,3 @@ cell-bits { { 64 [ "unix.stat.netbsd.64" require ] } } case -CONSTANT: _VFS_NAMELEN 32 -CONSTANT: _VFS_MNAMELEN 1024 - -C-STRUCT: statvfs - { "ulong" "f_flag" } - { "ulong" "f_bsize" } - { "ulong" "f_frsize" } - { "ulong" "f_iosize" } - { "fsblkcnt_t" "f_blocks" } - { "fsblkcnt_t" "f_bfree" } - { "fsblkcnt_t" "f_bavail" } - { "fsblkcnt_t" "f_bresvd" } - { "fsfilcnt_t" "f_files" } - { "fsfilcnt_t" "f_ffree" } - { "fsfilcnt_t" "f_favail" } - { "fsfilcnt_t" "f_fresvd" } - { "uint64_t" "f_syncreads" } - { "uint64_t" "f_syncwrites" } - { "uint64_t" "f_asyncreads" } - { "uint64_t" "f_asyncwrites" } - { "fsid_t" "f_fsidx" } - { "ulong" "f_fsid" } - { "ulong" "f_namemax" } - { "uid_t" "f_owner" } - { { "uint32_t" 4 } "f_spare" } - { { "char" _VFS_NAMELEN } "f_fstypename" } - { { "char" _VFS_NAMELEN } "f_mntonname" } - { { "char" _VFS_NAMELEN } "f_mntfromname" } ; - -FUNCTION: int statvfs ( char* path, statvfs* buf ) ; From 0aa5b61a349d34a2b697a3998db98113d7c3ce78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 16:40:40 -0500 Subject: [PATCH 075/228] tools.deploy.shaker: update for parser.notes --- basis/tools/deploy/shaker/shaker.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5a64878aee..46572de47b 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io.backend io.streams.c init fry namespaces -math make assocs kernel parser lexer strings.parser vocabs sequences -sequences.private words memory kernel.private continuations io -vocabs.loader system strings sets vectors quotations byte-arrays -sorting compiler.units definitions generic generic.standard -generic.single tools.deploy.config combinators classes -slots.private ; +math make assocs kernel parser parser.notes lexer strings.parser +vocabs sequences sequences.private words memory kernel.private +continuations io vocabs.loader system strings sets vectors quotations +byte-arrays sorting compiler.units definitions generic +generic.standard generic.single tools.deploy.config combinators +classes slots.private ; QUALIFIED: bootstrap.stage2 QUALIFIED: command-line QUALIFIED: compiler.errors From 750a17ff63635000ec45bf479c87f766137e03cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 16:54:02 -0500 Subject: [PATCH 076/228] help.html: fix escape-filename --- basis/help/html/html-tests.factor | 2 ++ basis/help/html/html.factor | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 61414cdfa2..3ba336be0b 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -2,3 +2,5 @@ IN: help.html.tests USING: help.html tools.test help.topics kernel ; [ ] [ "xml" >link help>html drop ] unit-test + +[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test \ No newline at end of file diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 09208749b9..fbfc42829e 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary +USING: io.encodings.utf8 io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order sorting debugger html xml.syntax xml.writer math.parser ; +FROM: io.encodings.ascii => ascii ; +FROM: ascii => ascii? ; IN: help.html : escape-char ( ch -- ) From d0225025ef4f84f637443e8e90b3a0fb678b540b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 May 2009 16:54:45 -0500 Subject: [PATCH 077/228] In Farkup, image text is only parsed if given separate from the URL --- basis/farkup/farkup-tests.factor | 4 +++- basis/farkup/farkup.factor | 8 ++++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index abee7194a2..7d9c900ec2 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -96,7 +96,7 @@ link-no-follow? off [ "
int main()
" ] [ "[c{int main()}]" convert-farkup ] unit-test -[ "

\"image:lol.jpg\"/

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"lol.jpg\"/

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test [ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test [ "

http://lol.com

" ] [ "[[http://lol.com]]" convert-farkup ] unit-test [ "

haha

" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test @@ -207,3 +207,5 @@ link-no-follow? off [ convert-farkup drop t ] [ drop print f ] recover ] all? ] unit-test + +[ "

http://foo.com/~foo

" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index c400457c0b..a008b1d049 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -70,11 +70,15 @@ DEFER: (parse-paragraph) { CHAR: % inline-code } } at ; +: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' ) + [ "" like dup simple-link-title ] if* ; inline + : parse-link ( string -- paragraph-list ) rest-slice "]]" split1-slice [ "|" split1 - [ "" like dup simple-link-title ] unless* - [ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if + [ "image:" ?head ] dip swap + [ [ ] or-simple-title image boa ] + [ [ parse-paragraph ] or-simple-title link boa ] if ] dip [ (parse-paragraph) cons ] [ 1list ] if* ; : ?first ( seq -- elt ) 0 swap ?nth ; From ef29d6263de0dcb55abefd9fdd7d6eae07543198 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 16:57:58 -0500 Subject: [PATCH 078/228] Fix regression with see'ing gensyms --- basis/see/see-tests.factor | 4 +++- basis/see/see.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/see/see-tests.factor b/basis/see/see-tests.factor index 3f11ec987e..ba81bf5e2f 100644 --- a/basis/see/see-tests.factor +++ b/basis/see/see-tests.factor @@ -1,5 +1,5 @@ IN: see.tests -USING: see tools.test io.streams.string math ; +USING: see tools.test io.streams.string math words ; CONSTANT: test-const 10 [ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ] @@ -9,3 +9,5 @@ ALIAS: test-alias + [ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ] [ [ \ test-alias see ] with-string-writer ] unit-test + +[ ] [ gensym see ] unit-test \ No newline at end of file diff --git a/basis/see/see.factor b/basis/see/see.factor index d2515a2e81..a8d78a68e4 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -44,7 +44,7 @@ M: word print-stack-effect? drop t ; > vocab pprinter-in set ; + vocabulary>> dup [ vocab ] when pprinter-in set ; : word-synopsis ( word -- ) { From 253a55970b1d60322c7fbc787975bdd5c8d07c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 16 May 2009 16:58:11 -0500 Subject: [PATCH 079/228] math.primes.list: update for lists.lazy changes --- extra/math/primes/lists/lists-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/primes/lists/lists-tests.factor b/extra/math/primes/lists/lists-tests.factor index 3bd7d70365..5af13415e4 100644 --- a/extra/math/primes/lists/lists-tests.factor +++ b/extra/math/primes/lists/lists-tests.factor @@ -1,4 +1,4 @@ -USING: lists.lazy math.primes.lists tools.test ; +USING: lists lists.lazy math.primes.lists tools.test ; { { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test { { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test From cab57f5547a569bc51a7c6f1d0c83c7d859b0442 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 18:00:56 -0500 Subject: [PATCH 080/228] checksums work now --- basis/checksums/md5/md5-tests.factor | 21 ++++++++++++++++++ basis/checksums/md5/md5.factor | 32 ++++++++++++++++++---------- core/checksums/checksums.factor | 6 +++++- 3 files changed, 47 insertions(+), 12 deletions(-) diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index 8e314f7c28..db15540f43 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -8,3 +8,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ; [ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test [ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test + +[ + t +] [ + "asdf" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index ee00817ea5..97a263bab5 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -8,11 +8,12 @@ checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 SINGLETON: md5 + INSTANCE: md5 stream-checksum TUPLE: md5-state < checksum-state state old-state ; -: ( -- md5-state ) +: ( -- md5 ) 64 md5-state new-checksum-state { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; @@ -21,7 +22,7 @@ TUPLE: md5-state < checksum-state state old-state ; : v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ; -: update-md5-state ( md5-state -- ) +: update-md5 ( md5 -- ) [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri [ (>>old-state) ] [ (>>state) ] bi ; inline @@ -69,13 +70,13 @@ CONSTANT: d 3 :: (ABCD) ( x V a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) a V [ - b V nth-unsafe - c V nth-unsafe - d V nth-unsafe quot call w+ - k x nth-unsafe w+ + b V nth + c V nth + d V nth quot call w+ + k x nth w+ i T w+ s bitroll-32 - b V nth-unsafe w+ + b V nth w+ ] change-nth ; inline MACRO: with-md5-round ( ops quot -- ) @@ -170,14 +171,23 @@ M: md5-state checksum-block ( block state -- ) [ (process-md5-block-I) ] } 2cleave ] [ - nip update-md5-state + nip update-md5 ] 2bi ; -: md5-state>checksum ( md5-state -- bytes ) +: md5>checksum ( md5 -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; -M: md5-state get-checksum ( md5-state -- bytes ) +M: md5-state clone ( md5 -- new-md5 ) + call-next-method + [ clone ] change-state + [ clone ] change-old-state ; + +M: md5-state get-checksum ( md5 -- bytes ) clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri - [ [ checksum-block ] curry each ] [ md5-state>checksum ] bi ; + [ [ checksum-block ] curry each ] [ md5>checksum ] bi ; + +M: md5 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; PRIVATE> diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 27ee6a3435..0910a3efac 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -14,6 +14,10 @@ TUPLE: checksum-state bytes-read block-size bytes ; 0 >>bytes-read V{ } clone >>bytes ; inline +M: checksum-state clone + call-next-method + [ clone ] change-bytes ; + GENERIC: checksum-block ( bytes checksum -- ) GENERIC: get-checksum ( checksum -- value ) @@ -26,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value ) over [ checksum-block ] [ [ 64 + ] change-bytes-read drop ] bi ] dip - ] while >vector >>bytes ; + ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; : add-checksum-stream ( checksum-state stream -- checksum-state ) [ From 6ac69d74c415a32171e4459bcd81531e020b7e80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 10:10:14 -0500 Subject: [PATCH 081/228] fix a bug in inflate -- length table was one entry too short --- basis/compression/inflate/inflate.factor | 25 ++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 3fe07b5994..7cb43ac68f 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -75,18 +75,20 @@ CONSTANT: length-table 19 23 27 31 35 43 51 59 67 83 99 115 - 131 163 195 227 + 131 163 195 227 258 } CONSTANT: dist-table - { 1 2 3 4 - 5 7 9 13 - 17 25 33 49 - 65 97 129 193 - 257 385 513 769 - 1025 1537 2049 3073 - 4097 6145 8193 12289 - 16385 24577 } + { + 1 2 3 4 + 5 7 9 13 + 17 25 33 49 + 65 97 129 193 + 257 385 513 769 + 1025 1537 2049 3073 + 4097 6145 8193 12289 + 16385 24577 + } : nth* ( n seq -- elt ) [ length 1- swap - ] [ nth ] bi ; @@ -156,7 +158,7 @@ CONSTANT: dist-table [ 1 bitstream bs:read 0 = ] [ bitstream - 2 bitstream bs:read ! B + 2 bitstream bs:read { { 0 [ inflate-raw ] } { 1 [ inflate-static ] } @@ -206,6 +208,5 @@ PRIVATE> : zlib-inflate ( bytes -- bytes ) bs: - [ check-zlib-header ] - [ inflate-loop ] bi + [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; From 5ec95fcef21b29dee207611c6658ec4a317ecf40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 11:03:04 -0500 Subject: [PATCH 082/228] sha2 now uses the incremental checksum protocol --- basis/checksums/md5/md5-tests.factor | 4 +- basis/checksums/sha2/sha2.factor | 101 +++++++++++++-------------- 2 files changed, 51 insertions(+), 54 deletions(-) diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index db15540f43..b7f388c002 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -1,4 +1,6 @@ -USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ; +USING: byte-arrays checksums checksums.md5 io.encodings.binary +io.streams.byte-array kernel math namespaces tools.test ; + [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 12e32f6c69..509b047d2e 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,16 +3,16 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors locals ; +accessors locals checksums.stream multiline ; IN: checksums.sha2 SINGLETON: sha-224 SINGLETON: sha-256 -INSTANCE: sha-224 checksum -INSTANCE: sha-256 checksum +INSTANCE: sha-224 stream-checksum +INSTANCE: sha-256 stream-checksum -TUPLE: sha2-state K H word-size block-size ; +TUPLE: sha2-state < checksum-state K H word-size ; TUPLE: sha2-short < sha2-state ; @@ -22,6 +22,11 @@ TUPLE: sha-224-state < sha2-short ; TUPLE: sha-256-state < sha2-short ; +M: sha2-state clone + call-next-method + [ clone ] change-H + [ clone ] change-K ; + ( -- sha2-state ) + 64 sha-224-state new-checksum-state + K-256 >>K + initial-H-224 >>H + 4 >>word-size ; + +: ( -- sha2-state ) + 64 sha-256-state new-checksum-state + K-256 >>K + initial-H-256 >>H + 4 >>word-size ; + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] @@ -172,7 +189,7 @@ ALIAS: K-512 K-384 [ -41 bitroll-64 ] tri ] [ bitxor ] reduce-outputs ; inline -: process-M-256 ( n seq -- ) +: prepare-M-256 ( n seq -- ) { [ [ 16 - ] dip nth ] [ [ 15 - ] dip nth s0-256 ] @@ -181,7 +198,7 @@ ALIAS: K-512 K-384 [ ] } 2cleave set-nth ; inline -: process-M-512 ( n seq -- ) +: prepare-M-512 ( n seq -- ) { [ [ 16 - ] dip nth ] [ [ 15 - ] dip nth s0-512 ] @@ -201,23 +218,6 @@ ALIAS: K-512 K-384 GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) -M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) - drop - dup [ - HEX: 80 , - length - [ 64 mod calculate-pad-length 0 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - -M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) - drop dup [ - HEX: 80 , - length - [ 128 mod calculate-pad-length-long 0 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; @@ -257,7 +257,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) [ word-size>> [ be> ] map ] [ block-size>> [ 0 pad-tail 16 ] keep [a,b) over - '[ _ process-M-256 ] each + '[ _ prepare-M-256 ] each ] bi ; inline :: process-chunk ( M block-size cloned-H sha2 -- ) @@ -268,39 +268,34 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) ] each cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -: sha2-steps ( sliced-groups state -- ) - '[ - _ - [ prepare-message-schedule ] - [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi - ] each ; +M: sha2-short checksum-block + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; -: byte-array>sha2 ( bytes state -- ) - [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] - [ sha2-steps ] bi ; +: sha-224>checksum ( sha2 -- bytes ) + H>> 7 head 4 seq>byte-array ; -: ( -- sha2-state ) - sha-224-state new - K-256 >>K - initial-H-224 >>H - 4 >>word-size - 64 >>block-size ; +: sha-256>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; -: ( -- sha2-state ) - sha-256-state new - K-256 >>K - initial-H-256 >>H - 4 >>word-size - 64 >>block-size ; +: pad-last-short-block ( state -- ) + [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri + [ checksum-block ] curry each ; PRIVATE> -M: sha-224 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 7 head 4 seq>byte-array ] bi ; +M: sha-224-state get-checksum + clone + [ pad-last-short-block ] [ sha-224>checksum ] bi ; -M: sha-256 checksum-bytes - drop - [ byte-array>sha2 ] - [ H>> 4 seq>byte-array ] bi ; +M: sha-256-state get-checksum + clone + [ pad-last-short-block ] [ sha-256>checksum ] bi ; + +M: sha-224 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; + +M: sha-256 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; From b5e315d2cdf11b517e2722850eaa431e641524dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 12:45:20 -0500 Subject: [PATCH 083/228] working on hmac --- basis/checksums/hmac/hmac-tests.factor | 11 ++++-- basis/checksums/hmac/hmac.factor | 47 ++++++++++---------------- basis/checksums/md5/md5.factor | 5 ++- basis/checksums/sha2/sha2-tests.factor | 2 -- basis/checksums/sha2/sha2.factor | 10 ++++-- core/checksums/checksums.factor | 5 +-- 6 files changed, 41 insertions(+), 39 deletions(-) diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 9541ca2f26..8835bed981 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,6 +1,6 @@ USING: kernel io strings byte-arrays sequences namespaces math parser checksums.hmac tools.test checksums.md5 checksums.sha1 -checksums.sha2 ; +checksums.sha2 checksums ; IN: checksums.hmac.tests [ @@ -39,4 +39,11 @@ IN: checksums.hmac.tests ] unit-test [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] -[ HEX: b 20 sha-256 hmac-bytes >string ] unit-test +[ 20 HEX: b "Hi There" sha-256 hmac-bytes hex-string ] unit-test + +[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ] +[ + "JefeJefeJefeJefeJefeJefeJefeJefe" + "what do ya want for nothing?" sha-256 hmac-bytes hex-string +] unit-test + diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 17b391f215..538dfc92c8 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -3,48 +3,35 @@ USING: arrays checksums checksums.md5 checksums.md5.private checksums.sha1 combinators fry io io.binary io.encodings.binary io.files io.streams.byte-array kernel math math.vectors memoize -sequences ; +sequences locals accessors ; IN: checksums.hmac sha1 get-sha1 - initialize-sha1 - [ process-sha1-block ] - [ process-sha1-block ] bi* get-sha1 ; - - : md5-hmac ( Ko Ki stream -- hmac ) - initialize-md5 process-md5-block - stream>md5 get-md5 - initialize-md5 - [ process-md5-block ] - [ process-md5-block ] bi* get-md5 ; -*/ - : seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ; -MEMO: opad ( -- seq ) 64 HEX: 5c ; +: opad ( checksum-state -- seq ) block-size>> HEX: 5c ; -MEMO: ipad ( -- seq ) 64 HEX: 36 ; +: ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; -: init-K ( K -- o i ) - 64 0 pad-tail - [ opad seq-bitxor ] - [ ipad seq-bitxor ] bi ; +:: init-K ( K checksum checksum-state -- o i ) + checksum-state block-size>> K length < + [ K checksum checksum-bytes ] [ K ] if + checksum-state block-size>> 0 pad-tail + [ checksum-state opad seq-bitxor ] + [ checksum-state ipad seq-bitxor ] bi ; PRIVATE> :: hmac-stream ( K stream checksum -- value ) - K init-K :> Ki :> Ko - checksum initialize-checksum - Ki add-bytes - stream add-stream finish-checksum - checksum initialize-checksum - Ko add-bytes swap add-bytes - finish-checksum ; + K checksum dup initialize-checksum-state + dup :> checksum-state + init-K :> Ki :> Ko + checksum-state Ki add-checksum-bytes + stream add-checksum-stream get-checksum + checksum initialize-checksum-state + Ko add-checksum-bytes swap add-checksum-bytes + get-checksum ; : hmac-file ( K path checksum -- value ) [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 97a263bab5..026df34012 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,10 +14,13 @@ INSTANCE: md5 stream-checksum TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) - 64 md5-state new-checksum-state + md5-state new-checksum-state + 64 >>block-size { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; +M: md5 initialize-checksum-state drop ; + ( -- sha2-state ) - 64 sha-224-state new-checksum-state + sha-224-state new-checksum-state + 64 >>block-size K-256 >>K initial-H-224 >>H 4 >>word-size ; : ( -- sha2-state ) - 64 sha-256-state new-checksum-state + sha-256-state new-checksum-state + 64 >>block-size K-256 >>K initial-H-256 >>H 4 >>word-size ; +M: sha-224 initialize-checksum-state drop ; + +M: sha-256 initialize-checksum-state drop ; + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 0910a3efac..1d57823e18 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -8,9 +8,8 @@ MIXIN: checksum TUPLE: checksum-state bytes-read block-size bytes ; -: new-checksum-state ( block-size class -- checksum-state ) +: new-checksum-state ( class -- checksum-state ) new - swap >>block-size 0 >>bytes-read V{ } clone >>bytes ; inline @@ -18,6 +17,8 @@ M: checksum-state clone call-next-method [ clone ] change-bytes ; +GENERIC: initialize-checksum-state ( class -- checksum-state ) + GENERIC: checksum-block ( bytes checksum -- ) GENERIC: get-checksum ( checksum -- value ) From 68ceb338914caf8474b48282f6e3d6a6c9899fde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 13:36:53 -0500 Subject: [PATCH 084/228] use literal-arrays --- basis/images/bitmap/bitmap-tests.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index 29ba3b9b80..ea8b0d4c0c 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -17,9 +17,9 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" -{ - $ test-bitmap8 - $ test-bitmap24 +${ + test-bitmap8 + test-bitmap24 "vocab:ui/render/test/reference.bmp" } [ [ ] swap [ load-image drop ] curry unit-test ] each @@ -34,11 +34,11 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" [ t ] [ - { - $ test-40 - $ test-41 - $ test-42 - $ test-43 - $ test-bitmap24 + ${ + test-40 + test-41 + test-42 + test-43 + test-bitmap24 } [ test-bitmap-save ] all? ] unit-test From 7a3f15a586b6260266ed3bd89fa9b1441f3d96f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 13:49:56 -0500 Subject: [PATCH 085/228] generalize sha1-interleave and move it to its own vocabulary --- basis/checksums/interleave/authors.txt | 1 + .../interleave/interleave-tests.factor | 19 +++++++++++++++++++ basis/checksums/interleave/interleave.factor | 17 +++++++++++++++++ 3 files changed, 37 insertions(+) create mode 100644 basis/checksums/interleave/authors.txt create mode 100644 basis/checksums/interleave/interleave-tests.factor create mode 100644 basis/checksums/interleave/interleave.factor diff --git a/basis/checksums/interleave/authors.txt b/basis/checksums/interleave/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/checksums/interleave/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor new file mode 100644 index 0000000000..060d35936f --- /dev/null +++ b/basis/checksums/interleave/interleave-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test checksums.interleave checksums.sha1 ; +IN: checksums.interleave.tests + +[ + B{ + 59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232 + 119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93 + 206 44 1 18 128 150 153 + } +] [ + B{ + 102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216 + 170 26 58 150 150 179 24 153 146 191 225 203 127 166 167 + } + sha1 interleaved-checksum +] unit-test + diff --git a/basis/checksums/interleave/interleave.factor b/basis/checksums/interleave/interleave.factor new file mode 100644 index 0000000000..caef033ec6 --- /dev/null +++ b/basis/checksums/interleave/interleave.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs checksums grouping kernel locals math sequences ; +IN: checksums.interleave + +: seq>2seq ( seq -- seq1 seq2 ) + #! { abcdefgh } -> { aceg } { bdfh } + 2 group flip [ { } { } ] [ first2 ] if-empty ; + +: 2seq>seq ( seq1 seq2 -- seq ) + #! { aceg } { bdfh } -> { abcdefgh } + [ zip concat ] keep like ; + +:: interleaved-checksum ( bytes checksum -- seq ) + bytes [ zero? ] trim-head + dup length odd? [ rest-slice ] when + seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ; From 5325675f9d33584cbc19472f29a89121ac76312d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 17:50:31 -0500 Subject: [PATCH 086/228] fix sha1 --- basis/checksums/adler-32/adler-32.factor | 2 +- basis/checksums/hmac/hmac-tests.factor | 4 +- .../interleave/interleave-tests.factor | 2 +- basis/checksums/sha1/authors.txt | 1 - basis/checksums/sha1/sha1-docs.factor | 11 -- basis/checksums/sha1/sha1-tests.factor | 14 -- basis/checksums/sha1/sha1.factor | 134 ------------------ basis/checksums/sha1/summary.txt | 1 - basis/checksums/sha2/sha2-tests.factor | 7 + basis/checksums/sha2/sha2.factor | 114 ++++++++++++++- 10 files changed, 120 insertions(+), 170 deletions(-) delete mode 100755 basis/checksums/sha1/authors.txt delete mode 100644 basis/checksums/sha1/sha1-docs.factor delete mode 100644 basis/checksums/sha1/sha1-tests.factor delete mode 100644 basis/checksums/sha1/sha1.factor delete mode 100644 basis/checksums/sha1/summary.txt diff --git a/basis/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor index d5e153ba99..f66860dc63 100644 --- a/basis/checksums/adler-32/adler-32.factor +++ b/basis/checksums/adler-32/adler-32.factor @@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521 M: adler-32 checksum-bytes ( bytes checksum -- value ) drop - [ sum 1+ ] + [ sum 1 + ] [ [ dup length [1,b] v. ] [ length ] bi + ] bi [ adler-32-modulus mod ] bi@ 16 shift bitor ; diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 8835bed981..02dfc271a4 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,6 +1,6 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser checksums.hmac tools.test checksums.md5 checksums.sha1 -checksums.sha2 checksums ; +parser checksums.hmac tools.test checksums.md5 checksums.sha2 +checksums ; IN: checksums.hmac.tests [ diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor index 060d35936f..14dddaafab 100644 --- a/basis/checksums/interleave/interleave-tests.factor +++ b/basis/checksums/interleave/interleave-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test checksums.interleave checksums.sha1 ; +USING: tools.test checksums.interleave checksums.sha2 ; IN: checksums.interleave.tests [ diff --git a/basis/checksums/sha1/authors.txt b/basis/checksums/sha1/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/checksums/sha1/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/checksums/sha1/sha1-docs.factor b/basis/checksums/sha1/sha1-docs.factor deleted file mode 100644 index 2c9093865f..0000000000 --- a/basis/checksums/sha1/sha1-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: help.markup help.syntax ; -IN: checksums.sha1 - -HELP: sha1 -{ $class-description "SHA1 checksum algorithm." } ; - -ARTICLE: "checksums.sha1" "SHA1 checksum" -"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")." -{ $subsection sha1 } ; - -ABOUT: "checksums.sha1" diff --git a/basis/checksums/sha1/sha1-tests.factor b/basis/checksums/sha1/sha1-tests.factor deleted file mode 100644 index 808d37d1e4..0000000000 --- a/basis/checksums/sha1/sha1-tests.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ; - -[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test -[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test -! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... -[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" -10 swap concat sha1 checksum-bytes hex-string ] unit-test - -[ - ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" -] [ - "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" - sha1-interleave -] unit-test diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor deleted file mode 100644 index 707aa66ba6..0000000000 --- a/basis/checksums/sha1/sha1.factor +++ /dev/null @@ -1,134 +0,0 @@ -! Copyright (C) 2006, 2008 Doug Coleman. -! 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 namespaces -make math parser sequences assocs grouping vectors io.binary -hashtables math.bitwise checksums checksums.common -checksums.stream ; -IN: checksums.sha1 - -! Implemented according to RFC 3174. - -SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ; - -: get-wth ( n -- wth ) w get nth ; inline -: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline - -: initialize-sha1 ( -- ) - 0 bytes-read set - HEX: 67452301 dup h0 set A set - HEX: efcdab89 dup h1 set B set - HEX: 98badcfe dup h2 set C set - HEX: 10325476 dup h3 set D set - HEX: c3d2e1f0 dup h4 set E set - [ - 20 HEX: 5a827999 % - 20 HEX: 6ed9eba1 % - 20 HEX: 8f1bbcdc % - 20 HEX: ca62c1d6 % - ] { } make K set ; - -! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) -: sha1-W ( t -- W_t ) - dup 3 - get-wth - over 8 - get-wth bitxor - over 14 - get-wth bitxor - swap 16 - get-wth bitxor 1 bitroll-32 ; - -! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19) -! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39) -! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59) -! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79) -: sha1-f ( B C D t -- f_tbcd ) - 20 /i - { - { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] } - { 1 [ bitxor bitxor ] } - { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } - { 3 [ bitxor bitxor ] } - } case ; - -: nth-int-be ( string n -- int ) - 4 * dup 4 + rot be> ; inline - -: make-w ( str -- ) - #! compute w, steps a-b of RFC 3174, section 6.1 - 16 [ nth-int-be w get push ] with each - 16 80 dup [ sha1-W w get push ] each ; - -: init-letters ( -- ) - ! step c of RFC 3174, section 6.1 - h0 get A set - h1 get B set - h2 get C set - h3 get D set - h4 get E set ; - -: inner-loop ( n -- temp ) - ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); - [ - [ B get C get D get ] keep sha1-f , - dup get-wth , - K get nth , - A get 5 bitroll-32 , - E get , - ] { } make sum 32 bits ; inline - -: set-vars ( temp -- ) - ! E = D; D = C; C = S^30(B); B = A; A = TEMP; - D get E set - C get D set - B get 30 bitroll-32 C set - A get B set - A set ; - -: calculate-letters ( -- ) - ! step d of RFC 3174, section 6.1 - 80 [ inner-loop set-vars ] each ; - -: update-hs ( -- ) - ! step e of RFC 3174, section 6.1 - A h0 update-old-new - B h1 update-old-new - C h2 update-old-new - D h3 update-old-new - E h4 update-old-new ; - -: (process-sha1-block) ( str -- ) - 80 w set make-w init-letters calculate-letters update-hs ; - -: process-sha1-block ( str -- ) - dup length [ bytes-read [ + ] change ] keep 64 = [ - (process-sha1-block) - ] [ - t bytes-read get pad-last-block - [ (process-sha1-block) ] each - ] if ; - -: stream>sha1 ( -- ) - 64 read [ process-sha1-block ] keep - length 64 = [ stream>sha1 ] when ; - -: get-sha1 ( -- str ) - [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; - -SINGLETON: sha1 - -INSTANCE: sha1 stream-checksum - -M: sha1 checksum-stream ( stream -- sha1 ) - drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; - -: seq>2seq ( seq -- seq1 seq2 ) - #! { abcdefgh } -> { aceg } { bdfh } - 2 group flip [ { } { } ] [ first2 ] if-empty ; - -: 2seq>seq ( seq1 seq2 -- seq ) - #! { aceg } { bdfh } -> { abcdefgh } - [ zip concat ] keep like ; - -: sha1-interleave ( string -- seq ) - [ zero? ] trim-head - dup length odd? [ rest ] when - seq>2seq [ sha1 checksum-bytes ] bi@ - 2seq>seq ; diff --git a/basis/checksums/sha1/summary.txt b/basis/checksums/sha1/summary.txt deleted file mode 100644 index d8da1df0aa..0000000000 --- a/basis/checksums/sha1/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA1 checksum algorithm diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 010ca96d4f..fa01796ae9 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -5,6 +5,13 @@ IN: checksums.sha2.tests : test-checksum ( text identifier -- checksum ) checksum-bytes hex-string ; +[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test +[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test +! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... +[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" +10 swap concat sha1 checksum-bytes hex-string ] unit-test + + [ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 8992299db0..6c799d7e6e 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,15 +3,39 @@ USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators -accessors locals checksums.stream multiline ; +accessors locals checksums.stream multiline literals +generalizations ; IN: checksums.sha2 +SINGLETON: sha1 +INSTANCE: sha1 stream-checksum + SINGLETON: sha-224 SINGLETON: sha-256 INSTANCE: sha-224 stream-checksum INSTANCE: sha-256 stream-checksum +TUPLE: sha1-state < checksum-state K H W word-size ; + +CONSTANT: initial-H-sha1 + { + HEX: 67452301 + HEX: efcdab89 + HEX: 98badcfe + HEX: 10325476 + HEX: c3d2e1f0 + } + +CONSTANT: K-sha1 + $[ + 20 HEX: 5a827999 + 20 HEX: 6ed9eba1 + 20 HEX: 8f1bbcdc + 20 HEX: ca62c1d6 + 4 { } nappend-as + ] + TUPLE: sha2-state < checksum-state K H word-size ; TUPLE: sha2-short < sha2-state ; @@ -121,6 +145,13 @@ CONSTANT: K-384 ALIAS: K-512 K-384 +: ( -- sha1-state ) + sha1-state new-checksum-state + 64 >>block-size + K-sha1 >>K + initial-H-sha1 >>H + 4 >>word-size ; + : ( -- sha2-state ) sha-224-state new-checksum-state 64 >>block-size @@ -135,6 +166,8 @@ ALIAS: K-512 K-384 initial-H-256 >>H 4 >>word-size ; +M: sha1 initialize-checksum-state drop ; + M: sha-224 initialize-checksum-state drop ; M: sha-256 initialize-checksum-state drop ; @@ -224,9 +257,6 @@ M: sha-256 initialize-checksum-state drop ; GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) -: seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; - :: T1-256 ( n M H sha2 -- T1 ) n M nth n sha2 K>> nth + @@ -272,12 +302,18 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) cloned-H T2-256 cloned-H update-H ] each - cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline + sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline M: sha2-short checksum-block [ prepare-message-schedule ] [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +: sha1>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; + : sha-224>checksum ( sha2 -- bytes ) H>> 7 head 4 seq>byte-array ; @@ -305,3 +341,71 @@ M: sha-224 checksum-stream ( stream checksum -- byte-array ) M: sha-256 checksum-stream ( stream checksum -- byte-array ) drop [ ] dip add-checksum-stream get-checksum ; + + + +: sha1-W ( t seq -- ) + { + [ [ 3 - ] dip nth ] + [ [ 8 - ] dip nth bitxor ] + [ [ 14 - ] dip nth bitxor ] + [ [ 16 - ] dip nth bitxor 1 bitroll-32 ] + [ ] + } 2cleave set-nth ; + +: prepare-sha1-message-schedule ( seq -- w-seq ) + 4 [ be> ] map + 80 0 pad-tail 16 80 [a,b) over + '[ _ sha1-W ] each ; inline + +: sha1-f ( B C D n -- f_nbcd ) + 20 /i + { + { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] } + { 1 [ bitxor bitxor ] } + { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } + { 3 [ bitxor bitxor ] } + } case ; + +:: inner-loop ( n H W K -- temp ) + a H nth :> A + b H nth :> B + c H nth :> C + d H nth :> D + e H nth :> E + [ + A 5 bitroll-32 + + B C D n sha1-f + + E + + n K nth + + n W nth + ] sum-outputs 32 bits ; + +:: process-sha1-chunk ( bytes H W K state -- ) + 80 [ + H W K inner-loop + d H nth e H set-nth + c H nth d H set-nth + b H nth 30 bitroll-32 c H set-nth + a H nth b H set-nth + a H set-nth + ] each + state [ H [ w+ ] 2map ] change-H drop ; inline + +M:: sha1-state checksum-block ( bytes state -- ) + bytes prepare-sha1-message-schedule state (>>W) + + bytes + state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ; + +M: sha1-state get-checksum + clone + [ pad-last-short-block ] [ sha-256>checksum ] bi ; + +M: sha1 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; From acf52363a783da5198cf3891a9d4f45f45e8e7f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 17:58:36 -0500 Subject: [PATCH 087/228] move sha1 and sha2 to checksums.sha, update usages --- basis/checksums/hmac/hmac-tests.factor | 3 +-- basis/checksums/hmac/hmac.factor | 7 +++---- .../interleave/interleave-tests.factor | 2 +- basis/checksums/openssl/openssl-docs.factor | 2 +- basis/checksums/{sha2 => sha}/authors.txt | 0 basis/checksums/sha/sha-docs.factor | 18 ++++++++++++++++++ .../sha2-tests.factor => sha/sha-tests.factor} | 4 ++-- .../{sha2/sha2.factor => sha/sha.factor} | 2 +- basis/checksums/sha/summary.txt | 1 + basis/checksums/sha2/sha2-docs.factor | 11 ----------- basis/checksums/sha2/summary.txt | 1 - basis/furnace/auth/auth-docs.factor | 2 +- basis/furnace/auth/auth.factor | 2 +- basis/uuid/uuid.factor | 3 +-- core/checksums/checksums-docs.factor | 3 +-- extra/benchmark/sha1/sha1.factor | 2 +- extra/ecdsa/ecdsa-tests.factor | 4 ++-- 17 files changed, 35 insertions(+), 32 deletions(-) rename basis/checksums/{sha2 => sha}/authors.txt (100%) create mode 100644 basis/checksums/sha/sha-docs.factor rename basis/checksums/{sha2/sha2-tests.factor => sha/sha-tests.factor} (97%) rename basis/checksums/{sha2/sha2.factor => sha/sha.factor} (99%) create mode 100644 basis/checksums/sha/summary.txt delete mode 100644 basis/checksums/sha2/sha2-docs.factor delete mode 100644 basis/checksums/sha2/summary.txt diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 02dfc271a4..ffae146614 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,5 +1,5 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser checksums.hmac tools.test checksums.md5 checksums.sha2 +parser checksums.hmac tools.test checksums.md5 checksums.sha checksums ; IN: checksums.hmac.tests @@ -46,4 +46,3 @@ IN: checksums.hmac.tests "JefeJefeJefeJefeJefeJefeJefeJefe" "what do ya want for nothing?" sha-256 hmac-bytes hex-string ] unit-test - diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 538dfc92c8..b163766016 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays checksums checksums.md5 checksums.md5.private -checksums.sha1 combinators fry io io.binary io.encodings.binary -io.files io.streams.byte-array kernel math math.vectors memoize -sequences locals accessors ; +USING: accessors arrays checksums combinators fry io io.binary +io.encodings.binary io.files io.streams.byte-array kernel +locals math math.vectors memoize sequences ; IN: checksums.hmac byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } "If we use the Factor implementation, we get the same result, just slightly slower:" -{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; +{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; ABOUT: "checksums.openssl" diff --git a/basis/checksums/sha2/authors.txt b/basis/checksums/sha/authors.txt similarity index 100% rename from basis/checksums/sha2/authors.txt rename to basis/checksums/sha/authors.txt diff --git a/basis/checksums/sha/sha-docs.factor b/basis/checksums/sha/sha-docs.factor new file mode 100644 index 0000000000..780c2b39d8 --- /dev/null +++ b/basis/checksums/sha/sha-docs.factor @@ -0,0 +1,18 @@ +USING: help.markup help.syntax ; +IN: checksums.sha + +HELP: sha-224 +{ $class-description "SHA-224 checksum algorithm." } ; + +HELP: sha-256 +{ $class-description "SHA-256 checksum algorithm." } ; + +ARTICLE: "checksums.sha" "SHA-2 checksum" +"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl +"SHA-2 checksums:" +{ $subsection sha-224 } +{ $subsection sha-256 } +"SHA-1 checksum:" +{ $subsection sha1 } ; + +ABOUT: "checksums.sha" diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha/sha-tests.factor similarity index 97% rename from basis/checksums/sha2/sha2-tests.factor rename to basis/checksums/sha/sha-tests.factor index fa01796ae9..b70b5e7ba2 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha/sha-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel math namespaces sequences tools.test -checksums.sha2 checksums ; -IN: checksums.sha2.tests +checksums.sha checksums ; +IN: checksums.sha.tests : test-checksum ( text identifier -- checksum ) checksum-bytes hex-string ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha/sha.factor similarity index 99% rename from basis/checksums/sha2/sha2.factor rename to basis/checksums/sha/sha.factor index 6c799d7e6e..287c39b2a1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha/sha.factor @@ -5,7 +5,7 @@ io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators accessors locals checksums.stream multiline literals generalizations ; -IN: checksums.sha2 +IN: checksums.sha SINGLETON: sha1 INSTANCE: sha1 stream-checksum diff --git a/basis/checksums/sha/summary.txt b/basis/checksums/sha/summary.txt new file mode 100644 index 0000000000..2dd351af0b --- /dev/null +++ b/basis/checksums/sha/summary.txt @@ -0,0 +1 @@ +SHA checksum algorithms diff --git a/basis/checksums/sha2/sha2-docs.factor b/basis/checksums/sha2/sha2-docs.factor deleted file mode 100644 index 6a128552fd..0000000000 --- a/basis/checksums/sha2/sha2-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: help.markup help.syntax ; -IN: checksums.sha2 - -HELP: sha-256 -{ $class-description "SHA-256 checksum algorithm." } ; - -ARTICLE: "checksums.sha2" "SHA2 checksum" -"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong." -{ $subsection sha-256 } ; - -ABOUT: "checksums.sha2" diff --git a/basis/checksums/sha2/summary.txt b/basis/checksums/sha2/summary.txt deleted file mode 100644 index 04365d439f..0000000000 --- a/basis/checksums/sha2/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA2 checksum algorithm diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index 3f1bcb6085..efd6a52ef0 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -1,6 +1,6 @@ USING: assocs classes help.markup help.syntax kernel quotations strings words words.symbol furnace.auth.providers.db -checksums.sha2 furnace.auth.providers math byte-arrays +checksums.sha furnace.auth.providers math byte-arrays http multiline ; IN: furnace.auth diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index b9c961941c..831ec7f8fc 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -3,7 +3,7 @@ USING: accessors assocs namespaces kernel sequences sets destructors combinators fry logging io.encodings.utf8 io.encodings.string io.binary random -checksums checksums.sha2 urls +checksums checksums.sha urls html.forms http.server http.server.filters diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 2fd6ffdaec..4d284a1a40 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license - -USING: byte-arrays checksums checksums.md5 checksums.sha1 +USING: byte-arrays checksums checksums.md5 checksums.sha kernel math math.parser math.ranges random unicode.case sequences strings system io.binary ; diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index 6ef0e85025..a05bf3a685 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -47,8 +47,7 @@ $nl "Checksum implementations:" { $subsection "checksums.crc32" } { $vocab-subsection "MD5 checksum" "checksums.md5" } -{ $vocab-subsection "SHA1 checksum" "checksums.sha1" } -{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } +{ $vocab-subsection "SHA checksums" "checksums.sha" } { $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } { $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ; diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index c1a7af2966..481bc31eb2 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,4 +1,4 @@ -USING: checksums checksums.sha1 sequences byte-arrays kernel ; +USING: checksums checksums.sha sequences byte-arrays kernel ; IN: benchmark.sha1 : sha1-file ( -- ) diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor index b319fa297b..2d9cda1460 100644 --- a/extra/ecdsa/ecdsa-tests.factor +++ b/extra/ecdsa/ecdsa-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Maxim Savchenko ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces ecdsa tools.test checksums checksums.sha2 ; +USING: namespaces ecdsa tools.test checksums checksums.sha ; IN: ecdsa.tests SYMBOLS: priv-key pub-key signature ; @@ -27,4 +27,4 @@ SYMBOLS: priv-key pub-key signature ; message sha-256 checksum-bytes signature get pub-key get "prime256v1" [ set-public-key ecdsa-verify ] with-ec -] unit-test \ No newline at end of file +] unit-test From 31e5090892a6eb3e507268d8b5a0973bb11f9167 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 18:05:46 -0500 Subject: [PATCH 088/228] fix multiple using warning in stage1, core can't use io.encodings.binary --- core/bootstrap/stage1.factor | 8 ++++---- core/checksums/checksums.factor | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 088a8a6320..c7be17e38d 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays debugger generic hashtables io assocs kernel.private -kernel math memory namespaces make parser prettyprint sequences -vectors words system splitting init io.files vocabs vocabs.loader -debugger continuations ; +USING: arrays assocs continuations debugger generic hashtables +init io io.files kernel kernel.private make math memory +namespaces parser prettyprint sequences splitting system +vectors vocabs vocabs.loader words ; QUALIFIED: bootstrap.image.private IN: bootstrap.stage1 diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 1d57823e18..9d40521fc8 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors io.encodings.binary quotations ; +sequences vectors quotations ; IN: checksums MIXIN: checksum @@ -39,7 +39,7 @@ GENERIC: get-checksum ( checksum -- value ) ] with-input-stream ; : add-checksum-file ( checksum-state path -- checksum-state ) - binary add-checksum-stream ; + normalize-path (file-reader) add-checksum-stream ; GENERIC: checksum-bytes ( bytes checksum -- value ) From c4162971e00060d5d2f7be90bd066f5099d18029 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 May 2009 18:18:07 -0500 Subject: [PATCH 089/228] callstack>array was keeping an uninitialized array around across potential GCs; add more assertions --- vm/callstack.cpp | 15 +++++++++------ vm/local_roots.hpp | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 4ef6db10bd..608a5c39e5 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -92,7 +92,9 @@ cell frame_executing(stack_frame *frame) else { array *literals = untag(compiled->literals); - return array_nth(literals,0); + cell executing = array_nth(literals,0); + check_data_pointer((object *)executing); + return executing; } } @@ -102,6 +104,7 @@ stack_frame *frame_successor(stack_frame *frame) return (stack_frame *)((cell)frame - frame->size); } +/* Allocates memory */ cell frame_scan(stack_frame *frame) { if(frame_type(frame) == QUOTATION_TYPE) @@ -133,12 +136,12 @@ struct stack_frame_counter { struct stack_frame_accumulator { cell index; - array *frames; - stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal(count)) {} + gc_root frames; + stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {} void operator()(stack_frame *frame) { - set_array_nth(frames,index++,frame_executing(frame)); - set_array_nth(frames,index++,frame_scan(frame)); + set_array_nth(frames.untagged(),index++,frame_executing(frame)); + set_array_nth(frames.untagged(),index++,frame_scan(frame)); } }; @@ -154,7 +157,7 @@ PRIMITIVE(callstack_to_array) stack_frame_accumulator accum(counter.count); iterate_callstack_object(callstack.untagged(),accum); - dpush(tag(accum.frames)); + dpush(accum.frames.value()); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index e074d999e7..4cee1c8e09 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -12,7 +12,7 @@ DEFPUSHPOP(gc_local_,gc_locals) template struct gc_root : public tagged { - void push() { gc_local_push((cell)this); } + void push() { check_tagged_pointer(tagged::value()); gc_local_push((cell)this); } explicit gc_root(cell value_) : tagged(value_) { push(); } explicit gc_root(T *value_) : tagged(value_) { push(); } From a469f78fa7ff76089036de8518e3b20e60617007 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 18:41:15 -0500 Subject: [PATCH 090/228] add some unit tests testing get-checksum --- basis/checksums/sha/sha-tests.factor | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/basis/checksums/sha/sha-tests.factor b/basis/checksums/sha/sha-tests.factor index b70b5e7ba2..be431af311 100644 --- a/basis/checksums/sha/sha-tests.factor +++ b/basis/checksums/sha/sha-tests.factor @@ -1,5 +1,6 @@ -USING: arrays kernel math namespaces sequences tools.test -checksums.sha checksums ; +USING: arrays checksums checksums.sha checksums.sha.private +io.encodings.binary io.streams.byte-array kernel math +namespaces sequences tools.test ; IN: checksums.sha.tests : test-checksum ( text identifier -- checksum ) @@ -45,3 +46,25 @@ IN: checksums.sha.tests ! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] ! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + From 9c85bc8ce33309345a8e095cd5254c1697ad8cf8 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 17 May 2009 20:29:32 -0500 Subject: [PATCH 091/228] fix duplicate using lines --- basis/cpu/x86/64/64.factor | 2 +- basis/io/backend/windows/windows.factor | 6 +++--- core/classes/predicate/predicate-docs.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index ad1b487e44..b77539b7e7 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.structs -slots splitting assocs combinators make locals cpu.x86.assembler +slots splitting assocs combinators locals cpu.x86.assembler cpu.x86 cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 9f5c00cc5f..2e9aac2ac9 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.ports io.binary io.timeouts system -windows.errors strings kernel math namespaces sequences -windows.errors windows.kernel32 windows.shell32 windows.types -windows.winsock splitting continuations math.bitwise accessors ; +strings kernel math namespaces sequences windows.errors +windows.kernel32 windows.shell32 windows.types windows.winsock +splitting continuations math.bitwise accessors ; IN: io.backend.windows : set-inherit ( handle ? -- ) diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index 3ea0a24674..552ff209b8 100644 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -1,6 +1,6 @@ USING: generic help.markup help.syntax kernel kernel.private namespaces sequences words arrays layouts help effects math -layouts classes.private classes compiler.units ; +classes.private classes compiler.units ; IN: classes.predicate ARTICLE: "predicates" "Predicate classes" From 1505da918f201095d30faff7e38274cee7586e49 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 20:32:43 -0500 Subject: [PATCH 092/228] fix checksum test -- short circuit so correct error is reported --- basis/checksums/openssl/openssl-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/checksums/openssl/openssl-tests.factor b/basis/checksums/openssl/openssl-tests.factor index 253069c952..2a160e1486 100644 --- a/basis/checksums/openssl/openssl-tests.factor +++ b/basis/checksums/openssl/openssl-tests.factor @@ -1,6 +1,6 @@ +USING: accessors byte-arrays checksums checksums.openssl +combinators.short-circuit kernel system tools.test ; IN: checksums.openssl.tests -USING: byte-arrays checksums.openssl checksums tools.test -accessors kernel system ; [ B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } @@ -22,7 +22,7 @@ accessors kernel system ; "Bad checksum test" >byte-array "no such checksum" checksum-bytes -] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ] +] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ] must-fail-with [ ] [ image openssl-sha1 checksum-file drop ] unit-test From 13a4c5b25a9bd5449e920569e1ada566dc6a961c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 May 2009 23:39:05 -0500 Subject: [PATCH 093/228] tools.disassembler.gdb: remove redundant using --- basis/tools/disassembler/gdb/gdb.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor index 9076b67606..c4c724b696 100755 --- a/basis/tools/disassembler/gdb/gdb.factor +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! See http://factorcode.org/license.txt for BSD license. USING: io.files io.files.temp io words alien kernel math.parser -alien.syntax io.launcher system assocs arrays sequences +alien.syntax io.launcher assocs arrays sequences namespaces make system math io.encodings.ascii accessors tools.disassembler ; IN: tools.disassembler.gdb From 46eae05d1088b40de5aa4043f2f3eea705608011 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 00:24:24 -0500 Subject: [PATCH 094/228] add nth-unsafe to sequences.private, making md5 faster --- basis/checksums/md5/md5.factor | 42 +++++++++++++++++---------------- core/checksums/checksums.factor | 14 ++++++----- core/sequences/sequences.factor | 3 +++ 3 files changed, 33 insertions(+), 26 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 026df34012..89ff5d46a2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -4,7 +4,8 @@ USING: kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry io.encodings.binary math.bitwise checksums accessors -checksums.common checksums.stream combinators combinators.smart ; +checksums.common checksums.stream combinators combinators.smart +specialized-arrays.uint literals ; IN: checksums.md5 SINGLETON: md5 @@ -16,7 +17,7 @@ TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) md5-state new-checksum-state 64 >>block-size - { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; M: md5 initialize-checksum-state drop ; @@ -29,8 +30,10 @@ M: md5 initialize-checksum-state drop ; [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri [ (>>old-state) ] [ (>>state) ] bi ; inline -: T ( N -- Y ) - sin abs 32 2^ * >integer ; inline +CONSTANT: T + $[ + 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as + ] :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -70,22 +73,22 @@ CONSTANT: b 1 CONSTANT: c 2 CONSTANT: d 3 -:: (ABCD) ( x V a b c d k s i quot -- ) +:: (ABCD) ( x state a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a V [ - b V nth - c V nth - d V nth quot call w+ - k x nth w+ - i T w+ + a state [ + b state nth-unsafe + c state nth-unsafe + d state nth-unsafe quot call w+ + k x nth-unsafe w+ + i T nth-unsafe w+ s bitroll-32 - b V nth w+ - ] change-nth ; inline + b state nth-unsafe w+ 32 bits + ] change-nth-unsafe ; inline MACRO: with-md5-round ( ops quot -- ) '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; -: (process-md5-block-F) ( block v -- ) +: (process-md5-block-F) ( block state -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -105,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 15 S14 16 ] } [ F ] with-md5-round ; inline -: (process-md5-block-G) ( block v -- ) +: (process-md5-block-G) ( block state -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -125,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 12 S24 32 ] } [ G ] with-md5-round ; inline -: (process-md5-block-H) ( block v -- ) +: (process-md5-block-H) ( block state -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -145,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 2 S34 48 ] } [ H ] with-md5-round ; inline -: (process-md5-block-I) ( block v -- ) +: (process-md5-block-I) ( block state -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -167,7 +170,7 @@ MACRO: with-md5-round ( ops quot -- ) M: md5-state checksum-block ( block state -- ) [ - [ 4 [ le> ] map ] [ state>> ] bi* { + [ byte-array>uint-array ] [ state>> ] bi* { [ (process-md5-block-F) ] [ (process-md5-block-G) ] [ (process-md5-block-H) ] @@ -177,8 +180,7 @@ M: md5-state checksum-block ( block state -- ) nip update-md5 ] 2bi ; -: md5>checksum ( md5 -- bytes ) - state>> [ 4 >le ] map B{ } concat-as ; +: md5>checksum ( md5 -- bytes ) state>> underlying>> ; M: md5-state clone ( md5 -- new-md5 ) call-next-method diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 9d40521fc8..0dd808c722 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,17 +1,17 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors quotations ; +sequences byte-arrays byte-vectors quotations ; IN: checksums MIXIN: checksum -TUPLE: checksum-state bytes-read block-size bytes ; +TUPLE: checksum-state + { bytes-read integer } { block-size integer } { bytes byte-vector } ; : new-checksum-state ( class -- checksum-state ) new - 0 >>bytes-read - V{ } clone >>bytes ; inline + BV{ } clone >>bytes ; inline M: checksum-state clone call-next-method @@ -27,11 +27,13 @@ GENERIC: get-checksum ( checksum -- value ) over bytes>> [ push-all ] keep [ dup length pick block-size>> >= ] [ - 64 cut-slice [ + 64 cut-slice [ >byte-array ] dip [ over [ checksum-block ] [ [ 64 + ] change-bytes-read drop ] bi ] dip - ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; + ] while + >byte-vector + [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; : add-checksum-stream ( checksum-state stream -- checksum-state ) [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 99dddb8aed..9b0f4c1530 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ; M: sequence nth-unsafe nth ; M: sequence set-nth-unsafe set-nth ; +: change-nth-unsafe ( i seq quot -- ) + [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline + ! The f object supports the sequence protocol trivially M: f length drop 0 ; M: f nth-unsafe nip ; From 96ade23963c6f7dcda4984ad28069943deca0e98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:16:03 -0500 Subject: [PATCH 095/228] median used the wrong algorithm. now it runs in O(n) time. add kth-smallest word, used to implement median --- basis/math/statistics/statistics-tests.factor | 18 ++++++ basis/math/statistics/statistics.factor | 58 ++++++++++++++++--- 2 files changed, 67 insertions(+), 9 deletions(-) diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index b6ff421956..c160d57db7 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -13,6 +13,24 @@ IN: math.statistics.tests [ 2 ] [ { 1 2 3 } median ] unit-test [ 5/2 ] [ { 1 2 3 4 } median ] unit-test +[ { } median ] must-fail +[ { } upper-median ] must-fail +[ { } lower-median ] must-fail + +[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test +[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test + + +[ 1 ] [ { 1 } lower-median ] unit-test +[ 1 ] [ { 1 } upper-median ] unit-test +[ 1 ] [ { 1 } median ] unit-test + +[ 1 ] [ { 1 2 } lower-median ] unit-test +[ 2 ] [ { 1 2 } upper-median ] unit-test +[ 3/2 ] [ { 1 2 } median ] unit-test + [ 1 ] [ { 1 2 3 } var ] unit-test [ 1.0 ] [ { 1 2 3 } std ] unit-test [ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 4cd8c5b888..5b0439906c 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman, Michael Judge. ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators kernel math math.analysis -math.functions math.order sequences sorting ; +math.functions math.order sequences sorting locals +sequences.private ; IN: math.statistics : mean ( seq -- n ) @@ -13,13 +14,55 @@ IN: math.statistics : harmonic-mean ( seq -- n ) [ recip ] sigma recip ; -: median ( seq -- n ) +: slow-median ( seq -- n ) natural-sort dup length even? [ [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; +:: kth-smallest ( seq k -- elt ) + #! Wirth's method, Algorithm's + Data structues = Programs p. 84 + #! The algorithm modifiers seq, so we clone it + seq clone :> seq + 0 :> i! + 0 :> j! + 0 :> l! + 0 :> x! + seq length 1 - :> m! + [ l m < ] + [ + k seq nth x! + l i! + m j! + [ i j <= ] + [ + [ i seq nth-unsafe x < ] [ i 1 + i! ] while + [ x j seq nth-unsafe < ] [ j 1 - j! ] while + i j <= [ + i j seq exchange + i 1 + i! + j 1 - j! + ] when + ] do while + + j k < [ i l! ] when + k i < [ j m! ] when + ] while + k seq nth ; inline + +: lower-median ( seq -- elt ) + dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ; + +: upper-median ( seq -- elt ) + dup midpoint@ kth-smallest ; + +: medians ( seq -- lower upper ) + [ lower-median ] [ upper-median ] bi ; + +: median ( seq -- x ) + dup length odd? [ lower-median ] [ medians + 2 / ] if ; + : minmax ( seq -- min max ) #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; @@ -32,15 +75,13 @@ IN: math.statistics dup length 1 <= [ drop 0 ] [ - [ [ mean ] keep [ - sq ] with sigma ] keep - length 1 - / + [ [ mean ] keep [ - sq ] with sigma ] + [ length 1 - ] bi / ] if ; -: std ( seq -- x ) - var sqrt ; +: std ( seq -- x ) var sqrt ; -: ste ( seq -- x ) - [ std ] [ length ] bi sqrt / ; +: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ; : ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) ! finds sigma((xi-mean(x))(yi-mean(y)) @@ -64,4 +105,3 @@ IN: math.statistics [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy swap / * ! stack is mean(x) mean(y) beta [ swapd * - ] keep ; - From 82fa71a03a5c4faf5324d90fcbdf21b693b9609c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:41:58 -0500 Subject: [PATCH 096/228] remove old median, fix docs --- basis/math/statistics/statistics-docs.factor | 10 +++++----- basis/math/statistics/statistics.factor | 15 ++++----------- 2 files changed, 9 insertions(+), 16 deletions(-) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 7a7eb70dd2..1a29d611f9 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ; IN: math.statistics HELP: geometric-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } } { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ; HELP: harmonic-mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." } { $notes "Positive reals only." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: mean -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } } { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: median -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" } @@ -29,7 +29,7 @@ HELP: median { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ; HELP: range -{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} } +{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} } { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." } { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" } diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 5b0439906c..3812e79ec5 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -5,22 +5,15 @@ math.functions math.order sequences sorting locals sequences.private ; IN: math.statistics -: mean ( seq -- n ) +: mean ( seq -- x ) [ sum ] [ length ] bi / ; -: geometric-mean ( seq -- n ) +: geometric-mean ( seq -- x ) [ length ] [ product ] bi nth-root ; -: harmonic-mean ( seq -- n ) +: harmonic-mean ( seq -- x ) [ recip ] sigma recip ; -: slow-median ( seq -- n ) - natural-sort dup length even? [ - [ midpoint@ dup 1 - 2array ] keep nths mean - ] [ - [ midpoint@ ] keep nth - ] if ; - :: kth-smallest ( seq k -- elt ) #! Wirth's method, Algorithm's + Data structues = Programs p. 84 #! The algorithm modifiers seq, so we clone it @@ -67,7 +60,7 @@ IN: math.statistics #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; -: range ( seq -- n ) +: range ( seq -- x ) minmax swap - ; : var ( seq -- x ) From 2b66d3d74339a8f3aec87878b5e7164dd5150761 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 18 May 2009 10:31:05 -0500 Subject: [PATCH 097/228] factor out grid mesh generation in terrain to its own vocab --- extra/grid-meshes/grid-meshes.factor | 48 ++++++++++++++++++++++++++++ extra/terrain/authors.txt | 2 ++ extra/terrain/summary.txt | 1 + extra/terrain/terrain.factor | 44 ++++--------------------- 4 files changed, 58 insertions(+), 37 deletions(-) create mode 100644 extra/grid-meshes/grid-meshes.factor create mode 100644 extra/terrain/authors.txt create mode 100644 extra/terrain/summary.txt diff --git a/extra/grid-meshes/grid-meshes.factor b/extra/grid-meshes/grid-meshes.factor new file mode 100644 index 0000000000..19c4568b7c --- /dev/null +++ b/extra/grid-meshes/grid-meshes.factor @@ -0,0 +1,48 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays destructors kernel math opengl +opengl.gl sequences sequences.product specialized-arrays.float ; +IN: grid-meshes + +TUPLE: grid-mesh dim buffer row-length ; + +vertex-buffer ( bytes -- buffer ) + [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; + +: draw-vertex-buffer-row ( grid-mesh i -- ) + swap [ GL_TRIANGLE_STRIP ] 2dip + row-length>> [ * ] keep + glDrawArrays ; + +PRIVATE> + +: draw-grid-mesh ( grid-mesh -- ) + GL_ARRAY_BUFFER over buffer>> [ + [ 3 GL_FLOAT 0 f glVertexPointer ] dip + dup dim>> second iota [ draw-vertex-buffer-row ] with each + ] with-gl-buffer ; + +: ( dim -- grid-mesh ) + [ ] [ vertex-array >vertex-buffer ] [ first 1 + 2 * ] tri + grid-mesh boa ; + +M: grid-mesh dispose + [ [ delete-gl-buffer ] when* f ] change-buffer + drop ; + diff --git a/extra/terrain/authors.txt b/extra/terrain/authors.txt new file mode 100644 index 0000000000..0bc3c5ad4d --- /dev/null +++ b/extra/terrain/authors.txt @@ -0,0 +1,2 @@ +Joe Groff +Doug Coleman diff --git a/extra/terrain/summary.txt b/extra/terrain/summary.txt new file mode 100644 index 0000000000..3244803592 --- /dev/null +++ b/extra/terrain/summary.txt @@ -0,0 +1 @@ +Walk around on procedurally generated terrain diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index cfacfeb700..5847426fae 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff, Doug Coleman. bsd license USING: accessors arrays combinators game-input game-loop game-input.scancodes grouping kernel literals locals math math.constants math.functions math.matrices math.order @@ -6,7 +7,8 @@ opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game-worlds method-chains -math.affine-transforms noise ui.gestures combinators.short-circuit ; +math.affine-transforms noise ui.gestures combinators.short-circuit +destructors grid-meshes ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -26,8 +28,6 @@ CONSTANT: SKY-PERIOD 1200 CONSTANT: SKY-SPEED 0.0005 CONSTANT: terrain-vertex-size { 512 512 } -CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } -CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player location yaw pitch velocity velocity-modifier @@ -37,7 +37,7 @@ TUPLE: terrain-world < game-world player sky-image sky-texture sky-program terrain terrain-segment terrain-texture terrain-program - terrain-vertex-buffer + terrain-mesh history ; : ( -- player ) @@ -65,35 +65,6 @@ M: terrain-world tick-length [ yaw>> 0.0 1.0 0.0 glRotatef ] [ location>> vneg first3 glTranslatef ] tri ; -: vertex-array-vertex ( x z -- vertex ) - [ terrain-vertex-distance first * ] - [ terrain-vertex-distance second * ] bi* - [ 0 ] dip float-array{ } 3sequence ; - -: vertex-array-row ( z -- vertices ) - dup 1 + 2array - terrain-vertex-size first 1 + iota - 2array [ first2 swap vertex-array-vertex ] product-map - concat ; - -: vertex-array ( -- vertices ) - terrain-vertex-size second iota - [ vertex-array-row ] map concat ; - -: >vertex-buffer ( bytes -- buffer ) - [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; - -: draw-vertex-buffer-row ( i -- ) - [ GL_TRIANGLE_STRIP ] dip - terrain-vertex-row-length * terrain-vertex-row-length - glDrawArrays ; - -: draw-vertex-buffer ( buffer -- ) - [ GL_ARRAY_BUFFER ] dip [ - 3 GL_FLOAT 0 f glVertexPointer - terrain-vertex-size second iota [ draw-vertex-buffer-row ] each - ] with-gl-buffer ; - : degrees ( deg -- rad ) pi 180.0 / * ; @@ -119,7 +90,6 @@ M: terrain-world tick-length : clamp-pitch ( pitch -- pitch' ) 90.0 min -90.0 max ; - : walk-forward ( player -- ) dup forward-vector [ v+ ] curry change-velocity drop ; : walk-backward ( player -- ) @@ -274,12 +244,12 @@ BEFORE: terrain-world begin-world >>sky-program terrain-vertex-shader terrain-pixel-shader >>terrain-program - vertex-array >vertex-buffer >>terrain-vertex-buffer + terrain-vertex-size >>terrain-mesh drop ; AFTER: terrain-world end-world { - [ terrain-vertex-buffer>> delete-gl-buffer ] + [ terrain-mesh>> dispose ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] [ sky-program>> delete-gl-program ] @@ -306,7 +276,7 @@ M: terrain-world draw-world* [ GL_DEPTH_TEST glEnable dup terrain-program>> [ [ "heightmap" glGetUniformLocation 0 glUniform1i ] [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi - terrain-vertex-buffer>> draw-vertex-buffer + terrain-mesh>> draw-grid-mesh ] with-gl-program ] } cleave gl-error ; From 4ca7ce8657f527feabbff773ab9efec4327e9592 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 12:27:04 -0500 Subject: [PATCH 098/228] llines was broken. it still probably is -- what if the stream throws an exception? cleanup some old code --- basis/lists/lazy/lazy-tests.factor | 6 +- basis/lists/lazy/lazy.factor | 127 +++++++++++++---------------- basis/promises/promises.factor | 4 +- 3 files changed, 62 insertions(+), 75 deletions(-) diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index f4e55cba19..8fb638b856 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: lists lists.lazy tools.test kernel math io sequences ; +USING: io io.encodings.utf8 io.files kernel lists lists.lazy +math sequences tools.test ; IN: lists.lazy.tests [ { 1 2 3 4 } ] [ @@ -33,3 +34,6 @@ IN: lists.lazy.tests [ [ drop ] foldl ] must-infer [ [ drop ] leach ] must-infer [ lnth ] must-infer + +[ ] [ "resource:license.txt" utf8 llines list>array drop ] unit-test +[ ] [ "resource:license.txt" utf8 lcontents list>array drop ] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 49aee471bf..bde26e2fb9 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors ; +USING: accessors arrays combinators io kernel lists math +promises quotations sequences summary vectors ; IN: lists.lazy M: promise car ( promise -- car ) @@ -10,16 +10,16 @@ M: promise car ( promise -- car ) M: promise cdr ( promise -- cdr ) force cdr ; -M: promise nil? ( cons -- bool ) +M: promise nil? ( cons -- ? ) force nil? ; - + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; : lazy-cons ( car cdr -- promise ) - [ promise ] bi@ \ lazy-cons boa - T{ promise f f t f } clone - swap >>value ; + [ T{ promise f f t f } clone ] 2dip + [ promise ] bi@ \ lazy-cons boa + >>value ; M: lazy-cons car ( lazy-cons -- car ) car>> force ; @@ -27,7 +27,7 @@ M: lazy-cons car ( lazy-cons -- car ) M: lazy-cons cdr ( lazy-cons -- cdr ) cdr>> force ; -M: lazy-cons nil? ( lazy-cons -- bool ) +M: lazy-cons nil? ( lazy-cons -- ? ) nil eq? ; : 1lazy-list ( a -- lazy-cons ) @@ -41,11 +41,9 @@ M: lazy-cons nil? ( lazy-cons -- bool ) TUPLE: memoized-cons original car cdr nil? ; -: not-memoized ( -- obj ) - { } ; +: not-memoized ( -- obj ) { } ; -: not-memoized? ( obj -- bool ) - not-memoized eq? ; +: not-memoized? ( obj -- ? ) not-memoized eq? ; : ( cons -- memoized-cons ) not-memoized not-memoized not-memoized @@ -65,7 +63,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr ) cdr>> ] if ; -M: memoized-cons nil? ( memoized-cons -- bool ) +M: memoized-cons nil? ( memoized-cons -- ? ) dup nil?>> not-memoized? [ dup original>> nil? [ >>nil? drop ] keep ] [ @@ -80,14 +78,12 @@ C: lazy-map over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ cons>> car ] keep - quot>> call( old -- new ) ; + [ cons>> car ] [ quot>> call( old -- new ) ] bi ; M: lazy-map cdr ( lazy-map -- cdr ) - [ cons>> cdr ] keep - quot>> lazy-map ; + [ cons>> cdr ] [ quot>> lazy-map ] bi ; -M: lazy-map nil? ( lazy-map -- bool ) +M: lazy-map nil? ( lazy-map -- ? ) cons>> nil? ; TUPLE: lazy-take n cons ; @@ -95,7 +91,7 @@ TUPLE: lazy-take n cons ; C: lazy-take : ltake ( n list -- result ) - over zero? [ 2drop nil ] [ ] if ; + over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) cons>> car ; @@ -104,12 +100,8 @@ M: lazy-take cdr ( lazy-take -- cdr ) [ n>> 1- ] keep cons>> cdr ltake ; -M: lazy-take nil? ( lazy-take -- bool ) - dup n>> zero? [ - drop t - ] [ - cons>> nil? - ] if ; +M: lazy-take nil? ( lazy-take -- ? ) + dup n>> zero? [ drop t ] [ cons>> nil? ] if ; TUPLE: lazy-until cons quot ; @@ -125,7 +117,7 @@ M: lazy-until cdr ( lazy-until -- cdr ) [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; -M: lazy-until nil? ( lazy-until -- bool ) +M: lazy-until nil? ( lazy-until -- ? ) drop f ; TUPLE: lazy-while cons quot ; @@ -141,7 +133,7 @@ M: lazy-while car ( lazy-while -- car ) M: lazy-while cdr ( lazy-while -- cdr ) [ cons>> cdr ] keep quot>> lwhile ; -M: lazy-while nil? ( lazy-while -- bool ) +M: lazy-while nil? ( lazy-while -- ? ) [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; @@ -167,7 +159,7 @@ M: lazy-filter cdr ( lazy-filter -- cdr ) dup skip cdr ] if ; -M: lazy-filter nil? ( lazy-filter -- bool ) +M: lazy-filter nil? ( lazy-filter -- ? ) dup cons>> nil? [ drop t ] [ @@ -189,10 +181,9 @@ M: lazy-append car ( lazy-append -- car ) list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ list1>> cdr ] keep - list2>> lappend ; + [ list1>> cdr ] [ list2>> ] bi lappend ; -M: lazy-append nil? ( lazy-append -- bool ) +M: lazy-append nil? ( lazy-append -- ? ) drop f ; TUPLE: lazy-from-by n quot ; @@ -209,7 +200,7 @@ M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep quot>> [ call( old -- new ) ] keep lfrom-by ; -M: lazy-from-by nil? ( lazy-from-by -- bool ) +M: lazy-from-by nil? ( lazy-from-by -- ? ) drop f ; TUPLE: lazy-zip list1 list2 ; @@ -226,14 +217,14 @@ M: lazy-zip car ( lazy-zip -- car ) M: lazy-zip cdr ( lazy-zip -- cdr ) [ list1>> cdr ] keep list2>> cdr lzip ; -M: lazy-zip nil? ( lazy-zip -- bool ) +M: lazy-zip nil? ( lazy-zip -- ? ) drop f ; TUPLE: sequence-cons index seq ; C: sequence-cons -: seq>list ( index seq -- list ) +: sequence-tail>list ( index seq -- list ) 2dup length >= [ 2drop nil ] [ @@ -241,21 +232,24 @@ C: sequence-cons ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ index>> ] keep - seq>> nth ; + [ index>> ] [ seq>> nth ] bi ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] keep - seq>> seq>list ; + [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ; -M: sequence-cons nil? ( sequence-cons -- bool ) +M: sequence-cons nil? ( sequence-cons -- ? ) drop f ; +ERROR: list-conversion-error object ; + +M: list-conversion-error summary + drop "Could not convert object to list" ; + : >list ( object -- list ) { - { [ dup sequence? ] [ 0 swap seq>list ] } - { [ dup list? ] [ ] } - [ "Could not convert object to a list" throw ] + { [ dup sequence? ] [ 0 swap sequence-tail>list ] } + { [ dup list? ] [ ] } + [ list-conversion-error ] } cond ; TUPLE: lazy-concat car cdr ; @@ -265,18 +259,10 @@ C: lazy-concat DEFER: lconcat : (lconcat) ( car cdr -- list ) - over nil? [ - nip lconcat - ] [ - - ] if ; + over nil? [ nip lconcat ] [ ] if ; : lconcat ( list -- result ) - dup nil? [ - drop nil - ] [ - uncons (lconcat) - ] if ; + dup nil? [ drop nil ] [ uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) car>> car ; @@ -284,12 +270,8 @@ M: lazy-concat car ( lazy-concat -- car ) M: lazy-concat cdr ( lazy-concat -- cdr ) [ car>> cdr ] keep cdr>> (lconcat) ; -M: lazy-concat nil? ( lazy-concat -- bool ) - dup car>> nil? [ - cdr>> nil? - ] [ - drop f - ] if ; +M: lazy-concat nil? ( lazy-concat -- ? ) + dup car>> nil? [ cdr>> nil? ] [ drop f ] if ; : lcartesian-product ( list1 list2 -- result ) swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; @@ -298,7 +280,9 @@ M: lazy-concat nil? ( lazy-concat -- bool ) dup nil? [ drop nil ] [ - [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ + [ car ] [ cdr ] bi + [ car lcartesian-product ] [ cdr ] bi + list>array swap [ swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; @@ -322,9 +306,9 @@ DEFER: lmerge : lmerge ( list1 list2 -- result ) { - { [ over nil? ] [ nip ] } - { [ dup nil? ] [ drop ] } - { [ t ] [ (lmerge) ] } + { [ over nil? ] [ nip ] } + { [ dup nil? ] [ drop ] } + { [ t ] [ (lmerge) ] } } cond ; TUPLE: lazy-io stream car cdr quot ; @@ -338,30 +322,29 @@ C: lazy-io f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup car>> dup [ + dup car>> [ nip ] [ - drop dup stream>> over quot>> - call( stream -- value ) - >>car - ] if ; + [ ] [ stream>> ] [ quot>> ] tri + call( stream -- value ) [ >>car ] [ drop nil ] if* + ] if* ; M: lazy-io cdr ( lazy-io -- cdr ) dup cdr>> dup [ nip ] [ drop dup - [ stream>> ] keep - [ quot>> ] keep - car [ + [ stream>> ] + [ quot>> ] + [ car ] tri [ [ f f ] dip [ >>cdr drop ] keep ] [ 3drop nil ] if ] if ; -M: lazy-io nil? ( lazy-io -- bool ) - car not ; +M: lazy-io nil? ( lazy-io -- ? ) + car nil? ; INSTANCE: sequence-cons list INSTANCE: memoized-cons list diff --git a/basis/promises/promises.factor b/basis/promises/promises.factor index c3951f46ba..cd98827206 100755 --- a/basis/promises/promises.factor +++ b/basis/promises/promises.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math arrays namespaces -parser effects generalizations fry words accessors ; +USING: accessors arrays effects fry generalizations kernel math +namespaces parser sequences words ; IN: promises TUPLE: promise quot forced? value ; From ce5fde3f24450190eff4fc3c0c93eab6cf44ca5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 16:17:11 -0500 Subject: [PATCH 099/228] fix lazy lists --- basis/lists/lazy/lazy-docs.factor | 8 ++++---- extra/parser-combinators/parser-combinators.factor | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index 0b1bfe2d02..e7401d6af1 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -33,7 +33,7 @@ ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists" { $subsection 1lazy-list } { $subsection 2lazy-list } { $subsection 3lazy-list } -{ $subsection seq>list } +{ $subsection sequence-tail>list } { $subsection >list } { $subsection lfrom } ; @@ -105,15 +105,15 @@ HELP: lfrom { $values { "n" "an integer" } { "list" "a lazy list of integers" } } { $description "Return an infinite lazy list of incrementing integers starting from n." } ; -HELP: seq>list +HELP: sequence-tail>list { $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } } { $description "Convert the sequence into a list, starting from " { $snippet "index" } "." } { $see-also >list } ; HELP: >list { $values { "object" "an object" } { "list" "a list" } } -{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } -{ $see-also seq>list } ; +{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link sequence-tail>list } " and other objects cause an error to be thrown." } +{ $see-also sequence-tail>list } ; { leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 030d0a2a73..814821fba9 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -172,7 +172,7 @@ M: or-parser parse ( input parser1 -- list ) #! Return the combined list resulting from the parses #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. - parsers>> 0 swap seq>list + parsers>> sequence>list [ parse ] with lazy-map lconcat ; : trim-head-slice ( string -- string ) From 08db84fe428301c82cd852a90cc6a94a950f58ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 May 2009 16:50:11 -0500 Subject: [PATCH 100/228] mason.report: join lines with \n --- extra/mason/report/report.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 1b5aaf39ec..e74db9a1ae 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -31,10 +31,13 @@ IN: mason.report write-xml ] with-file-writer ; inline +: file-tail ( file encoding lines -- seq ) + [ file-lines ] dip short tail* "\n" join ; + :: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error - file utf8 file-lines 400 short tail* :> output + file utf8 400 file-tail :> output [XML

<-what->

From 1326f4ee286a1854f20dc74eaa30529a6d3bda08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 23:45:52 -0500 Subject: [PATCH 101/228] fix some duplicate using lines --- basis/furnace/actions/actions.factor | 1 - extra/galois-talk/galois-talk.factor | 2 +- extra/minneapolis-talk/minneapolis-talk.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index c7893117d1..06e743e967 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -12,7 +12,6 @@ furnace.conversations furnace.chloe-tags html.forms html.components -html.components html.templates.chloe html.templates.chloe.syntax html.templates.chloe.compiler ; diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor index ba929867e9..0d2a5a73d8 100644 --- a/extra/galois-talk/galois-talk.factor +++ b/extra/galois-talk/galois-talk.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize io.encodings.binary +sequences kernel parser memoize io.encodings.binary locals kernel.private help.vocabs assocs quotations urls peg.ebnf tools.annotations tools.crossref help.topics math.functions compiler.tree.optimizer diff --git a/extra/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor index 6f1df44bfb..a96bb2ce20 100755 --- a/extra/minneapolis-talk/minneapolis-talk.factor +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -1,5 +1,5 @@ USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser memoize ; +sequences kernel parser memoize ; IN: minneapolis-talk CONSTANT: minneapolis-slides From 6f2aadd2ab68f2133cde37d885173e896e98dd03 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 May 2009 01:40:04 -0500 Subject: [PATCH 102/228] make: minor doc fix --- core/make/make-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/make/make-docs.factor b/core/make/make-docs.factor index 7808872588..6a77ef65fc 100644 --- a/core/make/make-docs.factor +++ b/core/make/make-docs.factor @@ -27,7 +27,7 @@ $nl { $heading "Utilities for simple make patterns" } "Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:" { $code "[ , % ] { } make" } -"The existing utility words can in some cases express intent better than an arbitrary-looking string or " { $link , } " and " { $link % } "." +"The existing utility words can in some cases express intent better than a bunch of " { $link , } " and " { $link % } "." { $heading "Constructing quotations" } "Simple quotation construction can often be accomplished using " { $link "fry" } " and " { $link "compositional-combinators" } "." $nl From 873bb498494c93e31c163d7cac34738b1de4a7d1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 May 2009 17:28:13 -0500 Subject: [PATCH 103/228] Working on global optimizations --- basis/compiler/cfg/builder/builder.factor | 43 ++-- basis/compiler/cfg/cfg.factor | 2 + basis/compiler/cfg/copy-prop/copy-prop.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 1 + basis/compiler/cfg/dominance/authors.txt | 1 + basis/compiler/cfg/dominance/dominance.factor | 41 +++ .../cfg/instructions/instructions.factor | 2 +- basis/compiler/cfg/stack-analysis/authors.txt | 1 + .../cfg/stack-analysis/stack-analysis.factor | 238 ++++++++++++++++++ basis/compiler/cfg/utilities/utilities.factor | 5 +- 10 files changed, 316 insertions(+), 20 deletions(-) create mode 100644 basis/compiler/cfg/dominance/authors.txt create mode 100644 basis/compiler/cfg/dominance/dominance.factor create mode 100644 basis/compiler/cfg/stack-analysis/authors.txt create mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis.factor diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 4b521725fe..b3a0287f3c 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -81,30 +81,33 @@ GENERIC: emit-node ( node -- next ) basic-block get successors>> push stop-iterating ; -: emit-call ( word -- next ) +: emit-call ( word height -- next ) { - { [ dup loops get key? ] [ loops get at local-recursive-call ] } + { [ over loops get key? ] [ drop loops get at local-recursive-call ] } { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } - { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] } - [ ##epilogue ##jump stop-iterating ] + { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] } + [ drop ##epilogue ##jump stop-iterating ] } cond ; ! #recursive -: compile-recursive ( node -- next ) - [ label>> id>> emit-call ] +: recursive-height ( #recursive -- n ) + [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ; + +: emit-recursive ( #recursive -- next ) + [ [ label>> id>> ] [ recursive-height ] bi emit-call ] [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; : remember-loop ( label -- ) basic-block get swap loops get set-at ; -: compile-loop ( node -- next ) +: emit-loop ( node -- next ) ##loop-entry begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi iterate-next ; M: #recursive emit-node - dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; + dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; ! #if : emit-branch ( obj -- final-bb ) @@ -191,28 +194,34 @@ M: #if emit-node ds-pop ^^offset>slot i 0 ##dispatch dispatch-branches ; -: ( -- word ) +! If a dispatch is not in tail position, we compile a new word where the dispatch is in +! tail position, then call this word. + +: (non-tail-dispatch) ( -- word ) gensym dup t "inlined-block" set-word-prop ; +: ( node -- word ) + current-word get (non-tail-dispatch) [ + [ + begin-word + emit-dispatch + ] with-cfg-builder + ] keep ; + M: #dispatch emit-node tail-call? [ emit-dispatch stop-iterating ] [ - current-word get [ - [ - begin-word - emit-dispatch - ] with-cfg-builder - ] keep emit-call + f emit-call ] if ; ! #call M: #call emit-node dup word>> dup "intrinsic" word-prop - [ emit-intrinsic ] [ nip emit-call ] if ; + [ emit-intrinsic ] [ swap call-height emit-call ] if ; ! #call-recursive -M: #call-recursive emit-node label>> id>> emit-call ; +M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; ! #push M: #push emit-node diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 054b4f7ed0..be047f0658 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -10,6 +10,8 @@ number { successors vector } { predecessors vector } ; +M: basic-block hashcode* nip id>> ; + : ( -- basic-block ) basic-block new V{ } clone >>instructions diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 52cc75f047..d526ea9c1d 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop SYMBOL: copies : resolve ( vreg -- vreg ) - dup copies get at swap or ; + [ copies get at ] keep or ; : record-copy ( insn -- ) [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 068a6a6377..6275ae2003 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -43,6 +43,7 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: insn uses-vregs drop f ; +! Instructions that use vregs UNION: vreg-insn ##flushable ##write-barrier diff --git a/basis/compiler/cfg/dominance/authors.txt b/basis/compiler/cfg/dominance/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/dominance/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor new file mode 100644 index 0000000000..9d11fdf5b7 --- /dev/null +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators compiler.cfg.rpo +compiler.cfg.stack-analysis fry kernel math.order namespaces +sequences ; +IN: compiler.cfg.dominance + +! Reference: + +! A Simple, Fast Dominance Algorithm +! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy +! http://www.cs.rice.edu/~keith/EMBED/dom.pdf + +SYMBOL: idoms + +: idom ( bb -- bb' ) idoms get at ; + +> ] compare { + { +lt+ [ [ idom ] dip intersect ] } + { +gt+ [ idom intersect ] } + [ 2drop ] + } case ; + +: compute-idom ( bb -- idom ) + predecessors>> [ idom ] map sift + [ ] [ intersect ] map-reduce ; + +: iterate ( rpo -- changed? ) + [ [ compute-idom ] keep set-idom ] map [ ] any? ; + +PRIVATE> + +: compute-dominance ( cfg -- cfg ) + H{ } clone idoms set + dup entry>> reverse-post-order + unclip dup set-idom drop '[ _ iterate ] loop ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d152a8cc33..359e7188b0 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -57,7 +57,7 @@ TUPLE: stack-frame spill-counts ; INSN: ##stack-frame stack-frame ; -INSN: ##call word ; +INSN: ##call word height ; INSN: ##jump word ; INSN: ##return ; diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor new file mode 100644 index 0000000000..682d2ac092 --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -0,0 +1,238 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel namespaces math sequences fry deques +search-deques dlists sets make combinators compiler.cfg.copy-prop +compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.rpo ; +IN: compiler.cfg.stack-analysis + +! Convert stack operations to register operations + +! If 'poisoned' is set, disregard height information. This is set if we don't have +! height change information for an instruction. +TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ; + +: ( -- state ) + state new + H{ } clone >>locs>vregs + H{ } clone >>vregs>locs + H{ } clone >>changed-locs + 0 >>d-height + 0 >>r-height ; + +M: state clone + call-next-method + [ clone ] change-locs>vregs + [ clone ] change-vregs>locs + [ clone ] change-changed-locs ; + +: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; + +: record-peek ( dst loc -- ) + state get + [ locs>vregs>> set-at ] + [ swapd vregs>locs>> set-at ] + 3bi ; + +: delete-old-vreg ( loc -- ) + state get locs>vregs>> at [ state get vregs>locs>> delete-at ] when* ; + +: changed-loc ( loc -- ) + state get changed-locs>> conjoin ; + +: redundant-replace? ( src loc -- ? ) + loc>vreg = ; + +: record-replace ( src loc -- ) + ! Locs are not single assignment, which means we have to forget + ! that the previous vreg, if any, points at this loc. Also, record + ! that the loc changed so that all the right ##replace instructions + ! are emitted at a sync point. + 2dup redundant-replace? [ 2drop ] [ + dup delete-old-vreg dup changed-loc record-peek + ] if ; + +: save-changed-locs ( state -- ) + [ changed-locs>> ] [ locs>vregs>> ] bi '[ + _ at swap 2dup redundant-replace? + [ 2drop ] [ ##replace ] if + ] assoc-each ; + +: clear-state ( state -- ) + { + [ 0 >>d-height drop ] + [ 0 >>r-height drop ] + [ changed-locs>> clear-assoc ] + [ locs>vregs>> clear-assoc ] + [ vregs>locs>> clear-assoc ] + } cleave ; + +: sync-state ( -- ) + ! also: update height + ! but first, sync outputs + state get { + [ save-changed-locs ] + [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ] + [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ] + [ clear-state ] + } cleave ; + +: poison-state ( -- ) state get t >>poisoned? drop ; + +GENERIC: translate-loc ( loc -- loc' ) + +M: ds-loc translate-loc n>> state get d-height>> + ; + +M: rs-loc translate-loc n>> state get r-height>> + ; + +! Abstract interpretation +GENERIC: visit ( insn -- ) + +! Instructions which don't have any effect on the stack +UNION: neutral-insn + ##flushable + ##effect + ##branch + ##loop-entry + ##conditional-branch ; + +M: neutral-insn visit , ; + +: adjust-d ( n -- ) state get [ + ] change-d-height drop ; + +M: ##inc-d visit n>> adjust-d ; + +: adjust-r ( n -- ) state get [ + ] change-r-height drop ; + +M: ##inc-r visit n>> adjust-r ; + +: eliminate-peek ( dst src -- ) + ! the requested stack location is already in 'src' + [ ##copy ] [ swap copies get set-at ] 2bi ; + +M: ##peek visit + dup + [ dst>> ] [ loc>> translate-loc ] bi + dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ; + +M: ##replace visit + [ src>> resolve ] [ loc>> translate-loc ] bi + record-replace ; + +M: ##copy visit + [ call-next-method ] [ record-copy ] bi ; + +M: ##call visit + [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ; + +M: ##fixnum-mul visit + call-next-method -1 adjust-d ; + +M: ##fixnum-add visit + call-next-method -1 adjust-d ; + +M: ##fixnum-sub visit + call-next-method -1 adjust-d ; + +! Instructions that poison the stack state +UNION: poison-insn + ##jump + ##return + ##dispatch + ##dispatch-label + ##alien-callback + ##callback-return + ##fixnum-mul-tail + ##fixnum-add-tail + ##fixnum-sub-tail ; + +M: poison-insn visit call-next-method poison-state ; + +! Instructions that kill all live vregs +UNION: kill-vreg-insn + poison-insn + ##stack-frame + ##call + ##prologue + ##epilogue + ##fixnum-mul + ##fixnum-add + ##fixnum-sub + ##alien-invoke + ##alien-indirect ; + +M: kill-vreg-insn visit sync-state , ; + +: visit-alien-node ( node -- ) + params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + +M: ##alien-invoke visit + [ call-next-method ] [ visit-alien-node ] bi ; + +M: ##alien-indirect visit + [ call-next-method ] [ visit-alien-node ] bi ; + +! Basic blocks we still need to look at +SYMBOL: work-list + +: add-to-work-list ( basic-block -- ) + work-list get push-front ; + +! Maps basic-blocks to states +SYMBOLS: state-in state-out ; + +: merge-states ( seq -- state ) + [ ] [ first ] if-empty ; + +: block-in-state ( bb -- states ) + predecessors>> state-out get '[ _ at ] map merge-states ; + +: maybe-set-at ( value key assoc -- changed? ) + 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; + +: set-block-in-state ( state b -- ) + state-in get set-at ; + +: set-block-out-state ( bb state -- changed? ) + swap state-out get maybe-set-at ; + +: finish-block ( bb state -- ) + [ drop ] [ set-block-out-state ] 2bi + [ successors>> [ add-to-work-list ] each ] [ drop ] if ; + +: visit-block ( bb -- ) + dup block-in-state + [ swap set-block-in-state ] [ + state [ + [ [ [ [ visit ] each ] V{ } make ] change-instructions drop ] + [ state get finish-block ] + bi + ] with-variable + ] 2bi ; + +: visit-blocks ( bb -- ) + reverse-post-order work-list get + [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ; + +: optimize-stack ( cfg -- cfg ) + [ + H{ } clone copies set + H{ } clone state-in set + H{ } clone state-out set + work-list set + dup entry>> visit-blocks + ] with-scope ; + +! To do: +! - implement merge-states +! - insert loads to convert partially available values into available values + +! if any state is poisoned, then we need to sync in every predecessor that didn't sync +! and begin with a new state. + +! if heights differ, throw an error. + +! changed-locs is the union of the changed-locs of all predecessors +! locs>vregs: take the union, then for each predecessor, diff its locs>vregs against the union. +! those are the ones that need to be loaded in. +! think about phi insertion. \ No newline at end of file diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 99a138a763..e415008808 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -35,5 +35,8 @@ IN: compiler.cfg.utilities : stop-iterating ( -- next ) end-basic-block f ; +: call-height ( ##call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + : emit-primitive ( node -- ) - word>> ##call ##branch begin-basic-block ; + [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ; From 2c67064da5e0cff06932da499647ec9b0a525717 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 May 2009 17:46:05 -0500 Subject: [PATCH 104/228] webapps.mason: minor improvements --- extra/webapps/mason/mason.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index ea7040ac6e..359b277677 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -9,7 +9,7 @@ IN: webapps.mason : log-file ( -- path ) home "mason.log" append-path ; : recent-events ( -- xml ) - log-file utf8 file-lines 10 short tail* "\n" join [XML 
<->
XML] ; + log-file utf8 10 file-tail [XML 
<->
XML] ; : git-link ( id -- link ) [ "http://github.com/slavapestov/factor/commit/" prepend ] keep @@ -21,8 +21,9 @@ IN: webapps.mason : current-status ( builder -- xml ) dup status>> { - { "dirty" [ drop "Dirty" ] } - { "clean" [ drop "Clean" ] } + { "status-dirty" [ drop "Dirty" ] } + { "status-clean" [ drop "Clean" ] } + { "status-error" [ drop "Error" ] } { "starting" [ "Starting" building ] } { "make-vm" [ "Compiling VM" building ] } { "boot" [ "Bootstrapping" building ] } From de14c9e69584d3b4ff4d92b7e0cb917efa0681f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 May 2009 17:56:34 -0500 Subject: [PATCH 105/228] webapps.mason: fix using --- extra/webapps/mason/mason.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 359b277677..74c459e38e 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators db db.tuples furnace.actions http.server.responses kernel mason.platform mason.notify.server -math.order sequences sorting splitting xml.syntax xml.writer -io.pathnames io.encodings.utf8 io.files ; +mason.report math.order sequences sorting splitting xml.syntax +xml.writer io.pathnames io.encodings.utf8 io.files ; IN: webapps.mason : log-file ( -- path ) home "mason.log" append-path ; From 11ad6452e56e5ab5a737435d2e098871971654ec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 May 2009 18:05:04 -0500 Subject: [PATCH 106/228] speed up md5 compilation time by not inlining everything --- basis/checksums/md5/md5.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 89ff5d46a2..c74aa550d2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -5,7 +5,7 @@ math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry io.encodings.binary math.bitwise checksums accessors checksums.common checksums.stream combinators combinators.smart -specialized-arrays.uint literals ; +specialized-arrays.uint literals hints ; IN: checksums.md5 SINGLETON: md5 @@ -28,7 +28,7 @@ M: md5 initialize-checksum-state drop ; : update-md5 ( md5 -- ) [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri - [ (>>old-state) ] [ (>>state) ] bi ; inline + [ (>>old-state) ] [ (>>state) ] bi ; CONSTANT: T $[ @@ -106,7 +106,7 @@ MACRO: with-md5-round ( ops quot -- ) [ d a b c 13 S12 14 ] [ c d a b 14 S13 15 ] [ b c d a 15 S14 16 ] - } [ F ] with-md5-round ; inline + } [ F ] with-md5-round ; : (process-md5-block-G) ( block state -- ) { @@ -126,7 +126,7 @@ MACRO: with-md5-round ( ops quot -- ) [ d a b c 2 S22 30 ] [ c d a b 7 S23 31 ] [ b c d a 12 S24 32 ] - } [ G ] with-md5-round ; inline + } [ G ] with-md5-round ; : (process-md5-block-H) ( block state -- ) { @@ -146,7 +146,7 @@ MACRO: with-md5-round ( ops quot -- ) [ d a b c 12 S32 46 ] [ c d a b 15 S33 47 ] [ b c d a 2 S34 48 ] - } [ H ] with-md5-round ; inline + } [ H ] with-md5-round ; : (process-md5-block-I) ( block state -- ) { @@ -166,7 +166,12 @@ MACRO: with-md5-round ( ops quot -- ) [ d a b c 11 S42 62 ] [ c d a b 2 S43 63 ] [ b c d a 9 S44 64 ] - } [ I ] with-md5-round ; inline + } [ I ] with-md5-round ; + +HINTS: (process-md5-block-F) { uint-array md5-state } ; +HINTS: (process-md5-block-G) { uint-array md5-state } ; +HINTS: (process-md5-block-H) { uint-array md5-state } ; +HINTS: (process-md5-block-I) { uint-array md5-state } ; M: md5-state checksum-block ( block state -- ) [ From be164796da1c9417759112dc0f15b7bfc24ad501 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 May 2009 18:53:12 -0500 Subject: [PATCH 107/228] make sure you can define words in fhtml templates --- basis/html/templates/fhtml/fhtml-tests.factor | 13 ++++++++++++- basis/html/templates/fhtml/fhtml.factor | 6 ++++-- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor index 55cf90c2dd..427b3215c1 100644 --- a/basis/html/templates/fhtml/fhtml-tests.factor +++ b/basis/html/templates/fhtml/fhtml-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.streams.string io.encodings.utf8 -html.templates html.templates.fhtml kernel +html.templates html.templates.fhtml kernel multiline tools.test sequences parser splitting prettyprint ; IN: html.templates.fhtml.tests @@ -17,3 +17,14 @@ IN: html.templates.fhtml.tests [ [ ] [ "<%\n%>" parse-template drop ] unit-test ] with-file-vocabs + +[ + [ ] [ + <" + <% + IN: html.templates.fhtml.tests + : test-word ( -- ) ; + %> + "> parse-template drop + ] unit-test +] with-file-vocabs diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 6c5e78e917..ceb2e72478 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -4,7 +4,7 @@ USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors assocs fry vocabs.parser parser parser.notes lexer io io.files -io.streams.string io.encodings.utf8 html.templates ; +io.streams.string io.encodings.utf8 html.templates compiler.units ; IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not @@ -58,11 +58,13 @@ SYNTAX: %> lexer get parse-%> ; : parse-template ( string -- quot ) [ + [ "quiet" on parser-notes off "html.templates.fhtml" use-vocab string-lines parse-template-lines - ] with-file-vocabs ; + ] with-file-vocabs + ] with-compilation-unit ; : eval-template ( string -- ) parse-template call( -- ) ; From 63aacecab2ed11e680d61f29b2134a686505c4a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 19 May 2009 18:54:56 -0500 Subject: [PATCH 108/228] clean up vim syntax highlighting file, add a few more syntax words --- misc/factor.vim.fgen | 256 +++++++++++++++++++--------------- misc/vim/syntax/factor.vim | 276 +++++++++++++++++++------------------ 2 files changed, 286 insertions(+), 246 deletions(-) diff --git a/misc/factor.vim.fgen b/misc/factor.vim.fgen index b0d61b8dd0..af1e9e600a 100644 --- a/misc/factor.vim.fgen +++ b/misc/factor.vim.fgen @@ -1,15 +1,26 @@ -<% USING: kernel io prettyprint vocabs sequences ; -%>" Vim syntax file -" Language: factor -" Maintainer: Alex Chapman -" Last Change: 2008 Apr 28 +<% +USING: kernel io prettyprint vocabs sequences multiline ; +IN: factor.vim.fgen + +: print-keywords ( vocab -- ) + words [ + "syn keyword factorKeyword " write + [ bl ] [ pprint ] interleave nl + ] when* ; + +%> +" Vim syntax file +" Language: factor +" Maintainer: Alex Chapman +" Last Change: 2009 May 19 +" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" call-template " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded if version < 600 - syntax clear + syntax clear elseif exists("b:current_syntax") - finish + finish endif " factor is case sensitive. @@ -47,25 +58,27 @@ syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing <% + ! uncomment this if you want all words from all vocabularies highlighted. Note ! that this changes factor.vim from around 8k to around 100k (and is a bit ! broken) -! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each +! vocabs [ print-keywords ] each + + { + "kernel" "assocs" "combinators" "math" "sequences" + "namespaces" "arrays" "io" "strings" "vectors" + "continuations" + } [ print-keywords ] each %> -" kernel vocab keywords -<% { "kernel" "assocs" "combinators" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "continuations" } [ - words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write - ] each %> - -syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal -syn cluster factorNumber contains=@factorReal,factorComplex -syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr -syn match factorInt /\<-\=\d\+\>/ -syn match factorFloat /\<-\=\d*\.\d\+\>/ -syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/ -syn region factorComplex start=/\/ end=/\<}\>/ contains=@factorReal +syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal +syn cluster factorNumber contains=@factorReal,factorComplex +syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr +syn match factorInt /\<-\=\d\+\>/ +syn match factorFloat /\<-\=\d*\.\d\+\>/ +syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/ +syn region factorComplex start=/\/ end=/\<}\>/ contains=@factorReal syn match factorBinErr /\/ syn match factorBinary /\/ syn match factorHexErr /\/ @@ -73,31 +86,36 @@ syn match factorHex /\/ syn match factorOctErr /\/ syn match factorOctal /\/ -syn match factorIn /\/ -syn match factorUse /\/ +syn match factorIn /\/ +syn match factorUse /\/ +syn match factorUnuse /\/ -syn match factorCharErr /\/ +syn match factorCharErr /\/ -syn match factorBackslash /\<\\\>\s\+\S\+\>/ +syn match factorBackslash /\<\\\>\s\+\S\+\>/ -syn region factorUsing start=/\/ end=/;/ -syn region factorRequires start=/\/ end=/;/ +syn region factorUsing start=/\/ end=/;/ +syn region factorSingletons start=/\/ end=/;/ +syn match factorSymbol /\/ +syn region factorSymbols start=/\/ end=/;/ +syn region factorConstructor2 start=/\/ end=/\<;\>/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor -syn match factorSymbol /\/ -syn match factorPostpone /\/ -syn match factorDefer /\/ -syn match factorForget /\/ -syn match factorMixin /\/ -syn match factorInstance /\/ -syn match factorHook /\/ -syn match factorMain /\/ -syn match factorConstructor /\/ +syn match factorConstant /\/ +syn match factorSingleton /\/ +syn match factorPostpone /\/ +syn match factorDefer /\/ +syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ +syn match factorAlien /\/ -syn match factorAlien /\/ +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor -syn region factorTuple start=/\/ end=/\<;\>/ "TODO: "misc: @@ -116,6 +134,12 @@ syn region factorTuple start=/\/ end=/\<;\>/ " TYPEDEF: " LIBRARY: " C-UNION: +"QUALIFIED: +"QUALIFIED-WITH: +"FROM: +"ALIAS: +"! POSTPONE: " +"#\ " syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline @@ -165,88 +189,92 @@ syn sync lines=100 if version >= 508 || !exists("did_factor_syn_inits") if version <= 508 - let did_factor_syn_inits = 1 - command -nargs=+ HiLink hi link + let did_factor_syn_inits = 1 + command -nargs=+ HiLink hi link else - command -nargs=+ HiLink hi def link + command -nargs=+ HiLink hi def link endif - HiLink factorComment Comment - HiLink factorStackEffect Typedef - HiLink factorTodo Todo - HiLink factorInclude Include - HiLink factorRepeat Repeat - HiLink factorConditional Conditional - HiLink factorKeyword Keyword - HiLink factorOperator Operator - HiLink factorBoolean Boolean - HiLink factorDefnDelims Typedef - HiLink factorMethodDelims Typedef - HiLink factorGenericDelims Typedef - HiLink factorGenericNDelims Typedef - HiLink factorConstructor Typedef - HiLink factorPrivate Special - HiLink factorPrivateDefnDelims Special - HiLink factorPrivateMethodDelims Special - HiLink factorPGenericDelims Special + HiLink factorComment Comment + HiLink factorStackEffect Typedef + HiLink factorTodo Todo + HiLink factorInclude Include + HiLink factorRepeat Repeat + HiLink factorConditional Conditional + HiLink factorKeyword Keyword + HiLink factorOperator Operator + HiLink factorBoolean Boolean + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorConstructor2 Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special HiLink factorPGenericNDelims Special - HiLink factorString String - HiLink factorSbuf String - HiLink factorMultiStringContents String - HiLink factorMultiStringDelims Typedef - HiLink factorBracketErr Error - HiLink factorComplex Number - HiLink factorRatio Number - HiLink factorBinary Number - HiLink factorBinErr Error - HiLink factorHex Number - HiLink factorHexErr Error - HiLink factorOctal Number - HiLink factorOctErr Error - HiLink factorFloat Float - HiLink factorInt Number - HiLink factorUsing Include - HiLink factorUse Include - HiLink factorRequires Include - HiLink factorIn Define - HiLink factorChar Character - HiLink factorCharErr Error - HiLink factorDelimiter Delimiter - HiLink factorBackslash Special - HiLink factorCompileDirective Typedef - HiLink factorSymbol Define - HiLink factorMixin Typedef - HiLink factorInstance Typedef - HiLink factorHook Typedef - HiLink factorMain Define - HiLink factorPostpone Define - HiLink factorDefer Define - HiLink factorForget Define - HiLink factorAlien Define - HiLink factorTuple Typedef + HiLink factorString String + HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef + HiLink factorBracketErr Error + HiLink factorComplex Number + HiLink factorRatio Number + HiLink factorBinary Number + HiLink factorBinErr Error + HiLink factorHex Number + HiLink factorHexErr Error + HiLink factorOctal Number + HiLink factorOctErr Error + HiLink factorFloat Float + HiLink factorInt Number + HiLink factorUsing Include + HiLink factorUse Include + HiLink factorUnuse Include + HiLink factorIn Define + HiLink factorChar Character + HiLink factorCharErr Error + HiLink factorDelimiter Delimiter + HiLink factorBackslash Special + HiLink factorCompileDirective Typedef + HiLink factorSymbol Define + HiLink factorConstant Define + HiLink factorSingleton Define + HiLink factorSingletons Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define + HiLink factorPostpone Define + HiLink factorDefer Define + HiLink factorForget Define + HiLink factorAlien Define + HiLink factorTuple Typedef if &bg == "dark" - hi hlLevel0 ctermfg=red guifg=red1 - hi hlLevel1 ctermfg=yellow guifg=orange1 - hi hlLevel2 ctermfg=green guifg=yellow1 - hi hlLevel3 ctermfg=cyan guifg=greenyellow - hi hlLevel4 ctermfg=magenta guifg=green1 - hi hlLevel5 ctermfg=red guifg=springgreen1 - hi hlLevel6 ctermfg=yellow guifg=cyan1 - hi hlLevel7 ctermfg=green guifg=slateblue1 - hi hlLevel8 ctermfg=cyan guifg=magenta1 - hi hlLevel9 ctermfg=magenta guifg=purple1 + hi hlLevel0 ctermfg=red guifg=red1 + hi hlLevel1 ctermfg=yellow guifg=orange1 + hi hlLevel2 ctermfg=green guifg=yellow1 + hi hlLevel3 ctermfg=cyan guifg=greenyellow + hi hlLevel4 ctermfg=magenta guifg=green1 + hi hlLevel5 ctermfg=red guifg=springgreen1 + hi hlLevel6 ctermfg=yellow guifg=cyan1 + hi hlLevel7 ctermfg=green guifg=slateblue1 + hi hlLevel8 ctermfg=cyan guifg=magenta1 + hi hlLevel9 ctermfg=magenta guifg=purple1 else - hi hlLevel0 ctermfg=red guifg=red3 - hi hlLevel1 ctermfg=darkyellow guifg=orangered3 - hi hlLevel2 ctermfg=darkgreen guifg=orange2 - hi hlLevel3 ctermfg=blue guifg=yellow3 - hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4 - hi hlLevel5 ctermfg=red guifg=green4 - hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3 - hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4 - hi hlLevel8 ctermfg=blue guifg=darkslateblue - hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet + hi hlLevel0 ctermfg=red guifg=red3 + hi hlLevel1 ctermfg=darkyellow guifg=orangered3 + hi hlLevel2 ctermfg=darkgreen guifg=orange2 + hi hlLevel3 ctermfg=blue guifg=yellow3 + hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4 + hi hlLevel5 ctermfg=red guifg=green4 + hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3 + hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4 + hi hlLevel8 ctermfg=blue guifg=darkslateblue + hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet endif delcommand HiLink diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 7d847c7238..86f4f19147 100755 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -1,14 +1,15 @@ " Vim syntax file -" Language: factor -" Maintainer: Alex Chapman -" Last Change: 2008 Apr 28 +" Language: factor +" Maintainer: Alex Chapman +" Last Change: 2009 May 19 +" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" call-template " For version 5.x: Clear all syntax items " For version 6.x: Quit when a syntax file was already loaded if version < 600 - syntax clear + syntax clear elseif exists("b:current_syntax") - finish + finish endif " factor is case sensitive. @@ -45,29 +46,26 @@ syn region None matchgroup=factorPrivate start=/\</ end=/\\>/ syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing +syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean +syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip +syn keyword factorKeyword case execute-effect dispatch-case-quot no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot +syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f +syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth second change-each join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim +syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc +syn keyword factorKeyword 2array 3array pair >array 1array 4array pair? array resize-array array? +syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial +syn keyword factorKeyword resize-string >string 1string string string? +syn keyword factorKeyword vector? ?push vector >vector 1vector +syn keyword factorKeyword with-return restarts return-continuation with-datastack recover rethrow-restarts ifcc set-catchstack >continuation< cleanup ignore-errors restart? compute-restarts attempt-all-error error-thread continue attempt-all-error? condition? throw-restarts error catchstack continue-with thread-error-hook continuation rethrow callcc1 error-continuation callcc0 attempt-all condition continuation? restart return -" kernel vocab keywords -syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple -syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-any? assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys -syn keyword factorKeyword case dispatch-case-quot with-datastack no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot -syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f -syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek any? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth second change-each join set-repetition-len all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch -syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc -syn keyword factorKeyword 3array >array 4array pair? array pair 2array 1array resize-array array? -syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln -syn keyword factorKeyword resize-string >string 1string string string? -syn keyword factorKeyword vector? ?push vector >vector 1vector -syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts - - -syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal -syn cluster factorNumber contains=@factorReal,factorComplex -syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr -syn match factorInt /\<-\=\d\+\>/ -syn match factorFloat /\<-\=\d*\.\d\+\>/ -syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/ -syn region factorComplex start=/\/ end=/\<}\>/ contains=@factorReal +syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal +syn cluster factorNumber contains=@factorReal,factorComplex +syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr +syn match factorInt /\<-\=\d\+\>/ +syn match factorFloat /\<-\=\d*\.\d\+\>/ +syn match factorRatio /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/ +syn region factorComplex start=/\/ end=/\<}\>/ contains=@factorReal syn match factorBinErr /\/ syn match factorBinary /\/ syn match factorHexErr /\/ @@ -75,31 +73,36 @@ syn match factorHex /\/ syn match factorOctErr /\/ syn match factorOctal /\/ -syn match factorIn /\/ -syn match factorUse /\/ +syn match factorIn /\/ +syn match factorUse /\/ +syn match factorUnuse /\/ -syn match factorCharErr /\/ +syn match factorCharErr /\/ -syn match factorBackslash /\<\\\>\s\+\S\+\>/ +syn match factorBackslash /\<\\\>\s\+\S\+\>/ -syn region factorUsing start=/\/ end=/;/ -syn region factorRequires start=/\/ end=/;/ +syn region factorUsing start=/\/ end=/;/ +syn region factorSingletons start=/\/ end=/;/ +syn match factorSymbol /\/ +syn region factorSymbols start=/\/ end=/;/ +syn region factorConstructor2 start=/\/ end=/\<;\>/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor -syn match factorSymbol /\/ -syn match factorPostpone /\/ -syn match factorDefer /\/ -syn match factorForget /\/ -syn match factorMixin /\/ -syn match factorInstance /\/ -syn match factorHook /\/ -syn match factorMain /\/ -syn match factorConstructor /\/ +syn match factorConstant /\/ +syn match factorSingleton /\/ +syn match factorPostpone /\/ +syn match factorDefer /\/ +syn match factorForget /\/ +syn match factorMixin /\/ +syn match factorInstance /\/ +syn match factorHook /\/ +syn match factorMain /\/ +syn match factorConstructor /\/ +syn match factorAlien /\/ -syn match factorAlien /\/ +syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor -syn region factorTuple start=/\/ end=/\<;\>/ "TODO: "misc: @@ -118,6 +121,12 @@ syn region factorTuple start=/\/ end=/\<;\>/ " TYPEDEF: " LIBRARY: " C-UNION: +"QUALIFIED: +"QUALIFIED-WITH: +"FROM: +"ALIAS: +"! POSTPONE: " +"#\ " syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline @@ -131,18 +140,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained "adapted from lisp.vim if exists("g:factor_norainbow") - syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL + syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL else - syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 - syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 - syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 - syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 - syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 - syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 - syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 - syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 - syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 - syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 + syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 + syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 + syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 + syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 + syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 + syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 + syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 + syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 + syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 + syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 endif if exists("g:factor_norainbow") @@ -167,88 +176,92 @@ syn sync lines=100 if version >= 508 || !exists("did_factor_syn_inits") if version <= 508 - let did_factor_syn_inits = 1 - command -nargs=+ HiLink hi link + let did_factor_syn_inits = 1 + command -nargs=+ HiLink hi link else - command -nargs=+ HiLink hi def link + command -nargs=+ HiLink hi def link endif - HiLink factorComment Comment - HiLink factorStackEffect Typedef - HiLink factorTodo Todo - HiLink factorInclude Include - HiLink factorRepeat Repeat - HiLink factorConditional Conditional - HiLink factorKeyword Keyword - HiLink factorOperator Operator - HiLink factorBoolean Boolean - HiLink factorDefnDelims Typedef - HiLink factorMethodDelims Typedef - HiLink factorGenericDelims Typedef - HiLink factorGenericNDelims Typedef - HiLink factorConstructor Typedef - HiLink factorPrivate Special - HiLink factorPrivateDefnDelims Special - HiLink factorPrivateMethodDelims Special - HiLink factorPGenericDelims Special + HiLink factorComment Comment + HiLink factorStackEffect Typedef + HiLink factorTodo Todo + HiLink factorInclude Include + HiLink factorRepeat Repeat + HiLink factorConditional Conditional + HiLink factorKeyword Keyword + HiLink factorOperator Operator + HiLink factorBoolean Boolean + HiLink factorDefnDelims Typedef + HiLink factorMethodDelims Typedef + HiLink factorGenericDelims Typedef + HiLink factorGenericNDelims Typedef + HiLink factorConstructor Typedef + HiLink factorConstructor2 Typedef + HiLink factorPrivate Special + HiLink factorPrivateDefnDelims Special + HiLink factorPrivateMethodDelims Special + HiLink factorPGenericDelims Special HiLink factorPGenericNDelims Special - HiLink factorString String - HiLink factorSbuf String - HiLink factorMultiStringContents String - HiLink factorMultiStringDelims Typedef - HiLink factorBracketErr Error - HiLink factorComplex Number - HiLink factorRatio Number - HiLink factorBinary Number - HiLink factorBinErr Error - HiLink factorHex Number - HiLink factorHexErr Error - HiLink factorOctal Number - HiLink factorOctErr Error - HiLink factorFloat Float - HiLink factorInt Number - HiLink factorUsing Include - HiLink factorUse Include - HiLink factorRequires Include - HiLink factorIn Define - HiLink factorChar Character - HiLink factorCharErr Error - HiLink factorDelimiter Delimiter - HiLink factorBackslash Special - HiLink factorCompileDirective Typedef - HiLink factorSymbol Define - HiLink factorMixin Typedef - HiLink factorInstance Typedef - HiLink factorHook Typedef - HiLink factorMain Define - HiLink factorPostpone Define - HiLink factorDefer Define - HiLink factorForget Define - HiLink factorAlien Define - HiLink factorTuple Typedef + HiLink factorString String + HiLink factorSbuf String + HiLink factorMultiStringContents String + HiLink factorMultiStringDelims Typedef + HiLink factorBracketErr Error + HiLink factorComplex Number + HiLink factorRatio Number + HiLink factorBinary Number + HiLink factorBinErr Error + HiLink factorHex Number + HiLink factorHexErr Error + HiLink factorOctal Number + HiLink factorOctErr Error + HiLink factorFloat Float + HiLink factorInt Number + HiLink factorUsing Include + HiLink factorUse Include + HiLink factorUnuse Include + HiLink factorIn Define + HiLink factorChar Character + HiLink factorCharErr Error + HiLink factorDelimiter Delimiter + HiLink factorBackslash Special + HiLink factorCompileDirective Typedef + HiLink factorSymbol Define + HiLink factorConstant Define + HiLink factorSingleton Define + HiLink factorSingletons Define + HiLink factorMixin Typedef + HiLink factorInstance Typedef + HiLink factorHook Typedef + HiLink factorMain Define + HiLink factorPostpone Define + HiLink factorDefer Define + HiLink factorForget Define + HiLink factorAlien Define + HiLink factorTuple Typedef if &bg == "dark" - hi hlLevel0 ctermfg=red guifg=red1 - hi hlLevel1 ctermfg=yellow guifg=orange1 - hi hlLevel2 ctermfg=green guifg=yellow1 - hi hlLevel3 ctermfg=cyan guifg=greenyellow - hi hlLevel4 ctermfg=magenta guifg=green1 - hi hlLevel5 ctermfg=red guifg=springgreen1 - hi hlLevel6 ctermfg=yellow guifg=cyan1 - hi hlLevel7 ctermfg=green guifg=slateblue1 - hi hlLevel8 ctermfg=cyan guifg=magenta1 - hi hlLevel9 ctermfg=magenta guifg=purple1 + hi hlLevel0 ctermfg=red guifg=red1 + hi hlLevel1 ctermfg=yellow guifg=orange1 + hi hlLevel2 ctermfg=green guifg=yellow1 + hi hlLevel3 ctermfg=cyan guifg=greenyellow + hi hlLevel4 ctermfg=magenta guifg=green1 + hi hlLevel5 ctermfg=red guifg=springgreen1 + hi hlLevel6 ctermfg=yellow guifg=cyan1 + hi hlLevel7 ctermfg=green guifg=slateblue1 + hi hlLevel8 ctermfg=cyan guifg=magenta1 + hi hlLevel9 ctermfg=magenta guifg=purple1 else - hi hlLevel0 ctermfg=red guifg=red3 - hi hlLevel1 ctermfg=darkyellow guifg=orangered3 - hi hlLevel2 ctermfg=darkgreen guifg=orange2 - hi hlLevel3 ctermfg=blue guifg=yellow3 - hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4 - hi hlLevel5 ctermfg=red guifg=green4 - hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3 - hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4 - hi hlLevel8 ctermfg=blue guifg=darkslateblue - hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet + hi hlLevel0 ctermfg=red guifg=red3 + hi hlLevel1 ctermfg=darkyellow guifg=orangered3 + hi hlLevel2 ctermfg=darkgreen guifg=orange2 + hi hlLevel3 ctermfg=blue guifg=yellow3 + hi hlLevel4 ctermfg=darkmagenta guifg=olivedrab4 + hi hlLevel5 ctermfg=red guifg=green4 + hi hlLevel6 ctermfg=darkyellow guifg=paleturquoise3 + hi hlLevel7 ctermfg=darkgreen guifg=deepskyblue4 + hi hlLevel8 ctermfg=blue guifg=darkslateblue + hi hlLevel9 ctermfg=darkmagenta guifg=darkviolet endif delcommand HiLink @@ -262,4 +275,3 @@ set expandtab set autoindent " annoying? " vim: syntax=vim - From dbe341b6c2324fef53ed78ea9b8320a953bbe994 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 May 2009 10:26:24 -0500 Subject: [PATCH 109/228] clean up some GL state mgmt in spheres --- extra/spheres/spheres.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 1a8f41b4a2..b07b7a5ad1 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -3,7 +3,6 @@ opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays generalizations combinators ui.gadgets.worlds literals ui.pixel-formats ; -FROM: opengl.demo-support => rect-vertices ; IN: spheres STRING: plane-vertex-shader @@ -117,11 +116,11 @@ TUPLE: spheres-world < demo-world reflection-framebuffer reflection-depthbuffer reflection-texture ; -M: spheres-world near-plane ( gadget -- z ) +M: spheres-world near-plane drop 1.0 ; -M: spheres-world far-plane ( gadget -- z ) +M: spheres-world far-plane drop 512.0 ; -M: spheres-world distance-step ( gadget -- dz ) +M: spheres-world distance-step drop 0.5 ; : (reflection-dim) ( -- w h ) @@ -175,6 +174,9 @@ M: spheres-world distance-step ( gadget -- dz ) M: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions + GL_DEPTH_TEST glEnable + GL_VERTEX_ARRAY glEnableClientState + 0.15 0.15 1.0 1.0 glClearColor 20.0 10.0 20.0 set-demo-orientation (plane-program) >>plane-program (solid-sphere-program) >>solid-sphere-program @@ -194,13 +196,13 @@ M: spheres-world end-world [ plane-program>> [ delete-gl-program ] when* ] } cleave ; -M: spheres-world pref-dim* ( gadget -- dim ) +M: spheres-world pref-dim* drop { 640 480 } ; :: (draw-sphere) ( program center radius -- ) program "center" glGetAttribLocation center first3 glVertexAttrib3f program "radius" glGetAttribLocation radius glVertexAttrib1f - { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; + { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect ; :: (draw-colored-sphere) ( program center radius surfacecolor -- ) program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f @@ -283,9 +285,7 @@ M: spheres-world pref-dim* ( gadget -- dim ) } cleave ] with-framebuffer ; M: spheres-world draw-world* - GL_DEPTH_TEST glEnable - GL_SCISSOR_TEST glDisable - 0.15 0.15 1.0 1.0 glClearColor { + { [ (draw-reflection-texture) ] [ demo-world-set-matrix ] [ sphere-scene ] From 4dba6979dab13e97a2df4a3ca0bd44188a4b6b8b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 20 May 2009 10:26:55 -0500 Subject: [PATCH 110/228] vector bilerp word --- basis/math/vectors/vectors.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index bad2733bbf..0fe1404516 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -58,6 +58,10 @@ IN: math.vectors : vnlerp ( a b t -- a_t ) [ lerp ] curry 2map ; +: vbilerp ( aa ba ab bb {t,u} -- a_tu ) + [ first vnlerp ] [ second vnlerp ] bi-curry + [ 2bi@ ] [ call ] bi* ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; From cedb0bdcb5b0345ef833efc77e4fe571e93e5532 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 15:50:01 -0500 Subject: [PATCH 111/228] fix comments and dtds in html parser --- extra/html/parser/parser-tests.factor | 23 +++++++++++++++++++++++ extra/html/parser/parser.factor | 8 +++++--- 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index ca276fc54e..2876d03b16 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -73,3 +73,26 @@ V{ T{ tag f "head" H{ } f t } } ] [ "Spagna" + parse-html +] unit-test + +[ +V{ + T{ tag { name comment } { text "comment" } } +} +] [ + "" parse-html +] unit-test diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index d95c79dd88..948bd0c954 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables sequence-parser -html.parser.utils kernel namespaces sequences +html.parser.utils kernel namespaces sequences math unicode.case unicode.categories combinators.short-circuit quoting fry ; IN: html.parser @@ -63,10 +63,12 @@ SYMBOL: tagstack [ blank? ] trim ; : read-comment ( sequence-parser -- ) - "-->" take-until-sequence comment new-tag push-tag ; + [ "-->" take-until-sequence comment new-tag push-tag ] + [ '[ _ advance drop ] 3 swap times ] bi ; : read-dtd ( sequence-parser -- ) - ">" take-until-sequence dtd new-tag push-tag ; + [ ">" take-until-sequence dtd new-tag push-tag ] + [ advance drop ] bi ; : read-bang ( sequence-parser -- ) advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& From 2a3813374920c4cd820f8ff1c10de5d839b464b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 18:51:01 -0500 Subject: [PATCH 112/228] windows.advapi32: add windows.kernel32 dependency --- basis/windows/advapi32/advapi32.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/advapi32/advapi32.factor diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor old mode 100644 new mode 100755 index fd037cb2a0..1ba08e657b --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,4 +1,5 @@ -USING: alien.syntax kernel math windows.types math.bitwise ; +USING: alien.syntax kernel math windows.types windows.kernel32 +math.bitwise ; IN: windows.advapi32 LIBRARY: advapi32 From 9bea42405a9f9feffe3ad8d637e35930c15c671a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 18:52:21 -0500 Subject: [PATCH 113/228] callstack>array primitive was not GC safe --- vm/callstack.cpp | 36 +++++++++++++++++------------------- vm/callstack.hpp | 14 ++++++++++++-- vm/layouts.hpp | 5 +++++ 3 files changed, 34 insertions(+), 21 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 608a5c39e5..38fb1e2b33 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -107,8 +107,9 @@ stack_frame *frame_successor(stack_frame *frame) /* Allocates memory */ cell frame_scan(stack_frame *frame) { - if(frame_type(frame) == QUOTATION_TYPE) + switch(frame_type(frame)) { + case QUOTATION_TYPE: cell quot = frame_executing(frame); if(quot == F) return F; @@ -120,28 +121,27 @@ cell frame_scan(stack_frame *frame) return tag_fixnum(quot_code_offset_to_scan( quot,(cell)(return_addr - quot_xt))); } - } - else + case WORD_TYPE: return F; + default: + critical_error("Bad frame type",frame_type(frame)); + return F; + } } namespace { -struct stack_frame_counter { - cell count; - stack_frame_counter() : count(0) {} - void operator()(stack_frame *frame) { count += 2; } -}; - struct stack_frame_accumulator { - cell index; - gc_root frames; - stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {} + growable_array frames; + void operator()(stack_frame *frame) { - set_array_nth(frames.untagged(),index++,frame_executing(frame)); - set_array_nth(frames.untagged(),index++,frame_scan(frame)); + gc_root executing(frame_executing(frame)); + gc_root scan(frame_scan(frame)); + + frames.add(executing.value()); + frames.add(scan.value()); } }; @@ -151,13 +151,11 @@ PRIMITIVE(callstack_to_array) { gc_root callstack(dpop()); - stack_frame_counter counter; - iterate_callstack_object(callstack.untagged(),counter); - - stack_frame_accumulator accum(counter.count); + stack_frame_accumulator accum; iterate_callstack_object(callstack.untagged(),accum); + accum.frames.trim(); - dpush(accum.frames.value()); + dpush(accum.frames.elements.value()); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/callstack.hpp b/vm/callstack.hpp index d92e5f69e0..a3cc058e2b 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -33,9 +33,19 @@ template void iterate_callstack(cell top, cell bottom, T &iterator) } } -template void iterate_callstack_object(callstack *stack, T &iterator) +/* This is a little tricky. The iterator may allocate memory, so we +keep the callstack in a GC root and use relative offsets */ +template void iterate_callstack_object(callstack *stack_, T &iterator) { - iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator); + gc_root stack(stack_); + fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame); + + while(frame_offset >= 0) + { + stack_frame *frame = stack->frame_at(frame_offset); + frame_offset -= frame->size; + iterator(frame); + } } } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 3fe89cb558..7736143c50 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -309,6 +309,11 @@ struct callstack : public object { /* tagged */ cell length; + stack_frame *frame_at(cell offset) + { + return (stack_frame *)((char *)(this + 1) + offset); + } + stack_frame *top() { return (stack_frame *)(this + 1); } stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); } }; From 2faaa66599e6ec4f093ab8b9cf247cd471e690ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 20 May 2009 20:01:21 -0400 Subject: [PATCH 114/228] Fix compile error on GCC 4.x --- vm/callstack.cpp | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 38fb1e2b33..39988ae976 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -110,16 +110,18 @@ cell frame_scan(stack_frame *frame) switch(frame_type(frame)) { case QUOTATION_TYPE: - cell quot = frame_executing(frame); - if(quot == F) - return F; - else { - char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame); - char *quot_xt = (char *)(frame_code(frame) + 1); + cell quot = frame_executing(frame); + if(quot == F) + return F; + else + { + char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame); + char *quot_xt = (char *)(frame_code(frame) + 1); - return tag_fixnum(quot_code_offset_to_scan( - quot,(cell)(return_addr - quot_xt))); + return tag_fixnum(quot_code_offset_to_scan( + quot,(cell)(return_addr - quot_xt))); + } } case WORD_TYPE: return F; From 7767686270159d34439505639a599c1661503937 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 19:30:35 -0500 Subject: [PATCH 115/228] fix error handling in random.windows if acquiring the crypto context fails --- basis/random/windows/windows.factor | 46 +++++++++++++++++--------- basis/windows/advapi32/advapi32.factor | 34 +++++++++++++++++++ 2 files changed, 65 insertions(+), 15 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 488deef41f..981b8ec14e 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,6 +1,7 @@ -USING: accessors alien.c-types byte-arrays continuations -kernel windows.advapi32 init namespaces random destructors -locals windows.errors ; +USING: accessors alien.c-types byte-arrays +combinators.short-circuit continuations destructors init kernel +locals namespaces random windows.advapi32 windows.errors +windows.kernel32 ; IN: random.windows TUPLE: windows-rng provider type ; @@ -12,22 +13,37 @@ C: windows-crypto-context M: windows-crypto-context dispose ( tuple -- ) handle>> 0 CryptReleaseContext win32-error=0/f ; -: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline +CONSTANT: factor-crypto-container "FactorCryptoContainer" -:: (acquire-crypto-context) ( provider type flags -- handle ) - [let | handle [ "HCRYPTPROV" ] | - handle - factor-crypto-container - provider - type - flags - CryptAcquireContextW win32-error=0/f - handle *void* ] ; +:: (acquire-crypto-context) ( provider type flags -- handle ret ) + "HCRYPTPROV" :> handle + handle + factor-crypto-container + provider + type + flags + CryptAcquireContextW handle swap ; : acquire-crypto-context ( provider type -- handle ) - [ 0 (acquire-crypto-context) ] - [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ; + 0 (acquire-crypto-context) + 0 = [ + GetLastError NTE_BAD_KEYSET = + [ drop f ] [ win32-error-string throw ] if + ] [ + *void* + ] if ; +: create-crypto-context ( provider type -- handle ) + CRYPT_NEWKEYSET (acquire-crypto-context) win32-error=0/f *void* ; + +ERROR: acquire-crypto-context-failed provider type ; + +: attempt-crypto-context ( provider type -- handle ) + { + [ acquire-crypto-context ] + [ create-crypto-context ] + [ acquire-crypto-context-failed ] + } 2|| ; : windows-crypto-context ( provider type -- context ) acquire-crypto-context ; diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index fd037cb2a0..6e040871f8 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -291,6 +291,40 @@ CONSTANT: SE_GROUP_ENABLED 4 CONSTANT: SE_GROUP_OWNER 8 CONSTANT: SE_GROUP_LOGON_ID -1073741824 +CONSTANT: NTE_BAD_UID HEX: 80090001 +CONSTANT: NTE_BAD_HASH HEX: 80090002 +CONSTANT: NTE_BAD_KEY HEX: 80090003 +CONSTANT: NTE_BAD_LEN HEX: 80090004 +CONSTANT: NTE_BAD_DATA HEX: 80090005 +CONSTANT: NTE_BAD_SIGNATURE HEX: 80090006 +CONSTANT: NTE_BAD_VER HEX: 80090007 +CONSTANT: NTE_BAD_ALGID HEX: 80090008 +CONSTANT: NTE_BAD_FLAGS HEX: 80090009 +CONSTANT: NTE_BAD_TYPE HEX: 8009000A +CONSTANT: NTE_BAD_KEY_STATE HEX: 8009000B +CONSTANT: NTE_BAD_HASH_STATE HEX: 8009000C +CONSTANT: NTE_NO_KEY HEX: 8009000D +CONSTANT: NTE_NO_MEMORY HEX: 8009000E +CONSTANT: NTE_EXISTS HEX: 8009000F +CONSTANT: NTE_PERM HEX: 80090010 +CONSTANT: NTE_NOT_FOUND HEX: 80090011 +CONSTANT: NTE_DOUBLE_ENCRYPT HEX: 80090012 +CONSTANT: NTE_BAD_PROVIDER HEX: 80090013 +CONSTANT: NTE_BAD_PROV_TYPE HEX: 80090014 +CONSTANT: NTE_BAD_PUBLIC_KEY HEX: 80090015 +CONSTANT: NTE_BAD_KEYSET HEX: 80090016 +CONSTANT: NTE_PROV_TYPE_NOT_DEF HEX: 80090017 +CONSTANT: NTE_PROV_TYPE_ENTRY_BAD HEX: 80090018 +CONSTANT: NTE_KEYSET_NOT_DEF HEX: 80090019 +CONSTANT: NTE_KEYSET_ENTRY_BAD HEX: 8009001A +CONSTANT: NTE_PROV_TYPE_NO_MATCH HEX: 8009001B +CONSTANT: NTE_SIGNATURE_FILE_BAD HEX: 8009001C +CONSTANT: NTE_PROVIDER_DLL_FAIL HEX: 8009001D +CONSTANT: NTE_PROV_DLL_NOT_FOUND HEX: 8009001E +CONSTANT: NTE_BAD_KEYSET_PARAM HEX: 8009001F +CONSTANT: NTE_FAIL HEX: 80090020 +CONSTANT: NTE_SYS_ERR HEX: 80090021 + ! SID is a variable length structure TYPEDEF: void* PSID From 4f6e3354df3b9668855235224a3c75433f1970ad Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 19:40:52 -0500 Subject: [PATCH 116/228] call the word that attempts both crypto contexts --- basis/random/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 981b8ec14e..c8e08c9abe 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -46,7 +46,7 @@ ERROR: acquire-crypto-context-failed provider type ; } 2|| ; : windows-crypto-context ( provider type -- context ) - acquire-crypto-context ; + attempt-crypto-context ; M: windows-rng random-bytes* ( n tuple -- bytes ) [ From a7c2d95db729a730d196824518be3b9db51edd7e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 20:06:05 -0500 Subject: [PATCH 117/228] try to fall back on AES if RSA isn't found --- basis/random/windows/windows.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index c8e08c9abe..aa9404fbb2 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -60,9 +60,13 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL system-random-generator set-global - MS_STRONG_PROV - PROV_RSA_FULL secure-random-generator set-global + [ + MS_STRONG_PROV + PROV_RSA_FULL secure-random-generator set-global + ] [ + drop + MS_ENH_RSA_AES_PROV + PROV_RSA_AES secure-random-generator set-global + ] recover - ! MS_ENH_RSA_AES_PROV - ! PROV_RSA_AES secure-random-generator set-global ] "random.windows" add-init-hook From 9faefdbcc03362a759aeed612b9b0897b08a34f3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 20 May 2009 20:08:26 -0500 Subject: [PATCH 118/228] better factoring --- basis/random/windows/windows.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index aa9404fbb2..6dce078d67 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -60,13 +60,8 @@ M: windows-rng random-bytes* ( n tuple -- bytes ) MS_DEF_PROV PROV_RSA_FULL system-random-generator set-global - [ - MS_STRONG_PROV - PROV_RSA_FULL secure-random-generator set-global - ] [ - drop - MS_ENH_RSA_AES_PROV - PROV_RSA_AES secure-random-generator set-global - ] recover + [ MS_STRONG_PROV PROV_RSA_FULL ] + [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES ] recover + secure-random-generator set-global ] "random.windows" add-init-hook From cfab937ce7060c73c0d1ea9165c72c7f5cea3709 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 00:08:43 -0500 Subject: [PATCH 119/228] Working on webapps.mason --- basis/io/launcher/launcher.factor | 2 +- extra/mason/common/common.factor | 11 +- extra/mason/notify/notify.factor | 6 +- extra/mason/notify/server/server.factor | 55 ++++++++-- extra/mason/report/report.factor | 28 ++--- extra/webapps/mason/download.xml | 23 ++++ extra/webapps/mason/mason.factor | 138 +++++++++++++++++++----- 7 files changed, 202 insertions(+), 61 deletions(-) create mode 100644 extra/webapps/mason/download.xml diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 7451499978..f4978672d9 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -264,7 +264,7 @@ M: output-process-error error. : try-output-process ( command -- ) >process +stdout+ >>stderr - +closed+ >>stdin + [ +closed+ or ] change-stdin utf8 [ stream-contents ] [ dup wait-for-process ] bi* 0 = [ 2drop ] [ output-process-error ] if ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 4ac5767009..d54a17ff91 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories @@ -13,10 +13,7 @@ SYMBOL: current-git-id : short-running-process ( command -- ) #! Give network operations and shell commands at most #! 15 minutes to complete, to catch hangs. - >process - 15 minutes >>timeout - +closed+ >>stdin - try-output-process ; + >process 15 minutes >>timeout try-output-process ; HOOK: really-delete-tree os ( path -- ) @@ -45,10 +42,6 @@ M: unix really-delete-tree delete-tree ; dup utf8 file-lines parse-fresh [ "Empty file: " swap append throw ] [ nip first ] if-empty ; -: cat ( file -- ) utf8 file-contents print ; - -: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ; - : to-file ( object file -- ) utf8 [ . ] with-file-writer ; : datestamp ( timestamp -- string ) diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index ccabccdf8b..87447e48cc 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -16,7 +16,7 @@ IN: mason.notify ] { } make prepend [ 5 ] 2dip '[ - _ [ +closed+ ] unless* >>stdin + _ >>stdin _ >>command short-running-process ] retry @@ -49,4 +49,6 @@ IN: mason.notify ] bi ; : notify-release ( archive-name -- ) - "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; + [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ] + [ f swap "release" swap 2array status-notify ] + bi ; diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor index cc055e38d8..9ed29aef45 100644 --- a/extra/mason/notify/server/server.factor +++ b/extra/mason/notify/server/server.factor @@ -1,26 +1,44 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.smart command-line db -db.sqlite db.tuples db.types io kernel namespaces sequences ; +db.sqlite db.tuples db.types io io.encodings.utf8 io.files +present kernel namespaces sequences calendar ; IN: mason.notify.server CONSTANT: +starting+ "starting" CONSTANT: +make-vm+ "make-vm" CONSTANT: +boot+ "boot" CONSTANT: +test+ "test" -CONSTANT: +clean+ "clean" -CONSTANT: +dirty+ "dirty" +CONSTANT: +clean+ "status-clean" +CONSTANT: +dirty+ "status-dirty" +CONSTANT: +error+ "status-error" -TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ; +TUPLE: builder +host-name os cpu +clean-git-id clean-timestamp +last-release release-git-id +last-git-id last-timestamp last-report +current-git-id current-timestamp +status ; builder "BUILDERS" { { "host-name" "HOST_NAME" TEXT +user-assigned-id+ } { "os" "OS" TEXT +user-assigned-id+ } { "cpu" "CPU" TEXT +user-assigned-id+ } + { "clean-git-id" "CLEAN_GIT_ID" TEXT } + { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP } + + { "last-release" "LAST_RELEASE" TEXT } + { "release-git-id" "RELEASE_GIT_ID" TEXT } + { "last-git-id" "LAST_GIT_ID" TEXT } + { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP } { "last-report" "LAST_REPORT" TEXT } + { "current-git-id" "CURRENT_GIT_ID" TEXT } + ! Can't name it CURRENT_TIMESTAMP because of bug in db library + { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP } { "status" "STATUS" TEXT } } define-persistent @@ -49,14 +67,23 @@ SYMBOLS: host-name target-os target-cpu message message-arg ; : make-vm ( builder -- ) +make-vm+ >>status drop ; -: boot ( report -- ) +boot+ >>status drop ; +: boot ( builder -- ) +boot+ >>status drop ; -: test ( report -- ) +test+ >>status drop ; +: test ( builder -- ) +test+ >>status drop ; : report ( builder status content -- ) [ >>status ] [ >>last-report ] bi* - dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when + dup status>> +clean+ = [ + dup current-git-id>> >>clean-git-id + dup current-timestamp>> >>clean-timestamp + ] when dup current-git-id>> >>last-git-id + dup current-timestamp>> >>last-timestamp + drop ; + +: release ( builder name -- ) + >>last-release + dup clean-git-id>> >>release-git-id drop ; : update-builder ( builder -- ) @@ -66,17 +93,25 @@ SYMBOLS: host-name target-os target-cpu message message-arg ; { "boot" [ boot ] } { "test" [ test ] } { "report" [ message-arg get contents report ] } + { "release" [ message-arg get release ] } } case ; : mason-db ( -- db ) "resource:mason.db" ; -: handle-update ( command-line -- ) +: handle-update ( command-line timestamp -- ) mason-db [ - parse-args find-builder + [ parse-args find-builder ] dip >>current-timestamp [ update-builder ] [ update-tuple ] bi ] with-db ; +CONSTANT: log-file "resource:mason.log" + +: log-update ( command-line timestamp -- ) + log-file utf8 [ + present write ": " write " " join print + ] with-file-appender ; + : main ( -- ) - command-line get handle-update ; + command-line get now [ log-update ] [ handle-update ] 2bi ; MAIN: main diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index e74db9a1ae..52237171cf 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -59,13 +59,13 @@ IN: mason.report "test-log" "Tests failed" failed-report ; : timings-table ( -- xml ) - { - $ boot-time-file - $ load-time-file - $ test-time-file - $ help-lint-time-file - $ benchmark-time-file - $ html-help-time-file + ${ + boot-time-file + load-time-file + test-time-file + help-lint-time-file + benchmark-time-file + html-help-time-file } [ dup eval-file milli-seconds>time [XML <-><-> XML] @@ -121,13 +121,13 @@ IN: mason.report ] with-report ; : build-clean? ( -- ? ) - { - [ load-all-vocabs-file eval-file empty? ] - [ test-all-vocabs-file eval-file empty? ] - [ help-lint-vocabs-file eval-file empty? ] - [ compiler-errors-file eval-file empty? ] - [ benchmark-error-vocabs-file eval-file empty? ] - } 0&& ; + ${ + load-all-vocabs-file + test-all-vocabs-file + help-lint-vocabs-file + compiler-errors-file + benchmark-error-vocabs-file + } [ eval-file empty? ] all? ; : success ( -- status ) successful-report build-clean? status-clean status-dirty ? ; \ No newline at end of file diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml new file mode 100644 index 0000000000..2b1bb76f64 --- /dev/null +++ b/extra/webapps/mason/download.xml @@ -0,0 +1,23 @@ + + + + + + + Factor binary package for <t:label t:name="platform" /> + + +

Factor binary package for

+ +

Requirements:

+ + +

Download

+ +

This package was built from GIT ID .

+ +

Once you download Factor, you can get started with the language.

+ + + + diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 74c459e38e..7e76de736d 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -1,11 +1,28 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators db db.tuples furnace.actions -http.server.responses kernel mason.platform mason.notify.server -mason.report math.order sequences sorting splitting xml.syntax -xml.writer io.pathnames io.encodings.utf8 io.files ; +http.server.responses http.server.dispatchers kernel mason.platform +mason.notify.server mason.report math.order sequences sorting +splitting xml.syntax xml.writer io.pathnames io.encodings.utf8 +io.files present validators html.forms furnace.db assocs urls ; IN: webapps.mason +TUPLE: mason-app < dispatcher ; + +: validate-os/cpu ( -- ) + { + { "os" [ v-one-line ] } + { "cpu" [ v-one-line ] } + } validate-params ; + +: current-builder ( -- builder ) + builder new "os" value >>os "cpu" value >>cpu select-tuple ; + +: ( -- action ) + + [ validate-os/cpu ] >>init + [ current-builder last-report>> "text/html" ] >>display ; + : log-file ( -- path ) home "mason.log" append-path ; : recent-events ( -- xml ) @@ -20,24 +37,48 @@ IN: webapps.mason [XML <-> for <-> XML] ; : current-status ( builder -- xml ) - dup status>> { - { "status-dirty" [ drop "Dirty" ] } - { "status-clean" [ drop "Clean" ] } - { "status-error" [ drop "Error" ] } - { "starting" [ "Starting" building ] } - { "make-vm" [ "Compiling VM" building ] } - { "boot" [ "Bootstrapping" building ] } - { "test" [ "Testing" building ] } - [ 2drop "Unknown" ] - } case ; + [ + dup status>> { + { +dirty+ [ drop "Dirty" ] } + { +clean+ [ drop "Clean" ] } + { +error+ [ drop "Error" ] } + { +starting+ [ "Starting build" building ] } + { +make-vm+ [ "Compiling VM" building ] } + { +boot+ [ "Bootstrapping" building ] } + { +test+ [ "Testing" building ] } + [ 2drop "Unknown" ] + } case + ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ; + +: build-status ( git-id timestamp -- xml ) + over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ; + +: binaries-url ( builder -- url ) + [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ; + +: url-link ( url -- xml ) + dup [XML ><-> XML] ; + +: latest-binary-link ( builder -- xml ) + [ URL" download" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + [XML >Latest download XML] ; : binaries-link ( builder -- link ) - [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend - dup [XML ><-> XML] ; + binaries-url url-link ; + +: clean-image-url ( builder -- url ) + [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ; : clean-image-link ( builder -- link ) - [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend - dup [XML ><-> XML] ; + clean-image-url url-link ; + +: report-link ( builder -- xml ) + [ URL" report" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + [XML >Latest build report XML] ; : machine-table ( builder -- xml ) { @@ -45,10 +86,12 @@ IN: webapps.mason [ cpu>> ] [ host-name>> "." split1 drop ] [ current-status ] - [ last-git-id>> dup [ git-link ] when ] - [ clean-git-id>> dup [ git-link ] when ] + [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ] + [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ] [ binaries-link ] [ clean-image-link ] + [ report-link ] + [ latest-binary-link ] } cleave [XML

<-> / <->

@@ -60,6 +103,8 @@ IN: webapps.mason Binaries:<-> Clean images:<-> + + <-> | <-> XML] ; : machine-report ( -- xml ) @@ -67,7 +112,7 @@ IN: webapps.mason [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort [ machine-table ] map ; -: build-farm-report ( -- xml ) +: build-farm-summary ( -- xml ) recent-events machine-report [XML @@ -77,9 +122,52 @@ IN: webapps.mason XML] ; -: ( -- action ) +: ( -- action ) - [ - mason-db [ build-farm-report xml>string ] with-db - "text/html" - ] >>display ; \ No newline at end of file + [ build-farm-summary xml>string "text/html" ] >>display ; + +TUPLE: builder-link href title ; + +C: builder-link + +: requirements ( builder -- xml ) + [ + os>> { + { "winnt" "Windows XP (also tested on Vista)" } + { "macosx" "Mac OS X 10.5 Leopard" } + { "linux" "Linux 2.6.16 with GLIBC 2.4" } + { "freebsd" "FreeBSD 7.0" } + { "netbsd" "NetBSD 4.0" } + { "openbsd" "OpenBSD 4.2" } + } at + ] [ + dup cpu>> "x86-32" = [ + os>> { + { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } + { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } + { [ t ] [ drop f ] } + } cond + ] [ drop f ] if + ] bi + 2array sift [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ; + +: ( -- action ) + + [ + validate-os/cpu + "os" value "cpu" value (platform) "platform" set-value + current-builder + [ latest-binary-link "package" set-value ] + [ release-git-id>> git-link "git-id" set-value ] + [ requirements "requirements" set-value ] + tri + ] >>init + { mason-app "download" } >>template ; + +: ( -- dispatcher ) + mason-app new-dispatcher + "" add-responder + "report" add-responder + "download" add-responder + mason-db ; + From b42bed7e77f2c0d7150349d042119c96674e1766 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 16:49:28 -0500 Subject: [PATCH 120/228] CFG optimizer work in progress - adding phi nodes --- basis/compiler/cfg/def-use/def-use.factor | 1 + basis/compiler/cfg/hats/hats.factor | 2 + .../cfg/instructions/instructions.factor | 2 + .../cfg/stack-analysis/stack-analysis.factor | 115 +++++++++++++----- 4 files changed, 92 insertions(+), 28 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 6275ae2003..97047a7c3e 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -39,6 +39,7 @@ M: ##dispatch uses-vregs src>> 1array ; M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; +M: ##phi uses-vregs inputs>> ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: insn uses-vregs drop f ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 817c0f4680..b61f091fad 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -73,3 +73,5 @@ IN: compiler.cfg.hats : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline + +: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 359e7188b0..6ebf064a94 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -178,6 +178,8 @@ INSN: ##branch ; INSN: ##loop-entry ; +INSN: ##phi < ##pure inputs ; + ! Condition codes SYMBOL: cc< SYMBOL: cc<= diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 682d2ac092..cbe46d7dd4 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces math sequences fry deques +USING: accessors assocs kernel namespaces math sequences fry deques grouping search-deques dlists sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.rpo ; +compiler.cfg.rpo compiler.cfg.hats ; IN: compiler.cfg.stack-analysis ! Convert stack operations to register operations @@ -67,10 +67,11 @@ M: state clone [ vregs>locs>> clear-assoc ] } cleave ; +ERROR: poisoned-state state ; + : sync-state ( -- ) - ! also: update height - ! but first, sync outputs state get { + [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] [ save-changed-locs ] [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ] [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ] @@ -181,11 +182,72 @@ SYMBOL: work-list ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: merge-states ( seq -- state ) - [ ] [ first ] if-empty ; +: sync-unpoisoned-states ( predecessors states -- ) + [ + dup poisoned?>> [ 2drop ] [ + state [ + instructions>> building set + sync-state + ] with-variable + ] if + ] 2each ; + +ERROR: must-equal-failed seq ; + +: must-equal ( seq -- elt ) + dup all-equal? [ first ] [ must-equal-failed ] if ; + +: merge-heights ( state predecessors states -- state ) + nip + [ [ d-height>> ] map must-equal >>d-height ] + [ [ r-height>> ] map must-equal >>r-height ] bi ; + +ERROR: inconsistent-vreg>loc states ; + +: check-vreg>loc ( states -- ) + ! The same vreg should not store different locs in + ! different branches + dup + [ vregs>locs>> ] map + [ [ keys ] map concat prune ] keep + '[ _ [ at ] with map sift all-equal? ] all? + [ drop ] [ inconsistent-vreg>loc ] if ; + +: insert-peek ( predecessor loc -- vreg ) + ! XXX critical edges + [ instructions>> building ] dip '[ _ ^^peek ] with-variable ; + +: merge-loc ( predecessors locs>vregs loc -- vreg ) + ! Insert a ##phi in the current block where the input + ! is the vreg storing loc from each predecessor block + [ '[ [ _ ] dip at ] map ] keep + '[ [ ] [ _ insert-peek ] if ] 2map + ^^phi ; + +: merge-locs ( state predecessors states -- state ) + [ locs>vregs>> ] map dup [ keys ] map prune + [ + [ 2nip ] [ merge-loc ] 3bi + ] with with H{ } map>assoc + >>locs>vregs ; + +: merge-states ( predecessors states -- state ) + ! If any states are poisoned, save all registers + ! to the stack in each branch + [ drop ] [ + dup [ poisoned?>> ] any? [ + sync-unpoisoned-states + ] [ + dup check-vreg>loc + [ state new ] 2dip + [ merge-heights ] + [ merge-locs ] 2bi + ! what about vregs>locs + ] if + ] if-empty ; : block-in-state ( bb -- states ) - predecessors>> state-out get '[ _ at ] map merge-states ; + predecessors>> dup state-out get '[ _ at ] map merge-states ; : maybe-set-at ( value key assoc -- changed? ) 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; @@ -201,14 +263,19 @@ SYMBOLS: state-in state-out ; [ successors>> [ add-to-work-list ] each ] [ drop ] if ; : visit-block ( bb -- ) - dup block-in-state - [ swap set-block-in-state ] [ - state [ - [ [ [ [ visit ] each ] V{ } make ] change-instructions drop ] - [ state get finish-block ] - bi - ] with-variable - ] 2bi ; + ! block-in-state may add phi nodes at the start of the basic block + ! so we wrap the whole thing with a 'make' + [ + dup block-in-state + [ swap set-block-in-state ] [ + state [ + [ instructions>> [ visit ] each ] + [ state get finish-block ] + [ ] + tri + ] with-variable + ] 2bi + ] V{ } make >>instructions drop ; : visit-blocks ( bb -- ) reverse-post-order work-list get @@ -223,16 +290,8 @@ SYMBOLS: state-in state-out ; dup entry>> visit-blocks ] with-scope ; -! To do: -! - implement merge-states -! - insert loads to convert partially available values into available values - -! if any state is poisoned, then we need to sync in every predecessor that didn't sync -! and begin with a new state. - -! if heights differ, throw an error. - -! changed-locs is the union of the changed-locs of all predecessors -! locs>vregs: take the union, then for each predecessor, diff its locs>vregs against the union. -! those are the ones that need to be loaded in. -! think about phi insertion. \ No newline at end of file +! XXX: what if our height doesn't match +! a future block we're merging with? +! - we should only poison tail calls +! - non-tail poisoning nodes: ##alien-callback, ##call of a non-tail dispatch +! do we need a distinction between height changes in code and height changes done by the callee \ No newline at end of file From 8dc6ba0eb1565421b7b6c04fc12cd5dae1f4ae40 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 May 2009 18:49:22 -0500 Subject: [PATCH 121/228] 0.0 neg ought to be -0.0 --- core/math/math-tests.factor | 3 +++ core/math/math.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index b7cc51e669..831430cf24 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -26,6 +26,9 @@ IN: math.tests [ f ] [ 0 fp-nan? ] unit-test [ t ] [ 0 fp-infinity? ] unit-test +[ t ] [ 0.0 neg -0.0 fp-bitwise= ] unit-test +[ t ] [ -0.0 neg 0.0 fp-bitwise= ] unit-test + [ 0.0 ] [ -0.0 next-float ] unit-test [ t ] [ 1.0 dup next-float < ] unit-test [ t ] [ -1.0 dup next-float < ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index da9bc4d1b5..28efbaa26e 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -60,7 +60,7 @@ PRIVATE> : 1- ( x -- y ) 1 - ; inline : 2/ ( x -- y ) -1 shift ; inline : sq ( x -- y ) dup * ; inline -: neg ( x -- -x ) 0 swap - ; inline +: neg ( x -- -x ) -1 * ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline : ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline From 79de3d9833b5b908ef11a2921adc56b7d6825468 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 19:15:04 -0500 Subject: [PATCH 122/228] webapps.mason: Now renders a download grid with links to build machine status and download pages --- extra/mason/build/build.factor | 20 ++-- extra/mason/child/child.factor | 5 +- extra/mason/report/report.factor | 7 +- extra/webapps/mason/download.xml | 13 +++ extra/webapps/mason/mason.factor | 178 ++++++++++++++++--------------- 5 files changed, 126 insertions(+), 97 deletions(-) diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index a9e32e5315..f2018449fc 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel calendar io.directories io.encodings.utf8 -io.files io.launcher namespaces prettyprint mason.child mason.cleanup -mason.common mason.help mason.release mason.report mason.email -mason.notify ; -IN: mason.build - +io.files io.launcher namespaces prettyprint combinators mason.child +mason.cleanup mason.common mason.help mason.release mason.report +mason.email mason.notify ; QUALIFIED: continuations +IN: mason.build : create-build-dir ( -- ) now datestamp stamp set @@ -18,11 +17,12 @@ QUALIFIED: continuations "git" "clone" builds/factor 3array short-running-process ; : begin-build ( -- ) - "factor" [ git-id ] with-directory - [ "git-id" to-file ] - [ current-git-id set ] - [ notify-begin-build ] - tri ; + "factor" [ git-id ] with-directory { + [ "git-id" to-file ] + [ "factor/git-id" to-file ] + [ current-git-id set ] + [ notify-begin-build ] + } cleave ; : build ( -- ) create-build-dir diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 8132e62078..4a9a864c40 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -64,7 +64,10 @@ IN: mason.child MACRO: recover-cond ( alist -- ) dup { [ length 1 = ] [ first callable? ] } 1&& - [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; + [ first ] [ + [ first first2 ] [ rest ] bi + '[ _ _ [ _ recover-cond ] recover-else ] + ] if ; : build-child ( -- status ) copy-image diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 52237171cf..3ed332abf2 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -4,13 +4,16 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces prettyprint sequences xml.syntax xml.writer combinators.short-circuit -literals ; +literals splitting ; IN: mason.report +: short-host-name ( -- string ) + host-name "." split1 drop ; + : common-report ( -- xml ) target-os get target-cpu get - host-name + short-host-name build-dir current-git-id get [XML diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml index 2b1bb76f64..af4ac0214d 100644 --- a/extra/webapps/mason/download.xml +++ b/extra/webapps/mason/download.xml @@ -17,6 +17,19 @@

    This package was built from GIT ID .

    Once you download Factor, you can get started with the language.

    + +

    Build machine information

    + + + + + + + + +
    Host name:
    Current status:
    Last build:
    Last clean build:
    Binaries:
    Clean images:
    + +

    diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 7e76de736d..4d42617520 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -4,11 +4,66 @@ USING: accessors arrays combinators db db.tuples furnace.actions http.server.responses http.server.dispatchers kernel mason.platform mason.notify.server mason.report math.order sequences sorting splitting xml.syntax xml.writer io.pathnames io.encodings.utf8 -io.files present validators html.forms furnace.db assocs urls ; +io.files present validators html.forms furnace.db urls ; +FROM: assocs => at keys values ; IN: webapps.mason TUPLE: mason-app < dispatcher ; +: link ( url label -- xml ) + [XML ><-> XML] ; + +: download-link ( builder label -- xml ) + [ + [ URL" download" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + ] dip link ; + +: download-grid-cell ( cpu os -- xml ) + builder new swap >>os swap >>cpu select-tuple dup + [ + dup last-release>> dup + [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if + ] when + [XML <-> XML] ; + +CONSTANT: oses +{ + { "winnt" "Windows" } + { "macosx" "Mac OS X" } + { "linux" "Linux" } + { "freebsd" "FreeBSD" } + { "netbsd" "NetBSD" } + { "openbsd" "OpenBSD" } +} + +CONSTANT: cpus +{ + { "x86.32" "x86" } + { "x86.64" "x86-64" } + { "ppc" "PowerPC" } +} + +: download-grid ( -- xml ) + oses + [ values [ [XML <-> XML] ] map ] + [ + keys + cpus [ + [ nip second ] [ first ] 2bi [ + swap download-grid-cell + ] curry map [XML <-><-> XML] + ] with map + ] bi [XML <->
    <->
    XML] ; + +: ( -- action ) + + [ + download-grid + xml>string "text/html" + ] >>display ; + : validate-os/cpu ( -- ) { { "os" [ v-one-line ] } @@ -23,11 +78,6 @@ TUPLE: mason-app < dispatcher ; [ validate-os/cpu ] >>init [ current-builder last-report>> "text/html" ] >>display ; -: log-file ( -- path ) home "mason.log" append-path ; - -: recent-events ( -- xml ) - log-file utf8 10 file-tail [XML 
    <->
    XML] ; - : git-link ( id -- link ) [ "http://github.com/slavapestov/factor/commit/" prepend ] keep [XML ><-> XML] ; @@ -36,19 +86,22 @@ TUPLE: mason-app < dispatcher ; swap current-git-id>> git-link [XML <-> for <-> XML] ; +: status-string ( builder -- string ) + dup status>> { + { +dirty+ [ drop "Dirty" ] } + { +clean+ [ drop "Clean" ] } + { +error+ [ drop "Error" ] } + { +starting+ [ "Starting build" building ] } + { +make-vm+ [ "Compiling VM" building ] } + { +boot+ [ "Bootstrapping" building ] } + { +test+ [ "Testing" building ] } + [ 2drop "Unknown" ] + } case ; + : current-status ( builder -- xml ) - [ - dup status>> { - { +dirty+ [ drop "Dirty" ] } - { +clean+ [ drop "Clean" ] } - { +error+ [ drop "Error" ] } - { +starting+ [ "Starting build" building ] } - { +make-vm+ [ "Compiling VM" building ] } - { +boot+ [ "Bootstrapping" building ] } - { +test+ [ "Testing" building ] } - [ 2drop "Unknown" ] - } case - ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ; + [ status-string ] + [ current-timestamp>> present " (as of " ")" surround ] bi + 2array ; : build-status ( git-id timestamp -- xml ) over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ; @@ -56,23 +109,17 @@ TUPLE: mason-app < dispatcher ; : binaries-url ( builder -- url ) [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ; -: url-link ( url -- xml ) - dup [XML ><-> XML] ; - : latest-binary-link ( builder -- xml ) - [ URL" download" ] dip - [ os>> "os" set-query-param ] - [ cpu>> "cpu" set-query-param ] bi - [XML >Latest download XML] ; + [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ; : binaries-link ( builder -- link ) - binaries-url url-link ; + binaries-url dup link ; : clean-image-url ( builder -- url ) [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ; : clean-image-link ( builder -- link ) - clean-image-url url-link ; + clean-image-url dup link ; : report-link ( builder -- xml ) [ URL" report" ] dip @@ -80,56 +127,6 @@ TUPLE: mason-app < dispatcher ; [ cpu>> "cpu" set-query-param ] bi [XML >Latest build report XML] ; -: machine-table ( builder -- xml ) - { - [ os>> ] - [ cpu>> ] - [ host-name>> "." split1 drop ] - [ current-status ] - [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ] - [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ] - [ binaries-link ] - [ clean-image-link ] - [ report-link ] - [ latest-binary-link ] - } cleave - [XML -

    <-> / <->

    - - - - - - - -
    Host name:<->
    Current status:<->
    Last build:<->
    Last clean build:<->
    Binaries:<->
    Clean images:<->
    - - <-> | <-> - XML] ; - -: machine-report ( -- xml ) - builder new select-tuples - [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort - [ machine-table ] map ; - -: build-farm-summary ( -- xml ) - recent-events - machine-report - [XML - - Factor build farm -

    Recent events

    <->

    Machine status

    <-> - - XML] ; - -: ( -- action ) - - [ build-farm-summary xml>string "text/html" ] >>display ; - -TUPLE: builder-link href title ; - -C: builder-link - : requirements ( builder -- xml ) [ os>> { @@ -141,7 +138,7 @@ C: builder-link { "openbsd" "OpenBSD 4.2" } } at ] [ - dup cpu>> "x86-32" = [ + dup cpu>> "x86.32" = [ os>> { { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } @@ -151,23 +148,36 @@ C: builder-link ] bi 2array sift [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ; +: last-build-status ( builder -- xml ) + [ last-git-id>> ] [ last-timestamp>> ] bi build-status ; + +: clean-build-status ( builder -- xml ) + [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ; + : ( -- action ) [ validate-os/cpu "os" value "cpu" value (platform) "platform" set-value - current-builder - [ latest-binary-link "package" set-value ] - [ release-git-id>> git-link "git-id" set-value ] - [ requirements "requirements" set-value ] - tri + current-builder { + [ latest-binary-link "package" set-value ] + [ release-git-id>> git-link "git-id" set-value ] + [ requirements "requirements" set-value ] + [ host-name>> "host-name" set-value ] + [ current-status "status" set-value ] + [ last-build-status "last-build" set-value ] + [ clean-build-status "last-clean-build" set-value ] + [ binaries-link "binaries" set-value ] + [ clean-image-link "clean-images" set-value ] + [ report-link "last-report" set-value ] + } cleave ] >>init { mason-app "download" } >>template ; : ( -- dispatcher ) mason-app new-dispatcher - "" add-responder "report" add-responder "download" add-responder + "grid" add-responder mason-db ; From c779fccd4d9e86ec0a970a2feeecfd36ba8d2fd1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 19:19:12 -0500 Subject: [PATCH 123/228] mason: use short host name not fully qualified host name --- extra/mason/common/common.factor | 5 ++++- extra/mason/notify/notify.factor | 2 +- extra/mason/report/report.factor | 3 --- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index d54a17ff91..22e37f8a8c 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -5,9 +5,12 @@ math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar calendar.format arrays mason.config locals debugger fry -continuations strings ; +continuations strings io.sockets ; IN: mason.common +: short-host-name ( -- string ) + host-name "." split1 drop ; + SYMBOL: current-git-id : short-running-process ( command -- ) diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 87447e48cc..122c8a47cd 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -10,7 +10,7 @@ IN: mason.notify [ "ssh" , status-host get , "-l" , status-username get , "./mason-notify" , - host-name , + short-host-name , target-cpu get , target-os get , ] { } make prepend diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 3ed332abf2..4a2138323c 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -7,9 +7,6 @@ prettyprint sequences xml.syntax xml.writer combinators.short-circuit literals splitting ; IN: mason.report -: short-host-name ( -- string ) - host-name "." split1 drop ; - : common-report ( -- xml ) target-os get target-cpu get From 23ae3f4ab63edd3738479f823906847f3bd4dce8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 May 2009 20:55:44 -0500 Subject: [PATCH 124/228] homogeneous coordinates coated in nurbsauce --- basis/math/vectors/vectors.factor | 3 + .../affine-transforms.factor | 3 - extra/math/vectors/homogeneous/authors.txt | 1 + .../homogeneous/homogeneous-tests.factor | 15 ++++ .../vectors/homogeneous/homogeneous.factor | 36 +++++++++ extra/math/vectors/homogeneous/summary.txt | 1 + extra/nurbs/authors.txt | 1 + extra/nurbs/nurbs-tests.factor | 32 ++++++++ extra/nurbs/nurbs.factor | 73 +++++++++++++++++++ extra/nurbs/summary.txt | 1 + 10 files changed, 163 insertions(+), 3 deletions(-) create mode 100644 extra/math/vectors/homogeneous/authors.txt create mode 100644 extra/math/vectors/homogeneous/homogeneous-tests.factor create mode 100644 extra/math/vectors/homogeneous/homogeneous.factor create mode 100644 extra/math/vectors/homogeneous/summary.txt create mode 100644 extra/nurbs/authors.txt create mode 100644 extra/nurbs/nurbs-tests.factor create mode 100644 extra/nurbs/nurbs.factor create mode 100644 extra/nurbs/summary.txt diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 0fe1404516..14a66b5c18 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -62,6 +62,9 @@ IN: math.vectors [ first vnlerp ] [ second vnlerp ] bi-curry [ 2bi@ ] [ call ] bi* ; +: v~ ( a b epsilon -- ? ) + [ ~ ] curry 2all? ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index d1fd602f72..7d63bbfac8 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -65,9 +65,6 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 } 2cleave [ [ 2array ] 2bi@ ] dip ; -: v~ ( a b epsilon -- ? ) - [ ~ ] curry 2all? ; - : a~ ( a b epsilon -- ? ) { [ [ [ x>> ] bi@ ] dip v~ ] diff --git a/extra/math/vectors/homogeneous/authors.txt b/extra/math/vectors/homogeneous/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/vectors/homogeneous/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/vectors/homogeneous/homogeneous-tests.factor b/extra/math/vectors/homogeneous/homogeneous-tests.factor new file mode 100644 index 0000000000..7e657dbe71 --- /dev/null +++ b/extra/math/vectors/homogeneous/homogeneous-tests.factor @@ -0,0 +1,15 @@ +! (c)2009 Joe Groff bsd license +USING: math.vectors.homogeneous tools.test ; +IN: math.vectors.homogeneous.tests + +[ { 1.0 2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h+ ] unit-test +[ { 1.0 -2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h- ] unit-test +[ { 2.0 2.0 2.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 2.0 } h+ ] unit-test +[ { 1.0 2.0 2.0 } ] [ { 1.0 0.0 2.0 } { 0.0 2.0 2.0 } h+ ] unit-test + +[ { 2.0 4.0 2.0 } ] [ 2.0 { 1.0 2.0 2.0 } n*h ] unit-test +[ { 2.0 4.0 2.0 } ] [ { 1.0 2.0 2.0 } 2.0 h*n ] unit-test + +[ { 0.5 1.5 } ] [ { 1.0 3.0 2.0 } h>v ] unit-test +[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test +[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test diff --git a/extra/math/vectors/homogeneous/homogeneous.factor b/extra/math/vectors/homogeneous/homogeneous.factor new file mode 100644 index 0000000000..218e56dfb5 --- /dev/null +++ b/extra/math/vectors/homogeneous/homogeneous.factor @@ -0,0 +1,36 @@ +! (c)2009 Joe Groff bsd license +USING: kernel math math.vectors sequences ; +IN: math.vectors.homogeneous + +: (homogeneous-xyz) ( h -- xyz ) + 1 head* ; inline +: (homogeneous-w) ( h -- w ) + peek ; inline + +: h+ ( a b -- c ) + 2dup [ (homogeneous-w) ] bi@ over = + [ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [ + drop + [ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi* v*n ] + [ [ (homogeneous-w) ] [ (homogeneous-xyz) ] bi* n*v v+ ] + [ [ (homogeneous-w) ] [ (homogeneous-w) ] bi* * suffix ] 2tri + ] if ; + +: n*h ( n h -- nh ) + [ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ; + +: h*n ( h n -- nh ) + swap n*h ; + +: hneg ( h -- -h ) + -1.0 swap n*h ; + +: h- ( a b -- c ) + hneg h+ ; + +: v>h ( v -- h ) + 1.0 suffix ; + +: h>v ( h -- v ) + [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ; + diff --git a/extra/math/vectors/homogeneous/summary.txt b/extra/math/vectors/homogeneous/summary.txt new file mode 100644 index 0000000000..eb6d457267 --- /dev/null +++ b/extra/math/vectors/homogeneous/summary.txt @@ -0,0 +1 @@ +Homogeneous coordinate math diff --git a/extra/nurbs/authors.txt b/extra/nurbs/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/nurbs/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor new file mode 100644 index 0000000000..db606f9c5c --- /dev/null +++ b/extra/nurbs/nurbs-tests.factor @@ -0,0 +1,32 @@ +! (c)2009 Joe Groff bsd license +USING: literals math math.functions math.vectors namespaces +nurbs tools.test ; +IN: nurbs.tests + +SYMBOL: test-nurbs + +CONSTANT: √2/2 $[ 0.5 sqrt ] +CONSTANT: -√2/2 $[ 0.5 sqrt neg ] + +! unit circle as NURBS +3 { + { 1.0 0.0 1.0 } + { $ √2/2 $ √2/2 $ √2/2 } + { 0.0 1.0 1.0 } + { $ -√2/2 $ √2/2 $ √2/2 } + { -1.0 0.0 1.0 } + { $ -√2/2 $ -√2/2 $ √2/2 } + { 0.0 -1.0 1.0 } + { $ √2/2 $ -√2/2 $ √2/2 } + { 1.0 0.0 1.0 } +} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } test-nurbs set + +[ t ] [ test-nurbs get 0.0 eval-nurbs { 1.0 0.0 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.25 eval-nurbs { 0.0 1.0 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test + +[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test diff --git a/extra/nurbs/nurbs.factor b/extra/nurbs/nurbs.factor new file mode 100644 index 0000000000..ff77d3e915 --- /dev/null +++ b/extra/nurbs/nurbs.factor @@ -0,0 +1,73 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays grouping kernel locals math math.order +math.ranges math.vectors math.vectors.homogeneous sequences +specialized-arrays.float ; +IN: nurbs + +TUPLE: nurbs-curve + { order integer } + control-points + knots + (knot-constants) ; + +: ?recip ( n -- 1/n ) + dup zero? [ recip ] unless ; + +:: order-index-knot-constants ( curve order index -- knot-constants ) + curve knots>> :> knots + index order 1 - + knots nth :> knot_i+k-1 + index knots nth :> knot_i + index order + knots nth :> knot_i+k + index 1 + knots nth :> knot_i+1 + + knot_i+k-1 knot_i - ?recip :> c1 + knot_i+1 knot_i+k - ?recip :> c2 + + knot_i c1 * neg :> c3 + knot_i+k c2 * neg :> c4 + + c1 c2 c3 c4 float-array{ } 4sequence ; + +: order-knot-constants ( curve order -- knot-constants ) + 2dup [ knots>> length ] dip - iota + [ order-index-knot-constants ] with with map ; + +: knot-constants ( curve -- knot-constants ) + 2 over order>> [a,b] + [ order-knot-constants ] with map ; + +: update-knots ( curve -- curve ) + dup knot-constants >>(knot-constants) ; + +: ( order control-points knots -- nurbs-curve ) + f nurbs-curve boa update-knots ; + +: knot-interval ( nurbs-curve t -- index ) + [ knots>> ] dip [ > ] curry find drop 1 - ; + +: clip-range ( from to sequence -- from' to' ) + length min [ 0 max ] dip ; + +:: eval-base ( knot-constants bases t -- base ) + knot-constants first t * knot-constants third + bases first * + knot-constants second t * knot-constants fourth + bases second * + + ; + +: (eval-curve) ( base-values control-points -- value ) + [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ; + +:: (eval-bases) ( curve t interval values order -- values' ) + order 2 - curve (knot-constants)>> nth :> all-knot-constants + interval order interval + all-knot-constants clip-range :> to :> from + from to all-knot-constants subseq :> knot-constants + values { 0.0 } { 0.0 } surround 2 :> bases + + knot-constants bases [ t eval-base ] 2map :> values' + order curve order>> = + [ values' from to curve control-points>> subseq (eval-curve) ] + [ curve t interval 1 - values' order 1 + (eval-bases) ] if ; + +: eval-nurbs ( nurbs-curve t -- value ) + 2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ; + + diff --git a/extra/nurbs/summary.txt b/extra/nurbs/summary.txt new file mode 100644 index 0000000000..46b9bebffb --- /dev/null +++ b/extra/nurbs/summary.txt @@ -0,0 +1 @@ +NURBS curve evaluation From 483c936eb335c179aec59ec6d248a7f472584e01 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 21 May 2009 20:56:57 -0500 Subject: [PATCH 125/228] get rid of useless test --- basis/compiler/tree/cleanup/cleanup-tests.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index c596be263a..549d492d20 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -136,8 +136,6 @@ M: object xyz ; \ +-integer-fixnum inlined? ] unit-test -[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test - [ t ] [ [ [ no-cond ] 1 From a20586855883948d5f2a9af38f6d16d913b5a557 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 May 2009 21:23:01 -0500 Subject: [PATCH 126/228] tuple-arrays: clean up a bit and add docs --- basis/tuple-arrays/tuple-arrays-docs.factor | 25 +++++++++++++++++++++ basis/tuple-arrays/tuple-arrays.factor | 2 +- 2 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 basis/tuple-arrays/tuple-arrays-docs.factor diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor new file mode 100644 index 0000000000..cedf900698 --- /dev/null +++ b/basis/tuple-arrays/tuple-arrays-docs.factor @@ -0,0 +1,25 @@ +IN: tuple-arrays +USING: help.markup help.syntax sequences ; + +HELP: TUPLE-ARRAY: +{ $syntax "TUPLE-ARRAY: class" } +{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ; + +ARTICLE: "tuple-arrays" "Tuple arrays" +"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array." +$nl +"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "." +$nl +"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays." +{ $subsection POSTPONE: TUPLE-ARRAY: } +"An example:" +{ $example + "USE: tuple-arrays" + "IN: scratchpad" + "TUPLE: point x y ;" + "TUPLE-ARRAY: point" + "{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short." + "T{ point f 1 2 }" +} ; + +ABOUT: "tuple-arrays" \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 35d771416c..761dbd816a 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -21,7 +21,7 @@ MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; [ new ] [ smart-tuple>array ] bi ; inline : tuple-slice ( n seq -- slice ) - [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline + [ n>> [ * dup ] keep + ] [ seq>> ] bi slice boa ; inline : read-tuple ( slice class -- tuple ) '[ _ boa-unsafe ] input Date: Thu, 21 May 2009 23:27:42 -0500 Subject: [PATCH 127/228] io.monitors: fix example (reported by levy in #concatenative0 --- basis/io/monitors/monitors-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index f0278e300e..c5f266de56 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -112,10 +112,10 @@ $nl { $code "USE: io.monitors" ": watch-loop ( monitor -- )" - " dup next-change . nl nl flush watch-loop ;" + " dup next-change path>> print nl nl flush watch-loop ;" "" ": watch-directory ( path -- )" - " [ t [ watch-loop ] with-monitor ] with-monitors" + " [ t [ watch-loop ] with-monitor ] with-monitors ;" } ; ABOUT: "io.monitors" From 10f86331b4b1b8c20054b5f01e3a6472e03d8b63 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 01:59:50 -0500 Subject: [PATCH 128/228] If a vocab fails to load, manifest would be left in a weird state (reported by Joe Groff) --- core/parser/parser-tests.factor | 11 ++++++++++- core/vocabs/loader/test/l/l.factor | 4 ++++ core/vocabs/loader/test/l/tags.txt | 1 + core/vocabs/parser/parser.factor | 4 ++-- 4 files changed, 17 insertions(+), 3 deletions(-) create mode 100644 core/vocabs/loader/test/l/l.factor create mode 100644 core/vocabs/loader/test/l/tags.txt diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a9e0bd08ab..32f432a6cd 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -618,4 +618,13 @@ EXCLUDE: qualified.tests.bar => x ; [ "USE: kernel UNUSE: kernel dup" "unuse-test" parse-stream -] [ error>> error>> error>> no-word-error? ] must-fail-with \ No newline at end of file +] [ error>> error>> error>> no-word-error? ] must-fail-with + +[ ] [ [ "vocabs.loader.test.l" forget-vocab ] with-compilation-unit ] unit-test + +[ + [ "vocabs.loader.test.l" use-vocab ] must-fail + [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test + [ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test + [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test +] with-file-vocabs diff --git a/core/vocabs/loader/test/l/l.factor b/core/vocabs/loader/test/l/l.factor new file mode 100644 index 0000000000..10cd35dff2 --- /dev/null +++ b/core/vocabs/loader/test/l/l.factor @@ -0,0 +1,4 @@ +IN: vocabs.loader.test.l +USE: kernel + +"Oops" throw \ No newline at end of file diff --git a/core/vocabs/loader/test/l/tags.txt b/core/vocabs/loader/test/l/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/core/vocabs/loader/test/l/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index 45084ae8ff..ff55f8e68d 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -108,8 +108,8 @@ TUPLE: no-current-vocab ; dup using-vocab? [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [ manifest get - [ [ vocab-name ] dip search-vocab-names>> conjoin ] [ [ load-vocab ] dip search-vocabs>> push ] + [ [ vocab-name ] dip search-vocab-names>> conjoin ] 2bi ] if ; @@ -121,8 +121,8 @@ TUPLE: no-current-vocab ; : unuse-vocab ( vocab -- ) dup using-vocab? [ manifest get - [ [ vocab-name ] dip search-vocab-names>> delete-at ] [ [ load-vocab ] dip search-vocabs>> delq ] + [ [ vocab-name ] dip search-vocab-names>> delete-at ] 2bi ] [ drop ] if ; From 5331e5ed16d6ebb047ffca82946fe798436d9059 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 02:04:36 -0500 Subject: [PATCH 129/228] io.monitors: spawn-monitor was broken and never used, so remove it (reported by levi in #concatenative) --- basis/io/monitors/monitors.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index 7d40a1563a..cc8cea37d2 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -60,9 +60,6 @@ SYMBOL: +rename-file+ : run-monitor ( path recursive? quot -- ) '[ [ @ t ] loop ] with-monitor ; inline -: spawn-monitor ( path recursive? quot -- ) - [ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi - spawn drop ; { { [ os macosx? ] [ "io.monitors.macosx" require ] } { [ os linux? ] [ "io.monitors.linux" require ] } From ec543242ea700c2ab165bce5386e56a3d3064b61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 16:21:35 -0500 Subject: [PATCH 130/228] webapps.mason: spiff up download.xml a bit --- extra/webapps/mason/download.xml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml index af4ac0214d..6dca81baf8 100644 --- a/extra/webapps/mason/download.xml +++ b/extra/webapps/mason/download.xml @@ -4,9 +4,12 @@ + Factor binary package for <t:label t:name="platform" /> +
    Logo
    +

    Factor binary package for

    Requirements:

    From 9dd3f818d7f5228cc4c89b77a1a6ff9aa15d8113 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 May 2009 17:15:40 -0500 Subject: [PATCH 131/228] fix random.windows -- use CRYPT_MACHINE_KEYSET --- basis/random/windows/windows.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 6dce078d67..06a7634a43 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -25,7 +25,8 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer" CryptAcquireContextW handle swap ; : acquire-crypto-context ( provider type -- handle ) - 0 (acquire-crypto-context) + CRYPT_MACHINE_KEYSET + (acquire-crypto-context) 0 = [ GetLastError NTE_BAD_KEYSET = [ drop f ] [ win32-error-string throw ] if @@ -34,7 +35,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer" ] if ; : create-crypto-context ( provider type -- handle ) - CRYPT_NEWKEYSET (acquire-crypto-context) win32-error=0/f *void* ; + { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } (acquire-crypto-context) win32-error=0/f *void* ; ERROR: acquire-crypto-context-failed provider type ; From 809a153c10fef24613541ecf150ff8d6cd358e98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 22 May 2009 17:18:24 -0500 Subject: [PATCH 132/228] fix typo --- basis/random/windows/windows.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 06a7634a43..83b1fab0d0 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,7 +1,7 @@ USING: accessors alien.c-types byte-arrays combinators.short-circuit continuations destructors init kernel locals namespaces random windows.advapi32 windows.errors -windows.kernel32 ; +windows.kernel32 math.bitwise ; IN: random.windows TUPLE: windows-rng provider type ; @@ -35,7 +35,8 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer" ] if ; : create-crypto-context ( provider type -- handle ) - { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } (acquire-crypto-context) win32-error=0/f *void* ; + { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags + (acquire-crypto-context) win32-error=0/f *void* ; ERROR: acquire-crypto-context-failed provider type ; From 7f04440566f668f043631a0a60e39204eeb03c68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 17:32:27 -0500 Subject: [PATCH 133/228] webapps.mason: make it look like the factorcode.org site --- extra/webapps/mason/download.xml | 5 ++++- extra/webapps/mason/mason.factor | 22 +++++++++++----------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/extra/webapps/mason/download.xml b/extra/webapps/mason/download.xml index 6dca81baf8..7e50f958cd 100644 --- a/extra/webapps/mason/download.xml +++ b/extra/webapps/mason/download.xml @@ -1,8 +1,11 @@ + + - + Factor binary package for <t:label t:name="platform" /> diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 4d42617520..690c4c9660 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -21,12 +21,13 @@ TUPLE: mason-app < dispatcher ; ] dip link ; : download-grid-cell ( cpu os -- xml ) - builder new swap >>os swap >>cpu select-tuple dup - [ + builder new swap >>os swap >>cpu select-tuple [ dup last-release>> dup [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if - ] when - [XML <-> XML] ; + [XML
    <->
    XML] + ] [ + [XML XML] + ] if* ; CONSTANT: oses { @@ -47,22 +48,21 @@ CONSTANT: cpus : download-grid ( -- xml ) oses - [ values [ [XML <-> XML] ] map ] + [ values [ [XML <-> XML] ] map ] [ keys cpus [ [ nip second ] [ first ] 2bi [ swap download-grid-cell - ] curry map [XML <-><-> XML] + ] curry map + [XML <-><-> XML] ] with map - ] bi [XML <->
    <->
    XML] ; + ] bi + [XML <->
    <->
    XML] ; : ( -- action ) - [ - download-grid - xml>string "text/html" - ] >>display ; + [ download-grid xml>string "text/html" ] >>display ; : validate-os/cpu ( -- ) { From 4bce8da3451169055797caa393735e93cab44d51 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 17:42:05 -0500 Subject: [PATCH 134/228] More cosmetic tweaks --- extra/webapps/mason/mason.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 690c4c9660..fad77286b2 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -26,7 +26,7 @@ TUPLE: mason-app < dispatcher ; [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if [XML
    <->
    XML] ] [ - [XML XML] + [XML XML] ] if* ; CONSTANT: oses @@ -58,7 +58,12 @@ CONSTANT: cpus [XML <-><-> XML] ] with map ] bi - [XML <->
    <->
    XML] ; + [XML + + <-> + <-> +
    OS/CPU
    + XML] ; : ( -- action ) From df769f53952258b950c0a0782dc94bc462a43e7d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 17:48:05 -0500 Subject: [PATCH 135/228] One last tweak --- extra/webapps/mason/mason.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index fad77286b2..f7aadb9a54 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -15,7 +15,7 @@ TUPLE: mason-app < dispatcher ; : download-link ( builder label -- xml ) [ - [ URL" download" ] dip + [ URL" http://builds.factorcode.org/download" ] dip [ os>> "os" set-query-param ] [ cpu>> "cpu" set-query-param ] bi ] dip link ; @@ -137,16 +137,16 @@ CONSTANT: cpus os>> { { "winnt" "Windows XP (also tested on Vista)" } { "macosx" "Mac OS X 10.5 Leopard" } - { "linux" "Linux 2.6.16 with GLIBC 2.4" } + { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" } { "freebsd" "FreeBSD 7.0" } { "netbsd" "NetBSD 4.0" } - { "openbsd" "OpenBSD 4.2" } + { "openbsd" "OpenBSD 4.4" } } at ] [ dup cpu>> "x86.32" = [ os>> { - { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } - { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } + { [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] } + { [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] } { [ t ] [ drop f ] } } cond ] [ drop f ] if From 85186e15eda4ddd6676281f68ad4db0448df01ec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 May 2009 17:52:31 -0500 Subject: [PATCH 136/228] websites.concatenatieve: add builds.factorcode.org --- extra/websites/concatenative/concatenative.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index d7b132d4f2..207ae9ab34 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -23,7 +23,8 @@ webapps.pastebin webapps.planet webapps.wiki webapps.user-admin -webapps.help ; +webapps.help +webapps.mason ; IN: websites.concatenative : test-db ( -- db ) "resource:test.db" ; @@ -95,6 +96,7 @@ SYMBOL: dh-file test-db "planet.factorcode.org" add-responder home "docs" append-path test-db "docs.factorcode.org" add-responder home "cgi" append-path "gitweb.factorcode.org" add-responder + "builds.factorcode.org" add-responder main-responder set-global ; : ( -- config ) From f45d82c01be54eed5c9707224855f2744e5756d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 May 2009 00:31:52 -0500 Subject: [PATCH 137/228] checksums.md5: make the new optimized code work with big endian CPUs --- basis/checksums/md5/md5.factor | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index c74aa550d2..d59976fb7e 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.binary io.files io.streams.byte-array math +USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math math.functions math.parser namespaces splitting grouping strings sequences byte-arrays locals sequences.private macros fry io.encodings.binary math.bitwise checksums accessors @@ -173,9 +173,27 @@ HINTS: (process-md5-block-G) { uint-array md5-state } ; HINTS: (process-md5-block-H) { uint-array md5-state } ; HINTS: (process-md5-block-I) { uint-array md5-state } ; +: byte-array>le ( byte-array -- byte-array ) + little-endian? [ + dup 4 [ + [ [ 1 2 ] dip exchange-unsafe ] + [ [ 0 3 ] dip exchange-unsafe ] bi + ] each + ] unless ; + +: byte-array>uint-array-le ( byte-array -- uint-array ) + byte-array>le byte-array>uint-array ; + +HINTS: byte-array>uint-array-le byte-array ; + +: uint-array>byte-array-le ( uint-array -- byte-array ) + underlying>> byte-array>le ; + +HINTS: uint-array>byte-array-le uint-array ; + M: md5-state checksum-block ( block state -- ) [ - [ byte-array>uint-array ] [ state>> ] bi* { + [ byte-array>uint-array-le ] [ state>> ] bi* { [ (process-md5-block-F) ] [ (process-md5-block-G) ] [ (process-md5-block-H) ] @@ -185,7 +203,7 @@ M: md5-state checksum-block ( block state -- ) nip update-md5 ] 2bi ; -: md5>checksum ( md5 -- bytes ) state>> underlying>> ; +: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ; M: md5-state clone ( md5 -- new-md5 ) call-next-method From 3a8fb29d70dcc8bf93a49788db95cd845b393f0d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 23 May 2009 08:39:01 -0500 Subject: [PATCH 138/228] disable WGL_ARB_pixel_format code path in windows UI backend 'cause ATI drivers are shit --- basis/ui/backend/windows/windows.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index e28776a51c..551d89b66c 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -51,10 +51,8 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{ { samples { $ WGL_SAMPLES_ARB } } } -MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? ) - { "WGL_ARB_pixel_format" } has-wgl-extensions? ; : has-wglChoosePixelFormatARB? ( world -- ? ) - handle>> hDC>> (has-wglChoosePixelFormatARB?) ; + drop f ; : arb-make-pixel-format ( world attributes -- pf ) [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 0 From f28439329c8557effe864c37523b719bab9c6f0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 May 2009 15:47:08 -0500 Subject: [PATCH 139/228] compiler.cfg.stack-analysis: change how inc-d/inc-r work --- basis/compiler/cfg/stack-analysis/stack-analysis.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index cbe46d7dd4..d43d97a8e0 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -101,11 +101,11 @@ M: neutral-insn visit , ; : adjust-d ( n -- ) state get [ + ] change-d-height drop ; -M: ##inc-d visit n>> adjust-d ; +M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ; : adjust-r ( n -- ) state get [ + ] change-r-height drop ; -M: ##inc-r visit n>> adjust-r ; +M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ; : eliminate-peek ( dst src -- ) ! the requested stack location is already in 'src' From c2499cdd55e20809fcf79a88c66d4e7b0c829874 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 May 2009 15:50:35 -0500 Subject: [PATCH 140/228] stack-checker: fix case where invalid code could infer --- basis/compiler/tree/normalization/normalization.factor | 2 +- basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor | 2 ++ basis/stack-checker/branches/branches.factor | 8 ++++++-- basis/stack-checker/known-words/known-words.factor | 2 -- basis/stack-checker/stack-checker-tests.factor | 6 +++++- basis/stack-checker/transforms/transforms-tests.factor | 2 +- 6 files changed, 15 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 7494ed064e..fcfa42c70b 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -60,7 +60,7 @@ M: #branch normalize* : eliminate-phi-introductions ( introductions seq terminated -- seq' ) [ [ nip ] [ - dup [ +bottom+ eq? ] trim-head + dup [ +top+ eq? ] trim-head [ [ length ] bi@ - tail* ] keep append ] if ] 3map ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 107ea59902..6bed4407b8 100755 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -91,6 +91,8 @@ M: #terminate unbox-tuples* [ flatten-values ] change-in-r ; M: #phi unbox-tuples* + ! pad-with-bottom is only needed if some branches are terminated, + ! which means all output values are bottom [ [ flatten-values ] map pad-with-bottom ] change-phi-in-d [ flatten-values ] change-out-d ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 690af39c28..8b0665aa49 100755 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -9,12 +9,16 @@ IN: stack-checker.branches : balanced? ( pairs -- ? ) [ second ] filter [ first2 length - ] map all-equal? ; -SYMBOL: +bottom+ +SYMBOLS: +bottom+ +top+ ; : unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) - dup [ [ - +bottom+ ] dip append ] [ 3drop f ] if ; + ! Introduced values can be anything, and don't unify with + ! literals. + dup [ [ - +top+ ] dip append ] [ 3drop f ] if ; : pad-with-bottom ( seq -- newseq ) + ! Terminated branches are padded with bottom values which + ! unify with literals. dup empty? [ dup [ length ] [ max ] map-reduce '[ _ +bottom+ pad-head ] map diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 70382c0829..cf2d08b84f 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -219,8 +219,6 @@ M: object infer-call* \ compose f "no-compile" set-word-prop ! More words not to compile -\ call t "no-compile" set-word-prop -\ execute t "no-compile" set-word-prop \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 201f3ce30b..b84f561861 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -371,4 +371,8 @@ DEFER: eee' [ [ bi ] infer ] must-fail [ at ] must-infer -[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer + +! Found during code review +[ [ [ drop [ ] ] when call ] infer ] must-fail +[ swap [ [ drop [ ] ] when call ] infer ] must-fail \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index fe0fa08356..843083bd52 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -6,7 +6,7 @@ classes classes.tuple ; : compose-n ( quot n -- ) "OOPS" throw ; << -: compose-n-quot ( word n -- quot' ) >quotation ; +: compose-n-quot ( n word -- quot' ) >quotation ; \ compose-n [ compose-n-quot ] 2 define-transform \ compose-n t "no-compile" set-word-prop >> From 4ffbc90ee79d949f1404cd4e972972e19be8bf39 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 24 May 2009 15:42:57 +0200 Subject: [PATCH 141/228] Do not create an extra scope in "if-amb" --- extra/backtrack/backtrack.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 9bef16d609..48bae97699 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -29,6 +29,10 @@ MACRO: checkpoint ( quot -- quot' ) [ 1quotation ] assoc-map ] bi '[ _ 0 unsafe-number-from-to nip _ case ] ; -: if-amb ( true false -- ) +: if-amb ( true false -- ? ) [ [ { t f } amb ] [ '[ @ require t ] ] [ '[ @ f ] ] tri* if - ] with-scope ; inline + ] amb-preserve ; inline : cut-amb ( -- ) f failure set ; From 5e96172ce10db721f247921fff9df31565a47415 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 24 May 2009 15:43:28 +0200 Subject: [PATCH 142/228] Add amb-all and bag-of --- extra/backtrack/backtrack.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 48bae97699..e4e13c3363 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -71,3 +71,9 @@ MACRO: amb-execute ( seq -- quot ) : cut-amb ( -- ) f failure set ; + +: amb-all ( quot -- ) + [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline + +: bag-of ( quot -- seq ) + V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline From 76e4245d6a76b30f29411d6dfb1a0be19f517f09 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 24 May 2009 15:40:08 +0200 Subject: [PATCH 143/228] Add documentation and tests for extra/backtrack --- extra/backtrack/backtrack-docs.factor | 53 ++++++++++++++++++++++++++ extra/backtrack/backtrack-tests.factor | 15 ++++++++ 2 files changed, 68 insertions(+) create mode 100644 extra/backtrack/backtrack-docs.factor create mode 100644 extra/backtrack/backtrack-tests.factor diff --git a/extra/backtrack/backtrack-docs.factor b/extra/backtrack/backtrack-docs.factor new file mode 100644 index 0000000000..c654ac234f --- /dev/null +++ b/extra/backtrack/backtrack-docs.factor @@ -0,0 +1,53 @@ +! Copyright (c) 2009 Samuel Tardieu. +! See See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: backtrack + +HELP: fail +{ $description "Signal that the current alternative is not acceptable. This will cause either backtracking to occur, or a failure to be signalled, as explained in the " { $link amb } " word description." } +{ $see-also amb cut-amb } +; + +HELP: amb +{ $values + { "seq" "the alternatives" } + { "elt" "one of the alternatives" } +} +{ $description "The amb (ambiguous) word saves the state of the current computation (through the " { $vocab-link "continuations" } " vocabulary) and returns the first alternative. When " { $link fail } " is invoked, the saved state will be restored and the next alternative will be returned. When there are no more alternatives, " { $link fail } " will go up one level to the location of the previous " { $link amb } " call. If there are no more calls up the chain, an error will be signalled." } +{ $see-also fail cut-amb } +; + +HELP: cut-amb +{ $description "Reset the amb system. Calling this word resets the whole stack of " { $link amb } " calls and should not be done lightly."} +{ $see-also amb fail } +; + +HELP: amb-execute +{ $values + { "seq" "a list of words" } +} +{ $description "Execute the first word in the list, and go to the next one if " { $link fail } " is called." } ; + +HELP: if-amb +{ $values + { "true" "a quotation with stack effect ( -- ? )" } + { "false" "a quotation" } + { "?" "a boolean" } +} +{ $description "Execute the first quotation and returns " { $link t } " if it returns " { $link t } " itself. If it fails with " { $link fail } " or returns " { $link f } ", then the second quotation is executed and " { $link f } " is returned." } ; + +HELP: amb-all +{ $values + { "quot" "a quotation with stack effect ( -- )" } +} +{ $description "Execute all the alternatives in the quotation by calling " { $link fail } " repeatedly at the end." } +{ $see-also bag-of fail } +; + +HELP: bag-of +{ $values + { "quot" "a quotation with stack effect ( -- result )" } + { "seq" "a sequence" } +} +{ $description "Execute all the alternatives in the quotation and collect the results." } +{ $see-also amb-all } ; \ No newline at end of file diff --git a/extra/backtrack/backtrack-tests.factor b/extra/backtrack/backtrack-tests.factor new file mode 100644 index 0000000000..d8e9830532 --- /dev/null +++ b/extra/backtrack/backtrack-tests.factor @@ -0,0 +1,15 @@ +! Copyright (c) 2009 Samuel Tardieu. +! See See http://factorcode.org/license.txt for BSD license. +USING: backtrack math tools.test ; + +cut-amb +[ 1 ] [ { 1 2 } amb ] unit-test +[ V{ { 1 2 } } ] [ [ { 1 2 } ] bag-of ] unit-test +[ V{ 1 2 } ] [ [ { 1 2 } amb ] bag-of ] unit-test +[ cut-amb { } amb ] must-fail +[ fail ] must-fail +[ V{ 1 10 2 20 } ] [ [ { 1 2 } amb { 1 10 } amb * ] bag-of ] unit-test +[ V{ 7 -1 } ] [ [ 3 4 { + - } amb-execute ] bag-of ] unit-test +[ "foo" t ] [ [ "foo" t ] [ "bar" ] if-amb ] unit-test +[ "bar" f ] [ [ "foo" f ] [ "bar" ] if-amb ] unit-test +[ "bar" f ] [ [ "foo" fail ] [ "bar" ] if-amb ] unit-test From 2e2dab011d20b97e818be3b3301271c32fc47c86 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 May 2009 15:45:25 -0500 Subject: [PATCH 144/228] add a mode word --- basis/math/statistics/statistics-tests.factor | 3 +++ basis/math/statistics/statistics.factor | 9 ++++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index c160d57db7..32ebcbc6a1 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -13,6 +13,9 @@ IN: math.statistics.tests [ 2 ] [ { 1 2 3 } median ] unit-test [ 5/2 ] [ { 1 2 3 4 } median ] unit-test +[ 1 ] [ { 1 } mode ] unit-test +[ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test + [ { } median ] must-fail [ { } upper-median ] must-fail [ { } lower-median ] must-fail diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 3812e79ec5..a1a214b2c0 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators kernel math math.analysis math.functions math.order sequences sorting locals -sequences.private ; +sequences.private assocs fry ; IN: math.statistics : mean ( seq -- x ) @@ -56,6 +56,13 @@ IN: math.statistics : median ( seq -- x ) dup length odd? [ lower-median ] [ medians + 2 / ] if ; +: frequency ( seq -- hashtable ) + H{ } clone [ '[ _ inc-at ] each ] keep ; + +: mode ( seq -- x ) + frequency >alist + [ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ; + : minmax ( seq -- min max ) #! find the min and max of a seq in one pass [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ; From 34e1d605785be62e629f8ae52753c0094d38d866 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 May 2009 21:35:50 -0500 Subject: [PATCH 145/228] add a clamp word to math.order, use clamp word throughout libraries --- basis/compiler/tree/propagation/propagation-tests.factor | 6 +++--- basis/math/functions/functions-docs.factor | 3 ++- basis/math/ranges/ranges.factor | 6 +++++- basis/models/models.factor | 3 +-- core/math/order/order-docs.factor | 5 +++++ core/math/order/order-tests.factor | 3 +++ core/math/order/order.factor | 1 + extra/math/compare/compare-tests.factor | 5 ----- extra/math/compare/compare.factor | 3 --- extra/terrain/terrain.factor | 2 +- 10 files changed, 21 insertions(+), 16 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index aba8dc9eda..9cb0e41291 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -197,7 +197,7 @@ IN: compiler.tree.propagation.tests { fixnum byte-array } declare [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift - 255 min 0 max + 0 255 clamp ] final-classes ] unit-test @@ -210,7 +210,7 @@ IN: compiler.tree.propagation.tests ] unit-test [ V{ 1.5 } ] [ - [ /f 1.5 min 1.5 max ] final-literals + [ /f 1.5 1.5 clamp ] final-literals ] unit-test [ V{ 1.5 } ] [ @@ -693,4 +693,4 @@ TUPLE: circle me ; [ ] [ circle new dup >>me 1quotation final-info drop ] unit-test ! Joe found an oversight -[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 48da8aa6ec..41800e46da 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -23,9 +23,10 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions" "Incrementing, decrementing:" { $subsection 1+ } { $subsection 1- } -"Minimum, maximum:" +"Minimum, maximum, clamping:" { $subsection min } { $subsection max } +{ $subsection clamp } "Complex conjugation:" { $subsection conjugate } "Tests:" diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 883be006dc..d0c918458a 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -26,12 +26,16 @@ M: range hashcode* tuple-hashcode ; INSTANCE: range immutable-sequence + -1 1 ? ; inline : (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline : ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline +PRIVATE> + : [a,b] ( a b -- range ) twiddle ; inline : (a,b] ( a b -- range ) twiddle (a, ; inline @@ -62,7 +66,7 @@ INSTANCE: range immutable-sequence dup range-decreasing? first-or-peek ; : clamp-to-range ( n range -- n ) - [ range-min max ] [ range-max min ] bi ; + [ range-min ] [ range-max ] bi clamp ; : sequence-index-range ( seq -- range ) length [0,b) ; diff --git a/basis/models/models.factor b/basis/models/models.factor index 4f7aafe3e3..19b478eaf9 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -109,5 +109,4 @@ GENERIC: set-range-min-value ( value model -- ) GENERIC: set-range-max-value ( value model -- ) : clamp-value ( value range -- newvalue ) - [ range-min-value max ] keep - range-max-value* min ; + [ range-min-value ] [ range-max-value* ] bi clamp ; diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 8b2200aa67..368d060eb9 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -51,6 +51,10 @@ HELP: min { $values { "x" real } { "y" real } { "z" real } } { $description "Outputs the smallest of two real numbers." } ; +HELP: clamp +{ $values { "x" real } { "min" real } { "max" real } { "y" real } } +{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ; + HELP: between? { $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." } @@ -105,6 +109,7 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection "order-specifiers" } "Utilities for comparing objects:" { $subsection after? } +{ $subsection after? } { $subsection before? } { $subsection after=? } { $subsection before=? } diff --git a/core/math/order/order-tests.factor b/core/math/order/order-tests.factor index 665537be5d..edd50d3f55 100644 --- a/core/math/order/order-tests.factor +++ b/core/math/order/order-tests.factor @@ -7,3 +7,6 @@ IN: math.order.tests [ +eq+ ] [ 4 4 <=> ] unit-test [ +gt+ ] [ 4 3 <=> ] unit-test +[ 20 ] [ 20 0 100 clamp ] unit-test +[ 0 ] [ -20 0 100 clamp ] unit-test +[ 100 ] [ 120 0 100 clamp ] unit-test diff --git a/core/math/order/order.factor b/core/math/order/order.factor index a06209bf63..435eec9b96 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -34,6 +34,7 @@ M: real after=? ( obj1 obj2 -- ? ) >= ; : min ( x y -- z ) [ before? ] most ; inline : max ( x y -- z ) [ after? ] most ; inline +: clamp ( x min max -- y ) [ max ] dip min ; inline : between? ( x y z -- ? ) pick after=? [ after=? ] [ 2drop f ] if ; inline diff --git a/extra/math/compare/compare-tests.factor b/extra/math/compare/compare-tests.factor index 272471fe5d..5b30af0e63 100644 --- a/extra/math/compare/compare-tests.factor +++ b/extra/math/compare/compare-tests.factor @@ -14,8 +14,3 @@ IN: math.compare.tests [ 0 ] [ 1 3 negmin ] unit-test [ -3 ] [ 1 -3 negmin ] unit-test [ -1 ] [ -1 3 negmin ] unit-test - -[ 0 ] [ 0 -1 2 clamp ] unit-test -[ 1 ] [ 0 1 2 clamp ] unit-test -[ 2 ] [ 0 3 2 clamp ] unit-test - diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor index 826f0ecf16..b48641d723 100644 --- a/extra/math/compare/compare.factor +++ b/extra/math/compare/compare.factor @@ -14,6 +14,3 @@ IN: math.compare : negmin ( a b -- x ) 0 min min ; - -: clamp ( a value b -- x ) - min max ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 5847426fae..42aa7e903a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -88,7 +88,7 @@ M: terrain-world tick-length yaw>> 0.0 ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; : clamp-pitch ( pitch -- pitch' ) - 90.0 min -90.0 max ; + -90.0 90.0 clamp ; : walk-forward ( player -- ) dup forward-vector [ v+ ] curry change-velocity drop ; From 5cfc1ab16d9195824deb0b236f5ff0c6dc5354b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 May 2009 21:46:59 -0500 Subject: [PATCH 146/228] remove at-default. it was hardly used and it's just '?at drop' --- basis/core-text/fonts/fonts.factor | 2 +- basis/unicode/data/data.factor | 6 +++--- basis/windows/fonts/fonts.factor | 2 +- core/assocs/assocs-docs.factor | 3 ++- core/assocs/assocs-tests.factor | 12 ------------ core/assocs/assocs.factor | 3 --- misc/vim/syntax/factor.vim | 2 +- 7 files changed, 8 insertions(+), 22 deletions(-) diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 4525509d44..2656811c1f 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -82,7 +82,7 @@ CONSTANT: font-names } : font-name ( string -- string' ) - font-names at-default ; + font-names ?at drop ; : (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 318a56627b..1c6c6afdf3 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -33,9 +33,9 @@ VALUE: name-map : name>char ( name -- char ) name-map at ; inline : char>name ( char -- name ) name-map value-at ; inline : property? ( char property -- ? ) properties at interval-key? ; inline -: ch>lower ( ch -- lower ) simple-lower at-default ; inline -: ch>upper ( ch -- upper ) simple-upper at-default ; inline -: ch>title ( ch -- title ) simple-title at-default ; inline +: ch>lower ( ch -- lower ) simple-lower ?at drop ; inline +: ch>upper ( ch -- upper ) simple-upper ?at drop ; inline +: ch>title ( ch -- title ) simple-title ?at drop ; inline : special-case ( ch -- casing-tuple ) special-casing at ; inline ! For non-existent characters, use Cn diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index 1753ff1ce1..269e8f8f48 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -7,7 +7,7 @@ IN: windows.fonts { "sans-serif" "Tahoma" } { "serif" "Times New Roman" } { "monospace" "Courier New" } - } at-default ; + } ?at drop ; MEMO:: (cache-font) ( font -- HFONT ) font size>> neg ! nHeight diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index e56fedbd26..f971b8971b 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -66,7 +66,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs" { $see-also at* assoc-size } ; ARTICLE: "assocs-values" "Transposed assoc operations" -"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" +"default Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:" { $subsection value-at } { $subsection value-at* } { $subsection value? } @@ -119,6 +119,7 @@ $nl { $subsection assoc-any? } { $subsection assoc-all? } "Additional combinators:" +{ $subsection assoc-partition } { $subsection cache } { $subsection map>assoc } { $subsection assoc>map } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index fc74df6d45..c473ac0dfa 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -119,18 +119,6 @@ unit-test } extract-keys ] unit-test -[ f ] [ - "a" H{ { "a" f } } at-default -] unit-test - -[ "b" ] [ - "b" H{ { "a" f } } at-default -] unit-test - -[ "x" ] [ - "a" H{ { "a" "x" } } at-default -] unit-test - [ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [ H{ { "a" [ 1 ] } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e783ef81c4..d655b99c30 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -82,9 +82,6 @@ PRIVATE> : at ( key assoc -- value/f ) at* drop ; inline -: at-default ( key assoc -- value/key ) - ?at drop ; inline - M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ dup assoc-size ] dip new-assoc [ [ set-at ] with-assoc assoc-each ] keep ; diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 86f4f19147..8da50017c8 100755 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -47,7 +47,7 @@ syn keyword factorBoolean boolean f general-t t syn keyword factorCompileDirective inline foldable parsing syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean -syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip +syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip syn keyword factorKeyword case execute-effect dispatch-case-quot no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth second change-each join when-empty accumulator immutable-sequence? all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim From efde3ff5f332f9fd958f972a11b5de2d9973aa81 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 11:03:40 -0500 Subject: [PATCH 147/228] document 2cache --- core/assocs/assocs-docs.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index f971b8971b..12e895591c 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -121,6 +121,7 @@ $nl "Additional combinators:" { $subsection assoc-partition } { $subsection cache } +{ $subsection 2cache } { $subsection map>assoc } { $subsection assoc>map } { $subsection assoc-map-as } ; @@ -237,6 +238,13 @@ HELP: assoc-filter-as { assoc-filter assoc-filter-as } related-words +HELP: assoc-partition +{ $values + { "assoc" assoc } { "quot" quotation } + { "true-assoc" assoc } { "false-assoc" assoc } +} +{ $description "Calls a predicate quotation on each key of the input assoc. If the test yields true, the key/value pair is added to " { $snippet "true-assoc" } "; if false, it's added to " { $snippet "false-assoc" } "." } ; + HELP: assoc-any? { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } } { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; @@ -332,7 +340,12 @@ HELP: substitute HELP: cache { $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } -{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." } +{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc. Returns a value either looked up or newly stored in the assoc." } +{ $side-effects "assoc" } ; + +HELP: 2cache +{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } } +{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." } { $side-effects "assoc" } ; HELP: map>assoc From 9413ec45c2a0341dbd7d7f9cf851f53f09cc5008 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 13:58:06 -0500 Subject: [PATCH 148/228] remove clamp from docs --- extra/math/compare/compare-docs.factor | 5 ----- 1 file changed, 5 deletions(-) diff --git a/extra/math/compare/compare-docs.factor b/extra/math/compare/compare-docs.factor index 6c20db10fd..27e68081a6 100644 --- a/extra/math/compare/compare-docs.factor +++ b/extra/math/compare/compare-docs.factor @@ -16,8 +16,3 @@ HELP: posmax HELP: negmin { $values { "a" number } { "b" number } { "x" number } } { $description "Returns the most-negative value, or zero if both are positive." } ; - -HELP: clamp -{ $values { "a" number } { "value" number } { "b" number } { "x" number } } -{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ; - From f8d0b87f1e8ea5444e7fd9e0af3a0d871e824a5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 15:18:20 -0500 Subject: [PATCH 149/228] use iota --- basis/tools/hexdump/hexdump-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/hexdump/hexdump-tests.factor b/basis/tools/hexdump/hexdump-tests.factor index 1a8ed35510..75537b0c11 100644 --- a/basis/tools/hexdump/hexdump-tests.factor +++ b/basis/tools/hexdump/hexdump-tests.factor @@ -4,7 +4,7 @@ IN: tools.hexdump.tests [ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test [ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test -[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test +[ t ] [ 256 iota [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test [ From 43f22ec2b2030c0424f35e43e27544dfeb320187 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 15:35:50 -0500 Subject: [PATCH 150/228] move some words to private vocabs --- basis/hints/hints.factor | 10 +++++----- core/combinators/combinators-tests.factor | 2 +- core/combinators/combinators.factor | 5 ++++- core/splitting/splitting.factor | 4 ++++ 4 files changed, 14 insertions(+), 7 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index db04033275..7624cb1517 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser words definitions kernel sequences assocs arrays -kernel.private fry combinators accessors vectors strings sbufs -byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.single generic.standard classes -hashtables namespaces ; +USING: accessors arrays assocs byte-arrays byte-vectors classes +combinators definitions fry generic generic.single +generic.standard hashtables io.binary io.streams.string kernel +kernel.private math math.parser namespaces parser sbufs +sequences splitting splitting.private strings vectors words ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index aae6618ee8..b239b1eac9 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ USING: alien strings kernel math tools.test io prettyprint namespaces combinators words classes sequences accessors -math.functions arrays ; +math.functions arrays combinators.private ; IN: combinators.tests [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 7bf76fea30..f293030f25 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -101,6 +101,8 @@ ERROR: no-case object ; [ \ drop prefix ] bi* ] assoc-map alist>quot ; + + : case>quot ( default assoc -- quot ) dup keys { { [ dup empty? ] [ 2drop ] } @@ -160,7 +164,6 @@ ERROR: no-case object ; [ drop linear-case-quot ] } cond ; -! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index c55a75baa6..04b3e53422 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -53,6 +53,8 @@ PRIVATE> [ ] bi@ split1-slice [ ] bi@ [ f ] [ swap ] if-empty ; + : split, ( seq separators -- ) 0 rot (split) ; +PRIVATE> + : split ( seq separators -- pieces ) [ split, ] { } make ; From 508a7466c430636b1d5a907bd7b517fab06618f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 15:42:59 -0500 Subject: [PATCH 151/228] fix using --- core/generic/single/single.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 747963256d..8a2243c264 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -3,7 +3,8 @@ USING: accessors arrays assocs classes classes.algebra combinators definitions generic hashtables kernel kernel.private layouts math namespaces quotations -sequences words generic.single.private effects make ; +sequences words generic.single.private effects make +combinators.private ; IN: generic.single ERROR: no-method object generic ; From 8da9d0f2031f0a027b7587f08033e951d5ffa086 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 16:38:33 -0500 Subject: [PATCH 152/228] rename peek -> last and update all usages --- basis/bootstrap/compiler/compiler.factor | 2 +- basis/circular/circular.factor | 4 ++-- basis/compiler/cfg/alias-analysis/alias-analysis.factor | 2 +- basis/compiler/cfg/intrinsics/allot/allot.factor | 2 +- basis/compiler/cfg/iterator/iterator.factor | 2 +- basis/compiler/cfg/linear-scan/debugger/debugger.factor | 2 +- basis/compiler/cfg/linear-scan/linear-scan-tests.factor | 2 +- basis/compiler/cfg/useless-blocks/useless-blocks.factor | 2 +- basis/compiler/tree/dead-code/branches/branches.factor | 2 +- basis/compiler/tree/debugger/debugger.factor | 2 +- .../tree/propagation/constraints/constraints.factor | 2 +- basis/compiler/tree/propagation/info/info.factor | 8 ++++---- basis/compiler/tree/tree.factor | 2 +- basis/csv/csv.factor | 2 +- basis/documents/documents-tests.factor | 4 ++-- basis/documents/documents.factor | 4 ++-- basis/farkup/farkup.factor | 8 ++++---- basis/generalizations/generalizations.factor | 2 +- basis/heaps/heaps.factor | 2 +- basis/help/lint/checks/checks.factor | 2 +- basis/hints/hints.factor | 2 +- basis/http/parsers/parsers.factor | 2 +- basis/inspector/inspector.factor | 2 +- basis/inverse/inverse.factor | 2 +- basis/lcs/lcs.factor | 2 +- basis/logging/parser/parser.factor | 2 +- basis/math/bits/bits-tests.factor | 6 +++--- basis/math/polynomials/polynomials.factor | 2 +- basis/math/ranges/ranges.factor | 8 ++++---- basis/peg/ebnf/ebnf.factor | 2 +- basis/persistent/vectors/vectors.factor | 6 +++--- basis/porter-stemmer/porter-stemmer.factor | 8 ++++---- basis/prettyprint/sections/sections.factor | 8 ++++---- basis/quoted-printable/quoted-printable-tests.factor | 2 +- basis/quoting/quoting.factor | 4 ++-- basis/splitting/monotonic/monotonic.factor | 4 ++-- basis/stack-checker/transforms/transforms.factor | 4 ++-- basis/tools/completion/completion.factor | 4 ++-- basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/unicode/case/case.factor | 2 +- basis/unicode/collation/collation.factor | 8 ++++---- basis/vlists/vlists-tests.factor | 2 +- basis/xml/xml.factor | 2 +- core/classes/algebra/algebra.factor | 2 +- core/continuations/continuations.factor | 2 +- core/destructors/destructors.factor | 2 +- core/generic/math/math.factor | 2 +- core/generic/single/single.factor | 2 +- core/namespaces/namespaces.factor | 2 +- core/sequences/sequences-docs.factor | 7 +++---- core/sequences/sequences.factor | 6 +++--- core/splitting/splitting.factor | 2 +- core/vectors/vectors-tests.factor | 4 ++-- core/vocabs/loader/loader.factor | 2 +- core/vocabs/parser/parser.factor | 2 +- extra/24-game/24-game.factor | 2 +- extra/animations/animations.factor | 2 +- extra/bson/reader/reader.factor | 4 ++-- extra/dns/dns.factor | 2 +- extra/html/parser/parser.factor | 2 +- extra/irc/messages/messages.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 2 +- extra/mason/notify/server/server.factor | 2 +- extra/math/vectors/homogeneous/homogeneous.factor | 2 +- extra/project-euler/049/049.factor | 2 +- extra/project-euler/059/059.factor | 2 +- extra/project-euler/116/116.factor | 4 ++-- extra/project-euler/117/117.factor | 2 +- extra/project-euler/164/164.factor | 2 +- 69 files changed, 105 insertions(+), 106 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 5e3827efea..0505dcb184 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -69,7 +69,7 @@ nl "." write flush { - new-sequence nth push pop peek flip + new-sequence nth push pop last flip } compile-unoptimized "." write flush diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 909b2ed713..ae79e70d73 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -46,13 +46,13 @@ M: growing-circular length length>> ; : full? ( circular -- ? ) [ length ] [ seq>> length ] bi = ; -: set-peek ( elt seq -- ) +: set-last ( elt seq -- ) [ length 1- ] keep set-nth ; PRIVATE> : push-growing-circular ( elt circular -- ) dup full? [ push-circular ] - [ [ 1+ ] change-length set-peek ] if ; + [ [ 1+ ] change-length set-last ] if ; : ( capacity -- growing-circular ) { } new-sequence 0 0 growing-circular boa ; diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index ec8fe62dfb..2a9d2579e3 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -165,7 +165,7 @@ SYMBOL: heap-ac : record-constant-set-slot ( slot# vreg -- ) history [ - dup empty? [ dup peek store? [ dup pop* ] when ] unless + dup empty? [ dup last store? [ dup pop* ] when ] unless store new-action swap ?push ] change-at ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 938dbbccbf..7b407c3ee4 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -19,7 +19,7 @@ IN: compiler.cfg.intrinsics.allot [ second ds-load ] [ ^^load-literal ] bi prefix ; : emit- ( node -- ) - dup node-input-infos peek literal>> + dup node-input-infos last literal>> dup array? [ nip ds-drop diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor index 3444b517ac..a8958733a7 100644 --- a/basis/compiler/cfg/iterator/iterator.factor +++ b/basis/compiler/cfg/iterator/iterator.factor @@ -7,7 +7,7 @@ SYMBOL: node-stack : >node ( cursor -- ) node-stack get push ; : node> ( -- cursor ) node-stack get pop ; -: node@ ( -- cursor ) node-stack get peek ; +: node@ ( -- cursor ) node-stack get last ; : current-node ( -- node ) node@ first ; : iterate-next ( -- cursor ) node@ rest-slice ; : skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ; diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index c6481b305e..dad87b62ae 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -23,7 +23,7 @@ IN: compiler.cfg.linear-scan.debugger [ split-children ] map concat check-assigned ; : picture ( uses -- str ) - dup peek 1 + CHAR: space + dup last 1 + CHAR: space [ '[ CHAR: * swap _ set-nth ] each ] keep ; : interval-picture ( interval -- str ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 4ddd1fdc0b..65b932c4a2 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -244,7 +244,7 @@ SYMBOL: max-uses swap int-regs swap vreg boa >>vreg max-uses get random 2 max [ not-taken ] replicate natural-sort [ >>uses ] [ first >>start ] bi - dup uses>> peek >>end + dup uses>> last >>end ] map ] with-scope ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index f543aa4036..05cb13748b 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -37,7 +37,7 @@ IN: compiler.cfg.useless-blocks : delete-conditional? ( bb -- ? ) dup instructions>> [ drop f ] [ - peek class { + last class { ##compare-branch ##compare-imm-branch ##compare-float-branch diff --git a/basis/compiler/tree/dead-code/branches/branches.factor b/basis/compiler/tree/dead-code/branches/branches.factor index eba82384ab..fd1b2d5adb 100644 --- a/basis/compiler/tree/dead-code/branches/branches.factor +++ b/basis/compiler/tree/dead-code/branches/branches.factor @@ -28,7 +28,7 @@ M: #branch remove-dead-code* : remove-phi-inputs ( #phi -- ) if-node get children>> - [ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map + [ dup ends-with-terminate? [ drop f ] [ last out-d>> ] if ] map pad-with-bottom >>phi-in-d drop ; : live-value-indices ( values -- indices ) diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index d1a9f5215a..4fc4f4814b 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -191,7 +191,7 @@ SYMBOL: node-count propagate compute-def-use dup check-nodes - peek node-input-infos ; + last node-input-infos ; : final-classes ( quot -- seq ) final-info [ class>> ] map ; diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 2652547aad..31f6cea148 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -83,7 +83,7 @@ TUPLE: implication p q ; C: --> implication : assume-implication ( p q -- ) - [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ] + [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; M: implication assume* diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 4d4b22218d..50762c2b66 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -259,12 +259,12 @@ SYMBOL: value-infos resolve-copy value-infos get assoc-stack null-info or ; : set-value-info ( info value -- ) - resolve-copy value-infos get peek set-at ; + resolve-copy value-infos get last set-at ; : refine-value-info ( info value -- ) resolve-copy value-infos get [ assoc-stack value-info-intersect ] 2keep - peek set-at ; + last set-at ; : value-literal ( value -- obj ? ) value-info >literal< ; @@ -294,10 +294,10 @@ SYMBOL: value-infos dup in-d>> first node-value-info literal>> ; : last-literal ( #call -- obj ) - dup out-d>> peek node-value-info literal>> ; + dup out-d>> last node-value-info literal>> ; : immutable-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ - dup in-d>> peek node-value-info + dup in-d>> last node-value-info literal>> first immutable-tuple-class? ] [ drop f ] if ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index 9f9a43df64..c73f2211f0 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -169,7 +169,7 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ; [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; : ends-with-terminate? ( nodes -- ? ) - [ f ] [ peek #terminate? ] if-empty ; + [ f ] [ last #terminate? ] if-empty ; M: vector child-visitor V{ } clone ; M: vector #introduce, #introduce node, ; diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 5902999a76..23416d6912 100755 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -63,7 +63,7 @@ PRIVATE> : csv ( stream -- rows ) [ [ (csv) ] { } make ] with-input-stream - dup peek { "" } = [ but-last ] when ; + dup last { "" } = [ but-last ] when ; : file>csv ( path encoding -- csv ) csv ; diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor index b0ff3bc8d8..9f7f25c56e 100644 --- a/basis/documents/documents-tests.factor +++ b/basis/documents/documents-tests.factor @@ -120,7 +120,7 @@ namespaces tools.test make arrays kernel fry ; [ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test [ "" { 0 9 } { 0 15 } ] [ - "d" get undos>> peek + "d" get undos>> last [ old-string>> ] [ from>> ] [ new-to>> ] tri ] unit-test @@ -150,4 +150,4 @@ namespaces tools.test make arrays kernel fry ; [ ] [ "Hello world" "d" get set-doc-string ] unit-test -[ { "" } ] [ "value" get ] unit-test \ No newline at end of file +[ { "" } ] [ "value" get ] unit-test diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index 104dea6b98..cc2466053b 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -86,7 +86,7 @@ CONSTANT: doc-start { 0 0 } ] [ first swap length 1- + 0 ] if - ] dip peek length + 2array ; + ] dip last length + 2array ; : prepend-first ( str seq -- ) 0 swap [ append ] change-nth ; @@ -191,4 +191,4 @@ PRIVATE> [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ; : redo ( document -- ) - [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ; \ No newline at end of file + [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ; diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index a008b1d049..4acd1eeab8 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -149,15 +149,15 @@ DEFER: (parse-paragraph) : trim-row ( seq -- seq' ) rest - dup peek empty? [ but-last ] when ; + dup last empty? [ but-last ] when ; -: ?peek ( seq -- elt/f ) - [ f ] [ peek ] if-empty ; +: ?last ( seq -- elt/f ) + [ f ] [ last ] if-empty ; : coalesce ( rows -- rows' ) V{ } clone [ '[ - _ dup ?peek ?peek CHAR: \\ = + _ dup ?last ?last CHAR: \\ = [ [ pop "|" rot 3append ] keep ] when push ] each diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 397166a418..28a1f7dddb 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -76,7 +76,7 @@ MACRO: ncleave ( quots n -- ) MACRO: nspread ( quots n -- ) over empty? [ 2drop [ ] ] [ [ [ but-last ] dip ] - [ [ peek ] dip ] 2bi + [ [ last ] dip ] 2bi swap '[ [ _ _ nspread ] _ ndip @ ] ] if ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 65cb6541f4..f2ccaad1b4 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -76,7 +76,7 @@ M: heap heap-size ( heap -- n ) data>> pop* ; inline : data-peek ( heap -- entry ) - data>> peek ; inline + data>> last ; inline : data-first ( heap -- entry ) data>> first ; inline diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index 4a15f864a6..f8a4e6c15d 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -25,7 +25,7 @@ SYMBOL: vocab-articles [ (eval>string) ] call( code -- output ) "\n" ?tail drop ] keep - peek assert= + last assert= ] vocabs-quot get call( quot -- ) ; : check-examples ( element -- ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 7624cb1517..cfd6329b1d 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -77,7 +77,7 @@ SYNTAX: HINTS: { first first2 first3 first4 } [ { array } "specializer" set-word-prop ] each -{ peek pop* pop } [ +{ last pop* pop } [ { vector } "specializer" set-word-prop ] each diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 1810617c56..1a80236817 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -142,7 +142,7 @@ PEG: parse-header-line ( string -- pair ) 'space' , 'attr' , 'space' , - [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional , + [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional , 'space' , ] seq* ; diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 8cab5b5ad3..82c2487f67 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -91,7 +91,7 @@ PRIVATE> : &back ( -- ) inspector-stack get - dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ; + dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ; : &add ( value key -- ) mirror get set-at &push reinspect ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 7690b34410..cf97a0b2c8 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -220,7 +220,7 @@ DEFER: __ \ first4 [ 4array ] define-inverse \ prefix \ unclip define-dual -\ suffix [ dup but-last swap peek ] define-inverse +\ suffix [ dup but-last swap last ] define-inverse \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index d32b199873..ab4fbd60bb 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -34,7 +34,7 @@ PRIVATE> : levenshtein ( old new -- n ) [ levenshtein-initialize ] [ levenshtein-step ] - run-lcs peek peek ; + run-lcs last last ; TUPLE: retain item ; TUPLE: delete item ; diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 5406d8fcd0..dbc26c7efc 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -66,7 +66,7 @@ PEG: parse-log-line ( string -- entry ) 'log-line' ; building get empty? [ "Warning: log begins with multiline entry" print drop ] [ - message>> first building get peek message>> push + message>> first building get last message>> push ] if ; : parse-log ( lines -- entries ) diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor index ed4e8419c9..b17d9d8b6e 100644 --- a/basis/math/bits/bits-tests.factor +++ b/basis/math/bits/bits-tests.factor @@ -23,9 +23,9 @@ IN: math.bits.tests ] unit-test [ t ] [ - 1067811677921310779 make-bits peek + 1067811677921310779 make-bits last ] unit-test [ t ] [ - 1067811677921310779 >bignum make-bits peek -] unit-test \ No newline at end of file + 1067811677921310779 >bignum make-bits last +] unit-test diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index fd6eda4a90..0de18b6feb 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -48,7 +48,7 @@ PRIVATE> : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences - [ peek ] bi@ / ; + [ last ] bi@ / ; : (p/mod) ( p p -- p p ) 2dup /-last diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d0c918458a..5b4bdae1e6 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -56,14 +56,14 @@ PRIVATE> : range-decreasing? ( range -- ? ) step>> 0 < ; -: first-or-peek ( seq head? -- elt ) - [ first ] [ peek ] if ; +: first-or-last ( seq head? -- elt ) + [ first ] [ last ] if ; : range-min ( range -- min ) - dup range-increasing? first-or-peek ; + dup range-increasing? first-or-last ; : range-max ( range -- max ) - dup range-decreasing? first-or-peek ; + dup range-decreasing? first-or-last ; : clamp-to-range ( n range -- n ) [ range-min ] [ range-max ] bi clamp ; diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index f3d555d5a1..4b2eca69b4 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -370,7 +370,7 @@ SYMBOL: ignore-ws ] bind ; M: ebnf (transform) ( ast -- parser ) - rules>> [ (transform) ] map peek ; + rules>> [ (transform) ] map last ; M: ebnf-tokenizer (transform) ( ast -- parser ) elements>> dup "default" = [ diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index ae33b7c39a..5927171aa3 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> peek (ppush-new-tail) + tuck children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; @@ -127,13 +127,13 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) : ppop-contraction ( node -- node' tail' ) dup children>> length 1 = - [ children>> peek f swap ] + [ children>> last f swap ] [ (ppop-contraction) ] if ; : (ppop-new-tail) ( root -- root' tail' ) dup level>> 1 > [ - dup children>> peek (ppop-new-tail) [ + dup children>> last (ppop-new-tail) [ dup [ swap node-set-last ] [ drop ppop-contraction drop ] diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index b6eb0ff464..35ed84aaf4 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -52,7 +52,7 @@ USING: kernel math parser sequences combinators splitting ; : consonant-end? ( n seq -- ? ) [ length swap - ] keep consonant? ; -: last-is? ( str possibilities -- ? ) [ peek ] dip member? ; +: last-is? ( str possibilities -- ? ) [ last ] dip member? ; : cvc? ( str -- ? ) { @@ -67,7 +67,7 @@ USING: kernel math parser sequences combinators splitting ; pick consonant-seq 0 > [ nip ] [ drop ] if append ; : step1a ( str -- newstr ) - dup peek CHAR: s = [ + dup last CHAR: s = [ { { [ "sses" ?tail ] [ "ss" append ] } { [ "ies" ?tail ] [ "i" append ] } @@ -199,13 +199,13 @@ USING: kernel math parser sequences combinators splitting ; [ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ; : remove-e ( str -- newstr ) - dup peek CHAR: e = [ + dup last CHAR: e = [ dup remove-e? [ but-last-slice ] when ] when ; : ll->l ( str -- newstr ) { - { [ dup peek CHAR: l = not ] [ ] } + { [ dup last CHAR: l = not ] [ ] } { [ dup length 1- over double-consonant? not ] [ ] } { [ dup consonant-seq 1 > ] [ but-last-slice ] } [ ] diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index b4eb40757d..0e0c7afb82 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -153,7 +153,7 @@ TUPLE: block < section sections ; : ( style -- block ) block new-block ; -: pprinter-block ( -- block ) pprinter-stack get peek ; +: pprinter-block ( -- block ) pprinter-stack get last ; : add-section ( section -- ) pprinter-block sections>> push ; @@ -292,7 +292,7 @@ M: colon unindent-first-line? drop t ; ! Long section layout algorithm : chop-break ( seq -- seq ) - dup peek line-break? [ but-last-slice chop-break ] when ; + dup last line-break? [ but-last-slice chop-break ] when ; SYMBOL: prev SYMBOL: next @@ -317,7 +317,7 @@ SYMBOL: next ] { } make { t } split harvest ; : break-group? ( seq -- ? ) - [ first section-fits? ] [ peek section-fits? not ] bi and ; + [ first section-fits? ] [ last section-fits? not ] bi and ; : ?break-group ( seq -- ) dup break-group? [ first latin2 encode >quoted ] unit-test [ 1 ] [ message >quoted string-lines length ] unit-test [ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test [ 4 ] [ message >quoted-lines string-lines length ] unit-test -[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test +[ "===o" ] [ message >quoted-lines string-lines [ last ] "" map-as ] unit-test diff --git a/basis/quoting/quoting.factor b/basis/quoting/quoting.factor index 5b09347c8c..86d8183ac6 100644 --- a/basis/quoting/quoting.factor +++ b/basis/quoting/quoting.factor @@ -9,8 +9,8 @@ IN: quoting { [ length 1 > ] [ first quote? ] - [ [ first ] [ peek ] bi = ] + [ [ first ] [ last ] bi = ] } 1&& ; : unquote ( str -- newstr ) - dup quoted? [ but-last-slice rest-slice >string ] when ; \ No newline at end of file + dup quoted? [ but-last-slice rest-slice >string ] when ; diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 2e2ac74e30..088de52766 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -6,9 +6,9 @@ IN: splitting.monotonic quot diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 00d86a1608..c8fd3a6658 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -24,7 +24,7 @@ IN: tools.completion 2dup number= [ drop ] [ nip V{ } clone pick push ] if 1+ - ] keep pick peek push + ] keep pick last push ] each ; : runs ( seq -- newseq ) @@ -78,4 +78,4 @@ IN: tools.completion all-vocabs-seq name-completions ; : chars-matching ( str -- seq ) - name-map keys dup zip completions ; \ No newline at end of file + name-map keys dup zip completions ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index b6c9b43271..aa84ee43c5 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -83,7 +83,7 @@ M: pasteboard set-clipboard-contents dup { 0 0 } = [ drop windows get length 1 <= [ -> center ] [ - windows get peek second window-loc>> + windows get last second window-loc>> dupd first2 -> cascadeTopLeftFromPoint: -> setFrameTopLeftPoint: ] if diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 1ad3931746..79db087220 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -59,7 +59,7 @@ SYMBOL: locale ! Just casing locale, or overall? : fix-sigma-end ( string -- string ) [ "" ] [ - dup peek CHAR: greek-small-letter-sigma = + dup last CHAR: greek-small-letter-sigma = [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when ] if-empty ; inline diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index f8beca3c60..5cab884b3c 100755 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -63,13 +63,13 @@ ducet insert-helpers [ drop { } ] [ [ AAAA ] [ BBBB ] bi 2array ] if ; -: last ( -- char ) - building get empty? [ 0 ] [ building get peek peek ] if ; +: building-last ( -- char ) + building get empty? [ 0 ] [ building get last last ] if ; : blocked? ( char -- ? ) combining-class dup { 0 f } member? - [ drop last non-starter? ] - [ last combining-class = ] if ; + [ drop building-last non-starter? ] + [ building-last combining-class = ] if ; : possible-bases ( -- slice-of-building ) building get dup [ first non-starter? not ] find-last diff --git a/basis/vlists/vlists-tests.factor b/basis/vlists/vlists-tests.factor index 3546051364..6df942eb84 100644 --- a/basis/vlists/vlists-tests.factor +++ b/basis/vlists/vlists-tests.factor @@ -16,7 +16,7 @@ IN: vlists.tests [ "foo" VL{ "hi" "there" } t ] [ VL{ "hi" "there" "foo" } dup "v" set - [ peek ] [ ppop ] bi + [ last ] [ ppop ] bi dup "v" get [ vector>> ] bi@ eq? ] unit-test diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 9df7165e6c..cca1b5e2e0 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -11,7 +11,7 @@ IN: xml quot picker prepend define-predicate-engine ] if-empty ; + [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: predicate-engine compile-engine [ compile-predicate-engine ] [ class>> ] bi diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 64cc328d19..9428445d26 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -12,7 +12,7 @@ IN: namespaces PRIVATE> -: namespace ( -- namespace ) namestack* peek ; inline +: namespace ( -- namespace ) namestack* last ; inline : namestack ( -- namestack ) namestack* clone ; : set-namestack ( namestack -- ) >vector 0 setenv ; : global ( -- g ) 21 getenv { hashtable } declare ; inline diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index b6cfface12..04c9aca035 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -546,12 +546,12 @@ HELP: join { join concat concat-as } related-words -HELP: peek +HELP: last { $values { "seq" sequence } { "elt" object } } { $description "Outputs the last element of a sequence." } { $errors "Throws an error if the sequence is empty." } ; -{ peek pop pop* } related-words +{ last pop pop* } related-words HELP: pop* { $values { "seq" "a resizable mutable sequence" } } @@ -1382,7 +1382,7 @@ ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection first2 } { $subsection first3 } { $subsection first4 } -{ $see-also nth peek } ; +{ $see-also nth last } ; ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" "Adding elements:" @@ -1579,7 +1579,6 @@ ARTICLE: "sequences-destructive" "Destructive operations" ARTICLE: "sequences-stacks" "Treating sequences as stacks" "The classical stack operations, modifying a sequence in place:" -{ $subsection peek } { $subsection push } { $subsection pop } { $subsection pop* } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9b0f4c1530..36e4c95470 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -626,7 +626,7 @@ PRIVATE> [ 0 swap copy ] keep ] new-like ; -: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ; +: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; @@ -821,7 +821,7 @@ PRIVATE> [ rest ] [ first-unsafe ] bi ; : unclip-last ( seq -- butlast last ) - [ but-last ] [ peek ] bi ; + [ but-last ] [ last ] bi ; : unclip-slice ( seq -- rest-slice first ) [ rest-slice ] [ first-unsafe ] bi ; inline @@ -852,7 +852,7 @@ PRIVATE> [ find-last ] (map-find) ; inline : unclip-last-slice ( seq -- butlast-slice last ) - [ but-last-slice ] [ peek ] bi ; inline + [ but-last-slice ] [ last ] bi ; inline : ( seq -- slice ) dup slice? [ { } like ] when diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 04b3e53422..5ec396e5ba 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -75,7 +75,7 @@ M: string string-lines but-last-slice [ "\r" ?tail drop "\r" split ] map - ] keep peek "\r" split suffix concat + ] keep last "\r" split suffix concat ] [ 1array ] if ; diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 12e2ea49f7..9052638e7d 100644 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -62,7 +62,7 @@ IN: vectors.tests [ ] [ V{ 1 5 } "funny-stack" get push ] unit-test [ ] [ V{ 2 3 } "funny-stack" get push ] unit-test [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test -[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test +[ V{ 1 5 } ] [ "funny-stack" get last ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test [ "funny-stack" get pop ] must-fail [ "funny-stack" get pop ] must-fail @@ -98,4 +98,4 @@ IN: vectors.tests [ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test -[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test \ No newline at end of file +[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6561c55b67..2c0f67641d 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -39,7 +39,7 @@ PRIVATE> : vocab-dir+ ( vocab str/f -- path ) [ vocab-name "." split ] dip - [ [ dup peek ] dip append suffix ] when* + [ [ dup last ] dip append suffix ] when* "/" join ; : find-vocab-root ( vocab -- path/f ) diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index ff55f8e68d..ca783c13e6 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -193,7 +193,7 @@ TUPLE: ambiguous-use-error words ; : qualified-search ( name manifest -- word/f ) qualified-vocabs>> - (vocab-search) 0 = [ drop f ] [ peek ] if ; + (vocab-search) 0 = [ drop f ] [ last ] if ; PRIVATE> diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 19928b2e0b..15c610ce7a 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -40,7 +40,7 @@ SYMBOL: commands if ; DEFER: check-status : quit-game ( vector -- ) drop "you're a quitter" print ; -: quit? ( vector -- t/f ) peek "quit" = ; +: quit? ( vector -- t/f ) last "quit" = ; : end-game ( vector -- ) dup victory? [ drop "You WON!" ] diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index a5c7dbdde4..8f416dc799 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -14,4 +14,4 @@ SYMBOL: sleep-period : set-end ( duration -- end-time ) duration>milliseconds millis + ; : loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline : animate ( quot duration -- ) reset-progress set-end loop ; inline -: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline \ No newline at end of file +: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 9f1d8c31d2..6fadcf7679 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -83,7 +83,7 @@ GENERIC: element-binary-read ( length type -- object ) get-state element>> pop ; inline : peek-scope ( -- ht ) - get-state scope>> peek ; inline + get-state scope>> last ; inline : read-elements ( -- ) read-element-type @@ -136,7 +136,7 @@ M: bson-not-eoo element-read ( type -- cont? ) read-int32 drop get-state [scope-changer] change-scope - scope>> peek ; inline + scope>> last ; inline M: bson-object element-data-read ( type -- object ) (object-data-read) ; diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 6d81f2a14b..f16664fb02 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -495,7 +495,7 @@ ERROR: name-error name ; : fully-qualified ( name -- name ) { { [ dup empty? ] [ "." append ] } - { [ dup peek CHAR: . = ] [ ] } + { [ dup last CHAR: . = ] [ ] } { [ t ] [ "." append ] } } cond ; diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 948bd0c954..9fcbffd0db 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -21,7 +21,7 @@ SYMBOL: tagstack : closing-tag? ( string -- ? ) [ f ] - [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ; + [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ; : ( name attributes closing? -- tag ) tag new diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 2006cc24c3..d53ef6924b 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -65,7 +65,7 @@ IRC: rpl-nick-collision "436" nickname : comment ; PREDICATE: channel-mode < mode name>> first "#&" member? ; PREDICATE: participant-mode < channel-mode parameter>> ; PREDICATE: ctcp < privmsg - trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ; + trailing>> { [ length 1 > ] [ first 1 = ] [ last 1 = ] } 1&& ; PREDICATE: action < ctcp trailing>> rest "ACTION" head? ; M: rpl-names post-process-irc-message ( rpl-names -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 7e124dc713..59120cc578 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -25,7 +25,7 @@ CONSTANT: random-rotation-angle $[ pi 20 / ] : (random-segments) ( segments n -- segments ) dup 0 > [ - [ dup peek random-segment over push ] dip 1- (random-segments) + [ dup last random-segment over push ] dip 1- (random-segments) ] [ drop ] if ; CONSTANT: default-segment-radius 1 diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor index 9ed29aef45..5e99b15df5 100644 --- a/extra/mason/notify/server/server.factor +++ b/extra/mason/notify/server/server.factor @@ -45,7 +45,7 @@ builder "BUILDERS" { SYMBOLS: host-name target-os target-cpu message message-arg ; : parse-args ( command-line -- ) - dup peek message-arg set + dup last message-arg set [ { [ host-name set ] diff --git a/extra/math/vectors/homogeneous/homogeneous.factor b/extra/math/vectors/homogeneous/homogeneous.factor index 218e56dfb5..65f57be514 100644 --- a/extra/math/vectors/homogeneous/homogeneous.factor +++ b/extra/math/vectors/homogeneous/homogeneous.factor @@ -5,7 +5,7 @@ IN: math.vectors.homogeneous : (homogeneous-xyz) ( h -- xyz ) 1 head* ; inline : (homogeneous-w) ( h -- w ) - peek ; inline + last ; inline : h+ ( a b -- c ) 2dup [ (homogeneous-w) ] bi@ over = diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor index 15dd7ed6d2..9ecf942ef6 100644 --- a/extra/project-euler/049/049.factor +++ b/extra/project-euler/049/049.factor @@ -50,7 +50,7 @@ HINTS: count-digits fixnum ; : (find-unusual-terms) ( n seq -- seq/f ) [ [ arithmetic-terms ] with map ] keep - '[ _ [ peek ] dip member? ] find nip ; + '[ _ [ last ] dip member? ] find nip ; : find-unusual-terms ( seq -- seq/? ) unclip-slice over (find-unusual-terms) [ diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor index 9a2fb8c868..1fb5c7c8bb 100644 --- a/extra/project-euler/059/059.factor +++ b/extra/project-euler/059/059.factor @@ -75,7 +75,7 @@ INSTANCE: rollover immutable-sequence ] { } make nip ; inline : most-frequent ( seq -- elt ) - frequency-analysis sort-values keys peek ; + frequency-analysis sort-values keys last ; : crack-key ( seq key-length -- key ) [ " " decrypt ] dip group but-last-slice diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor index 174618e147..2766322323 100644 --- a/extra/project-euler/116/116.factor +++ b/extra/project-euler/116/116.factor @@ -41,10 +41,10 @@ IN: project-euler.116 [ length swap - 1- ] keep ?nth 0 or ; : next ( colortile seq -- ) - [ nth* ] [ peek + ] [ push ] tri ; + [ nth* ] [ last + ] [ push ] tri ; : ways ( length colortile -- permutations ) - V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ; + V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ; : (euler116) ( length -- permutations ) 3 [1,b] [ ways ] with sigma ; diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor index cb485d3ce2..0d4ec78226 100644 --- a/extra/project-euler/117/117.factor +++ b/extra/project-euler/117/117.factor @@ -31,7 +31,7 @@ IN: project-euler.117 [ 4 short tail* sum ] keep push ; : (euler117) ( n -- m ) - V{ 1 } clone tuck [ next ] curry times peek ; + V{ 1 } clone tuck [ next ] curry times last ; PRIVATE> diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor index cea1472c0b..af8b7e49c0 100644 --- a/extra/project-euler/164/164.factor +++ b/extra/project-euler/164/164.factor @@ -18,7 +18,7 @@ IN: project-euler.164 Date: Mon, 25 May 2009 17:03:32 -0500 Subject: [PATCH 153/228] unassociate last with pop/pop* in docs --- core/sequences/sequences-docs.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 04c9aca035..927a404519 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -551,7 +551,7 @@ HELP: last { $description "Outputs the last element of a sequence." } { $errors "Throws an error if the sequence is empty." } ; -{ last pop pop* } related-words +{ pop pop* } related-words HELP: pop* { $values { "seq" "a resizable mutable sequence" } } @@ -1378,11 +1378,13 @@ ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection second } { $subsection third } { $subsection fourth } +"Extracting the last element:" +{ $subsection last } "Unpacking sequences:" { $subsection first2 } { $subsection first3 } { $subsection first4 } -{ $see-also nth last } ; +{ $see-also nth } ; ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" "Adding elements:" From b76cffbf80900550a37741354d269640ba0bfdda Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 19:00:18 -0500 Subject: [PATCH 154/228] remove duplicate definition of last --- extra/adsoda/adsoda.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index 4042528eba..c659e109ce 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -58,7 +58,6 @@ t to: remove-hidden-solids? : with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline : dimension ( array -- x ) length 1- ; inline -: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline : change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; inline From 531580ed3078d225b66f178bde71b35f34b5f542 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 May 2009 19:16:36 -0500 Subject: [PATCH 155/228] compiler.cfg.builder: don't make basic blocks after terminating calls --- basis/compiler/cfg/builder/builder.factor | 2 ++ basis/compiler/cfg/iterator/iterator.factor | 10 +++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index b3a0287f3c..1bf5bab067 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -84,6 +84,7 @@ GENERIC: emit-node ( node -- next ) : emit-call ( word height -- next ) { { [ over loops get key? ] [ drop loops get at local-recursive-call ] } + { [ terminate-call? ] [ ##call stop-iterating ] } { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] } { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] } [ drop ##epilogue ##jump stop-iterating ] @@ -102,6 +103,7 @@ GENERIC: emit-node ( node -- next ) : emit-loop ( node -- next ) ##loop-entry + ##branch begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi iterate-next ; diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor index 3444b517ac..c12e5bdd86 100644 --- a/basis/compiler/cfg/iterator/iterator.factor +++ b/basis/compiler/cfg/iterator/iterator.factor @@ -37,9 +37,9 @@ DEFER: (tail-call?) : tail-call? ( -- ? ) node-stack get [ rest-slice - [ t ] [ - [ (tail-call?) ] - [ first #terminate? not ] - bi and - ] if-empty + [ t ] [ (tail-call?) ] if-empty ] all? ; + +: terminate-call? ( -- ? ) + node-stack get peek + rest-slice [ f ] [ first #terminate? ] if-empty ; From 5d50f4eb5bdebab862408e5ca73c6459f135468b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 May 2009 19:16:58 -0500 Subject: [PATCH 156/228] compiler.cfg.checker: new vocabulary for checking CFG invariants --- basis/compiler/cfg/checker/authors.txt | 1 + basis/compiler/cfg/checker/checker.factor | 24 +++++++++++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 basis/compiler/cfg/checker/authors.txt create mode 100644 basis/compiler/cfg/checker/checker.factor diff --git a/basis/compiler/cfg/checker/authors.txt b/basis/compiler/cfg/checker/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/checker/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor new file mode 100644 index 0000000000..c14b7d0ae0 --- /dev/null +++ b/basis/compiler/cfg/checker/checker.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel compiler.cfg.instructions compiler.cfg.rpo sequences +combinators.short-circuit accessors ; +IN: compiler.cfg.checker + +ERROR: last-insn-not-a-jump insn ; + +: check-basic-block ( bb -- ) + peek dup { + [ ##branch? ] + [ ##conditional-branch? ] + [ ##compare-imm-branch? ] + [ ##return? ] + [ ##callback-return? ] + [ ##jump? ] + [ ##call? ] + [ ##dispatch-label? ] + } 1|| [ drop ] [ last-insn-not-a-jump ] if ; + +: check-cfg ( cfg -- ) + entry>> reverse-post-order [ + instructions>> check-basic-block + ] each ; \ No newline at end of file From 1c45d0e81b987cebbd11c939d612bd511e68ebcb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 May 2009 19:18:13 -0500 Subject: [PATCH 157/228] compiler.cfg.stack-analysis: progress --- .../stack-analysis-tests.factor | 66 +++++++ .../cfg/stack-analysis/stack-analysis.factor | 176 +++++++++--------- 2 files changed, 156 insertions(+), 86 deletions(-) create mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor new file mode 100644 index 0000000000..e9dc7035b2 --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -0,0 +1,66 @@ +USING: compiler.cfg.debugger compiler.cfg.linearization +compiler.cfg.predecessors compiler.cfg.stack-analysis +compiler.cfg.instructions sequences kernel tools.test accessors +sequences.private alien math combinators.private compiler.cfg +compiler.cfg.checker ; +IN: compiler.cfg.stack-analysis.tests + +[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test +[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test +[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test + +: linearize ( cfg -- seq ) + build-mr instructions>> ; + +: test-stack-analysis ( quot -- mr ) + dup cfg? [ test-cfg first ] unless + compute-predecessors optimize-stack + dup check-cfg ; + +[ ] [ [ ] test-stack-analysis drop ] unit-test + +! Only peek once +[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test + +! Redundant replace is redundant +[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test + +! Replace required here +[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test + +! Only one replace, at the end +[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test + +! Do we support the full language? +[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test +[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test +[ ] [ + [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ] + test-cfg second test-stack-analysis drop +] unit-test + +! Test loops +[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test +[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test + +! Make sure that peeks are inserted in the right place +[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test + +! This should be a total no-op +[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test + +! Don't insert inc-d/inc-r; that's wrong! +[ 2 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test + +! Bug in height tracking +[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test +[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test +[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test + +! Bugs with code that throws +[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test +[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test +[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test +[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index d43d97a8e0..f1b424e622 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -10,12 +10,12 @@ IN: compiler.cfg.stack-analysis ! If 'poisoned' is set, disregard height information. This is set if we don't have ! height change information for an instruction. -TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ; +TUPLE: state locs>vregs actual-locs>vregs changed-locs d-height r-height poisoned? ; : ( -- state ) state new H{ } clone >>locs>vregs - H{ } clone >>vregs>locs + H{ } clone >>actual-locs>vregs H{ } clone >>changed-locs 0 >>d-height 0 >>r-height ; @@ -23,34 +23,25 @@ TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ; M: state clone call-next-method [ clone ] change-locs>vregs - [ clone ] change-vregs>locs + [ clone ] change-actual-locs>vregs [ clone ] change-changed-locs ; : loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; : record-peek ( dst loc -- ) - state get - [ locs>vregs>> set-at ] - [ swapd vregs>locs>> set-at ] - 3bi ; - -: delete-old-vreg ( loc -- ) - state get locs>vregs>> at [ state get vregs>locs>> delete-at ] when* ; + state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; : changed-loc ( loc -- ) state get changed-locs>> conjoin ; -: redundant-replace? ( src loc -- ? ) - loc>vreg = ; +: changed-loc? ( loc -- ? ) + state get changed-locs>> key? ; : record-replace ( src loc -- ) - ! Locs are not single assignment, which means we have to forget - ! that the previous vreg, if any, points at this loc. Also, record - ! that the loc changed so that all the right ##replace instructions - ! are emitted at a sync point. - 2dup redundant-replace? [ 2drop ] [ - dup delete-old-vreg dup changed-loc record-peek - ] if ; + dup changed-loc state get locs>vregs>> set-at ; + +: redundant-replace? ( vreg loc -- ? ) + state get actual-locs>vregs>> at = ; : save-changed-locs ( state -- ) [ changed-locs>> ] [ locs>vregs>> ] bi '[ @@ -59,13 +50,10 @@ M: state clone ] assoc-each ; : clear-state ( state -- ) - { - [ 0 >>d-height drop ] - [ 0 >>r-height drop ] - [ changed-locs>> clear-assoc ] - [ locs>vregs>> clear-assoc ] - [ vregs>locs>> clear-assoc ] - } cleave ; + [ locs>vregs>> clear-assoc ] + [ actual-locs>vregs>> clear-assoc ] + [ changed-locs>> clear-assoc ] + tri ; ERROR: poisoned-state state ; @@ -73,8 +61,6 @@ ERROR: poisoned-state state ; state get { [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] [ save-changed-locs ] - [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ] - [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ] [ clear-state ] } cleave ; @@ -95,7 +81,8 @@ UNION: neutral-insn ##effect ##branch ##loop-entry - ##conditional-branch ; + ##conditional-branch + ##compare-imm-branch ; M: neutral-insn visit , ; @@ -140,8 +127,6 @@ UNION: poison-insn ##jump ##return ##dispatch - ##dispatch-label - ##alien-callback ##callback-return ##fixnum-mul-tail ##fixnum-add-tail @@ -173,6 +158,10 @@ M: ##alien-invoke visit M: ##alien-indirect visit [ call-next-method ] [ visit-alien-node ] bi ; +M: ##alien-callback visit , ; + +M: ##dispatch-label visit , ; + ! Basic blocks we still need to look at SYMBOL: work-list @@ -182,14 +171,18 @@ SYMBOL: work-list ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: sync-unpoisoned-states ( predecessors states -- ) - [ - dup poisoned?>> [ 2drop ] [ - state [ - instructions>> building set - sync-state - ] with-variable - ] if +: modify-instructions ( predecessor quot -- ) + [ instructions>> building ] dip + '[ building get pop _ dip building get push ] with-variable ; inline + +: with-state ( state quot -- ) + [ state ] dip with-variable ; inline + +: handle-back-edge ( bb states -- ) + [ predecessors>> ] dip [ + dup [ + [ [ sync-state ] modify-instructions ] with-state + ] [ 2drop ] if ] 2each ; ERROR: must-equal-failed seq ; @@ -202,64 +195,82 @@ ERROR: must-equal-failed seq ; [ [ d-height>> ] map must-equal >>d-height ] [ [ r-height>> ] map must-equal >>r-height ] bi ; -ERROR: inconsistent-vreg>loc states ; - -: check-vreg>loc ( states -- ) - ! The same vreg should not store different locs in - ! different branches - dup - [ vregs>locs>> ] map - [ [ keys ] map concat prune ] keep - '[ _ [ at ] with map sift all-equal? ] all? - [ drop ] [ inconsistent-vreg>loc ] if ; - : insert-peek ( predecessor loc -- vreg ) ! XXX critical edges - [ instructions>> building ] dip '[ _ ^^peek ] with-variable ; + '[ _ ^^peek ] modify-instructions ; + +SYMBOL: phi-nodes + +: find-phis ( insns -- assoc ) + [ ##phi? ] filter [ [ inputs>> ] [ dst>> ] bi ] H{ } map>assoc ; + +: insert-phi ( inputs -- vreg ) + phi-nodes get [ ^^phi ] cache ; : merge-loc ( predecessors locs>vregs loc -- vreg ) ! Insert a ##phi in the current block where the input ! is the vreg storing loc from each predecessor block [ '[ [ _ ] dip at ] map ] keep - '[ [ ] [ _ insert-peek ] if ] 2map - ^^phi ; + '[ [ ] [ _ insert-peek ] ?if ] 2map + dup all-equal? [ first ] [ insert-phi ] if ; + +: (merge-locs) ( predecessors assocs -- assoc ) + dup [ keys ] map concat prune + [ [ 2nip ] [ merge-loc ] 3bi ] with with + H{ } map>assoc ; : merge-locs ( state predecessors states -- state ) - [ locs>vregs>> ] map dup [ keys ] map prune - [ - [ 2nip ] [ merge-loc ] 3bi - ] with with H{ } map>assoc - >>locs>vregs ; + [ locs>vregs>> ] map (merge-locs) >>locs>vregs ; -: merge-states ( predecessors states -- state ) +: merge-actual-locs ( state predecessors states -- state ) + [ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ; + +: merge-changed-locs ( state predecessors states -- state ) + nip [ changed-locs>> ] map assoc-combine >>changed-locs ; + +ERROR: cannot-merge-poisoned states ; + +: merge-states ( bb states -- state ) ! If any states are poisoned, save all registers ! to the stack in each branch - [ drop ] [ - dup [ poisoned?>> ] any? [ - sync-unpoisoned-states - ] [ - dup check-vreg>loc - [ state new ] 2dip - [ merge-heights ] - [ merge-locs ] 2bi - ! what about vregs>locs - ] if - ] if-empty ; + dup length { + { 0 [ 2drop ] } + { 1 [ nip first clone ] } + [ + drop + dup [ not ] any? [ + handle-back-edge + ] [ + dup [ poisoned?>> ] any? [ + cannot-merge-poisoned + ] [ + [ state new ] 2dip + [ [ instructions>> find-phis phi-nodes set ] [ predecessors>> ] bi ] dip + { + [ merge-locs ] + [ merge-actual-locs ] + [ merge-heights ] + [ merge-changed-locs ] + } 2cleave + ] if + ] if + ] + } case ; : block-in-state ( bb -- states ) - predecessors>> dup state-out get '[ _ at ] map merge-states ; + dup predecessors>> state-out get '[ _ at ] map merge-states ; : maybe-set-at ( value key assoc -- changed? ) 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; -: set-block-in-state ( state b -- ) - state-in get set-at ; +: set-block-in-state ( state bb -- ) + [ clone ] dip state-in get set-at ; -: set-block-out-state ( bb state -- changed? ) - swap state-out get maybe-set-at ; +: set-block-out-state ( state bb -- changed? ) + [ clone ] dip state-out get maybe-set-at ; : finish-block ( bb state -- ) - [ drop ] [ set-block-out-state ] 2bi + [ drop ] [ swap set-block-out-state ] 2bi [ successors>> [ add-to-work-list ] each ] [ drop ] if ; : visit-block ( bb -- ) @@ -268,18 +279,17 @@ ERROR: inconsistent-vreg>loc states ; [ dup block-in-state [ swap set-block-in-state ] [ - state [ + [ [ instructions>> [ visit ] each ] [ state get finish-block ] [ ] tri - ] with-variable + ] with-state ] 2bi ] V{ } make >>instructions drop ; : visit-blocks ( bb -- ) - reverse-post-order work-list get - [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ; + reverse-post-order [ visit-block ] each ; : optimize-stack ( cfg -- cfg ) [ @@ -289,9 +299,3 @@ ERROR: inconsistent-vreg>loc states ; work-list set dup entry>> visit-blocks ] with-scope ; - -! XXX: what if our height doesn't match -! a future block we're merging with? -! - we should only poison tail calls -! - non-tail poisoning nodes: ##alien-callback, ##call of a non-tail dispatch -! do we need a distinction between height changes in code and height changes done by the callee \ No newline at end of file From 879dcf204c83327af9767542e8adebb96fad3337 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 21:24:12 -0500 Subject: [PATCH 158/228] remove clamp-to-range and associated words, update jamshred --- basis/math/ranges/ranges-tests.factor | 13 +------------ basis/math/ranges/ranges.factor | 21 --------------------- extra/jamshred/player/player.factor | 4 ++-- extra/jamshred/tunnel/tunnel.factor | 12 +++++++++--- 4 files changed, 12 insertions(+), 38 deletions(-) diff --git a/basis/math/ranges/ranges-tests.factor b/basis/math/ranges/ranges-tests.factor index aedd2f7933..e314f72c6b 100644 --- a/basis/math/ranges/ranges-tests.factor +++ b/basis/math/ranges/ranges-tests.factor @@ -22,17 +22,6 @@ IN: math.ranges.tests [ { 0 1/3 2/3 1 } ] [ 0 1 1/3 >array ] unit-test [ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 >array reverse ] unit-test -[ t ] [ 5 [0,b] range-increasing? ] unit-test -[ f ] [ 5 [0,b] range-decreasing? ] unit-test -[ f ] [ -5 [0,b] range-increasing? ] unit-test -[ t ] [ -5 [0,b] range-decreasing? ] unit-test -[ 0 ] [ 5 [0,b] range-min ] unit-test -[ 5 ] [ 5 [0,b] range-max ] unit-test -[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test -[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test -[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test -[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test - [ 100 ] [ 1 100 [a,b] [ 2^ [1,b] ] map prune length -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 5b4bdae1e6..d28afa1413 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -49,24 +49,3 @@ PRIVATE> : [1,b] ( b -- range ) 1 swap [a,b] ; inline : [0,b) ( b -- range ) 0 swap [a,b) ; inline - -: range-increasing? ( range -- ? ) - step>> 0 > ; - -: range-decreasing? ( range -- ? ) - step>> 0 < ; - -: first-or-last ( seq head? -- elt ) - [ first ] [ last ] if ; - -: range-min ( range -- min ) - dup range-increasing? first-or-last ; - -: range-max ( range -- max ) - dup range-decreasing? first-or-last ; - -: clamp-to-range ( n range -- n ) - [ range-min ] [ range-max ] bi clamp ; - -: sequence-index-range ( seq -- range ) - length [0,b) ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 5b92b3a434..3364179920 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -45,10 +45,10 @@ CONSTANT: max-speed 30.0 max-speed [0,b] ; : change-player-speed ( inc player -- ) - [ + speed-range clamp-to-range ] change-speed drop ; + [ + 0 max-speed clamp ] change-speed drop ; : multiply-player-speed ( n player -- ) - [ * speed-range clamp-to-range ] change-speed drop ; + [ * 0 max-speed clamp ] change-speed drop ; : distance-to-move ( seconds-passed player -- distance ) speed>> * ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 59120cc578..986574ee91 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ; +USING: accessors arrays colors combinators fry jamshred.oint +kernel literals locals math math.constants math.matrices +math.order math.quadratic math.ranges math.vectors random +sequences specialized-arrays.float vectors ; FROM: jamshred.oint => distance ; IN: jamshred.tunnel @@ -12,6 +15,9 @@ C: segment : segment-number++ ( segment -- ) [ number>> 1+ ] keep (>>number) ; +: clamp-length ( n seq -- n' ) + 0 swap length clamp ; + : random-color ( -- color ) { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; @@ -53,7 +59,7 @@ CONSTANT: default-segment-radius 1 : sub-tunnel ( from to segments -- segments ) #! return segments between from and to, after clamping from and to to #! valid values - [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; + [ '[ _ clamp-length ] bi@ ] keep ; : nearer-segment ( segment segment oint -- segment ) #! return whichever of the two segments is nearer to the oint @@ -82,7 +88,7 @@ CONSTANT: default-segment-radius 1 ] dip nearer-segment ; : get-segment ( segments n -- segment ) - over sequence-index-range clamp-to-range swap nth ; + over clamp-length swap nth ; : next-segment ( segments current-segment -- segment ) number>> 1+ get-segment ; From d4cf0148ac32c42f325762964421cf34cd8b946b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 25 May 2009 21:25:56 -0500 Subject: [PATCH 159/228] remove whitespace --- basis/math/ranges/ranges-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor index e35adb10e5..59053a4c02 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -1,5 +1,4 @@ USING: help.syntax help.markup arrays sequences ; - IN: math.ranges ARTICLE: "math.ranges" "Numeric ranges" @@ -24,4 +23,4 @@ $nl { $code "100 1 [a,b] product" } "A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; -ABOUT: "math.ranges" \ No newline at end of file +ABOUT: "math.ranges" From 015b7afe93330c7d60133b71d8829f8bbe352d10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 02:58:40 -0500 Subject: [PATCH 160/228] compiler.cfg.checker: new check-rpo word --- basis/compiler/cfg/checker/checker.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index c14b7d0ae0..ac3d133fe6 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -18,7 +18,8 @@ ERROR: last-insn-not-a-jump insn ; [ ##dispatch-label? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; +: check-rpo ( rpo -- ) + [ instructions>> check-basic-block ] each ; + : check-cfg ( cfg -- ) - entry>> reverse-post-order [ - instructions>> check-basic-block - ] each ; \ No newline at end of file + entry>> reverse-post-order check-rpo ; \ No newline at end of file From 44437cc891f51a2600afc658c816974f6157a8f2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 02:58:57 -0500 Subject: [PATCH 161/228] compiler.cfg.dce: new global dead code elimination pass --- basis/compiler/cfg/dce/authors.txt | 1 + basis/compiler/cfg/dce/dce.factor | 44 ++++++++++++++++++++++++++++++ 2 files changed, 45 insertions(+) create mode 100644 basis/compiler/cfg/dce/authors.txt create mode 100644 basis/compiler/cfg/dce/dce.factor diff --git a/basis/compiler/cfg/dce/authors.txt b/basis/compiler/cfg/dce/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/dce/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor new file mode 100644 index 0000000000..ed9b48f7c6 --- /dev/null +++ b/basis/compiler/cfg/dce/dce.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs sets kernel namespaces sequences +compiler.cfg.instructions compiler.cfg.def-use ; +IN: compiler.cfg.dce + +! Maps vregs to sequences of vregs +SYMBOL: liveness-graph + +! vregs which participate in side effects and thus are always live +SYMBOL: live-vregs + +: init-dead-code ( -- ) + H{ } clone liveness-graph set + H{ } clone live-vregs set ; + +GENERIC: compute-liveness ( insn -- ) + +M: ##flushable compute-liveness + [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ; + +: record-live ( vregs -- ) + [ + dup live-vregs get key? [ drop ] [ + [ live-vregs get conjoin ] + [ liveness-graph get at record-live ] + bi + ] if + ] each ; + +M: insn compute-liveness uses-vregs record-live ; + +GENERIC: live-insn? ( insn -- ? ) + +M: ##flushable live-insn? dst>> live-vregs get key? ; + +M: insn live-insn? drop t ; + +: eliminate-dead-code ( rpo -- rpo ) + init-dead-code + [ [ instructions>> [ compute-liveness ] each ] each ] + [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ] + [ ] + tri ; \ No newline at end of file From 75d1f6dfdae03b3d79ceb1f3676933093a47fba2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 02:59:14 -0500 Subject: [PATCH 162/228] compiler.cfg.stack-analysis: make it pass more tests --- .../stack-analysis-tests.factor | 67 ++++++++++++---- .../cfg/stack-analysis/stack-analysis.factor | 77 ++++++++++--------- 2 files changed, 94 insertions(+), 50 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index e9dc7035b2..517516e34a 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -1,37 +1,51 @@ -USING: compiler.cfg.debugger compiler.cfg.linearization +USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization compiler.cfg.predecessors compiler.cfg.stack-analysis compiler.cfg.instructions sequences kernel tools.test accessors sequences.private alien math combinators.private compiler.cfg -compiler.cfg.checker ; +compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo +compiler.cfg.dce compiler.cfg.registers sets ; IN: compiler.cfg.stack-analysis.tests [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test -: linearize ( cfg -- seq ) - build-mr instructions>> ; +! Fundamental invariant: a basic block should not load or store a value more than once +: check-for-redundant-ops ( rpo -- ) + [ + instructions>> + [ + [ ##peek? ] filter [ loc>> ] map duplicates empty? + [ "Redundant peeks" throw ] unless + ] [ + [ ##replace? ] filter [ loc>> ] map duplicates empty? + [ "Redundant replaces" throw ] unless + ] bi + ] each ; : test-stack-analysis ( quot -- mr ) dup cfg? [ test-cfg first ] unless - compute-predecessors optimize-stack - dup check-cfg ; + compute-predecessors + entry>> reverse-post-order + optimize-stack + dup [ [ normalize-height ] change-instructions drop ] each + dup check-rpo dup check-for-redundant-ops ; [ ] [ [ ] test-stack-analysis drop ] unit-test ! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test +[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##peek? ] count ] unit-test ! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test +[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test ! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test +[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test ! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test +[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test ! Do we support the full language? [ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test @@ -49,10 +63,10 @@ IN: compiler.cfg.stack-analysis.tests [ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test ! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test ! Don't insert inc-d/inc-r; that's wrong! -[ 2 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test +[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test ! Bug in height tracking [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test @@ -63,4 +77,27 @@ IN: compiler.cfg.stack-analysis.tests [ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test [ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test [ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test -[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test \ No newline at end of file +[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test + +! Make sure the replace stores a value with the right height +[ ] [ + [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi +] unit-test + +! translate-loc was the wrong way round +[ ] [ + [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ [ ##load-immediate? ] count 2 assert= ] + [ [ ##peek? ] count 1 assert= ] + [ [ ##replace? ] count 3 assert= ] + tri +] unit-test + +[ ] [ + [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ [ ##load-immediate? ] count 2 assert= ] + [ [ ##peek? ] count 1 assert= ] + [ [ ##replace? ] count 1 assert= ] + tri +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index f1b424e622..0650623ecc 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces math sequences fry deques grouping -search-deques dlists sets make combinators compiler.cfg.copy-prop -compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.rpo compiler.cfg.hats ; +USING: accessors assocs kernel namespaces math sequences fry grouping +sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo +compiler.cfg.hats ; IN: compiler.cfg.stack-analysis ! Convert stack operations to register operations @@ -34,19 +34,34 @@ M: state clone : changed-loc ( loc -- ) state get changed-locs>> conjoin ; -: changed-loc? ( loc -- ? ) - state get changed-locs>> key? ; - : record-replace ( src loc -- ) dup changed-loc state get locs>vregs>> set-at ; +GENERIC: height-for ( loc -- n ) + +M: ds-loc height-for drop state get d-height>> ; +M: rs-loc height-for drop state get r-height>> ; + +: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline + +GENERIC: translate-loc ( loc -- loc' ) + +M: ds-loc translate-loc (translate-loc) - ; +M: rs-loc translate-loc (translate-loc) - ; + +GENERIC: untranslate-loc ( loc -- loc' ) + +M: ds-loc untranslate-loc (translate-loc) + ; +M: rs-loc untranslate-loc (translate-loc) + ; + : redundant-replace? ( vreg loc -- ? ) - state get actual-locs>vregs>> at = ; + dup untranslate-loc n>> 0 < + [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; : save-changed-locs ( state -- ) [ changed-locs>> ] [ locs>vregs>> ] bi '[ _ at swap 2dup redundant-replace? - [ 2drop ] [ ##replace ] if + [ 2drop ] [ untranslate-loc ##replace ] if ] assoc-each ; : clear-state ( state -- ) @@ -66,12 +81,6 @@ ERROR: poisoned-state state ; : poison-state ( -- ) state get t >>poisoned? drop ; -GENERIC: translate-loc ( loc -- loc' ) - -M: ds-loc translate-loc n>> state get d-height>> + ; - -M: rs-loc translate-loc n>> state get r-height>> + ; - ! Abstract interpretation GENERIC: visit ( insn -- ) @@ -162,12 +171,6 @@ M: ##alien-callback visit , ; M: ##dispatch-label visit , ; -! Basic blocks we still need to look at -SYMBOL: work-list - -: add-to-work-list ( basic-block -- ) - work-list get push-front ; - ! Maps basic-blocks to states SYMBOLS: state-in state-out ; @@ -222,8 +225,20 @@ SYMBOL: phi-nodes : merge-locs ( state predecessors states -- state ) [ locs>vregs>> ] map (merge-locs) >>locs>vregs ; +: merge-loc' ( locs>vregs loc -- vreg ) + ! Insert a ##phi in the current block where the input + ! is the vreg storing loc from each predecessor block + '[ [ _ ] dip at ] map + dup all-equal? [ first ] [ drop f ] if ; + : merge-actual-locs ( state predecessors states -- state ) - [ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ; + nip + [ actual-locs>vregs>> ] map + dup [ keys ] map concat prune + [ [ nip ] [ merge-loc' ] 2bi ] with + H{ } map>assoc + [ nip ] assoc-filter + >>actual-locs>vregs ; : merge-changed-locs ( state predecessors states -- state ) nip [ changed-locs>> ] map assoc-combine >>changed-locs ; @@ -266,12 +281,8 @@ ERROR: cannot-merge-poisoned states ; : set-block-in-state ( state bb -- ) [ clone ] dip state-in get set-at ; -: set-block-out-state ( state bb -- changed? ) - [ clone ] dip state-out get maybe-set-at ; - -: finish-block ( bb state -- ) - [ drop ] [ swap set-block-out-state ] 2bi - [ successors>> [ add-to-work-list ] each ] [ drop ] if ; +: set-block-out-state ( state bb -- ) + [ clone ] dip state-out get set-at ; : visit-block ( bb -- ) ! block-in-state may add phi nodes at the start of the basic block @@ -281,21 +292,17 @@ ERROR: cannot-merge-poisoned states ; [ swap set-block-in-state ] [ [ [ instructions>> [ visit ] each ] - [ state get finish-block ] + [ [ state get ] dip set-block-out-state ] [ ] tri ] with-state ] 2bi ] V{ } make >>instructions drop ; -: visit-blocks ( bb -- ) - reverse-post-order [ visit-block ] each ; - -: optimize-stack ( cfg -- cfg ) +: optimize-stack ( rpo -- rpo ) [ H{ } clone copies set H{ } clone state-in set H{ } clone state-out set - work-list set - dup entry>> visit-blocks + dup [ visit-block ] each ] with-scope ; From f6fab1b0359f0fa925694aa91a2a3d25f3264555 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 03:42:39 -0500 Subject: [PATCH 163/228] Fix another bug in stack-analysis --- .../stack-analysis-tests.factor | 6 +++++ .../cfg/stack-analysis/stack-analysis.factor | 22 +++++++++++-------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 517516e34a..c89a8b1cfd 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -100,4 +100,10 @@ IN: compiler.cfg.stack-analysis.tests [ [ ##peek? ] count 1 assert= ] [ [ ##replace? ] count 1 assert= ] tri +] unit-test + +! Sync before a back-edge, not after +[ 1 ] [ + [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ ##add-imm? ] count ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 0650623ecc..419c43c47e 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -3,7 +3,7 @@ USING: accessors assocs kernel namespaces math sequences fry grouping sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo -compiler.cfg.hats ; +compiler.cfg.hats compiler.cfg ; IN: compiler.cfg.stack-analysis ! Convert stack operations to register operations @@ -95,6 +95,16 @@ UNION: neutral-insn M: neutral-insn visit , ; +UNION: sync-if-back-edge + ##branch + ##conditional-branch + ##compare-imm-branch ; + +M: sync-if-back-edge visit + basic-block get [ successors>> ] [ number>> ] bi '[ number>> _ < ] any? + [ sync-state ] when + , ; + : adjust-d ( n -- ) state get [ + ] change-d-height drop ; M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ; @@ -181,13 +191,6 @@ SYMBOLS: state-in state-out ; : with-state ( state quot -- ) [ state ] dip with-variable ; inline -: handle-back-edge ( bb states -- ) - [ predecessors>> ] dip [ - dup [ - [ [ sync-state ] modify-instructions ] with-state - ] [ 2drop ] if - ] 2each ; - ERROR: must-equal-failed seq ; : must-equal ( seq -- elt ) @@ -254,7 +257,7 @@ ERROR: cannot-merge-poisoned states ; [ drop dup [ not ] any? [ - handle-back-edge + 2drop ] [ dup [ poisoned?>> ] any? [ cannot-merge-poisoned @@ -288,6 +291,7 @@ ERROR: cannot-merge-poisoned states ; ! block-in-state may add phi nodes at the start of the basic block ! so we wrap the whole thing with a 'make' [ + dup basic-block set dup block-in-state [ swap set-block-in-state ] [ [ From d45c2c3e00583f3b41a78edc1aff2d796a3189da Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 10:05:55 -0500 Subject: [PATCH 164/228] fix human sort -- wrap all elements so that integers dont get compared against strings directly --- basis/sorting/human/human-tests.factor | 14 ++++++++++++-- basis/sorting/human/human.factor | 13 ++++++++++++- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 20a607188c..68ddf8c3c9 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -1,4 +1,14 @@ -USING: sorting.human tools.test sorting.slots ; +USING: sorting.human tools.test sorting.slots sorting ; IN: sorting.human.tests -[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test +[ { "x1y" "x2" "x10y" } ] +[ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test + +[ { "4dup" "nip" } ] +[ { "4dup" "nip" } [ human<=> ] sort ] unit-test + +[ { "4dup" "nip" } ] +[ { "nip" "4dup" } [ human<=> ] sort ] unit-test + +[ { "4dup" "4nip" "5drop" "nip" "nip2" "nipd" } ] +[ { "nip" "4dup" "4nip" "5drop" "nip2" "nipd" } [ human<=> ] sort ] unit-test diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index b3dae45a9b..56de7f2f48 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -6,4 +6,15 @@ IN: sorting.human : find-numbers ( string -- seq ) [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; -<< "human" [ find-numbers ] define-sorting >> +! For comparing integers or sequences +TUPLE: hybrid obj ; + +M: hybrid <=> + [ obj>> ] bi@ + 2dup [ integer? ] bi@ xor [ + drop integer? [ +lt+ ] [ +gt+ ] if + ] [ + <=> + ] if ; + +<< "human" [ find-numbers [ hybrid boa ] map ] define-sorting >> From ded3cb887c887f1cf93e88205cfb240c3f1b06f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 11:55:48 -0500 Subject: [PATCH 165/228] fix formatting --- basis/sorting/title/title.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor index dbdbf8a8fb..b9a46c41fc 100644 --- a/basis/sorting/title/title.factor +++ b/basis/sorting/title/title.factor @@ -4,4 +4,7 @@ USING: sorting.functor regexp kernel accessors sequences unicode.case ; IN: sorting.title -<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >> +<< "title" [ + >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match + [ to>> tail-slice ] when* +] define-sorting >> From c7b2eadb2851f84d09167d464ab093f56f6e696a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 12:01:28 -0500 Subject: [PATCH 166/228] fix using, make sure article-only title sort works --- basis/sorting/human/human.factor | 3 ++- basis/sorting/title/title-tests.factor | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index 56de7f2f48..7487f559ed 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.parser peg.ebnf sorting.functor ; +USING: accessors kernel math math.order math.parser peg.ebnf +sequences sorting.functor ; IN: sorting.human : find-numbers ( string -- seq ) diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor index 65a58e463d..1e978838c5 100644 --- a/basis/sorting/title/title-tests.factor +++ b/basis/sorting/title/title-tests.factor @@ -8,6 +8,9 @@ IN: sorting.title.tests "The Beatles" "A river runs through it" "Another" + "The" + "A" + "Los" "la vida loca" "Basketball" "racquetball" @@ -21,6 +24,7 @@ IN: sorting.title.tests } ; [ { + "A" "Another" "Basketball" "The Beatles" @@ -29,10 +33,12 @@ IN: sorting.title.tests "for the horde" "Los Fujis" "los Fujis" + "Los" "of mice and men" "on belay" "racquetball" "A river runs through it" + "The" "la vida loca" } ] [ From 14428b6b65b2091fe2e170a6188fa114b6ee84eb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 17:46:41 -0500 Subject: [PATCH 167/228] unbackwardsify hmac keys --- basis/checksums/hmac/hmac-tests.factor | 22 +++++++++++----------- basis/checksums/hmac/hmac.factor | 21 ++++++++++----------- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index ffae146614..70451252f7 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -6,43 +6,43 @@ IN: checksums.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ - 16 11 "Hi There" md5 hmac-bytes >string ] unit-test + "Hi There" 16 11 md5 hmac-bytes >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] -[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test +[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test [ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ - 16 HEX: aa - 50 HEX: dd md5 hmac-bytes >string + 50 HEX: dd + 16 HEX: aa md5 hmac-bytes >string ] unit-test [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ - 16 11 "Hi There" sha1 hmac-bytes >string + "Hi There" 16 11 sha1 hmac-bytes >string ] unit-test [ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ - "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string + "what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string ] unit-test [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ - 16 HEX: aa - 50 HEX: dd sha1 hmac-bytes >string + 50 HEX: dd + 16 HEX: aa sha1 hmac-bytes >string ] unit-test [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] -[ 20 HEX: b "Hi There" sha-256 hmac-bytes hex-string ] unit-test +[ "Hi There" 20 HEX: b sha-256 hmac-bytes hex-string ] unit-test [ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ] [ - "JefeJefeJefeJefeJefeJefeJefeJefe" - "what do ya want for nothing?" sha-256 hmac-bytes hex-string + "what do ya want for nothing?" + "JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string ] unit-test diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index b163766016..9ec78248a1 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -13,27 +13,26 @@ IN: checksums.hmac : ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; -:: init-K ( K checksum checksum-state -- o i ) - checksum-state block-size>> K length < - [ K checksum checksum-bytes ] [ K ] if +:: init-key ( checksum key checksum-state -- o i ) + checksum-state block-size>> key length < + [ key checksum checksum-bytes ] [ key ] if checksum-state block-size>> 0 pad-tail [ checksum-state opad seq-bitxor ] [ checksum-state ipad seq-bitxor ] bi ; PRIVATE> -:: hmac-stream ( K stream checksum -- value ) - K checksum dup initialize-checksum-state - dup :> checksum-state - init-K :> Ki :> Ko +:: hmac-stream ( stream key checksum -- value ) + checksum initialize-checksum-state :> checksum-state + checksum key checksum-state init-key :> Ki :> Ko checksum-state Ki add-checksum-bytes stream add-checksum-stream get-checksum checksum initialize-checksum-state Ko add-checksum-bytes swap add-checksum-bytes get-checksum ; -: hmac-file ( K path checksum -- value ) - [ binary ] dip hmac-stream ; +: hmac-file ( path key checksum -- value ) + [ binary ] 2dip hmac-stream ; -: hmac-bytes ( K seq checksum -- value ) - [ binary ] dip hmac-stream ; +: hmac-bytes ( seq key checksum -- value ) + [ binary ] 2dip hmac-stream ; From 957bc53d4b1ba3b0204359a6700271ab94bd5d8c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 18:45:37 -0500 Subject: [PATCH 168/228] Move maybe-set-at to assocs --- basis/compiler/cfg/stack-analysis/stack-analysis.factor | 3 --- core/assocs/assocs-tests.factor | 4 ++++ core/assocs/assocs.factor | 3 +++ 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 419c43c47e..bce3064a9e 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -278,9 +278,6 @@ ERROR: cannot-merge-poisoned states ; : block-in-state ( bb -- states ) dup predecessors>> state-out get '[ _ at ] map merge-states ; -: maybe-set-at ( value key assoc -- changed? ) - 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; - : set-block-in-state ( state bb -- ) [ clone ] dip state-in get set-at ; diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index fc74df6d45..c21cac2632 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -142,3 +142,7 @@ unit-test [ 1 f ] [ 1 H{ } ?at ] unit-test [ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test + +[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test +[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test +[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e783ef81c4..7fc3eae00c 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -22,6 +22,9 @@ M: assoc assoc-like drop ; : ?at ( key assoc -- value/key ? ) 2dup at* [ 2nip t ] [ 2drop f ] if ; inline +: maybe-set-at ( value key assoc -- changed? ) + 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; + Date: Tue, 26 May 2009 19:31:19 -0500 Subject: [PATCH 169/228] Refactoring low-level optimizer to support stack analysis pass --- .../alias-analysis-tests.factor | 55 ------------------- .../cfg/alias-analysis/alias-analysis.factor | 50 ++++++----------- basis/compiler/cfg/checker/checker.factor | 2 +- basis/compiler/cfg/dce/dce.factor | 13 ++--- basis/compiler/cfg/dominance/dominance.factor | 2 +- basis/compiler/cfg/height/height.factor | 20 ++++--- .../cfg/instructions/instructions.factor | 4 +- .../cfg/linearization/linearization.factor | 2 +- basis/compiler/cfg/liveness/authors.txt | 1 + basis/compiler/cfg/liveness/liveness.factor | 55 +++++++++++++++++++ basis/compiler/cfg/optimizer/optimizer.factor | 43 ++++++++------- .../cfg/predecessors/predecessors.factor | 8 +-- basis/compiler/cfg/rpo/rpo.factor | 19 +++---- .../stack-analysis-tests.factor | 23 ++++---- .../cfg/stack-analysis/stack-analysis.factor | 22 ++++---- .../cfg/useless-blocks/useless-blocks.factor | 12 ++-- .../expressions/expressions.factor | 12 ++-- .../value-numbering-tests.factor | 24 ++++---- .../value-numbering/value-numbering.factor | 12 +++- .../write-barrier/write-barrier-tests.factor | 12 ++-- .../cfg/write-barrier/write-barrier.factor | 9 ++- 21 files changed, 203 insertions(+), 197 deletions(-) create mode 100644 basis/compiler/cfg/liveness/authors.txt create mode 100644 basis/compiler/cfg/liveness/liveness.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index 81359690db..79165f2c96 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -1,56 +1 @@ -USING: compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.alias-analysis compiler.cfg.debugger -cpu.architecture tools.test kernel ; IN: compiler.cfg.alias-analysis.tests - -[ ] [ - { - T{ ##peek f V int-regs 2 D 1 f } - T{ ##box-alien f V int-regs 1 V int-regs 2 } - T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 } - } alias-analysis drop -] unit-test - -[ ] [ - { - T{ ##load-reference f V int-regs 1 "hello" } - T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 } - } alias-analysis drop -] unit-test - -[ - { - T{ ##peek f V int-regs 1 D 1 f } - T{ ##peek f V int-regs 2 D 2 f } - T{ ##replace f V int-regs 1 D 0 f } - } -] [ - { - T{ ##peek f V int-regs 1 D 1 f } - T{ ##peek f V int-regs 2 D 2 f } - T{ ##replace f V int-regs 2 D 0 f } - T{ ##replace f V int-regs 1 D 0 f } - } alias-analysis -] unit-test - -[ - { - T{ ##peek f V int-regs 1 D 1 f } - T{ ##peek f V int-regs 2 D 0 f } - T{ ##copy f V int-regs 3 V int-regs 2 f } - T{ ##copy f V int-regs 4 V int-regs 1 f } - T{ ##replace f V int-regs 3 D 0 f } - T{ ##replace f V int-regs 4 D 1 f } - } -] [ - { - T{ ##peek f V int-regs 1 D 1 f } - T{ ##peek f V int-regs 2 D 0 f } - T{ ##replace f V int-regs 1 D 0 f } - T{ ##replace f V int-regs 2 D 1 f } - T{ ##peek f V int-regs 3 D 1 f } - T{ ##peek f V int-regs 4 D 0 f } - T{ ##replace f V int-regs 3 D 0 f } - T{ ##replace f V int-regs 4 D 1 f } - } alias-analysis -] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index ec8fe62dfb..3a153740d5 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -1,15 +1,13 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.copy-prop ; +compiler.cfg.copy-prop compiler.cfg.rpo +compiler.cfg.liveness ; IN: compiler.cfg.alias-analysis -! Alias analysis -- assumes compiler.cfg.height has already run. -! -! We try to eliminate redundant slot and stack -! traffic using some simple heuristics. +! We try to eliminate redundant slot operations using some simple heuristics. ! ! All heap-allocated objects which are loaded from the stack, or ! other object slots are pessimistically assumed to belong to @@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis ! ! Freshly-allocated objects get their own alias class. ! -! The data and retain stack pointer registers are treated -! uniformly, and each one gets its own alias class. -! ! Simple pseudo-C example showing load elimination: ! ! int *x, *y, z: inputs @@ -189,23 +184,19 @@ SYMBOL: constants GENERIC: insn-slot# ( insn -- slot#/f ) GENERIC: insn-object ( insn -- vreg ) -M: ##peek insn-slot# loc>> n>> ; -M: ##replace insn-slot# loc>> n>> ; M: ##slot insn-slot# slot>> constant ; M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; -M: ##peek insn-object loc>> class ; -M: ##replace insn-object loc>> class ; M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -: init-alias-analysis ( -- ) +: init-alias-analysis ( basic-block -- ) H{ } clone histories set H{ } clone vregs>acs set H{ } clone acs>vregs set @@ -213,11 +204,10 @@ M: ##alien-global insn-object drop \ ##alien-global ; H{ } clone constants set H{ } clone copies set + live-in keys [ set-heap-ac ] each + 0 ac-counter set - next-ac heap-ac set - - ds-loc next-ac set-ac - rs-loc next-ac set-ac ; + next-ac heap-ac set ; GENERIC: analyze-aliases* ( insn -- insn' ) @@ -292,15 +282,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' ) ] unless ] when ; -M: ##replace eliminate-dead-stores* - #! Writes to above the top of the stack can be pruned also. - #! This is sound since any such writes are not observable - #! after the basic block, and any reads of those locations - #! will have been converted to copies by analyze-slot, - #! and the final stack height of the basic block is set at - #! the beginning by compiler.cfg.stack. - dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ; - M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ; M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ; @@ -310,8 +291,13 @@ M: insn eliminate-dead-stores* ; : eliminate-dead-stores ( insns -- insns' ) [ insn# set eliminate-dead-stores* ] map-index sift ; -: alias-analysis ( insns -- insns' ) - init-alias-analysis - analyze-aliases - compute-live-stores - eliminate-dead-stores ; +: alias-analysis-step ( basic-block -- ) + dup init-alias-analysis + [ + analyze-aliases + compute-live-stores + eliminate-dead-stores + ] change-instructions drop ; + +: alias-analysis ( rpo -- ) + [ alias-analysis-step ] each ; \ No newline at end of file diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index ac3d133fe6..3a9d4a2b90 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -22,4 +22,4 @@ ERROR: last-insn-not-a-jump insn ; [ instructions>> check-basic-block ] each ; : check-cfg ( cfg -- ) - entry>> reverse-post-order check-rpo ; \ No newline at end of file + reverse-post-order check-rpo ; \ No newline at end of file diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index ed9b48f7c6..5db760e861 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -14,9 +14,9 @@ SYMBOL: live-vregs H{ } clone liveness-graph set H{ } clone live-vregs set ; -GENERIC: compute-liveness ( insn -- ) +GENERIC: update-liveness-graph ( insn -- ) -M: ##flushable compute-liveness +M: ##flushable update-liveness-graph [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ; : record-live ( vregs -- ) @@ -28,7 +28,7 @@ M: ##flushable compute-liveness ] if ] each ; -M: insn compute-liveness uses-vregs record-live ; +M: insn update-liveness-graph uses-vregs record-live ; GENERIC: live-insn? ( insn -- ? ) @@ -36,9 +36,8 @@ M: ##flushable live-insn? dst>> live-vregs get key? ; M: insn live-insn? drop t ; -: eliminate-dead-code ( rpo -- rpo ) +: eliminate-dead-code ( rpo -- ) init-dead-code - [ [ instructions>> [ compute-liveness ] each ] each ] + [ [ instructions>> [ update-liveness-graph ] each ] each ] [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ] - [ ] - tri ; \ No newline at end of file + bi ; \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 9d11fdf5b7..750a46ee6c 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -37,5 +37,5 @@ PRIVATE> : compute-dominance ( cfg -- cfg ) H{ } clone idoms set - dup entry>> reverse-post-order + dup reverse-post-order unclip dup set-idom drop '[ _ iterate ] loop ; \ No newline at end of file diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index 9312f6f133..9c305442e5 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math namespaces sequences kernel fry -compiler.cfg compiler.cfg.registers compiler.cfg.instructions ; +compiler.cfg compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.rpo ; IN: compiler.cfg.height ! Combine multiple stack height changes into one at the @@ -42,10 +43,15 @@ M: ##replace normalize-height* normalize-peek/replace ; M: insn normalize-height* ; -: normalize-height ( insns -- insns' ) +: height-step ( insns -- insns' ) 0 ds-height set 0 rs-height set - [ [ compute-heights ] each ] - [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if - rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ; + [ + [ [ compute-heights ] each ] + [ [ [ normalize-height* ] map sift ] with-scope ] bi + ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if + rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if + ] change-instructions drop ; + +: normalize-height ( rpo -- ) + [ height-step ] each ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 6ebf064a94..650bcb5795 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -44,8 +44,8 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ; M: f ##load-literal drop \ f tag-number ##load-immediate ; M: object ##load-literal ##load-reference ; -INSN: ##peek < ##read { loc loc } ; -INSN: ##replace < ##write { loc loc } ; +INSN: ##peek < ##flushable { loc loc } ; +INSN: ##replace < ##effect { loc loc } ; INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 8ef3abda39..9d80a2b28e 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -75,6 +75,6 @@ M: ##compare-float-branch linearize-insn [ [ linearize-basic-block ] each ] { } make ; : build-mr ( cfg -- mr ) - [ entry>> reverse-post-order linearize-basic-blocks ] + [ reverse-post-order linearize-basic-blocks ] [ word>> ] [ label>> ] tri ; diff --git a/basis/compiler/cfg/liveness/authors.txt b/basis/compiler/cfg/liveness/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/liveness/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor new file mode 100644 index 0000000000..66a584c613 --- /dev/null +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces deques accessors sets sequences assocs fry dlists +compiler.cfg.def-use compiler.cfg.rpo ; +IN: compiler.cfg.liveness + +! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis + +! Assoc mapping basic blocks to sets of vregs +SYMBOL: live-ins + +: live-in ( basic-block -- set ) live-ins get at ; + +! Assoc mapping basic blocks to sets of vregs +SYMBOL: live-outs + +: live-out ( basic-block -- set ) live-outs get at ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +: map-unique ( seq quot -- assoc ) + map concat unique ; inline + +: gen-set ( basic-block -- seq ) + instructions>> [ uses-vregs ] map-unique ; + +: kill-set ( basic-block -- seq ) + instructions>> [ defs-vregs ] map-unique ; + +: update-live-in ( basic-block -- changed? ) + [ + [ [ gen-set ] [ live-out ] bi assoc-union ] + [ kill-set ] + bi assoc-diff + ] keep live-ins get maybe-set-at ; + +: update-live-out ( basic-block -- changed? ) + [ successors>> [ live-in ] map assoc-combine ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-liveness ( rpo -- ) + work-list set + H{ } clone live-ins set + H{ } clone live-outs set + add-to-work-list + work-list get [ liveness-step ] slurp-deque ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 7887faeb61..41cd3c4b90 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -1,29 +1,32 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences compiler.cfg.rpo -compiler.cfg.instructions +USING: kernel sequences accessors combinators compiler.cfg.predecessors compiler.cfg.useless-blocks compiler.cfg.height +compiler.cfg.stack-analysis compiler.cfg.alias-analysis compiler.cfg.value-numbering -compiler.cfg.dead-code -compiler.cfg.write-barrier ; +compiler.cfg.dce +compiler.cfg.write-barrier +compiler.cfg.liveness +compiler.cfg.rpo ; IN: compiler.cfg.optimizer -: trivial? ( insns -- ? ) - dup length 2 = [ first ##call? ] [ drop f ] if ; - -: optimize-cfg ( cfg -- cfg' ) - compute-predecessors - delete-useless-blocks - delete-useless-conditionals +: optimize-cfg ( cfg -- cfg ) [ - dup trivial? [ - normalize-height - alias-analysis - value-numbering - eliminate-dead-code - eliminate-write-barriers - ] unless - ] change-basic-blocks ; + [ compute-predecessors ] + [ delete-useless-blocks ] + [ delete-useless-conditionals ] tri + ] [ + reverse-post-order + { + [ compute-liveness ] + [ normalize-height ] + [ stack-analysis ] + [ alias-analysis ] + [ value-numbering ] + [ eliminate-dead-code ] + [ eliminate-write-barriers ] + } cleave + ] [ ] tri ; diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 01a2a771bc..9bc3a08f63 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences compiler.cfg.rpo ; IN: compiler.cfg.predecessors -: (compute-predecessors) ( bb -- ) +: predecessors-step ( bb -- ) dup successors>> [ predecessors>> push ] with each ; -: compute-predecessors ( cfg -- cfg' ) - dup [ (compute-predecessors) ] each-basic-block ; +: compute-predecessors ( cfg -- ) + [ predecessors-step ] each-basic-block ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index bb4153da78..766373175c 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces make math sequences sets assocs fry compiler.cfg compiler.cfg.instructions ; @@ -7,29 +7,24 @@ IN: compiler.cfg.rpo SYMBOL: visited : post-order-traversal ( bb -- ) - dup id>> visited get key? [ drop ] [ - dup id>> visited get conjoin + dup visited get key? [ drop ] [ + dup visited get conjoin [ successors>> [ post-order-traversal ] each ] [ , ] bi ] if ; -: post-order ( bb -- blocks ) - [ post-order-traversal ] { } make ; +: post-order ( cfg -- blocks ) + [ entry>> post-order-traversal ] { } make ; : number-blocks ( blocks -- ) [ >>number drop ] each-index ; -: reverse-post-order ( bb -- blocks ) +: reverse-post-order ( cfg -- blocks ) H{ } clone visited [ post-order dup number-blocks ] with-variable ; inline : each-basic-block ( cfg quot -- ) - [ entry>> reverse-post-order ] dip each ; inline - -: change-basic-blocks ( cfg quot -- cfg' ) - [ '[ _ change-instructions drop ] each-basic-block ] - [ drop ] - 2bi ; inline + [ reverse-post-order ] dip each ; inline diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index c89a8b1cfd..8c941f4539 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -6,10 +6,6 @@ compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo compiler.cfg.dce compiler.cfg.registers sets ; IN: compiler.cfg.stack-analysis.tests -[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test -[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test -[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test - ! Fundamental invariant: a basic block should not load or store a value more than once : check-for-redundant-ops ( rpo -- ) [ @@ -25,11 +21,12 @@ IN: compiler.cfg.stack-analysis.tests : test-stack-analysis ( quot -- mr ) dup cfg? [ test-cfg first ] unless - compute-predecessors - entry>> reverse-post-order - optimize-stack - dup [ [ normalize-height ] change-instructions drop ] each - dup check-rpo dup check-for-redundant-ops ; + dup compute-predecessors + reverse-post-order + dup stack-analysis + dup normalize-height + dup check-rpo + dup check-for-redundant-ops ; [ ] [ [ ] test-stack-analysis drop ] unit-test @@ -81,13 +78,13 @@ IN: compiler.cfg.stack-analysis.tests ! Make sure the replace stores a value with the right height [ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ [ . ] [ 2drop 1 ] if ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi ] unit-test ! translate-loc was the wrong way round [ ] [ - [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ 1 2 rot ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks [ [ ##load-immediate? ] count 2 assert= ] [ [ ##peek? ] count 1 assert= ] [ [ ##replace? ] count 3 assert= ] @@ -95,7 +92,7 @@ IN: compiler.cfg.stack-analysis.tests ] unit-test [ ] [ - [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ 1 2 ? ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks [ [ ##load-immediate? ] count 2 assert= ] [ [ ##peek? ] count 1 assert= ] [ [ ##replace? ] count 1 assert= ] @@ -104,6 +101,6 @@ IN: compiler.cfg.stack-analysis.tests ! Sync before a back-edge, not after [ 1 ] [ - [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize-basic-blocks + [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks [ ##add-imm? ] count ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index bce3064a9e..6d602ede76 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -10,15 +10,15 @@ IN: compiler.cfg.stack-analysis ! If 'poisoned' is set, disregard height information. This is set if we don't have ! height change information for an instruction. -TUPLE: state locs>vregs actual-locs>vregs changed-locs d-height r-height poisoned? ; +TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ; : ( -- state ) state new H{ } clone >>locs>vregs H{ } clone >>actual-locs>vregs H{ } clone >>changed-locs - 0 >>d-height - 0 >>r-height ; + 0 >>ds-height + 0 >>rs-height ; M: state clone call-next-method @@ -39,8 +39,8 @@ M: state clone GENERIC: height-for ( loc -- n ) -M: ds-loc height-for drop state get d-height>> ; -M: rs-loc height-for drop state get r-height>> ; +M: ds-loc height-for drop state get ds-height>> ; +M: rs-loc height-for drop state get rs-height>> ; : (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline @@ -105,11 +105,11 @@ M: sync-if-back-edge visit [ sync-state ] when , ; -: adjust-d ( n -- ) state get [ + ] change-d-height drop ; +: adjust-d ( n -- ) state get [ + ] change-ds-height drop ; M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ; -: adjust-r ( n -- ) state get [ + ] change-r-height drop ; +: adjust-r ( n -- ) state get [ + ] change-rs-height drop ; M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ; @@ -198,8 +198,8 @@ ERROR: must-equal-failed seq ; : merge-heights ( state predecessors states -- state ) nip - [ [ d-height>> ] map must-equal >>d-height ] - [ [ r-height>> ] map must-equal >>r-height ] bi ; + [ [ ds-height>> ] map must-equal >>ds-height ] + [ [ rs-height>> ] map must-equal >>rs-height ] bi ; : insert-peek ( predecessor loc -- vreg ) ! XXX critical edges @@ -300,10 +300,10 @@ ERROR: cannot-merge-poisoned states ; ] 2bi ] V{ } make >>instructions drop ; -: optimize-stack ( rpo -- rpo ) +: stack-analysis ( rpo -- ) [ H{ } clone copies set H{ } clone state-in set H{ } clone state-out set - dup [ visit-block ] each + [ visit-block ] each ] with-scope ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index f543aa4036..b4999a8074 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences combinators classes vectors -compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ; +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; IN: compiler.cfg.useless-blocks : update-predecessor-for-delete ( bb -- ) @@ -30,8 +30,8 @@ IN: compiler.cfg.useless-blocks [ t ] } cond nip ; -: delete-useless-blocks ( cfg -- cfg' ) - dup [ +: delete-useless-blocks ( cfg -- ) + [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block ; @@ -49,7 +49,7 @@ IN: compiler.cfg.useless-blocks [ but-last f \ ##branch boa suffix ] change-instructions drop ; -: delete-useless-conditionals ( cfg -- cfg' ) - dup [ +: delete-useless-conditionals ( cfg -- ) + [ dup delete-conditional? [ delete-conditional ] [ drop ] if ] each-basic-block ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index cc790c6c0a..bf750231c7 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -22,17 +22,17 @@ M: constant-expr equal? and ] [ 2drop f ] if ; -SYMBOL: input-expr-counter - -: next-input-expr ( -- n ) - input-expr-counter [ dup 1 + ] change ; - ! Expressions whose values are inputs to the basic block. We ! can eliminate a second computation having the same 'n' as ! the first one; we can also eliminate input-exprs whose ! result is not used. TUPLE: input-expr < expr n ; +SYMBOL: input-expr-counter + +: next-input-expr ( class -- expr ) + input-expr-counter [ dup 1 + ] change input-expr boa ; + : constant>vn ( constant -- vn ) expr>vn ; inline GENERIC: >expr ( insn -- expr ) @@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ; M: ##compare-float >expr compare>expr ; -M: ##flushable >expr class next-input-expr input-expr boa ; +M: ##flushable >expr class next-input-expr ; : init-expressions ( -- ) 0 input-expr-counter set ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index abd2720817..11c0819027 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture tools.test kernel math combinators.short-circuit accessors -sequences ; +sequences compiler.cfg vectors arrays ; : trim-temps ( insns -- insns ) [ @@ -13,6 +13,10 @@ sequences ; } 1|| [ f >>temp ] when ] map ; +: test-value-numbering ( insns -- insns ) + basic-block new swap >vector >>instructions + dup value-numbering-step instructions>> >array ; + [ { T{ ##peek f V int-regs 45 D 1 } @@ -24,7 +28,7 @@ sequences ; T{ ##peek f V int-regs 45 D 1 } T{ ##copy f V int-regs 48 V int-regs 45 } T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } value-numbering + } test-value-numbering ] unit-test [ @@ -40,14 +44,14 @@ sequences ; T{ ##peek f V int-regs 3 D 0 } T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } T{ ##replace f V int-regs 4 D 0 } - } value-numbering + } test-value-numbering ] unit-test [ t ] [ { T{ ##peek f V int-regs 1 D 0 } T{ ##dispatch f V int-regs 1 V int-regs 2 0 } - } dup value-numbering = + } dup test-value-numbering = ] unit-test [ t ] [ @@ -60,7 +64,7 @@ sequences ; T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 } T{ ##shl-imm f V int-regs 23 V int-regs 22 3 } T{ ##replace f V int-regs 23 D 0 } - } dup value-numbering = + } dup test-value-numbering = ] unit-test [ @@ -76,7 +80,7 @@ sequences ; T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } T{ ##replace f V int-regs 3 D 0 } - } value-numbering + } test-value-numbering ] unit-test [ @@ -94,7 +98,7 @@ sequences ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering trim-temps + } test-value-numbering trim-temps ] unit-test [ @@ -112,7 +116,7 @@ sequences ; T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } T{ ##replace f V int-regs 6 D 0 } - } value-numbering trim-temps + } test-value-numbering trim-temps ] unit-test [ @@ -134,7 +138,7 @@ sequences ; T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } T{ ##replace f V int-regs 14 D 0 } - } value-numbering trim-temps + } test-value-numbering trim-temps ] unit-test [ @@ -150,5 +154,5 @@ sequences ; T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } T{ ##compare-imm-branch f V int-regs 33 5 cc/= } - } value-numbering trim-temps + } test-value-numbering trim-temps ] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index d17b2a7e1f..ac0c512bf8 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs biassocs classes kernel math accessors sorting sets sequences +compiler.cfg.liveness compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.propagate @@ -9,7 +10,14 @@ compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering -: value-numbering ( insns -- insns' ) +: number-input-values ( basic-block -- ) + live-in keys [ [ next-input-expr ] dip set-vn ] each ; + +: value-numbering-step ( basic-block -- ) init-value-graph init-expressions - [ [ number-values ] [ rewrite propagate ] bi ] map ; + dup number-input-values + [ [ [ number-values ] [ rewrite propagate ] bi ] map ] change-instructions drop ; + +: value-numbering ( rpo -- ) + [ value-numbering-step ] each ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index 73748dbc37..fb755399dc 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,8 +1,12 @@ USING: compiler.cfg.write-barrier compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test ; +arrays tools.test vectors compiler.cfg kernel accessors ; IN: compiler.cfg.write-barrier.tests +: test-write-barrier ( insns -- insns ) + basic-block new swap >vector >>instructions + dup write-barriers-step instructions>> >array ; + [ { T{ ##peek f V int-regs 4 D 0 f } @@ -24,7 +28,7 @@ IN: compiler.cfg.write-barrier.tests T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } T{ ##replace f V int-regs 7 D 0 } - } eliminate-write-barriers + } test-write-barrier ] unit-test [ @@ -42,7 +46,7 @@ IN: compiler.cfg.write-barrier.tests T{ ##peek f V int-regs 6 D -2 } T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } - } eliminate-write-barriers + } test-write-barrier ] unit-test [ @@ -69,5 +73,5 @@ IN: compiler.cfg.write-barrier.tests T{ ##copy f V int-regs 29 V int-regs 19 } T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } - } eliminate-write-barriers + } test-write-barrier ] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 4a55cb3266..5a08296617 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences locals compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ; @@ -35,8 +35,11 @@ M: ##set-slot-imm eliminate-write-barrier M: insn eliminate-write-barrier ; -: eliminate-write-barriers ( insns -- insns' ) +: write-barriers-step ( basic-block -- ) H{ } clone safe set H{ } clone mutated set H{ } clone copies set - [ eliminate-write-barrier ] map sift ; + [ [ eliminate-write-barrier ] map sift ] change-instructions drop ; + +: eliminate-write-barriers ( rpo -- ) + [ write-barriers-step ] each ; From 1242a3a41147d612a7703fc40a6a86e6c6e3a082 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 May 2009 19:56:56 -0500 Subject: [PATCH 170/228] New local-optimization combinator removes some boilerplate --- .../cfg/alias-analysis/alias-analysis.factor | 17 +++++++---------- basis/compiler/cfg/height/height.factor | 12 +++++------- basis/compiler/cfg/liveness/liveness.factor | 4 ++-- basis/compiler/cfg/rpo/rpo.factor | 9 ++++++++- .../cfg/value-numbering/value-numbering.factor | 16 +++++++++------- .../cfg/write-barrier/write-barrier.factor | 9 +++++---- 6 files changed, 36 insertions(+), 31 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 3a153740d5..8e1034fb0d 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -196,7 +196,7 @@ M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -: init-alias-analysis ( basic-block -- ) +: init-alias-analysis ( live-in -- ) H{ } clone histories set H{ } clone vregs>acs set H{ } clone acs>vregs set @@ -204,7 +204,7 @@ M: ##alien-global insn-object drop \ ##alien-global ; H{ } clone constants set H{ } clone copies set - live-in keys [ set-heap-ac ] each + [ set-heap-ac ] each 0 ac-counter set next-ac heap-ac set ; @@ -291,13 +291,10 @@ M: insn eliminate-dead-stores* ; : eliminate-dead-stores ( insns -- insns' ) [ insn# set eliminate-dead-stores* ] map-index sift ; -: alias-analysis-step ( basic-block -- ) - dup init-alias-analysis - [ - analyze-aliases - compute-live-stores - eliminate-dead-stores - ] change-instructions drop ; +: alias-analysis-step ( insns -- insns' ) + analyze-aliases + compute-live-stores + eliminate-dead-stores ; : alias-analysis ( rpo -- ) - [ alias-analysis-step ] each ; \ No newline at end of file + [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ; \ No newline at end of file diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index 9c305442e5..336a8a33c2 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -46,12 +46,10 @@ M: insn normalize-height* ; : height-step ( insns -- insns' ) 0 ds-height set 0 rs-height set - [ - [ [ compute-heights ] each ] - [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if - rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if - ] change-instructions drop ; + [ [ compute-heights ] each ] + [ [ [ normalize-height* ] map sift ] with-scope ] bi + ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if + rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ; : normalize-height ( rpo -- ) - [ height-step ] each ; + [ ] [ height-step ] local-optimization ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 66a584c613..7cc6158e68 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces deques accessors sets sequences assocs fry dlists -compiler.cfg.def-use compiler.cfg.rpo ; +USING: kernel namespaces deques accessors sets sequences assocs fry +dlists compiler.cfg.def-use ; IN: compiler.cfg.liveness ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 766373175c..32ca87de97 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces make math sequences sets -assocs fry compiler.cfg compiler.cfg.instructions ; +assocs fry compiler.cfg compiler.cfg.instructions +compiler.cfg.liveness ; IN: compiler.cfg.rpo SYMBOL: visited @@ -28,3 +29,9 @@ SYMBOL: visited : each-basic-block ( cfg quot -- ) [ reverse-post-order ] dip each ; inline + +: optimize-basic-block ( bb init-quot insn-quot -- ) + [ '[ live-in keys _ each ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline + +: local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- ) + '[ _ _ optimize-basic-block ] each ; \ No newline at end of file diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index ac0c512bf8..b22c8b4388 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs biassocs classes kernel math accessors sorting sets sequences -compiler.cfg.liveness +compiler.cfg.rpo compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.propagate @@ -10,14 +10,16 @@ compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering -: number-input-values ( basic-block -- ) - live-in keys [ [ next-input-expr ] dip set-vn ] each ; +: number-input-values ( live-in -- ) + [ [ f next-input-expr ] dip set-vn ] each ; -: value-numbering-step ( basic-block -- ) +: init-value-numbering ( live-in -- ) init-value-graph init-expressions - dup number-input-values - [ [ [ number-values ] [ rewrite propagate ] bi ] map ] change-instructions drop ; + number-input-values ; + +: value-numbering-step ( insns -- insns' ) + [ [ number-values ] [ rewrite propagate ] bi ] map ; : value-numbering ( rpo -- ) - [ value-numbering-step ] each ; + [ init-value-numbering ] [ value-numbering-step ] local-optimization ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 5a08296617..b952c062e7 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences locals -compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ; +compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop +compiler.cfg.rpo ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -35,11 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier M: insn eliminate-write-barrier ; -: write-barriers-step ( basic-block -- ) +: write-barriers-step ( insns -- insns' ) H{ } clone safe set H{ } clone mutated set H{ } clone copies set - [ [ eliminate-write-barrier ] map sift ] change-instructions drop ; + [ eliminate-write-barrier ] map sift ; : eliminate-write-barriers ( rpo -- ) - [ write-barriers-step ] each ; + [ ] [ write-barriers-step ] local-optimization ; From ceeb8944d86b50a360a2a6f0d6e8d004ab20c36f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 21:05:46 -0500 Subject: [PATCH 171/228] check in kobie's image rotation code --- extra/images/processing/rotation/authors.txt | 2 + .../processing/rotation/rotation-tests.factor | 77 ++++++++++++++++++ .../processing/rotation/rotation.factor | 71 ++++++++++++++++ .../rotation/test-bitmaps/PastedImage.bmp | Bin 0 -> 43702 bytes .../rotation/test-bitmaps/PastedImage90.bmp | Bin 0 -> 43578 bytes .../processing/rotation/test-bitmaps/lake.bmp | Bin 0 -> 485 bytes .../rotation/test-bitmaps/small-rotated.bmp | Bin 0 -> 454 bytes .../rotation/test-bitmaps/small.bmp | Bin 0 -> 470 bytes 8 files changed, 150 insertions(+) create mode 100644 extra/images/processing/rotation/authors.txt create mode 100755 extra/images/processing/rotation/rotation-tests.factor create mode 100644 extra/images/processing/rotation/rotation.factor create mode 100755 extra/images/processing/rotation/test-bitmaps/PastedImage.bmp create mode 100755 extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp create mode 100755 extra/images/processing/rotation/test-bitmaps/lake.bmp create mode 100755 extra/images/processing/rotation/test-bitmaps/small-rotated.bmp create mode 100755 extra/images/processing/rotation/test-bitmaps/small.bmp diff --git a/extra/images/processing/rotation/authors.txt b/extra/images/processing/rotation/authors.txt new file mode 100644 index 0000000000..07c95811a0 --- /dev/null +++ b/extra/images/processing/rotation/authors.txt @@ -0,0 +1,2 @@ +Kobie Lurie +Doug Coleman diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor new file mode 100755 index 0000000000..ffad4130b5 --- /dev/null +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Kobie Lurie, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors fry images.loader images.normalization +images.processing.rotation kernel literals math sequences +tools.test images.processing.rotation.private ; +IN: images.processing.rotation.tests + +: first-row ( seq^2 -- seq ) first ; +: first-col ( seq^2 -- item ) harvest [ first ] map ; +: last-row ( seq^2 -- item ) last ; +: last-col ( seq^2 -- item ) harvest [ last ] map ; +: end-of-first-row ( seq^2 -- item ) first-row last ; +: first-of-first-row ( seq^2 -- item ) first-row first ; +: end-of-last-row ( seq^2 -- item ) last-row last ; +: first-of-last-row ( seq^2 -- item ) last-row first ; + +<< + +: clone-image ( image -- new-image ) + clone [ clone ] change-bitmap ; + +>> + +CONSTANT: pasted-image + $[ + "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" + load-image normalize-image clone-image + ] + +CONSTANT: pasted-image90 + $[ + "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" + load-image normalize-image clone-image + ] + +CONSTANT: lake-image + $[ + "vocab:images/processing/rotation/test-bitmaps/lake.bmp" + load-image preprocess + ] + +[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test +[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test +[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test +[ t ] [ + pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each = +] unit-test + +[ t ] [ + pasted-image 90 rotate + pasted-image90 = +] unit-test + +[ t ] [ + "vocab:images/processing/rotation/test-bitmaps/small.bmp" + load-image 90 rotate + "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp" + load-image normalize-image = +] unit-test + +[ t ] [ + lake-image + [ first-of-first-row ] + [ 90 (rotate) end-of-first-row ] bi = +] unit-test + +[ t ] +[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test + +[ t ] +[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test + +[ t ] +[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test + +[ t ] +[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test diff --git a/extra/images/processing/rotation/rotation.factor b/extra/images/processing/rotation/rotation.factor new file mode 100644 index 0000000000..93b67e3b34 --- /dev/null +++ b/extra/images/processing/rotation/rotation.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2009 Kobie Lurie. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays colors combinators +combinators.short-circuit fry grouping images images.bitmap +images.loader images.normalization kernel locals math sequences ; +IN: images.processing.rotation + +ERROR: unsupported-rotation degrees ; + +> length ] [ dim>> second ] bi /i ; + +: image>byte-rows ( image -- byte-rows ) + [ bitmap>> ] [ row-length ] bi group rows-remove-pad ; + +: (seperate-to-pixels) ( byte-rows image -- pixel-rows ) + component-order>> bytes-per-pixel '[ _ group ] map ; + +: image>pixel-rows ( image -- pixel-rows ) + [ image>byte-rows ] keep (seperate-to-pixels) ; + +: flatten-table ( seq^3 -- seq ) + [ concat ] map concat ; + +: preprocess ( image -- pixelrows ) + normalize-image image>pixel-rows ; + +: ?reverse-dimensions ( image n -- ) + { 270 90 } member? [ [ reverse ] change-dim ] when drop ; + +: normalize-degree ( n -- n' ) 360 rem ; + +: processing-effect ( image quot -- image' ) + '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline + +:: rotate' ( image n -- image ) + n normalize-degree :> n' + image preprocess :> pixel-table + image n' ?reverse-dimensions + pixel-table n' (rotate) :> table-rotated + image table-rotated flatten-table >>bitmap ; + +PRIVATE> + +: rotate ( image n -- image' ) + normalize-degree + [ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ; + +: reflect-y-axis ( image -- image ) + [ [ reverse ] map ] processing-effect ; + +: reflect-x-axis ( image -- image ) + [ reverse ] processing-effect ; diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp b/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp new file mode 100755 index 0000000000000000000000000000000000000000..8edfedd4b55c01573c53caab5380b867826904cd GIT binary patch literal 43702 zcmd44caY=fbuHNMpRMOD+ag8IOh@FL(P(sGSHA1vMqCrH8cixP_PVDazyBrHQ?3ryu&xH#Fb7Xuk34z}j<1 z%cmdDj6E22cO^aD%Ld7uio2u{hV|mOMHVy&mvr2qj=Q8{E)Fsl2Wg8c+T1`(Ktqoh z*>Ni`ZskNwte}n&)G@;b79PayvX(wS*gV_cG}G63;l%FCs^&Q@bwNwRnp3wdYG`2t zJ7VA@%!0H{oUrnvCT85sULK-`G>ov0m9PloW^v3cN!nYJ4#l!j7`8|Yqx)B;AG`jQ zzK_3V{O0SH4_-4~e@T1u6~pGU1FNS`;CA!5{>|t5s%MT>P9MGYRrLq28$N#1xbfVv z^vJ=eUAd^`FKf9m13zgJq|CyImL1lxq6Ti<%#T~JcqzLm=aeT*;)Fp|7ckQ1b(C36 z%bboruV>6^=@$kX-|o5Z?GyLD+mFxFIHPW!8El#zXqvmT`WgZnM$#dVJ7f{7q&j`* z#!JU4Cm#yh7k*P3&R(l$ZXE-rdn*T(m)jO{NC?=24R&kygbOgyx8 z?x_!79sJ&T%l9uhzw?&;qpw-s`>OuNOPcpz)n0pX;JufIzV(LryYJY({igXl->`h^ zE%TqfV|)KK&9#^Mi&KxpT^(_U5`hviiQ;Bq(kx6{#c7))>yW0bqO4Pzaf-1LRzch( zh-!He4YzJV(=Q%1FZ9-5?Av{Luzo>H2^bjjBvL2~L)0ZLeMv(N zY8e?<>(-e^*G@g08SY*^{b*_GP}HSdwn=C7-192hMHT(Bih6mFI;UnVYB}>7_PmO@ zq~R_Oae{h5%p#7M`C$`TK|Lp87DTPWm{kxlaiYM>$U-mz+@&Gf9efwmO_%%XYY;aF zG|aGtzo2I>=ool2iyA88H)vpmjO?I+y`*L0I^pdB+=5$L0Ng%h&efW*%Hr16jH|0W zcIfJJ$G`iI>AUC6AAMbW;}!LLFY9i6RkQg_@AaWCwIitf-Zrc1yBu zS!LqD2e0&8dH(6OGmqbVr9VG$C^@ok?U^TXsgCxDxMtF(U&#Ur6DT*IXBocr=o;(tgw~|W>{9!Lgb~` zK`ncJkQp(_a^8K#(TBF4J$CU(-T%r}7d29&MoPj$Pgt=@X(1gwVqiuL^st_`tfdk* zG_a!z;TiTFAq9%bCune?{fnwN&V3La(7EeF0~t6bBH*=G?_BK)0E=gJh z32Y863$HLgNC^xvvo7V0XP>_D-0_vE!@1Ez|0}`8->OSmS#b+JVrmI!8y1ET$drJF zhWrrJ(3Vt`fQl9~^3qOe(kYE#BRi#Gq!EuYKYlRf+Z(dA#avz0>Bl~JMYVbE$ksDQ zuRMEf^SP%sUwE=GeQ@3^I6p|6)v@RG>1=s z>^T+k7_E%n5It-nu#$9P6QrzysDTqRaB4Y(hg}u1@q@tK%8Oa}8Jj3) z6BX>@tX-b8$)YAv)F?>U#A%1DGP)1oe(M$0hhG`Ea`xDj=TF?hcV}nk-vRpH|LMQ; zi(mXv9e5yNX9e_)SRpeV6cNxf1K6HgCgKR3lCTKKr@|eFG&j;w8sC@m?~S?IlAg}o z@cz~5!{2;OedXMdtao2-_(0CLzdZTi+L?z}P9I8m+mcuwMbfRvc-r#A9e_A)6-SJ` zh>4HSAGe7^Mt;;Hidn@`GZMWZYUI_ZnMbyZOPcq|OT&u18`(pUvecGckhJk57S6JX zy=Y(t&4gPbI#$xaO&NJ{gCJp+WE_gJzl*HVZqQ}X|G?(iBOkq{``&ri4`xU1Lh$c^ z`0xDa?yvuzcj{73QP|7~ny4{5E8*ftZTyfK5={_y%Az)L*vyOB@R5W78d03{C`!ZK zm5B%Pqx&+$UD@G%8Sh?Tns#+Xt*vppGU;efx!Vh)dy)NCPd!wgIFN8D;*Qp|r#)_O zUDgYNdj7JG6EpxpS!Jv{?^9-6@|>qN=aLpY@{+Hu3}eT;-BFKlFoknvR1 z09aKAfzblu3K@_yX(1xu7>g=ORL@Cci`eBkhXO2AA;@-BrVf@SA1s}GZ2P5w58kqT zcXsTv*b8@YxeFrh-1+bBk8lT%-2Lb8ynpvs?*8<*?%erj-K+|Uz9nR4#+BR_7E0I!f$8n#NKHaS+(0az7rt1RtMWSnhr zn>68&XS^L@izH+cFB?TMduzeJzclth+S3`gDi&8leBPiE>X@U&N{?-mkfkn8g8$Q?#+3X zAcw50E$b$G1rd-N+g~{O@a9+hzdhsqVf5Tj(l7rXxi^0cwY#AFKA7Hp&hPxKyAR&E zbLX}$=8)uvl~oqTZPH1yn~ z)v1SyV-FBf|h@=pL%(Kwy0%AuuCi`4Y*hdpf;k+`V?u896$$6+^|Iuvx=~F z3O;4ZA<4RAMX#dhZY_J;D#IPs(S2*vhsqNV=0^`?hxZmn_U1?S6-E!NoPO;6*HwQ$ z>;B8o)Q@B5eqMh4AFs^(x6PT~2j71U&|OUL{Niu@=wJWz&X4Xs@*8}slLsr4`->A@ zxzYBxTOP4Xiem@9`I_pJH#OVO94=t1x~17+S;hxZg_soq)`U}*bddxFxO3234q3`B zA?n&DiW#{mqEdDgYyd?F$|lPx4_hT6s{}CxN%!#^hR*_HKb&uiQ$#_|xd~KMtP#{>>0v&Yj!3s7<=4V=tSyF{e0e7X>ZCph=wfb(co=Chf9- zj(vHsX--24TDdWoB~%^ zk!=p>laAJe9jdM^YK4qx$I5!T;a$N@d+z9s7f*cj zy7r^5>)(4-d;MkgM{gKzyfhefb}t(hS?_`3$f1nqV9eST(6ufO2|_v^KK~sE?jnmj zcmBKkqdRx*Jnin2f9pAS|M{C=uI0nK58nOVx|mH2YO9WS6-JavmlV7iMr94b>yko~ zr5w`YaC_0;frX+g<`#u)+>nWhVh`dUb^-83<^jZEBMMwDki~DMU2^;))Na+I`IArPki)B&quGRDw7YTTy3D~s1ckCoy$VJhfJIx;$4HPj1e;nQ#N_gySF-a zs5pF}I(le*>d}?)hpwG@di&IqH(xmZ$s3w)zBcgQS5AER>cF?YKJ@WxLu;p>Oaaib zhe~4)ZJd03W#ZwKT^Z7gmWFs(VS^}Xk;M$Z!S^nLzt0_@_FGT;;v>KH1pM>PbLvX| z&I;CO2hvy4DNZ@1DVIFyk)&%{B8NTeR*-yU6)qcCO9uLa4qiml(ol2Qz#vsqE#VY= zZMZ_kk@kcguOQEW8GW57h#~J$wiSJy)vQx6oq9WkqP$sm{;LR_O*;3dqQxRFU} zMICKU)ikGq_F~3O@Soc9?vB#%{>|yf)+ZhlFCaj8}LA0RdULIsF z=>=I|SJu-VF}Efh9Z-rPgEVZAENgi%>XwJt0X1_;&48V>q@phj(Cz~9`(SkE$zOct z7azI%vUl(N2H(PPX9;T2-&KJAcgvGVO~@^FamK62k9MSeZ6P3Q zcqxY*stEZyX8J{8QHsa_OaY>C!DslvlVJTX%&Zb#Lx*^ z_#}PVC6K*EpCSk5u?wQ$ajP(Df#m8ediJJW9VP!kkO1&1`yW`FcqHp+591&!( z|95=v0`dQQ=l4PLi!bsUd^27pGE5c0o9eW_>>CO-DFN_>O6;~X4aP9Qroc|zf-@@2|;^_XQOPL$#&inTQVrV#I zs+>nzCUUK-Fy2`l?=JYe^CRT8G=|$QB)aPKL)&Mc{OHC0k6!G%{_K&f&mOt?m7eQx zU0t1Fqa>u`f;XU-16poaFO28}5e*DLRs@EQmbs{=%?;8o^iyi9Wp;oLi#e!fg|Sfv znae6TK8&!D8?gz$2*m%?N9v%o5+0NlZ7{Ura0XDeBGJRc)vy*}71~8nhZs_+2nIl9 zHQcdz^3avjj}|=LOGEsNz4T?hIA&GM5Ao)PxJ!Cb&;)7G7I!Ehyx?R9&5{TV0XxKO zN6yz(90uH7X}~)6z}l(9tJ9CIOh3AH?uqSZpZd<5y1%^a`skIRD`$>eKX+vF)ZzTd z{=EMH>cd5iV0HkGB{QUl3CUUtF7D?FFn)Gxf zyqP;gi;Sl05F)SMXc#YHfHVrDU^)V17&AP?F*|1%_Z00ZOILkUNA|eWd+$c_3 zQ0BMioE-%hR(lyD-`!F6b*+rsvedWYX2Wpc7xl1=C6AG?I&btXUN=Y=Jv04PghEWY{0L zcwr+yXy9OvN6n(7RhqWSk|rT+hoprM#htJTQ+8?8B8`}3AmX?MO9(z$M*XdVQ!I#@ zWKq31iQ?WMiW!Z#O(69;S z`{5>{3B+6+XqoG4oa=3vg-3e4VfIAx(g1zFr+L1o3DD1+sK>f|d=J*0`*>R2vWbNz z+k&35WMCr6gmG0h++{5QWiM*kKz3fsTGGK1L=UFDil{qKCZO=Q~i%wJRYeo@7FcYvK5Ik5f0@%LUCeD7t|H{UQ^e`#Rt%u_i(jEMaa zOZ&w>&gFjgoSFkA5HyP;C>fvu?8=lI-h~v#1+)S9Cv1{N&E$F`@uJg#swV@($RdlI zgz!!wLeTp_A%izO2RSjsTTru?hLDYM3l|&uPn@vG6Bb2GFHPvhVD0%n>ZRjNGd(Sr zPPAO=X?gc}^LdgITP_@>yz^Ak`KOyN9z)pDNRtp9!oKE9$M-A_Qb0rqPlD`;hK0W7 zrGCmnA7#F`W%fiPLi^&8U6+sTxp3tEi${0O^)}*}2;Sfjy)NaEWPIY>2pkz%(t(DB z1aBy8L?cHSLG#WcMu7)Q4D6ZrcIH8&j<$@w4V;j+wH5%br@cgQCyyu0@@0)^PR*aw zisJ6BD=(h-t3}@r=RBV+`9Ga;fB32<=RcHmbs;vF4dP`jHmR)Ed4zc+OS@!gryQXd z)QcCjycreq-CoMYUa$dk0T)2cnpeRcMjH@aB6id$3}HKy0Hnc6g^{+PrZ1|Q3o5ws z+@O|+C;`g>+@O{d)bb%Yz-EC#?ouCfp_hiBTj-}P4A28ZtN_@22%?({&ROVVF7~q) z2{|yp4|siCgNsM^053%DJR-NRacPiBcuCC+53!a9Y4g3!b3M%qeNk$1Eu zVVfaw8DR~>Y=y1Unzpy4?d@4tcgDT1I`uf>^e-;EKb`Sl{pGCZ!`Ft&laIt5or_u+ zzL3%~(i1aD6DCPi&kJc;%R_MVY0DaVK+8t-UGAq{?4w-jZ@JV*L3?zjk9rZ|*4sFX zPuSm#t-7pcBfjSPXfu6im^RlIWe!^v5vN9*gB{dxAb#ijX-k95AQJB&Py=?%#a`wT zQsn?+X%OI|!OB8U1iuo{a2A0tpzmiatJrux;deD>d&H4&rstY5=QJmQ~Dt|d> zG!3Ac-;B5efg%PM`k~S|0pQ+GTO5E&Xov-TQ4m5Y#%i<^)^L`GSh)NlEs7dCKF-YX`nqKu zZ$ZU~7zIHCKcGj}7A)!c0WCkI6@)eTO-T%#=xmR>l&Bie%PP8*X=fYKbi{(j2Pj1z z0TtTYSEdg`60Dp$w*9>7`b)Z-uj;p-?+@F%mkg~-dSb*xA>EK(%u=#UvWQL`*Gr=s zKHe5k#-_tt$0xkpN1IoX);+R+P=oMcg@!m`9d`juqrv8dK?=6^;vlQ0URX7rsYAo&U%6Rv0K6Ct=Z(2Tj-SqJr_HV!CSUcAf_Z(a@DPoR} zh_y9{0s&(KpcJ_BMoHW#1-MD0EM=6Y0k;9y5=6m|=tRpp{6#^=iQR+CAR=N0Tx1Xc zg|uCgf~{;4MT|nU`jPZV5o8euwcHtSML#}2>1-jbEn+kP8cxl@%LZ^~kVdw%5!oA} zf(!Y)giEMF^~^x}swshn7gVyN>Zc!*H$BF?w?}%vvAurmV9N`K8E+hAUFc!Y_5&PN z2qO(TVQ7et5MJn|UOrlX;pyEFa3G&$FbVdeiiyiV+tYIXsofWj?wL7OUx(r~X$NFN zNT0BQ0}YQ|0453yf)+U_mO@71lAgDK2-0%F37BNKBN!KkxM8C-=i9e&`iYNU9s1Ur z<`2Jas-8U-_dOigB7Y3CfFh%oP|D;<>o;|M;k63*#n5RZk;6kDJ}Zxe||P{ zpYsLAQ@w36&Li9}9~0fLY2D@B-*EcjmRFvlzjcgp;W%rihq2I052{!(kR%~u9@HD* zx4xE{DSM;noXmXMcvKw&LmLXN^Tia@J8 zN?;P>5y*fL+y(;-d(evjR}>vmm^g6Yu)@%eNU%^Ngw_$=tuZ5ZhAd%}gtY=LMt|`CS=x_&d3gI5qTFX+ zTKeRVPtG(Bd4&fLJixm5al!q4(p{F0J);M9Kl4b#*N;)=RB-+T7)nbRg)zM_W)LDc z>M|Zh)&t*~2r|@{^F!=Q$lxdq`(UPUmN7}D?gdGkavNdjnUjg?E zvDuw}Rc24i<$em*q6V(K5c?Mb6WIV6 z3=$`#;Y9V|Uw&|iNUH#ptO^MoMJH{hmja1)xewD&oPa?vt7b3g(czXvtkQ&4o-~7D zK-LQ6iQteRsN&C~3_FHOq2aA3cB75}#EX4kyq2Jv9o35xHC+g8fQ4X>z$!8bv2~t0 zc~YMK^!#7%O#blST#oPl(}|n^psf6?KK%VZdM;XTKE*%$RF_ilxbXgg*4<+d>_Kvl z8~F(%vg_uRg16@K?&Gu5TklazA<7%O(!z(Yt zJupi!#~9G?qdIX+Ck_$H7A&e@9dKrPn3sDQa|57n{6#jdBL2i&FA4-~UQQ6sh8nkA zM19tQ=Ai<5CSnvnF@35v^XdG5**X1_-*;)hb^GAPEn4E!|Lv7xlg2wBzwhlH`hUmQ zh$|n#oO~i~>&UwH#!ZTVia**!ipvZh0_}iUxfBgrqvA@{)qi3T}i|_wN4>Lh10>LXl4uBS}+c^95 z*101XEd1c*0Sx05M-Npd9xjhRT=YK}x3-st4;DT9vd*rI6OFF}`4OOh80c5WAHH(- z$dzY~uAh8rb^7sTqwFFvM-V2A%O_~_0|*>cs{~*8Bgj8VGrFG`jzU2UKU0DM3GhtX zsX+L|Ok}Gjjnbq+l0!vfmVkL7isJ^nOA)~W8_gh`8Dw1Oqg)A^5>)W8Q5f%sx3DclAyZ_VF8t3rydaKt3R z<1pmXme#DbEn{iL2gZ&LY3>wSFc1VFfh8?}4x$w)&Vb=4)HPs#TnSlth#yw*;M(9m z9LV`W{Ap4|K&ZjBxZH<=8;+m|G8uER$TlhLAvJsUINZgSMU-|bxMHLLgMs8z4?#r@@*C4>2Ly>OOhL^TBJT(&W=A-=X68qt)rh z3u6zKCl6(P-N^fRyK}v)**-Rib@TMoH@>2}^1@(c;xGim)n`up)x7^(Z<=nrJQ#6w zz^e^munysg&u>ArO36foLyDmjFkM(Hg769qaYH&j)JSWjR*Yzc zcL)JW9zl()g{Xwe4#E#Iisptm=T9`BNAIT}hB|YuhYmj>0y9%h%2_nra22uTQAeQ& z4j@me(c+T=J0KVY)sRw*SAj9@)Aj zIv)bXVEp}6b7+Nq}t{zGwRCuU(V1(S55#S76R z%elJOrw(6x?!@}pqs6JmWA@I39bLPJ%HxlvM;=Ug_b-`bi+WMWg0USquw))TZIk6a zikwT4btux-)|!#21#UyAB3@hi>C%%kWva#0o6A2HSr2m>=-IT zH7B7*X6K_8hyige_l_wM7=TI7#y=mLUlAlez44DbZ~XEPUT1!~b9n0(_mRge$}hkD zbYoxu^#x=#bYXMd*7F0^Ge@eYo?MxJ9L$Shy`&3n4tfw|k^>4iX;Wt1-4J0=T^QO} zG@;m)#Vm68yb(~I5#Eg~Y*B~tYq1&D zqxO|Yji_!~BPMx3CtA>;;Y7W7q7kf(%m9goD&W#F%FJ=>-pP*i3jt z4>`dQB|pVl`>&tB^Uphf=t4@I{`7XE+O3h@^Npt(me9z+%ze-9nG?I}zW1*4&o9`& z^OoW2bH`RDA1Ms)PrEx&)W+_5D4;*&uwEdw$&Zx(GNBxvG~pq3@}5}F`Lcld-5RY9!~Qshz}>+%5m zo#V8(VT|?QoCR|pbwM8$_`;11X&@&gNdw$*(tSW`hEm36N17rc#s)YBZ@hQU--fiJrCOp#Fex_4&$Hb)KMQUeb$-#QRK7R z7k|C;hpuP;X6Njux9@Yk*e|)~>rXW-_BAf_*3aQI&hh)|uD#fM<%Q#=i9=C4ByC$1 zW*9iZp#;8=z%etbDJ1F>RnqK;tt?OpzTevIW>1y#X@`j^<#ZIR`u60kafvgPQ1YpLJJmVI_WYdwyr<4_(jS+R5ME`QuZwM}_yi{$%6w zAefQ3~4bDj$Ds3R!B8a<0+j`W@IzgMiJn8+%aLHbJ22#7lV{Y z#DG;9Gb;~h zOWC&h*KR4zBoEMXgJoK0eTR92Mr5Di0CR|)HQ-rV0y?$c%fY5 zm0MV;pWIIF?EInYm0LU2+dKEaS$T~6r(Zq1XZG0c*<-tc11%{dr*7FO4j3>&B0}iF z+nyU>K-SC*ux1A#wvaT?cI8FT8LWBjX*;;04LLo685!(WD;gXf$nTg>fFn_pwBQX{ z*aX#yW||D$3W6OJXsu*On?(r&J~`SJ$YaE=3!5++f_x}V+1nG=j+hCRH)i@Uvw{+l z{H+uS3M^!hM0FxiM9LxqrXWxhU{G=~Bc_HSGsx@X1@R#C1LO)S8bb7#gVDoOWWwSC ztVm+DGgF)h`U_e{NJoq4>A*Lp=e%y}v|hXAxcT$R4{rVRpLhQ3^PP`=wR7XwJL@|; ztG~y3^VZJB?VXOor;l*H^p(e(f@)esO;74M856%QYL#Kc4=ZF6!YhE1hmZty25J>& zEl!cyv6XQCNKVQD=>J+y$NU4Hh6Ms$g5i&f8(l~v>4bw8@F2){PQ^x0qjOU$;e;9J zHppI+3@Hv(8Nt^`P8^~Mbm2J8#jzLFXdn^JNx3?+-Y$%Bl8zr5sqU@<;@Z(3gHQwE z)))o}5HEYj&&Dkp@^KT6U?|ae#RbSZocwM|+jL=O3qHr^YnQD2`|iQtOsc#zDAX@*5pC7X*V6Mih*j7#iaU9BBBO z{Q>_FZY-i3`R7s(@_lLJNo7F=5_^b7#c}9YeR#f*2fC zqglzAb{t*&;q9gWSDZcbxBuk*?DpgD-|AfdtR?Y%_w}Fs{pUM>zO(b)e`C$v+WGMI z&g93pWDh+s^)UJ@OduP^(IC_pajO&~csNx7*9Id`Xpe(Z!2lq>xqjA6FXLUz2J}$S z!G8Nl{aa7%#x2fcUhbvUFvS3e2x|$g5%j4L9Y$darfsbi1osFLjWchs5D{5W!DMQ} zMeLy>h>|p%-taWm`JW))`=H2Ld>uP(7D3Y46+J_ z>Cml0b~2-F&cOj<3<%?6-|@l`+8}7O!WLCH$p>W$M}|Y{A{19Ah!chx4mf9sdf=6` zDbQn1TA@-flp|ccnbOe+ZGXgZV$YU)_gAHLVHKGU55G{@KeS2nmcFp(gMote7 zQsP=xLdS~XXaf34gH7YsN8&%eo&43#rJdig-uS1_ySF}LCBOeb{!{(dXXie?mHhEP ztpCmJ|NGZFSpT@Qv;B*mAOCV^?Qd=~jU%InD9d_b!70mPy4TFF!-q$65YY-%0Ou(I z1!iwAdb%sVeMt)(8FFL=DGOCU1|hIQW^|H3vRw2Qp=uWg*>kmNfteE+6+o}0@zRlo zx#JjV!8|~%J+8s26--Df3Fp9a1MQGL9%gOe&?}M0&^ijkY}E7TwVVLvF3>B&v<~_a zWR4HN3zwR-M4{Ev_;rH>TmkKjoQWPC8Juw7>^2&41mCokn|JWj7FJA;^W9CMp~hu3 z#6$gJ|DGk>4(wjm)F(~!w3(eTbJOT-BDrD8*37=>*@w*b@xS~IaG}*c`Ins^{L9X@ z&v!OH-+AkAe|he2ZXfyh77*taK5Yzt0?$e z)3nfwq6G#ntP==8S{Np}mJ9P6Y?~)OGA4h~a)!tik>-L{i0lv3fK+-Gpx=s#i=3|` zi(yMNOmPALom2GXEYhq+mP0LIlcBYNq2P>FmbJ=Du6B&J;51g&jzK9=#*S7HFJ)?7>B09V3LPzW#x@V4#LLGGGrCrU-a3BZ@IW#)d{2Do%KPZk$e5f}P95T~!dYOYaXW3dgri ztZ!I5PP?DdO#6Dyoq7CXLK9inZhm&8`lD0k$3UmcWIBS1x+ZSq#7%5`Q$ig+9`qw7 zI0114oeK?E40#y^g#_SY!FdU4M2i?Ms?8Px;w7z+Ks>|)Yo`!It~N}lS4MDLf@Ce6 zEw7Ap21Ax4JGL>Z?nhtr2X zWyRB0b}O)oF7%j1X^XIoQ}H-?U=`*u)rmWHbnl^g>13N*SSd3rs-wmYbPz?+BVHX< z;5KQ&ya+}aF%Z@i)-=ZqIPptQS=m{qAnz8HJkqj9UUW)}c8U7=b3==nC$iu6zxT7} zKEAc^=`Xf!-99{5dhrC>SFE^^l`xT8{Kb@+hlTS}h@=!wH5qGNWF04E6cik?s;_O; z-?2K{u`$sFejs58vV-VB845N?JK9l4;7$}pgbu&2%s}(oJ23N$UIsKqO+0mzLJK3- z-Y#^H&_=?_Vp`IF0CU=<5u7>LTk-EJLc_Yd$|L(qe)N_wf7Mm;K>)O7&^iOvf?jcW z9tY#~_5%iQskd5>{pgSHg>u1Xq!tFmY1`ZqmR`7}*&czw9IQQuK(hN**AH-Zt+JzJR#k z5SCn`ydAleo3Zh7_@`T3^+-!j8REC(#Gb>TlcEfLMoLW7Ha0R>fB}vaTu0Qeknv=S z3Bikv*_uYL6BB%7AVC}f$(oT;-+)-^>8l)Rf?^a>D_ z05oT2=Pj(fg(x`;S59`V_~m(^=@H}{+=P)15?EH%#|@OCTUZ^D zuZ-Yx$}?7B%7V1qa`E_mVLdfvW0!};)e%W$SOV;7OO(MJu?gpx`9+Y1Pg?NeoSLZQ z6Ic9_s$T{wulid{K55A#$svClnQ`nk4Fz!x#Ia*a9&yPdTk*B8kL=y>?_2S9l-#X# zX`~K(_XdKCOzKI=H~~Qx-Ztho(APn(hv$ULD@s|!anwjwVcDYq_ti=xbRqee4uNYE z7@*@cMBIpRE?7LA95%I=9AByW+snh?9Gu_~V9Uqhs^~DZ+#FCfhBPfH3$x(l6w*o%E0g?p+Y)*8qj$(3Igt!K>8{_g7zhq?u!7j<#xMg7K zm938|x2N}RO?Pihc5IyNT$xa;Pbs%fwgckIhz#Ja_!ZS*dC?^z0qc_?k#0 zj49Vfl`A94HGgN-+l~+hOO$~x>L2V`99KiB8Z*Ii=3#ON-xY+F#W<4%qY_+vg%4&0 z!#I{^08yev%1YrYj&Kyq3`-Er0+g6^RP^B?3WR6eh=F}Z!o-Xk>DbyS3mcgSYANgB zXB>Pa?zEL%OE0{tA8%Iz!4x-AW5$-Gg_Z?y1W;z$N(bU8Gc9Lhz8NHL#%16FFT^i)Is$opybWt}s%>jpxjq4gm9CB{5PBeowXqHmBJONX zv~P~LuK2L=d087PZN_V|3J$@FPqqrlF{(h+m%KR4gF`;dgcaMaC1%D~kg&ilz;|Q3 zeY1w?=49vkc>Bg==LTMLvK!ZLW2|#~a^Kd(zOC`S>!Y2UV_kIxv~X}@4X1=Lf>!$~ zB;<5_e@)RN+ZgX!!+}aSt`Y<@#1_7$2}m&$7Dmd(0$xy^S%;|NQ&fCNLHxXpnYB=3 z_#O#ueOQO^L8_ho2eNqJ#L~z4b2%lqvYe`7b_#!v+~WUj_s3OV2RDib`S;r2{neRh`)kY zyYnXi?$&hI`cxMZ`sVoFt;xLzSX`~Fm7X$DuyR&r!NJ`ak*|4>JozajJ*sIzCRps> zJ==5d!odCbAPF;-M7>|Wfon6-0f=#DeWJZO+E(@}iz96-qn#VTbgZkkfNbX`^uvg< zF7E_^wvtAqjYuW*mUB3n=0biD-@z235A;uxi4(WTq)fz4!b%V6Tb4B~Q3HaSftW?O zr7d{74N=|hux3|Ow)O2e3_<7ZsljEfhyacdbBiV8Xp>5*G-u<}-V(ax%R1gpc6ic6R` zGfFmA)g`Dp1qB;7XXUK=#A_px)nU=X1liRG5UG(y+e)0MQ^gq7k2^ox6cJrzp{>G?eYqD)?O1VC+*c?|}nNVJxLeK&I zw(IBiR>o!JQPKLOY;y{HP_E$iZD9b9lx z#6ZKha^QP~Kx;*}WNlPY6C3hXVCR?O!r&38j?GcowW+rE&vd_k3TyApQ+wY(yZ_qB z&h4r8?a7W!T*9f&E6Av)y0>b31;JYxRTllqoEJl(yaf3I6>i$h&sg|b3wARuk`VaH za1oG#R`67>tm1Dg<6BugV!Znz_OA!mpPh0rlQw$J#X*SSJynNgWQ)0YxcEgoyX+Pq zOBB4kieIofg}fo!7!z+#w_crYTOY$Sg~;_)#GOyDHHM^*tSv$eRz^S(0)V?QCS6BJ zj)*r$#8o$seBg<;?Ws)5Hz<0 zmF5+%Bfbbst*d^;ioX@HygDl1m{e{}bzogRwfEYoeK*fN@ZQ;jH_q(8`Ru`~r$H=T z*U#*`c6uMM+n(y!m~7peQfy7MZjHBY_{rKDZ`%NOgKe=zruS{1+K2eXS{=hTtF^69 zV(uSD(c4$Yx>s<7&7)ZLDObI1Wqh*@zEGfsa$R)Z<53vsDHwYbeWI0am=VQJnDHOfd} znJ}b+(-}?p2Bx6C9xGv`RiMu%lt@QK7X&{$X{4pi^sEiil?SnfM7M>Yn{G#^#=D-kMq$#RzN|{I&KxQH86By$Cu&NrDB$aaBmU;XvWb$=SJC8{!EJ!^Z`K z$W2(-#IJBd1wp?fSED}S)`}z4%E()oVnN%9nJ}W_fD%V%8dG=7x`@6$qTdtM?+$D4 zi|FoK9=d07;7qZm26}*1)|1AO zIZ9o@!^%48c_*#lg2IOip;m|4)e!**baP66{cOkeGwoMTE3ckvyLqnjgJ-&Lo(0Eu zTshf(bs8V3?aCCAPiu8lie$ApDchcsUOCxz^>oLzGspu-wQXdRPAUM+`lxt&TzYL1 zSxa$kN_q2i7d}`O?CcdHgX0!x;=!Bex(RWQh_NaVybw<|W(n!u$wujsb+Xb9Ccxd8 zkZ+913G)DGWJ}z7;5=|ptyH|CJC7IL2qgw0Am?C}+&pZ2Py~qh`ssaFraEq%?%o`e zulht=qq0rEWMfo@EQiF1=YU(TpV;!v-Nvh`8hsXU&2n z`EEAinc(YNVmPU5g!M?yBNG32WlUJ{^DD#L6+f@+W0k#3;JX4Q9p>kp48$x}-i61x zMclfP&DfP;Bs6>m-r9&@%@5%MF(h6alWt8)H^u~29}n^tyK-$@4mpKV3JGl+d1D+O zL%e}p=Mf+`7VPY}t{JQ3;Gi%gaWp1J23e-E{|CZj~^G4Dey&Uq9XP{xf@lFRlTo3>PC~C4pST z@4{ubv!Q%)U^z2AZ()=j>=OQIMGj!)K`Blki*FA>aY*njprm$S*Mn^#|2b(BI|;W> zO~p!^c=&2N^!E~GHlCR@vB{SV8qg<0S<4Iz(CQMV#-yn+g=MTynd;M~`l1soLCHC= zs6aVoX-=7%b9P$R+LE<2Ck^!(OLNgl$J5Gg0F9!SR`hVnUVIE>u$GFOQE{^hc6#21 z=OFp8$WPr6hSa=`0XSAi;RfIxlL~FkE5Jhd0OA!080-wPA#h3fWe=<5#7p6tfxFpN z=s)m)4^mIMH33F$2ip<`ucZNGf|83v^3{YAdmqtSLP6*R960vY9MLwx?#bGiMF+EB zrK2pYfRT|lOf)P&oYJ>M)%7WTa|)%ft|4YtdqR43Qo21M-Wn5JnSi`SywF#?jFPJ*V`%_)m%VHRZ_!DqxLR_S zhP0_6V`<8mnzB~P$}n$bSg<)J#o8K|Z%?&BW`aFI7aM-@s)t|2-UPB9K7t4!7Cl_- zn4*VO@c}RH>M#d?cY6}QE8QepUa>KX&8~!Uf^0x;1iq+rb5=UYdIg%@30s*Gf!@%- zliRg8a6j&#K!*lj18WV#B;w;jR$RQYgHyC|$_`!?29u42wF0(rK({oJkg`%zHk4HO zK4}UHRN$LH2SiJaYH08$R@2gd7$95 zfs)iW=K&V-7&v5D2$H!vt$6>L&i9aDr(3T~L5C8ehYWy1fFD@)h@dfQRE}NGE;(3f zBMs3S)iuHAOqi$%gr}Vi4*L%Uw1bV`UG-!B3Y3jDhq#EoiCu)SUGcSH!GVO8h;DI#RBL?VyE`z&EsVo) zG@!(g)&a7Lo4Q)NExRbIKKkk~bA6Pz=100ft94HX%eX6Tx-VeJW6$lz6v z2o?d-6!@p=2C=dMblJ^8jZ+>*v4digXx>#nz6)7gD|1L+BTG~*#D;)~0a&*#QQ0Y| z!oIYT2BI=Z zZYY#-=upp18o6~D6Si}G*4#*<*hgRS(boK|>M#odiZi&_#;%?3(}td@cu0Y%3J%Q)A;y6CDstuEe$M7{=Z3rB%I6b&v!lCynGZM{~j1oVC?w?G0%g490sBru#G2Jvm!_ z-d3M6?@H+JjqC4C8t*Gu8_JI6RS&IXZ_1g$*L#rGaCxu~a@K~J_THH8%h91P$27aL z=BBKrA!FW+>y$C=$r$RhhQ^|mT7e+7GV*3x5ltEcHDjbEbj_iGU2z@CJhU)cVnYoP z)gG8bg3mKoz$N)i?%-QRqw7 zQ7DhLZI3HA5W;To1H`fr^itDdm}T)HP@|c zc<_(Isy_*<{y5P0p92Gb6xH05G647HB3QynIH&5NlpM`fCvDZmETa(DHO5uDf_?V} zdhbQzF519Ryj7oopffB)mMb~H%bXQAvJfj{Y(Zv+vy6?u>KCKfy?Uzi=Gpx>PVa?O zxH8!e;av3!G8P)H4Q@f5SrX|?$TFlm&|=mEsld#bXlOp69Eaf-M59mDFyFsBtZRW6 z2%08*g=!nkJrvw_PR>ZrXj@|ay939+ymv^TUxTl=CrOcXQmWTH@mp7(4Y-!N?DAe07Q&J?!8l;DD#kZ zu1~kWce3*a!E`U`MpP~^cd*CrI6D~&Kw+Xz2@lmrwT&e9bqyiS?u4l&X-57)(qm=x z*d=t}3r{KuuNB(`o+^IJ1h17D!#AW8S=NkA6CB(fR@Vmyb}b(NQsCH^f+y|?oVaJX z_r9pQF{WvOACflFaShO8O=8=bm3a?o>@=7OyyXKl_|P+TFn z8gp3IMo{*O4~hc2j9#!&%T5M}7-QASD(Q8_GP$ zhP4R=yhK=qaI@}&C!80Mz!sVXZ~{H(TH*iFf}TdWIr(4wGOYiAkJQ1?LQ^Y;>}+kx zSepS~5mD^H{%S@P7d^;wsM9DQ=)9c*F+gO$gHf>3ill;|6bJ**Q3&M7ueZbvdxGkF zBij3egI|tm>r?3Hn48Nk`nn$x&4a&lbwYmq6kIOFwNq$7D7Ih|!>l;lwSB7n`ni4Y zKli}qR43X5Yj=|Vhzv#-Y2^~<1t;oJdNQ*pz-o=9|A1(I@h#PrT+9_8WV~SAkHSH? zIS#o8F9J_|-;MUBbuIp#fwIxP4%vSUb z;U&T?gnbN+g=P=DE40xzrn|14*$a0G6pY5@7eCB@z(?vTUe=l)=BaRFRJ=YaTJyuZ zK@r75n8)?Aqzh>t}&cH<|)lC-KjY z_s(@+I|Var|9fY;5UO}(RJZV}U^Cu0(?!5N)sD42jaCJqBsTooDBSK2G(L?*ZSTn-~uDg%Fdw08CXUg zFeQ*00D>)sSerXP2>V{$eRyGOrlT--?(O4ifARA_eEaC*FCTyM_R%%vueXms{POYD zw~wy8hQ0pm(l#(*mfyJe)x*ngEoh&8xc@+SpzNsr3MLm+bOFPdIA8}Q@mZCwvoKjy zGh24IZZg}?ZZ$iS{%z?w-*)6(ep`M{`H|A==OE(z0~f3^2E#Ts!;W+9g?k;v`<;6a zl%$kc@HS$hPd8xW!M#ovR}Bp8JO<Yh-W5ol*5 z0`T$$B`D=;MYaK?(i%Ju*{zyk`HiJVe7=h{%g-slV5z0P@#5ccF#T-~h6~Qv7(dMe z9L#lCj<`j05P4u{w%uoB@%Mn`22sbGhhKZo*SzN=g^cqD;T$+$OaCWd{qp0tKfjh% zu-|@m&1ki$&c1qhMcI6J_5ze-ZSa3>;)RwbNrbA037mfPstj+9@p{7mPh2eW@G`<3I_pX{{UPQJc) zSN`6z59*I94z^YlAo$Q-#aGOa@OMEsdj0Ui+n-(h^3kPN56`je{sUFjtbk|;Ul3RE zlKb~nurHxxB_&&-Lhx%|KfH2qKj=emAAe+AzxnLi0lPoCVx)7*ukVMI`DLz#!(mos zH1HU-H_9Kd`I)wDWU^_G`J94{;8%8#-Poa9&F-!A1b3dDmhK-ql6}o~vg?!{$qr^$ zOLt1oN%zywoTAQ~hm4|nruyGmoWrK+Jowp#*N-h(F+2~FwP^o-mv!uGh$PQ1<2WfY zs@AlG^F^kcQ>5Z9&Z92i)G#y#O?rGgsx^3Xm-pwcV9((a>^;0(ymw(+4Sco>OJQ?T zu>*A%uV3B7R)^T|{1!}yA24$3SCOgiwyowZn+jsk!dB5+`Hhv{v)fDmWT*Y#1AlFC zbI=K;pXt{_zddy2(y!V6H(o!td$0Y~BgOqrq@#mJ=L*;{56+4)&3c~!K_yGSic75K z)5zIr!L8Y}wecPS2t2yzNd(ab5;iLyxEOUXGhoi@)E0%_ydrDM(g1RTUv=OjA`-As zQW9@Qiz>j+5bj2U9qr8R$&TH-=U?5s@-1ocQ9-bXj;Ig- zmoj15SNT#^ji*im2?wo>yCPy0Z{FtqSv7OZpz@+H86(=N6`Wj^+8NZ1*20vFv>N`# zKH3iZ0tR`8LLTUKemCER!X=7`;eVf%yH>|g;*iU0=e-27yR!6_va$2-cmDr*<~#n2 zIn`f5XaocII(F_h?MycofqQpb_NUuatyOlDt+8O(;=xTc?!;ik&EX|g!=g4W`>gFw4er|7HR7?I;Otc=z#3=#iTJiU4BdAHI- z;3g}m1$}iZBtgNoIB7#wA!!Rv;~)L)fAV+#)<6AwzgKGC-{}6kKZ)}HM$TXiejt-E zQ@){)M;ff#8n0Jygb)T_T#Y0_3zY?9U)nYig-Co6DTz;TVzR?n3JtjYmCB&=QGBab zb_|;0Q0>|%M5cCSw01L(9nNr&-;*0jX%cM^#}+LrIH{Pg*rFhN{DeeVk>*Pp&$elx#=M{*lsN41cKB9o2ODs%#E-G6Xz2W#N4TjP*f z1VLIRt&qGrQoHWS zO@XveF7zB*xP9!|jrV_b125qCJfJozl~FKvHI?T1URJJtaYyO*$nzdBbd8j9aqy%^ z6?IHrYx1|Fd_Loy)sw@4~rsv&k03YNiZVM#$?0VL;^bm@?f+Y-KV#} z zFbx##K$JEk2BK5YDzMI z28xZkPOzau&?CQ)W&D;c^~3(TT)NQv+?&O2YR2B(3ljqtnhLnOcN^F94a?)TtK+pP zCt)jZ2peLjHb!fCUV}HdUqQ^N-}Z@6g2OR_0||YHsaG%dRl=8J5==I%7`b`RGBV)c zXi~07~Gw0r5>;lqex^^bj!=Y}-bioBz=w0g97{(;jH7gAxALqSn?T4341}7s31!5ZrIG4| z;p%67$5+N`jmj99!BhhS!FOnG>JvsmgXJ++$ce`NDI64>*@z!(*pgg_v`{s7>u!>j zgmLMB8}Ldc6xfoO9{?RZ1Z;%esm^UR-QmXNek}xWygWs$wTs*1og~6oGjx7b3pnU# zkfk?Vx}V)@da(3s`F{D4@?SYpdRq3i^kBMQek8}oiDcEj46&u*lT2(|K<61d$;t|a zC}>vvo#~)0IVVmS$5q9lsudF8D5@>u<%yBaZYJhx!cju&5hmxbKV=rdV?>9+sYcJ1 zo}r~u1%(J}ux4eXF3P$HAL9s&Mj>Fsm|08 z<)3cy(4X`i2Q$-TJL$pF6Uz6~lgqDJ{@d~+^esVWvn^ZV$4&t%H}iEH`BSUo%3PH} z4GuCE4sYeNp5sn1ehagfsrqooh+;8F+iXe|#o!=C{L8*!Wpuo;aK6h!VMmFt>KSUD z)y(#?55A0dEZ&Hkyt=QT7{yQNQ2e{tduq9l!)eC?UmI>g_VT$sf%>yc4qlb`Ngv%ISH8YYZN20KkGU6^v(z3p(nQ?>p%ME zKmENYw?5dIXpkvvPc`k&0c1m7v3HN?lyf*8Opd$Fg-IM<2BokNNF+kFu?7j7>c%Q9 zphymYFp9GdFIG`3{}p=+j>N>2;>Vgw~qmBx$$ z`sm9(%)ZKC_TlACx4u>}yLVPyl4Di+-Oek)S;49qMG3AT*TB&WFM;GNu7V!OgF^uj zb3*YHfq@ekM${E!Nr*$rv5w}Y)I_EMcgAHJ6V=gNH1amVg$CY7giG|&S8(&eJ#CgcCd6OPEGz~HqE};aWH2hTcdnh zpu%L+l3gip{mw)~@ZAuh$s2E1Jim!kQn}nuqe1*vnH1hni*2{Z>NaufWN4IsYMtT) zr1N2$wX4Cy!vbctL~YTi`315}$lLf0VjzW4CZ0h33-N)+5d2(mNT`&8RTl1eSZYHz z&_a^RCs^+A@zLmb=hB-m-_P!|{I7oSk?*}`YSYr|=NLE1uTI<9$)AA*W2Ns*HUwvM z?97%*fqKE6s#THyP))FUhbj?rck@`DNV_asgQ2q2S2^Ev91+-}$4oDJg2TbY{OnQ) zTtjR`7s;!Nv1mDi%?QnjWsra`Vh>|>1?L%UbOOl^6T4~MlR!_RneT51E!i+hMdvtClJT+RwLi@RF+@`y%kHn74qHXp~_9Hz&tiJw}6pXyDl&otp`~oWT%Gpq56%% z`kk@nor%^0fKg0_(`XcjWjz2KIF7=48198&b!p(#ylPMnM1t~y(c8B2kl&6C(#SmF z#{a9o9kRmj)Yn`HOM>m(hUULVF)`sipx#4vB9%=61TegzJYmXyI77w!z=>zQUcLDK z7dJk5PUd?1*kbRAwZUrHn%H?hR0Wvs*g#bXxt_{4d}HYJ7M|}=-PUkDGV{hz{rVt? zr*>W|g4-utBt*ddXhB$L{J3>8a*$PU`w+GyO+c`r2;)h`$?reEL5Lg;NPeg6_-+50 zoRKRLAfu4cLcb(bPi|L`vs%P$pe&dG{7!n+gyQ4CU*_(Wf_$(pjWf2hyr+TQY4j(MMoh z6H3U5Ibu#jK0ItNF3nLG1@eCKA$mT;L5qhA=55*EJP71)E?1cu%Ytf_jLCTT>J*(K!dNQ#4 zP;@HtxjNdqGD@Z1OugoLIA2Lg%K#@NH}KY{OVfqNx^* zXtqbm={t9I(wXSkrbnCvVZ+DiG~0LXs*{nEYe;ZKva>1YL@}O11wSwSDdx`?P}|4P z%7%RA68!KK$C~(7D@?>jsiwzG+Sqq1U`c9|+KsVV$O9G+q6sRLh6IU|Z2)r4BPHIh zn7>nPrZX;(lhas-^Y&G(oBRFMD?Jqn;WsP@B;##8*Az&D6f^WfF9INF^dxlDMHYK2 zUvwXH@;1v(G`>RHA+R5BTpH2p08O#VDjF1PM9OiM6p~E+EZVn5+oKOodN<2rUgHVp-D^#YFBu zxjtB%tWNl_wGo;1R&ce8ed05sy@;hEHjoYs(aqr1;`ddCEMPU3uG)kk_g8O# z(scsRp``!h8dqZ=rwgD(l0I}4T4X^Zk2wYK1b%`#seIxw44xwTK2S-))7L15aw>7k zi-Xb@A$Fq1QdCYzCs8VuH){qptTPVQbR$Jo(gjWJqvBWH`gfR}C`i$XLth>mOp)K# zSliZU8x#AAnv{PCcQ$EdNo6#3) zO6fzAJG|(t{8jf6oXKamfBdrdy~X}xt2ptXjDaf7cNNK(moS8N-{`4a?5Par5C}Ri zUm-t!?wR$2=T8FOw#MtWCtzs}32Qb$^u4JzlPUfiqkK`gi0$afpvu>2D`>Ant(qqa zY*`(*BsMK-Jl3sohG!p59w+ zC2eRBMte0tvJicY7?*|sFtRhDja4*u*r4DZi6E5{!?rHwFVlChyhGqn@ks41{9AZV$3tF6(k6Cqmc`YvERrI z`uoN>{x8>w!-^vu)c&1uFj^b5zIb|1A8Mt74TZb#T4`j%v;1t-Z) zXoEy@K%Z^nbiA1$qBz+UGG(#dWNbSITB=i(eduIHF+A41Mz0ccpL|lF9qpkMOf@jz ztapOllm4=c5kU}1g0*FlZGV8h>#;GvK3WD2{wl#CKHpW$Z@_v zi4^+yy6%}YhzLk1;u+OaVwD(T#VHF#gv=qJkTi?l#+o)6aX{izzp9PJ0N1GzT687| zz63Fao?I3{UApKj_+?n9i|DmtrG7Vd#5;8hMUWT^lM};)%p`1*l zDv_-~*HT~4-2;Gx+tQh>Jb@1P7s~*I2w5VE_IKqGtfLFjSu>Octv|~HCPCdwU+vPJ znw6eYYkl==ktjDT^lDtMM@_B%eS*0ZP%e^YPm)tLhF)dx%!-y))Wbcswge|?B4aDH z?}d(kZ!10W>+b)ZPyR#w$$wY+tDVXAoOS6%Pbd~ma6&B-szvq0sBa1z=ya1z492KA zfyPZVBvIe3Ae~s~;S*}1w-PN?^vzL9%m#RcdZ_S@Lr-LU=DYOQY7jd4C{zckKt2f@ zYl*Hm;rd||`TY*swWtW=Et2 z(-0ESvoWPrD`ad<{!v{&WY`-tK*Nnj`clv7`8!InM8-7v_{(~wv}LyV;75P?m;d&E z{g=P`-#@^_e*0(t?7yX{vrpH_E@I~8LVP@+Z_bIA{nTqmmilO~#Gw&gS&Mi~xd0K` z3yHv;euu2>t+f4P_nJYbJZ~g8{T!)s?CPF9o=At8VY00MeUxz zBSWFrR(6WsNRb)VFZb3`q3F=D9vMv}<(|a49-uLJIYZ#Go(B!c6`6hi;XnAR%s>M@ z|0z5Ey*rHium9Em%zm5hWY5W(nG1IRl%^7HLtY^7LicO?1ok1E#OuLh z)7W8Nj-x&uL~er@Sr()T6;TP~DBz-KL>>EreC~CW_^+KrjVee}KM)G9q8VMl^RoFQ zYP13i-j{o-mPF;<6)(Cgp58eA;#TD%OygGNvzzXvGBqC?u}GksSPW6g}zi048zr!aAP75msi7s&L)s6uACwZMkJn+eVt zl$_Bzh0%-#i4(;Mn6q1>kw!a#$aqDgoJ8XE{8q&mH;;ikk~TF}D+*2{K{RpBx=tBm z9tKP@d}zc^QJS-$)vXOR7^fRrh9&zOT8!wAI1)_`#6JR|mqNyyN1j}N@7eVuFRmYX ze&gsoQF1rQc~!DVG%WYk%-{anzH@i~b7q%p=Uq%(>K2S*{Zst1W&hA(v=Xa)&YOXsZXTV#dGzU@zW3zQ_o+es>(*P7 zjMFnO)A7q=reVze0Chve= zPnD9uWZv+qV!n`Oi&a2qAczF_AllP1LFWsN8ss~*bgD~whw!Zgh5eQ(F=7&p8N7iM zpMI$mQa4Nk++1h1O#XEPTmpFtv=sjVQ%5I*@O8GDjgj!bMpOYWx%%=qNykj2U+dVgQ6_{glMNT31Ao zA_hC_h!zZFE0WbeMy|0RBT;Rl(fVT|Zw@zX3*hKZ2Wr_@o((pOv;|rp4k782q)A`* z@u%01JiYn;lj}czVMMEVMlu~Pb*V=vZE@qlq4Lp0Bf_u5v!^lwv2F4o#eWF0#E823 z>Ne9ZG1(byDNe{o+Ibt8Cl(fmlb`|-KV%kJS^V$m06b)3gE~E)eHxhGXj~__Ncvai zgs)lv=Ku>YZy$Yf^T$uS-;cf$gIe#wb1PTH!qVA0l^(bigMAG;xfZi(v;t!bIv!(% z-Gjs@!Hr=%qMcMVB3fLQSiAegN^i|e%F-Lhq%Dp-{q+53Hwd?n0f@zXDJ;7t7_Q={GV3l$P?%o$a{qc+IN0)9_vG4pXnPEkM53pc!bLdn`!jx_E3=*@Q@s{FP z+n&@uSqAr|7~%~!70)R=t9lrT*2ytA6cjBeQUOt-vs?F+LA8xl0F6Gpx~S60M7yWm z8LfDsSr>{^7k8&GAIx2SegB%yrfBqgvq7e3f^0=fEs~k|P~er0VpINIyhnBs7)VZB z1svE&_>ka7#GLhf&E{0i`b5ndIw{AR)`8%Mhzi}ujKt{sbi3l2rZ&EIA7f%G2^vF0 z$31`rtv8OMM=stzvEEm+)+^VlQ6vp#3Njz5D~_Jom1T^ahCqgIK`djwvDVFj=E6wZ z?qqD+Al(s`Z7Pmy!q8e6Z{3{?_S6CCp;^ze2}TpWWb@HquQ=VcKYLy?#pv}(%|TlK zn68FRFKH6X4{lFg*v^AsE*GX)_S*ivk9TK3WQZ)lI%HpeRc_+aP`BJ~WM<8F=*@FG z8m$Cu29(k723xXzZ9;>w8YG>S;V21%wRlX%HK~_*492~A3u@6+w$3G8cmsomf@2TyapJ24U)6WhhWlr$$~cayihFwwD} zzp$S_UmS1W8gAk=3*&9JT~r5JfqX|15iPnJH)*c-yf@nZs%0z=;T$z><#}7(=Pti_ z_#u^tE{35@dUR!O@&ib}9(zrL#x(E7FsT_re!5&+SlPzeIyE<}WJx$>B zbrm#`PRzPLb#9;40%JWN&{tAK&~k+```6B{5KO`tr`yCHC5xzEr$NIddht z9pAegfT4!UvsYg~{K?+jC$H}R;p_W9*`K+#H+^M$qHAq9*0;?6a-F`GZ-+)P6C1_l zr+wp*h|iJ+c}S0v3*d$>3bx8=u;D;qIN`M&GK3ec12yTwhN8`>}uXOPL2SUhWX3TI$zIF z9G-hMbK&*ur8oDlzPW$-%>(TUuI}p>J$H`8n`(|wi9>jG@ACfaCH5^&Uu9qIcMCI@ zG^s|Q!coIS@u~#fy5p}VFKvup*cd;z>a7_=5b@^4{w7Ar>|46N9WvG-6PHH2ht53o z_4R{~;J<-0D2qjdD)}fYK0*N1x2xuQ6F+*OG z)WYfEJ8>PIYpnP%`$#SZn7Gli@k3Z;g5+Y5s50ob9_ieAfHkfA`Lkc@T=?L^tJ$tM z_b$GgySP7d@%8;H*81XflzbG^2$~CU%V}M8bT{lYaLQ7ZpFRs^WV(yhPPrYpGhIbS}-?fuJ!yH+#^}VAqTM5%4%;<-#S^m`vK5`3p zPFT}fd5xt&{rCpAYv#K}qgA5%q)-&7)mk{vx{aYT+c>$yjj?GFgqAQ8NCJS>vIA_5 zB4AQe*mm=d5VoO94P!`xAA^J%tS2-z#hx)~h*r1Jvsp&4o9}!z)%9lP`~fK)Jxm@U z^K7($=6_?FcWKQ}+ZA;)1j{Jl#HNCAw(I&pf{!&GkP2>4_)TtLJam zE%a!y*YMP93+?xNRe<-sc!{Ui^?scnXI@o!P;R5rBfqYRy~Ia;tSDKb9?mBKT)ett zsn5V{-W+PO&S*&<4#6!AvTTbXw(XWIDSBgxgrc_88r1{~l+aSmM!%+Ljp5ZA(dRhY z#S_v;=i~S**0+@Lxr`3(+Qwx80f!h~+FE?!?u~;>c!K>6^S$1( zt$Ehz)OJ}?@Q?q|e=W7E%*^FB$QB(f}V3;Oil(1BfYDN+(CiR4!F0jBpE^sbzg!gk73JhY&^;+5IE}lCx7lXOqd+zz2 z^F7~l=CP-nWB=;zzj}Tu`G21OBmDo@|LOog-}_(Os+~70X4|C~p7~b~zRh%2T{(Gh zwo8FEB;#|})ji6TA9gi{~3sOGKeS+i`qLlibkuAV5FZY{ff;-O2& zKQ!G|nzYH&cGX;aWz;NL4%H+bs;EVJwe?`kAzL45TJEo32-Oq=)eC{@jiILX{<`IW zG4Ix7oT{u#9kWShIx9Fnizz0f20|3K5+o#BNo|wk94Z7^3w5x zuO8h$+acu&My(oQvuWlnsyVYX+$CT>)mnb#U%fWixG~tU95UwIYA|2$8{&4^OjpHBXC=Qi+bOwv zsxoCa#I2f`MKRwgo^2_gX{m_z$ah0`@44)Lb!Y!Q597(50~Y-zV88pb`rrKPpX}Kb zqMv>IBX{_@=lOddW__lZT|L_+-g)N-*_mo92lI*6vRSh@+#{Xt6kR@9`pQ%LrrRX* zW@Xf(iP?lLYQ-#7GwoHAE#=c~MPJS4@S%;N#>Jo!z;kX*(XY>XwR7E~sg8<-Q$5$k|-#>n;1k7ifl$NI{4*Jm3-mJ{h#|p>8C$YIrh==(2x|~;^cBraB}O_z+InuD;Y#_05x_Z=95T<%Imq zM-B!XKIE+XU9<6bTJ^tkRP#GeDE{Neu&LMj z8j3z+F=$-wuUj8#1oNf7hL}~c(p#5us>9uqoKGKfDDXuIyDaIDr=1GcRu<)?RS`E! z<~yn)J?}E1ozK6$v-5DzN%4@E?)|rO7?-}_H5UD*mEPKIB=O!m$4^iEZ=Q77{wA0H zMeFhZb}!UB&%_+6jL(p8Yj@uH-aozjrS1KzcQL(j*@ zii!4vDVIEHm!@puyjzuXsuSIkNJnL~OB}QOHg*iFebf!Z}Sa{`R z$ybh5v{mmbHHZG~3z5?BTWlZOyz}Jdozri<^XyyiovoYiY<=gQt?#|F z^^;$0z3|;TM&IaJ#}iSDV!4+ z%O^^o|JcD#Xg>V^yi^$aPg^5@zBTsatusH_I{z12&;8}r3xBos={s95-P!uuovl~y zY>nU9nz^%e?dMzlw|~}h`)AKA{Wxk<0cqB&$$Hh-PB*QOHWm777l#|Oq3V^P=3#ZVln< z4y3r0-LSKy?!5GVJM-PLlv|$-RPX*sJ8!bHv-?%{Cr*`LJy~|;M9KKcvM_euqrQBy zV*FGkR(kP7`QRh_n(EY5@wWi^Gk?AH`JZon>3?l~^%q+&|HIaWUvFLA+DdF~t!!=G z-rD-X*4AHaZT;QW)}y(%7Jj|ez43O^r31sXTbU5@qlWd-#)W~p#o>m+KwYuFJ{KUN zP?D8o9O~J&iiA~x)sdIwyoQuropovwR%zTKig#D-{=l5Y?uXm^@A>5J!|pv`vA=qu zx4PgrEQkInR>Zcka1P%7N5pb}*m)JRNx5`|Q0?wN_s{NMIZ;l^c@^YOmBnnt56Y{p z<*z=yFWRHJa8lxI*spr>sUz!m9uV{Y@7G%;;qSlpt1a{VTE?SKyVNPCB5bZG1axb| z^-F`bh2HAL!MdfPx?Dh)bSg4Vbv8#fqSD z?-{-4le-VQ_W%H22vu*grU(BiZo!y=eRq5g?5w2kY2+NqtHgB)hlar5K7a1szkcax z>6H^@ICJtHA_}%Er%EmzJwP7%wP!>vhKCL~&UXLdI}eVzBLCK({c`IQ7vgERmYX-{ zA;%$BH*SnJu8q{^f(DRZ8^z8wX}5wvWx=P5bXJ5rE7$t!k~ZaXZ*5X=EYe6%Mch)E zwoC4FI@>SZdr~~J=ilx(VSi)f5TVQ3K>dPGe=nrFoeb}DFYG&aMAWK^IW$?nY4`i{ zEBATGOIJ>mUOs+ss+9~#N&3_`uvj>pHP4J-@X_*_fx@vKZtKx`>S`F zH{bs8FSkxUcRuM*-px0)37drVQE=%a^$UH*jj@K+;o6i(k#fuPK3uvk)=lnHxfn2F z-e8{h>El-MTvtiB>tMoKdH>JPt9#CI_wnzyzdqay=1alq1^;_s&QYoeuWu2VAKC7NSi{*%9b=DT-p{kLD3Pxpd3!FHZC)U7P|wHvtf;ri9#y3I39D?`;` zOJ&j}TM8M#JZY0+*jymiO*~A_3j-jU?KlAD8OPq-pHtZR@a*h)xc$<-r@8xA*k2uJ zSnjJW`gCw^_uBdPGnn_z`>?YO`)T#*7exK&ZBXx^EdqB(yaG(3`o#+1Qo#M~lITv^;;ZUSqN`jVRP`}h? z0&oHL(T3}1n>SB4CS0<#SGm{+N2eh~Opy~o0$61^kCvq^+EX>#d2qh#VEP`+Ii1~5 z+~@4>bJ)s2J(%Y_>Xp#@Vh-{I>NxG4_hE(Iy~uJEBA&XKx2`aFc=yNHIevR*_en(^ifAe+)=sGue~oryR&`R#baexTPrW#rO>D0 ztGi^8Zq=(NW#;OKDqHMNUiQ_S%@Rn63`iayiJAmiw#8Rr5Y=q(>CBidP1zm--D0L0!0` zbn^IzW=?(RUvxUV55CX-a<5@+ux2r+Cwma+>+_s?`nsO}}~`mY|99@BpK14Cc$e)AU(g86^{hpqDX55M)xt&3X% zAwW*_?Z5fOljFrnx2X`+7JGGTV|8(tc%tpYtNr?$XByXsYFGMA7<10AS?V`IDze2L zR7@%sLfX{<{Ypriwuq*W|L*jO-?{fQ|KC5e5;AQJ)&g>P%V3u+df@@VV6*?TbGeZ%fKmj{2i-djsmj#5$1^}cK9 z?)V&+vd6-=ug=o>V}JAw=Z~-S-utKD6YcH8uAHnIZ>gMY7qiWD%40U&c)N1wNO`SM zE=~OSK`_7l>#bM*^yi;=0&K@*&;&nZ|5DGugT?>yp2I_R#u3 zHLF<0EiZ<2H_kSv+_HpAoOH8+xpX_q6cs3$*cK>knRb?_jcbTfWCVlH3u zsox+E9j?A{x;_ox63}dp)#n2gFJw_`Nzz%C^HePal}jN_(W5MQKK8x+2dtTakxO1A@J39||4k-9_S&wQVs3$;rKbL}q-yd*(apl~J*FN9% z=1Uzr@BAP;6P>CH$3-tcRXW)!ooW@2w~9agiHavorB#u)o_}lWGe6#Xw^gT|$Sf6DzqnB%wqJqY0Br`Y+;&$hksg|>S?!2fxt zcP&8MhfQ{=FQ1aUdbDDqMKW=!3djD9qm@THpVp_|GT*#&a^q*F)LYf*w`$UFVa)$- z{CmpSTk7~*+QeIp*&p{@zhk?8$NTzUfAzoqa_aB4BLA?J_|?{T|8eUt|L&JP8*g`h z`nd(KfeJo47BZdXUgK&|mve|W294{Z)oUX#Fs8gvo~|KO7BIJzE&Jsg{o19V8n>UZ zOA0P&wCmuW)7kxy^VN{o8^726`nxgT^Qrbcll^0G`zIwcT0#VT2ZMsYLnGR!jpy%n+V^5tv{nVK= zpFDk5_Qh$%OS7N6kb3%J=JBh`VE)nK+uNACZr<_Ux-5# zD|qyjJL7gm&Zk`n8uDKCdcSGWuOUjjHr8>I$4aNoifOZavO|QF>&l6P6f&S0CtAgG z7WKSMH`A?&I1FL-d(_ASQ0Pr}R?c))MQn;M+ZzY%PoDN3Js&(a?E2V+AWAuX&aEx@ z49oqs84s0cO~$QA!MAu7D}8zl8y`-HxG`M2IYf}GU-Zcryt1UFT)=z~7o>&;Au-Qz zA*}D>TloBY{_Q^5_uJ=J_Pm5zGUrs~UFx;onjL?RVFT%I@^;VPy7%F?zhryu3zm)N zPwjsHJ%4V`LyiRVi!D{(I$k!_C7K&+oPQJ%De^jsD=v&NqMGdHW0IJs)iM!Fyif;Y64GYP;m($#PuE3_alk(PtEt+t*Dr{Eb^QYT@R}r_XkQ&ZgBy3TO49ufFviWW? zoJq!miE4^L1EdNITpka(sjRj=zHSHN$o!6?fpF`UT|v)9?ep~u=4I2^bYdu;IxSwv3z_x zg=seS*>)?AzWe*OKl-}owJ-MUdH?%Aq@p*`AwgC#-6fqxmunVDTN|-xh~8%jCh_^LRr5Wngj0)hY~CuJx8RN_rB%&$iKE;m78G$Bxba*-3t>(% zXsKVnJfJTIm0+H8iB|gcH_kS#ja0Le=0rzixuH}cX`fk6}x%1}tUheG=x%;Ee zT2vG5V#pTcxYJz%c|K>6&YIEAi7;~fIcz}OuE)sPpKKLFf=#!JBUVk?V@!E)(hZ+@kF`<-_KyYsj1eKP9M&6wpEkC&pwooW}&^~h(t(TIvCTIj#1+{S#i zO9AGHyAZ?Be8CzTv1(IpW7cm(QX8hs(NPgGOAyn>x(TX%#HJ2g2xy^>xx^GrvL4NXUzc|)qvo=#L!7o%a_cPyG^_nJ8^g_;qmQl+J-i&M z&APR8C`8eiITU%1DnIz}cYd$^2d_B(MV}{P*G8=BtGJOi%3;u4ve|CsRHy9n33Tb@ z;Ea*OeX)8@w@a@aFGEBcwIGnz&0Calr#fm=%%e8PnRm+)Xvk3qIb<1+68ntWM2md} zYR#1R$?-Qv>V=imDJO2Zeg5H%(Rz3oNX1*{4%0SL^eKuSf!$gRsxlr$-mj*tkg$v5 z?_NXq82N*o>GrSeIWosGO@bEE@d04?SwS)`RnDbCP808`Sn?|iZb{ZDTJWp65wP>k zkw-R%AKe%{l=T=mU-W57yFBBRhn5i1L*is%KAm$b(nsoTIg@FFGXOB>iMhw7qmm+18r0rr{9I-3QI(MIdIdbCu z=FOoan?sM}y{5S?LBdT5ENz$0*ffhHkKcIl_~r}8vV)IZ|MZDJyVC!5^fUh@`?deQ zaruXr2jjlRxgJ3sH_=u#PIH7?6LTZEr|hneTXa(`lF3sPMimj8jwof@)Uoi0MGFaY z<#;*QCF#(Cc^tHfTZCQ!p*aE%AL~(pdCI~4vTw$G0L)|7s<63CF!g@ZbZ7a>U_Jd@ z8^ebXcO{+5*PnZok{lbQPh$18;hL;h3e&RI2j)s5bNCj(PuMEb&b|7UJ*e(}xU+vB zw10zn5Dm5j4w*a@%wb)?oI5mO6JzITJC3D_yJ?rWw)gnLiexKrfxN?bYl&}7@bLO>m{RLyjjPIZ)G-YhzZ&sT>U=<13R zURotL&mIQqRch0{ddRM8qjhN)jV+SZKJ8*ijfJlc(9wqYzlv=K$$NKxYddFwj##S_ zPVp*41mr`XF^l%VDoNTT5f+i|(nL?`f=@2^^S+vEBZrs!8W%#1*T)`T2sVVxLP|nc z)KWm7@KhK29!~q4vZ2GbUp)Su&$YezrJiqp-T9-)bAP??<-dr0`udAq(>>K;s}?l{ zqQsd_F^*-XTNSZWl&`tkCc}FZ2hMhg028MnWI8OSr^?4qmCsp}6Z|cwZnjG{-zkrB zr8;F18e!TiIWq0ip_ZhL=xWRUsrCbed3XB|%jV2gnmxhEC@YlwgVs5hCa{LMY zd}FM>7*rPnN|x7@QyjBaEcfYHPnY_1YlEhBiW+uF+WIbi%eDdU{(0|(*z?SL+WbOD z&pjCKE-wbuEB%lU`kX_au@O6|#>J57@va=bTj;ACs1P>eR?z!lT2G|E+7ZLNwpv=Ns+?l!QP zM!Qw>ZPIW%UIol)@FZt6;^fhgPqmj!w(d_jq(lO9=F0gV@!C+sLdZmZgyLfJbW_@| zoVQkOjy0@})NYJXhF0KJuAi>WdZhE+rQ}W2Lste&D}Bam!*vtLk)p+%2;Eo4~lr3bB%eyGLX`Wt5+BVt4v zL9~#x$kR4?%%NKzdN}Sfl2>N@b--R2c(i!tiH$F`{`uV4|0ull{crlx!6RT!(V2yS z>;^Y7(DFU!L+JXYrEE5Ec;cl+i0b)hOLW#RdAHFp7zrWA`>tlt|cwX z`Q;gp1kCe(d8CJ+s07OwTs(F@6<=#rfHT-xEI2kmMS`P=ggFrD#8|NK3I(md(I3| zfEy=~kpgcah~{5K3`~WH^dF|W*sIBhR2i>geY6fEUm2pARF-y&H%3fsDW_<%?Zfa| z1np}>2$f9*pE~7u7v_Mu8^%2kcfWN1tFx^)NH}E}0N@Lu3&E0C1?E{>WwdjD!hA6A z60Zcc>;2ey-L;XX)xmnYkZ8a}u#J(^fD`Ggq@%WgxVN`1Y>{0hPWBoX2Adbhj%0@( ze&fp>e?A^sKKoQA^hnZEM_b%<2U<`%a3v9&lH7BuO9brr5UQeco!kg=IDw=KPonzz zC-+@#m(Dv3F;C5<77=UiWQ%C>RJnk8mxw;BFdraTgKwdM9Xm(E9JPrFS11g@nGl&5 z0-Cj92y+y4nqr?O<5#QUOPI|pxD{?5a!Un{7^2oBxyEK=28J*Hmts)`;tX~KNxLkUYM3EEn} zabu8I@&Gse&bxXkiW;>x`lzJ!eCQw@bL1v zCvJVAWzO9&W2;#n`RGiy@)Ay?9X?h%Z&k*en%N%0auwHtdh}$wR3OqjBr&@d@BQ*q z2gloFvAY7)iB9=+mz>mT`~;l>2j&*-X_%&Rr+x}=V^PhTaum zBGKwlwGfBjjSK~{Yq)y8yDV<2C=?X2wA$%gtjP!KGJ)D$|KXob_5IN|owq;VUL1OS&T61e@hYPdI>b?@A>zlPJ-UJor{s!*A-OLA^; z#wkiWMOlx0W4NBU3l;a~SR+E>wb4Ulc8oHJF^j{Y1oH?5#9kIqf(Hp5^a-~y?tl@6 zWvb2hANtF=p`T}7c=M~)!qDR>f78V_(W|W$7urQpPxZXRCe4vhJGM>7$(?pyDe@?9-=TQQC zq^Ap3Cd^X`VhRXadV`OMU&{I;FGQNsaN~8 zX=hc!c0b>;4Jin}AGYuJJY}pUzi~Ne0yomhf*0~lNlmaQ)M2agBxnv%(k6!KT_32Y zF^7+esjQ8X*)?Uox)et4P-g6kxJ$LrUpGtnrUw#6pYfPtRy98XKht;U$5Z`(yY$kn zFLowFkHozV(-t+DUu+k}Jf?`#FiynMA-&ozzI3YWN-K6Q!HvvYfn7h_rJn3iCcO=_ z7Twi$Dn#13yYVDp)5J z-@11nJ6{MGSNdvTbc+GXQqUSwti9-=`CU@*%5zRBr0!Bcw>eag^SOEE(9JUsuM7&k z^K?^YT$;3QXX-rlODrNkL<3Ii_ltJX%$~?6^Dt~E!vo~dd{MoHmm1)s8EdARFc`j+>E_dTDy7w6s26lk~U zucnnOkAyX(3E=`~s`L$K&nwVFwY1Qy+A%6aG-mS-HY zxI>)@m}afA@%HkBO9j(Qqbt9XLX`E9I?iR@Qpr#9{ms#ayFMIFscI>xx^<>*DWqEN zRf9PJL)In2v9OPwzwvDIQb-+pcisOz;eF31cO!i7K71yrs6ga~bYu|JaN{W70{32PUU=;YNidAK$`Q_Wjxh{@zj_oc0i}kTNMe9 zF744~JkVSs&V}>BtIVKO3}~o3;~1BE4W!$M?Qx;6oo`$WskUJUbD@w#!ITPVPz~mr zLniEP4`O=|-t%zJ!SDAl?^7cfULC4g>NC=~$BK{LA~t}=FZdJ-ehslYP9F1E?KhE1 z6EQCJ)vgUTvq9~m=0!HZMjbQZ)y`U_Q&h^(&-093K}|UuFfEaj4m`X#`qA5;J@K92 zYnwtc0X@FEU;Y{Qu@~6XQn~e1-*t4PM=(xoY02;OC6F za=N2z-ld#%DCX$9^wTZUkP9}>*$g*dJo?(_PF!l2z$n5SKp{fB;D4ev3T&ARgtl z(R!jsZioA$_uIXS0Ta^_EMdkhlzFGB;8L&nwFnPjGV?AuLb7c;=h9HWBd1P#lp7;W z*YWD~t^4##em%XVq|v~;|s>eb_A6YWxOVVH5?-v))=trPCc!lGdfZX24JTY6zBcUN#0j5yJ?fpr8)2RU!kx)C*)uU8VSW zmMWa*`VdTunB<5U25*A}aJ~VH67vfmB=z z>d;^>2$EnW*L?{dCaA?X0y_jXPKL#Fh4NNVzt&g195haJS54cbQ{AFDi)6a1a^9_) zvCHPHlB}O)qBi z%PzHxrkL{Q)XzHfU;fmAmycCI6pyz_E*verTRD|dh8AqQOCgj^VUmN5GhKLf1EcU@ zcbQX>g&_5-NH-v|5-w^+`i;|d&?!@$`xpCktHXrrr1|g$74X;?HaLSr-lrn4M^^Ou zvkzlt6fV&gLXoWunbt>Yh=ss`)qz5fkjxI4V%-(vM?Vm5-?xfW3PP#zsW1S+59j^5 zb!sJjHCd;sC=~kjkXpP0zZkQUKCoCS_qRzG+{#sS!hJ@fbWA<#l0gXI8#$g; z3E#+1!T`P9LvOEvF=s;Y#~DKHADuQ3yBin{Aw|IG2Y zt7gWm-Y&o)Q)Fsc+FOnHrU3ow(Ng%9d7CC|SI^kgU_N0{%{X-5JX!ILV`Xtq^`%zP zrBf9!GZ70qE82zVy%h)neiFv8<{}9w`s=eUA&AY=2MwFit7d&f(htYAK320aRx@ua zi@U0BKi{-CpaJ%bmw`oca-xmly1REh^8wU3zw*Y}MlMYX8Ah)L>R^48->m}ygaQ2I zT2OiblcZg8@#+6C*S>E#C{(V612EJ8&DS)6GQYw^|04?FqK{;=I)dx)Yxu2{Tbg!D zS8*@B23Xt-OOHp%w(Li4q)ejY!_c>6~XAfa=aAL7ugWg|G*qm$ECBLf;N68 z>8hSJt1>RmkyXY($14r{3w~MAN8e&)u~)S`s9zg3rv2hs%YoGq{o;T+<&`YK#wOS!;kt7Ccjyivyr;l~ zkz>rv>S16AOdyl)AOjf`Lx=T35dB64321XJ zCWFcFZ^9L%?+@{CzmX1wTu^iK{2@w;=roWSqXE0rQ8sB2hn=c~S3kk{GKVVZA(s&$ z`$>9XzYSoX@;Bc+|8(3@J7ZQ(c1fnFra_2N7Axs@uC614zvOVmnD*%-Cz*b4r}jHjM3KJ7wJu4h^T%TvZy zm2-;L`m{NZIPDQH^l26bwZ#E7n5Vqrl_7n`N9shO9}`7-RI}KRC>`Pm)q2Is0BKY` z21$DtCtK{(u8vUnsEOLeMWQ%viUIC@6YcGEDlw3OyJ>C6NTrDuZ0hn%u3(k|v+QVQ z=fg1C5u1-WAa7M0qjeNVNP$_n*I|2T>!9hwC8grOIbb4aK}V6YOO^s!9SeG?s((`Jf3DwKy*goSaeomD9a-rl;1OBZn&;@-OD;m0HP zYEqlKk}Vm(GArbd>MIPWY$>_gif<`PdGs-mbQ-36RFh`;j8%0Bex{`YS2Nxvzt}>- z)DXAmlQ!5GMZ!vyQXe+shnsTV#+0)r>#I$<4HU;|A;}W=5+Q_0G*BXyWrK>vVPhsp zXnGI>-W)~JBc-u|D4lI%*tj~VOM9!bUWUmWfb4qx*+WEYNw;$SbkowHiOi8%4GEV# z<5w*XR_FT+jNi!zba2Sw?vk{dK{0CjVnB>38N!&*P&L98lodF341TGvI(gTC1*rRV zMXzins9Ni#Hb)X9qX?e&$~FcWF{;nu9PC^IG^=VV7dM9Lmi$`Gesh!}oe6a}>V=iw zn#&;8R!(Y3Og`H~+9+T?#q>62dIW3c9a`KAE`4q6;|X_t##=wvqkvbLVj?Tr31kus zaXnQ6@)K?4B=RvLb8pR@m05q4Gd+rnl>P~9I%U}W#Z$;Z^*|lB875n0ksi*d5n3ke zZ72kqiEUDDe2x&M7m>fZ(SOQ_w;@$x_KKuOa_hN6`JiTo5ek+vx{C656VJR?vJ_Ho z4jZnInbPj6tfw;8vp?gkynU7lfpr<5hQd>^Pw)v~F1U_>YMD-r0mItqMqZlhW)AB9 ztWUh$C&&f_m8nk;<^}jD2N#qw5W*or1`jEb^C$>PuMeA6xw-s8znD<(7J5`A`2bwH zj?y!$Dh;Z6rk#*4P%WYuEwn8VN*!Jsq;zf!n?>9>z%|}hdZo2wva@2|M%9TN9N!{= z^@_T*Ggf8XV_FzEvNZTuKJ@VF$j8Dq{S^xRW^#WM!Qljhc8{07di3C3{zM&h>XY7T zsP)S&l}L8s1fT+@gmEQ;7JaH!7PB%wt9q&($F45~nsDO~V!1#A#k(}JIuC&#!}NsE zg=MsW$hnu?6OB;i`baI^@tjky1p#)1VwH&zGUK+uN^Ctp^uuV1v$BvV+C=%Z4T<@Vm z-y>@yA72=FH05ucG^@uuaOO2(yMY=I@FJO;>yjrNdgylmr=oHBRK=B36=a%VPI45s z8Q{AvA18rTr`@$PU8;n`l=amMCF~xCYSt#4hAfklJ>=93`h!mv*hQAbtVfn|RHhwO z8^blr{ltf2INlqhb$Mz87A8VhF8IaQMs%;8ucwDD?~xSTqO`62*6Dg;NK|$J&icE; z5#V7?qsuYq~536AmRSo4iB`djO% zSs)W-Qts7`(uvN}$*!_FtBAOz*jE#EDz9{u%`zXAiDbdr;=tjhp~p5(KLLe)>&0W~ z(4mQL&8(fZQg^vka-~&t@mMLUA>x)f3uL1JxGi9g3O#J8Dujq|Bw4qZsxDfc8)FSnqfCE_TdJ-P z*W_H1SoguSy?iksS?QC%@q8nsF8y2?dj&0Bw7S5+3sK5|etFOU;6RF@F7y)bX$wLJ z0pTTA8MS2Dd^ce~#hsePkdZ|bJ4f@3@^h`vwBUt(l|y9Z{i>CI9b_gS20P#AH_&CU z)?dRYNCFjvAJ{q1WF3+PFHyQgP*IW{gL%lbIRNH|H-{RRL#BlQ!LWi!xl`tHw(0JQ z>F!G0ORm=xb)f~SoTq=yXP`(|=s#2l5db_)a`gJ=PUZ$4nYQWYoCX+}3nWA>6|WvU zh{^)Y5p0m=kjsyssz7Ljtcwr@WgRqQ)Mh}k%ZBTY*bH$n?`=+cYv2mvF6O19g*N2e zrbUK_yH#^N6}f;4f;8#CW~3Qg<@J%e*PlJY>=b6RTpOkzSux%6!ARG>qEEciuefo# z=K5$|(ptgQSq>;~j@7{cfH}&6^^xl9W5n>atYtWD;vAA(#+3{6y#Te7;T^|8+q987`5|AgmD%fT%;%Reb*e*}|4H1`W+A2u}O>v(- z6RKSpXimCKc-`W_ksB{Olk0zY#->MH%F6hyQxz9m%P*WPK?wj=h`xd&!#zqA0zxwj z#23EhZtg?bf@GhLb%^wYrzYX8%Y>RT!Nw`(r905cFcQjy-f6M7F5yB#P%>|=z|N6U zWL;t$DZYiW1q)fyDuP{E>(@=3{6M68|3Xl@*h^QVjsp@_266A_d|x};2m?S$Lgu(R zT8GL`pe2RDq}4>uu^th(IsGXah#iIoII4(SsPwJ$noz=%duAQXwNtN>NcL)l2+&3K zlf?y5oFZ+n08+vdJ_Fe(X-*-4QWx@EUi6Xs%Tm?~REt9UB)-U}5-{(tyFS!#bCf~u zTqAwK2d_w@gk-9#inxWk|0JXPeR{SiohH3Cn0kg~rN4oDUx?-W4Yyu+X5;LW<6X+I z(**37J0urcDlWB@qXB?3nHD52Oq(aiM2Ji6UM-B$HKTn}GWMD5=_)1cE_o_YpAI%9 z{f)(eM`i_OsT{YT@ll3r%KC8Tipll^;hs`*e_SPfa4@APLa&WAlIBxn&p0JuKGpiW zF-ysEKP;Jau}`4f<5q^{9we4~{ah0rcB?~mWFn-5B!*-tkOSmC)b-%XmT|L#^@Mh? zQb~KI5O5CRcx&Mab9be)8HdosB={3p1ux@d0bdYQfakUnnDHjO8`qS)49r`O=CY|nJX`_pu z0tanJL@akP zzpHi6xvCZevXx%?+yzQ=xnGZ{49w9_@~QAAq;m6}AI>-`h~d|J4NG3lTF`J~sP^{h zhP6SxKtcDRQNg8%sazoPL7jD}r7Ub$6$cuodn9p|?}7SkUu~hkj_Wdm+Rfki=4V^4 zpMPe`tiRAAje97h5-vgoh#0;-1N~(tgeKZF&C=x6QVHz1cPK;_Q^3D)qC{x>>Q<%w zjd4%IoXwO9G*f<>>Cr@8rW71+pf2V@XeXL#-;bo3#0U2hwUhqCLQ``gjY3f@CQ*9* zxn=^Dh^2IS083Digx-4gaGEg}a`IQLCeNiHCZb9M%XY6 zp4Nb*qcY{FD0rneMyhX)){)n2GY@Dd1fezMzYwiq)JJgU!UBrac_}Dc4#^kkye1>- z<@Sfzq5DZAI3K^f;6V$zFJ+@sSPAB9LE~!3xH(XLd#vHwFwRrWB0i4uvtPkIM@y%>;RouY_WH?AT`u@Yq5sG%zR0G| z^fjgf{9R}?`1w*KD=_5PIYv&wk-FPb0EfvyMasTPyvJHUos3n~`Y~+o>)Yq)++mb= zDFsvPlYIY;7as+A>Uy}HO$1;=bW%gS2)%f8sRLuIyOdTGHWt1Odc=n6ezR`6Bsm5M z1Oz3jKokeah7`27gJ;%Rx#*WI1)<=!3svaNR?oYbuZ$i}Goo{_an26r zrSmS$(&@+l{E|OE^2F61!@RpXXy)g}HOY;e?9_S~T#7l=!cns7zQ%9BQK$ z{k+96VOG6-9HPb)bufUa;o=Ed+*P0JdpP1YUG2urBPuAZ9*4naO~6ALU%*LQieZS4r%7v9$F!h@6!n0=DEY0rx_^?n4*#OF1Hd=#D*LuhPBCB!*0DJ+?UH$bhE z?<*-U_=H9St~Jaj()Z;7T`r_Zda6?H%Dhjq7?3BrOXKFUHCQs2cC)WxDO8Izdd085 z-d}sIzixA&G3HXTj8fT*I22Q6@py+QB8+l1B#}we^V?sa3f4qDx*3Sao~npbT^M@! zkG|Hka`uy#I;kk>QhpN6)#FtNu(L#r{<=v5dtWtL0!X$9pGQ#Y?k8x8+RDLPAix7kxQ=Z*hhG9- zxTcN8lMC%_N#C1iFYF*I1)Lb7sOsse}%~w+foivLDiM~sh z4bm;Bo=0@V*VYU)r2{6M4|z($qs|XBU3=lFrPEJL^ysJ@QBwo+iI&n?l!{iq-NQ8B ztwKu2fNs9U2JI*edBSO$>Qs%l$>;5+i!IVQtDY)G)L|f*qLm;MY=B@7JB03ol-HDS za*qg87H2w2xUXZjN-P$iKnTqm#A$BZxe!zkZ2J{NhF~rP6@C@QPv;tqRO>^`+o`_! zY}3v2O*EO_7^{E%O!M`jT42912Hm8?S;6WllI1H8 zhMG5@`{c&+&m{cKFt;Fi<4heb zT5wI+IXIJp3yc$sm%z;E@egThB~us3n2<@|IM={-ZH&gox|?H-jPt_CZ!&jx(8TN) z^3$B3C7zk>RJuji#%dCdD$>cEPae0HF83;7axmuAeh64(Z>3l`<_)BIKiOXy3k{er z^-&XqAA=d-o0v*wyY|z{iu2*pVDQ`p*M@8ORN#+VIBKhaX}bnY9+kXM=VN= zJYrTQZ8V?4)6%~$Xm_DpkVdDxHS>rPY0m9XMr@|pZVeh~WQ|0mFz^YtAr~Tm(Gjj= z^Td`ZC#1T9fjN_{2a-Z=cbAF++L+x0(=y(QtOd@2JV=f+0dsmW2sYp^kAyfpX`_Ak zAV0ZAAepcOZ`oq6dSjS|8mgSaH=r>99L$RW3Q3|Yg%y@yd&MgC!G739Eh~G*D_JIX zI@2`SE{wV*CQk-TlW0dhwEyUmB!k}SiEh=8uK54#g6H)wv?Tqt=qTcRXVyUT>e(l+ zzj*5Ar(5Tp^)uZdNh_#ozK2oR*tsC6c=c!rLiAUT9(?)efuz3%Wg|L9;+e38PF}4b zB@!eA3hsrhzb@ZPy%qJNi7-Cg3FaogOo~Rih?N$Dk_-%LFM=7-686@wjWTb+uf%T? zD-v%YYvEqrq?|!G?Ut_fX^Jj!tmC0nPs!~wwKvb!;fuf=5&Op3rfbh0-Z*#Y8dUaZ z1GA1v!&&SKE>X%-g2z}JLT?~K$N`g?a8wpUib9alnh5)~TpcL2NEf4zS*e*pje9ST zkZcAh>KRsOxCp?yYnYD|?J0$n!?D2O3tg)|*hSSUJ-o1L1AHrr5cIAL*J6-Y7#+`$ z{D3hGdG0gL+o8LaQIBcPS^f6((Dz^U{@`2g#nH#dk)ycOh2iG>(4)&|KXvP~t*PL{ zGghQ5Gyxf7c4N#&Vb=h=a^ZLx_2>&H%fEH9EbcXh2_5-*GKXGRPaOuz{TvhF5_Bu` z!3J_q)=-=|F?_g7$#)K>?|vs&63(ZyOenbbktLNo!pH~0vp z-inm7YPDCjNE+2slChQD9IL)@rsl?7*zrg=&NbhD{>Y7Uhi^Xn$Og(@ipWDIVnXuD zl&u7hK^n!oZLc6KsSCZTB5s7p9MLtp0%#dqWyW4f_5|jnu6TIxCl^?x4CjN_WqJ(5 z!Ai-n1TWN6!X31Zw9KcZR0P>bT?r3E2?iHOl78_-$-G0A3Q%z-iqp>1x6&h@XI%?4 zefO)@TQ7C~;8o9?U+TE4pit$98&mzwi)WtvgRfY!1CPSG2rHnA7Jfs-re|8qOqb%7 zXAVx9Wh@86ir|7&*J0iejDQT(01nd_vmrre!fkyn)U=H`odRJ>7*@Wqr5g8=aL`g$ zC3L8T$ZZdR_ENu=)NeZ`ygq_-K`8E!;}D|69F>utgM@Ph7v}=FCDPH3xxH7&N z0*MjK1GSP~9Vr081Jz-o2=Wp1atXIC=0aPmq7SGr^yupOPsBq_3!@)-^QDtf8igF{ z;$Ty@uPNR8@ar$NubzJ@;cuD)YKMS%+-0D^f!yMoNB3W9t(Xw1)hx0)Y<{i>p&gfl z*%z#^j1ZC1VF7uYcGqP6Op>pq+mw6?ri(Wz_BJLxdd9p^`DN+?eHPQ5`=}PJ58-2( zQGf&2-W;tVXdx8G-x8UmUCf91VAfflv6ig(B@2xH^GR-um^PV)0pMqwZl6E=`g2D% zh8u33Kf*XWN|W>}tqd|HhJ=gW8MUwxg!J+aj}jytWMNE?K^0Gtl!_1LnsbP<*ttv0 zmbO*kmsm>3iMA)nP^x2fAdD}##cYv|eHmMY5XT188%(igECal5FPb8leA85q;?9WHZ7h0*c-ps@dsbEe&_ehF)z%3F=98&p@Q~Qv-n=cU(xMF zzd4C2zS?ep_@aTA(2)rwgzkK!qQLa>^^10j&eaJw6huwb#XX{9BQz!KM}3;|u+|Hh z3)Oj-h+Lb{m-P$x3t`UE$uqdt4N9C|@odKj;yoWu+xHi}Wkqj!-d(=lPw}D}o_2k> zn!a_$1*{Jft_!^n@QOs#U{1pq340+V&$DPkRSi(U5($J%Kn>H529N2El-uaEWm|yb zvXvJEU?prwELPzVuy8mT2pmX7WI6QExuhv(C0WX$aln6t$%M#Va56}7hG>9--!P&! zq;Rl#{$qTr#XR4GMx`cLpC5R5{oKdHU~ZL9TV?1jmWB?~-o+J31sk#hkE}oc%xhol zck>(5n=mAY(l$ioS}q0mbce93yBNZ=HMOwP!yYBEjreLwKSbsw% zbO?zfH_oM#)I$Y1I?Lj=J=1(K(WMlKM{WmNW7H*nE&AkwtT^hptA^#%K-896<|?eibGb^g)oXAU9vrTPp9OB*$pj37h^KL|4Y1cBn~qm1Z5p(-Y> z19^d3Bp~<77Co{Yt$D5{_6bVsk zfb@zWCDmpEaBJ0<+r(Ge#H=IS5wm1NUI<P0k8=)O6^tS2cEH9;m+ZJI(uuL`w{fWH?ymoWmWjGMtMvSrMk;M`HU4SQZFNhpX0 zc?s(kdRP0>8+kvY3A+t&c*G_cV5k_pt%mJZ;#fkOyx!|3)y&B^{p{_|w-TbG01`?@3SX`Zrk zu^Ms%4=;=yLB#c~<0V32s2!1*nD1@O`Vo23-iZ26MFE;Vx%bvc(HS$yTt%yW$JWQL`2s{ z&>krAK9VCb?@!zadn3?jm_2sR!4SOQ?DE~ANGy0LKm3ux@DWDwT;|(~+bG6W zQefgMN^{&kxbz+^L5`q}aTvk>atqz-Dk@6CR63!Sr%Ac17Y7bgT8+DO`4GBa5#Oyq z>>aa}Qjeoje0S!#?D|<+FHP8C4nd2(G-7_J=$BH#iJBkEI?C4jlzDe$v>P3r>gL(I zc7Fa5BJ*v`5m&DcBK=}G0R1UdIrsnH(s@5eVV-&X*Snb{hrtN7ZCaIG_1@@U2skzd z3|3uj?^P9qD6yUMIQA9$9NQR>goLE+y{jS&F1fVJqD={wbk?@hWWIqhSXCLKQh_HPsBC2GEx6%SoZRxt2-ZFN#8zQ zTsXIN=Z(0#F9^nBY6LkCpsTU90RX0a$0Lp&TK$@#B|Uxm;YfYRIq=s<&j0?#{rxA} zt^4n;*#`LfzOQvZhYktfsFhd3y%ydBu)OM%8gfT852{5!SUgu>@DXB7H z16)IQe)4$O)(!}k6t5`q+baVT$6{vsNhi%D0Dt6Ce|vY37J*DLZN&*&70|qnaE^Ww z7&{!*9oz9i+$+|G4}&;;cYl!QNVaBszI$-y<-JoprY59x)7)i1B{-U^Vus3s8z}{n zS_!|hJqexB$PLR{O2Ogp_%5)^XDGN$&X*`{mS$}VexQvCbeNK34%iLWkDC{2Dd!OE z1~3k&LR?!#t_x)^;sPj%+fhFToC7P`hDRf^%-oqj{zkX^;V-uCzLB2d|8)nrR@5q< zE%p<{=jez#d%|{jx|1PW7nRS>oL)C|ENYsW(*NTN>&uTO{`k2q@0o!+vj*D#E(5n5i;j=au=xf$>8-Q^dV8k&<_z z0Ol%8AqwpPQ7kjRtPHG ztf1Q`%@WFvax86;^6zCkD>BkkVe|m(r2OZ(>Y+Kn6}ex46k@uH&{$bqCt;We-p7SR zL@Gf*@#(WqG<6S06sxAzS0CTleg7@C&ZrZ61@3axK5G1N@YEp^v52_8b0Ix_DrD=9 zyZSe8o#(_Zj;af{F8}sZ?eh;te)q4|kmrru{FR;i*Yh(!k68Pk+^l_cUA|0mi>cL5 zJRr245%pIye+?p;E^*UQ&|r<~n=2K(Mj8=4yf-sB7__zpO{^z?_KKjEb6yr_-kxDf zL3mb{bky$8qY+XSIiF5AN(5cy5kq;>QWey^wmS6pTi%+Yr)F*RwXmUjZ@zo)PT$Ua z--~-EM9r!8t$u6*psYn05Q{XdJBBI=k^;tUZ@P^`&acyy_&I=f`IjO<1xN(rDiKC} zvnq=o&{{eMf;#*x$`~OJbbb%v54gO^(32-EvVf*6q$y8<6^NllMKeFh6U!}J{`@`Z zmm~5eedG6^4DFMI<~bR$^`apR8bl}`21X$t#Sm(3;cU~3)(mY?TkqEFxr}@8*?4o@ zd1B}8)#9D2|NhU0!o91xg)6)Ful?|=;e_MF>WF&rMh#wRK~h*4ftpAcSt7Gbn6~KE z5Ox^Bn$S9ab45J=%H!R@jG4((5qpn-#gMp@y4HXe{)$T3gTnON;OxmFs*e@D$ z4yXZ1-XUQ)j2bIBu}O2q>dn7Pn2u!~Agjj`)*6y9_wOCwzjxx*FVDQZe~QM!HOiI* zs6}haIC%i2vfx7MMpPrB6hVTB?Glxp8?7Dr_R6fcHfkYQsXBrkUMJMQ5yR1(izgjx z3g|I}cBme5N+fZ)1pLcsXVr@FG3l#(`Mo;xMA0>sp?S)G{T4@e29YI2sHX z7S+Rdc%@OoRGIM&CftJvVDJv$(c2i4rYxwr$o7$7ugLk-etlH}xO=XBZ;qC$Oj;p@ zr8JX-SrRi=;pzl%_bfvfJ}JyW^;Ev-gGVTj8!MR1H%5LM z8b6dYRnmS7UTQw@e7+y)#r~avAKpKU5`fG1`Ft-|p12M;lNL@aTK8Je8`#f-0OV55 zp`U7^dJZbxTM7M&$2lq_F%oVHKI?*)4}}y{H78t9;b>Qc^+QPMz<=OODR@9rj!rBg zGF{ceg*3?}()pK%#{B&GfTJhkJ5jj%=8wM~*}s1U{jJCVboGMoMJ$M!MFer$)4g-& zLT38x(wGXkJL4ohbs+2Ni&?uv04CPnxclVqJ{kM-XNHvLOu~6G={y+{c{{-J-F{o& z3do^}5wR0+=Ia{@bnGkRDtNjT40Iy|11c8ZWvOp1ZM!{5*I?S&5B#`3svsJOu1*{) zKpzj!1r2gCi?|kHe}G&0BIn!;b&8PgXhe6ERwb?EdikakGq72#v%+%@J~xbOkWT2%Cwj5Vs*CA|pCU)Hw&wgh@9v z$08;vU$>;4^1@XqiX|^R!#oQtSFl*Mkj-nW{DgGDE`iUmtKu;7wv!n4r+*uN_0iSr zt#hf_a{<>Ng#Pb89WAwV!Qc=T1)P2$tHaV22Wj!1WV()8kVp1snO;yHvdEj;K?M=Q z?JT^xclWKV?<^Li;`AFk^KWk6zRZ^T>f_mf-rs}L+P{x9T=2VNC!(8yvaVPc1=LL8UXg~v@2|zT{85qk;e}&T_ z$-jvrL-eG?fGvp|s_7okJw!h-rI3vygp{bZz}wB>(!g%wx6@dlmY8J3cxjN~J|O)M zq#Xn-15oAw&IJzb+FCeYxP5MO;o|qdesBAiZwDO%o3}5aFh}PDw32jn2l3+*DXE9M zY$eep?K_3+9F!*Q=*`%>v#wqoi@+nm0t_=r&xy3>WPa*w(sg`y{?hY%SGMQh`rSWi z|L~b1<~zHFnh2DiOYZ?9Y~@ewR8nUt0zJVMh{UO z^DvLJG7kt5BOA@uBs4Ma6wBkLih{c)rY}FJxqsxR!Evzks6ob89;nE2ozUoT&zE zHtrmty!#K{`M>4K|5=*M&HNlWXu#M(!I2e(%-z)dtE*BprBD^%jY8izp<-O2u^?!S zSvcN}Q9?`1ppj^k*h*?eKB~}GDFITpe0+t`nNV1+(W;2{NWxH-wUX!gT8NsPt5X($ zmpV2|Fk5QQvoHI1M9mrRp;kHPbRHprqpKi?gKlO}aWyb_eQ_~HS_CCU$Sk)mT zp5aLsv3~8#gtSbk!&dO{4*nW2b?x7~^6G;dFCJXaPKkM*g$S@^LyO3tI4||rSIHqk zjIAavV3A-tbQ)tS3Z8NwPda+hy5JcELSNTPAm#anf~*qZ!ngay?H*>iG>f5KR&=AD zs*dSikL!sXR~eG#(CZOt2o zx@Qxzm9gp#ovJW>CQaE#d9t||LlBLfARPcP0D*v|op&zQVT<7It(_5DHyyh$^TyuY zx4Bir*8ZTW1IQ)e=%Y3Hb;4ov@ETER@{))e89@EY2)lp^rEZeXUD*Gz{1AkW+Dd@~ zi%@Qiv}@y4QBw^qT6~M`H5t*gQCJZXTt?Y*w(11?5p#u!I>`5#Z8)E$9{YT*^TnNB zjyhxzHD^|&M6?v4MT9Ma6?N4Xyo`CWysx3?1LlI@jvfWSQRpu&Dk^i3l|agqllyCacg&kE`+t29STUi zRC6q)ai<`c7e`fv*$dx&cr!nHDQHF9D=bI}H0OGBi6w{8yHe15=+_NB+pd~|uV|Vu z0`RAip^*a?dz_oj&Mc%1>!c`fLgR=Kfgvg7h2a^OX4M$~bzEn!`7(lK?<4tb=~uzhUYw%w5{Nb7lX-;mobePYs<&7NnLL6a>!}YYUgtN!5BP|L#iDWi*A|>JzTv`ys2YmGR z_xf39K*%Gy^8Hyj8d+3-D5N_S(H}|M(77QK;srVYaI(LIIGj_Bnhp)XtAzp5F!+IM zVA;&!GZi8?G2|D#4SBEVE&LUnq3FeKBS~3Fa^NMw>a;_VbJMhWl0d=$$?Z(p!Prr- zqw?aY=glw_HJfBVieDF6U)Z8JY>^50y$L-=k>~(B<_iS*3jCof08SHbND4@`Hw|9{Lvc8u`B_N&8dqx6a4f7p z#?VfG=48?kxJIctLeQ6hz<6?}+P5(fAvl3_V1M_}Opp)NgLIYl{o37`R@556gW#5V zH!polu#s-@cb&w`S5tGQ&=RRfh8Qt-j40)K9E;e9P@17vw2Jh4C0LdXFCdWFuj<)ja4Y^?T+v%I9em_4irbvO3tH%4bY>Hcwtmn z3DH0>NAx0Q266;fN2%+#v_2(Y6!hD7oc%Q6Iu&!A+Ff}2+xM>nHu_E7Y)?p_!zLz7 zfJY_g9L9v2bLTFPG@#(+zR1&FEWB*qvN28!H3OjmdKTk)FvRQwBzaNGu0uEr7 z;16Z}Oc-B}>JNuS&B>fEhaN2*QDxR8=uXfTYAzlkneXE+KsCw}B=88Z3G^12ChkoZ zd}_|n64Y1i&9;Ge;e2Ej-J*$smRl7F4^SO2Is)1=;c%q_YLNmF(N$rr$f5>u!;lhM zC>DQyV@yXPdL{n~YF=~@uv1^Ow`@7vmPRE{hN_mwWSCj7ZedOYLW}^j*jsYEbM0wg z<53bQ)^3trLpl&? zrWanpP(&;W7SDBLS~lg2JKZ37fr;{@RsI6t#eo|CNKAh?ZiKvGLje{mW2DJCuz<-J zyy@h;6G!$7o6#Q61Pp=7giV=a47dZAo4d_qH#NOV`~jsIxz8?}hqV(W+MUsugYhqahjVB%ZH?eIRJ)d~&lc>7YvwQt%+_zoyyG=%N)O z#)qhDbodKUCGnmD-nwRLp7)-LnY%D+_%$%{1V*V@`J*f^Ghn>Zq_ghD0>O01?4?md z_4C=bv{k~O7}gw0S<15x)U({JOQbo3Ry;_+zpl19FU_#f+>zVxn&r7_{@q`mX= zXqe7ZlkxUKiE@V5ER6wMOTgCp%&1->U)Rz`V+mQg5JjdU7wDQ^y>3viXzIbi=*$_{ z2^ zG*Y>$t0AFCc<4stG?opcDm{gWr57jB>I6)&1a25h52H*BqI*5*~Cdc)enQAe~N zwXuq#Fl@zRPNEK3I_oGN@ip6fvffi!?`h6C6%JcE*-uO33h`)-?EBOlDfQzUHAL|s zD*_fqozBn3L@O;F^BvbTwu`N)ep-6aph!Uk`_NicCLFlr`UGCe9m+W8s*M>DXC6b` z5;t>oR_9!xk<}SGjHx25FMl?A1pCSE?Jg$s?Gge&YInZm)ZhRkr6~9s#m^)b6@tj* ze(f>;MEUMitH8!>sy+OACT2p#-zsUV1M;Qv9C(m1L0FVDT_Rfv(%-6zY2|TGnw}E7YHZ?&q8Hj2ZzQb(jS#UpetjeQ7UuAj=VZv-8+Q(( zc!_Y5?a)u%Kx7z;xGn`ZYV25ij}UL3FYiQp#7;!b13HN2E{0X4M+qA*K!F&Oqg9(> zwDa*IPXz|X-CJx2h<~I>n~Wc3>C$E-3mf3$Dhghr_>ZNXl9&bmUHRJh(H!FoNj4GM{9*^H~5?3$RhfxsW$$))BvcS?LT;uC5P#8;VfG01VKh|oV2 zvk>A<{9{?tUY&NzA@%6bo3rg(a~+&>K;Rd52LKoe@!o?c#Ry5BfDoX9$mmSzCKWI+qx&laAuI({SW$XDm(lb16PJWZHz9QId7n za4+MC+=761HbpeDytQeI3DBtg;@u+;Z8= zZtfiEyHQs^qNAX#XGPQan1`fE)8#yitCKlxkhCaJbiWp6s)wI|j`^IB@D{S!OCfl; zw#8$Mc+yu#kJ1Woo##EZX(w-Zm1mvu?J2Uk2(>GZmQHxccr@*jvsW?!id3BG)~#9L z4~4mYey5Lfjwqdr65^gAgaI2_3mo^sAdTYW&4(~>=&J~ zO|Noml4S%X%#oxGD4qw8_fdDh@crL)V#q@H!>&0D2I<&IPA@Dc=2)wg~ zpN_h*hr)eVM2wXzL7N zrY3fCv@TJOI?2WaM_XD5&h_iL1l35FQI^Kty+r&y83C=TOCbZBJ^|4jfY+EgpP4$B zo4ruDeK|dO4k{##1J@*=Fg8$zmZ+@;y4NKaZ zC#6zv=;X^|73)St*r85%J5p1}oD4+vK%yBN!>QFHO312v!lgZtobv6ill9c6+| zSR?=i7<*|rsDJTmXLw=9fhMPC6;t_yVsTsoS{pWllUJ;2D}%Vn&<5N+m7MAg+FJtF zrnIjIC?JjCpDY(=$1_9ys$RLGQ^v{mneHbOU`?lHs>FU6GNYgG<6_;qeST~H(vKex zefQCD)N?N6I90rT`NjKJ1J>@Zc`=GNcMMGlmw+D;7lAY~x9}if7$}(M7j+`1vGmi% z;}>zdx(iNCyeERidqYFb6~#%W_p+#-npbVQ5x=1@k)>_bDXWCZJi)|nmO%GVa6wG) zCY`&1g%tVL?p!A!na|O^%ylrFYjdio? z$+%=`90__A`?cR7q2_A_*}74=|I2fk*@0(Vg&&0*86 z-1NW~Bju8%EZ`yN&)ND#0t0nsd7)hZWWhx65$xSMSV+471gI+8I+r6d2|f;>Fm6mi z0J&5!LHr_Rgy=*~3J(a*K+W+G31cbwjima(!I`QfqI-)Fj1s6$P*|mZ{B_acZDN5E z9|V*%3>OM^v>EQ^fVFXHLi%K^a(T1@DPYK?2wQ76j0E&aQr@2Y+(`f{8Z}5`ezHHy zdoF+e~kEl6Na=o{rVxNuli6s1vT9%;fR78`Jca|6Q8?@l!+o z&b7kbEC2bmb^pU_OKeX%HdZn!)kv(FbBL@b3WMl5!j53*aF(GFjlo&)+=HD&>&`ST zc&-?_qJ`P!SOSV+k~9Y7Ta_8EFopytkV|>iPG42T^i^n^!J4Qu_aKD=!s36VtaAGE zxAWcm3$Xv~cy)26u&r?YQAxqEvImvap+ebSB0H!U6{aci@ljHavB*_GYEI%J5+j2w ztgnh9>hJ;4<4I@pRir?@w8Z9!FUC4YGoGIy19p~S5^|GV?pk3AutQ;x zoYu8@`z!{ToqKQp*VnE;|Hk#hr^dYxhW_%E{o7yNSZB@Gla>jEK_nwsdIwi3`_w_K zD^39%lwvqXwQlc7J9w_8E9K;ePS(LaOGt%yMhEE^{OP8*0Ws1JlB9Xu(1N)@KEXMs=A3h2c1}3wTrkvv?;!C{ zg;Ng$3#Xl$Ls*bp1g%N@V_c7!OOD)y&mCx&KZo}mY4QLp;9%RObqRVXjcS*bN(3)d J1HW*U|36r0nGpa0 literal 0 HcmV?d00001 diff --git a/extra/images/processing/rotation/test-bitmaps/lake.bmp b/extra/images/processing/rotation/test-bitmaps/lake.bmp new file mode 100755 index 0000000000000000000000000000000000000000..431e4ef8ae54a49e6fe9dcfbb7dfe6611921cf3b GIT binary patch literal 485 zcma)%%L#x$3`EDP;N23e!1LnWp3;$3Sx1~r)`-jc36nw1!kU;vcJ~>mrCY$3(1C_5x)prJUxt$(sLR UkU%|9cvQr5i9Vt1`U7R|0QP}-@c;k- literal 0 HcmV?d00001 diff --git a/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp b/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp new file mode 100755 index 0000000000000000000000000000000000000000..571ea835ffe7948a5c48c781b78905126194bb26 GIT binary patch literal 454 zcmcJI!3}^g3(p>h>6M}?ogZW%8LrgEpDXcIlp4l8h=*DOtzk@D{_AhyVtLa5 literal 0 HcmV?d00001 From caf4b6c8a175b33d60cc0ae1bcb4edb4ed595681 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 May 2009 21:07:14 -0500 Subject: [PATCH 172/228] misspelled kobi's name --- extra/images/processing/rotation/authors.txt | 2 +- extra/images/processing/rotation/rotation-tests.factor | 2 +- extra/images/processing/rotation/rotation.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/images/processing/rotation/authors.txt b/extra/images/processing/rotation/authors.txt index 07c95811a0..09801441c8 100644 --- a/extra/images/processing/rotation/authors.txt +++ b/extra/images/processing/rotation/authors.txt @@ -1,2 +1,2 @@ -Kobie Lurie +Kobi Lurie Doug Coleman diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index ffad4130b5..493f09b145 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/images/processing/rotation/rotation-tests.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Kobie Lurie, Doug Coleman. +! Copyright (C) 2009 Kobi Lurie, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry images.loader images.normalization images.processing.rotation kernel literals math sequences diff --git a/extra/images/processing/rotation/rotation.factor b/extra/images/processing/rotation/rotation.factor index 93b67e3b34..c10bfa0ee0 100644 --- a/extra/images/processing/rotation/rotation.factor +++ b/extra/images/processing/rotation/rotation.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Kobie Lurie. +! Copyright (C) 2009 Kobi Lurie. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays colors combinators combinators.short-circuit fry grouping images images.bitmap From a29317df5f29408bff193a728e6defa6fb067b9f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 17:55:15 -0500 Subject: [PATCH 173/228] Remove old local DCE pass --- .../cfg/dead-code/dead-code-tests.factor | 9 --- basis/compiler/cfg/dead-code/dead-code.factor | 61 ------------------- basis/compiler/cfg/dead-code/summary.txt | 1 - 3 files changed, 71 deletions(-) delete mode 100644 basis/compiler/cfg/dead-code/dead-code-tests.factor delete mode 100644 basis/compiler/cfg/dead-code/dead-code.factor delete mode 100644 basis/compiler/cfg/dead-code/summary.txt diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor deleted file mode 100644 index ee7d8d2a43..0000000000 --- a/basis/compiler/cfg/dead-code/dead-code-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: compiler.cfg.dead-code compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.debugger -cpu.architecture tools.test ; -IN: compiler.cfg.dead-code.tests - -[ { } ] [ - { T{ ##load-immediate f V int-regs 134 16 } } - eliminate-dead-code -] unit-test diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor deleted file mode 100644 index 73aa7b4a5a..0000000000 --- a/basis/compiler/cfg/dead-code/dead-code.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs sets kernel namespaces sequences -compiler.cfg.instructions compiler.cfg.def-use ; -IN: compiler.cfg.dead-code - -! Dead code elimination -- assumes compiler.cfg.alias-analysis -! has already run. - -! Maps vregs to sequences of vregs -SYMBOL: liveness-graph - -! vregs which participate in side effects and thus are always live -SYMBOL: live-vregs - -! mapping vregs to stack locations -SYMBOL: vregs>locs - -: init-dead-code ( -- ) - H{ } clone liveness-graph set - H{ } clone live-vregs set - H{ } clone vregs>locs set ; - -GENERIC: compute-liveness ( insn -- ) - -M: ##flushable compute-liveness - [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ; - -M: ##peek compute-liveness - [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ] - [ call-next-method ] - bi ; - -: live-replace? ( ##replace -- ? ) - [ src>> vregs>locs get at ] [ loc>> ] bi = not ; - -M: ##replace compute-liveness - dup live-replace? [ call-next-method ] [ drop ] if ; - -: record-live ( vregs -- ) - [ - dup live-vregs get key? [ drop ] [ - [ live-vregs get conjoin ] - [ liveness-graph get at record-live ] - bi - ] if - ] each ; - -M: insn compute-liveness uses-vregs record-live ; - -GENERIC: live-insn? ( insn -- ? ) - -M: ##flushable live-insn? dst>> live-vregs get key? ; - -M: ##replace live-insn? live-replace? ; - -M: insn live-insn? drop t ; - -: eliminate-dead-code ( insns -- insns' ) - init-dead-code - [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ; diff --git a/basis/compiler/cfg/dead-code/summary.txt b/basis/compiler/cfg/dead-code/summary.txt deleted file mode 100644 index c66cd99606..0000000000 --- a/basis/compiler/cfg/dead-code/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Dead-code elimination From 3954c3fdc33803d9c30ddfd25c0d4ec02a17dec9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 18:55:49 -0500 Subject: [PATCH 174/228] Add a new ##allocation union to remove some code duplication --- .../cfg/alias-analysis/alias-analysis.factor | 12 +--------- .../cfg/instructions/instructions.factor | 5 ++++- .../cfg/linearization/linearization.factor | 22 +++++++++---------- 3 files changed, 15 insertions(+), 24 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 8e1034fb0d..6b1e0c47b6 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -220,17 +220,7 @@ M: ##load-reference analyze-aliases* M: ##alien-global analyze-aliases* dup dst>> set-heap-ac ; -M: ##allot analyze-aliases* - #! A freshly allocated object is distinct from any other - #! object. - dup dst>> set-new-ac ; - -M: ##box-float analyze-aliases* - #! A freshly allocated object is distinct from any other - #! object. - dup dst>> set-new-ac ; - -M: ##box-alien analyze-aliases* +M: ##allocation analyze-aliases* #! A freshly allocated object is distinct from any other #! object. dup dst>> set-new-ac ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 650bcb5795..747233dbba 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -160,6 +160,9 @@ INSN: ##set-alien-double < ##alien-setter ; ! Memory allocation INSN: ##allot < ##flushable size class { temp vreg } ; + +UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ; + INSN: ##write-barrier < ##effect card# table ; INSN: ##alien-global < ##read symbol library ; @@ -225,7 +228,7 @@ INSN: _epilogue stack-frame ; INSN: _label id ; -INSN: _gc ; +INSN: _gc live-in ; INSN: _branch label ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9d80a2b28e..64507779a4 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -1,9 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math accessors sequences namespaces make -combinators classes +combinators assocs +cpu.architecture compiler.cfg compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.instructions ; IN: compiler.cfg.linearization @@ -18,7 +20,7 @@ M: insn linearize-insn , drop ; : useless-branch? ( basic-block successor -- ? ) #! If our successor immediately follows us in RPO, then we #! don't need to branch. - [ number>> ] bi@ 1- = ; inline + [ number>> ] bi@ 1 - = ; inline : branch-to-branch? ( successor -- ? ) #! A branch to a block containing just a jump return is cloned. @@ -56,18 +58,14 @@ M: ##compare-float-branch linearize-insn binary-conditional _compare-float-branch emit-branch ; : gc? ( bb -- ? ) - instructions>> [ - class { - ##allot - ##integer>bignum - ##box-float - ##box-alien - } memq? - ] any? ; + instructions>> [ ##allocation? ] any? ; + +: object-pointer-regs ( basic-block -- vregs ) + live-in keys [ reg-class>> int-regs eq? ] filter ; : linearize-basic-block ( bb -- ) [ number>> _label ] - [ gc? [ _gc ] when ] + [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ] [ linearize-insns ] tri ; From dd8152f7bb8b402c6aaa8af1b4db93d097bdbe67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 18:58:01 -0500 Subject: [PATCH 175/228] Add phi elimination pass --- basis/compiler/cfg/cfg.factor | 14 +++++-- .../cfg/optimizer/optimizer-tests.factor | 8 ++++ basis/compiler/cfg/optimizer/optimizer.factor | 38 ++++++++++--------- .../compiler/cfg/phi-elimination/authors.txt | 1 + .../phi-elimination/phi-elimination.factor | 21 ++++++++++ .../stack-analysis-tests.factor | 3 +- .../cfg/stack-analysis/stack-analysis.factor | 18 ++------- 7 files changed, 67 insertions(+), 36 deletions(-) create mode 100644 basis/compiler/cfg/optimizer/optimizer-tests.factor create mode 100644 basis/compiler/cfg/phi-elimination/authors.txt create mode 100644 basis/compiler/cfg/phi-elimination/phi-elimination.factor diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index be047f0658..265cbb8f00 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays vectors accessors namespaces ; +USING: kernel arrays vectors accessors +namespaces make fry sequences ; IN: compiler.cfg TUPLE: basic-block < identity-tuple @@ -12,13 +13,20 @@ number M: basic-block hashcode* nip id>> ; -: ( -- basic-block ) +: ( -- bb ) basic-block new V{ } clone >>instructions V{ } clone >>successors V{ } clone >>predecessors \ basic-block counter >>id ; +: add-instructions ( bb quot -- ) + [ instructions>> building ] dip '[ + building get pop + _ dip + building get push + ] with-variable ; inline + TUPLE: cfg { entry basic-block } word label ; C: cfg diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor new file mode 100644 index 0000000000..5cc01173ad --- /dev/null +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -0,0 +1,8 @@ +USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger +compiler.cfg.def-use sets kernel ; +IN: compiler.cfg.optimizer.tests + +! Miscellaneous tests + +[ ] [ [ 1array ] test-mr first check-mr ] unit-test +[ ] [ [ 1 2 ? ] test-mr first check-mr ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 41cd3c4b90..f59e9e0b83 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors combinators +USING: kernel sequences accessors combinators namespaces compiler.cfg.predecessors compiler.cfg.useless-blocks compiler.cfg.height @@ -10,23 +10,27 @@ compiler.cfg.value-numbering compiler.cfg.dce compiler.cfg.write-barrier compiler.cfg.liveness -compiler.cfg.rpo ; +compiler.cfg.rpo +compiler.cfg.phi-elimination ; IN: compiler.cfg.optimizer : optimize-cfg ( cfg -- cfg ) [ - [ compute-predecessors ] - [ delete-useless-blocks ] - [ delete-useless-conditionals ] tri - ] [ - reverse-post-order - { - [ compute-liveness ] - [ normalize-height ] - [ stack-analysis ] - [ alias-analysis ] - [ value-numbering ] - [ eliminate-dead-code ] - [ eliminate-write-barriers ] - } cleave - ] [ ] tri ; + [ + [ compute-predecessors ] + [ delete-useless-blocks ] + [ delete-useless-conditionals ] tri + ] [ + reverse-post-order + { + [ normalize-height ] + [ stack-analysis ] + [ compute-liveness ] + [ alias-analysis ] + [ value-numbering ] + [ eliminate-dead-code ] + [ eliminate-write-barriers ] + [ eliminate-phis ] + } cleave + ] [ ] tri + ] with-scope ; diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/phi-elimination/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor new file mode 100644 index 0000000000..d94e57f378 --- /dev/null +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors compiler.cfg compiler.cfg.instructions fry +kernel sequences ; +IN: compiler.cfg.phi-elimination + +: insert-copy ( predecessor input output -- ) + '[ _ _ swap ##copy ] add-instructions ; + +: eliminate-phi ( bb ##phi -- ) + [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi* + '[ _ insert-copy ] 2each ; + +: eliminate-phi-step ( bb -- ) + dup [ + [ ##phi? ] partition + [ [ eliminate-phi ] with each ] dip + ] change-instructions drop ; + +: eliminate-phis ( rpo -- ) + [ eliminate-phi-step ] each ; \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 8c941f4539..d43900018e 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -100,7 +100,8 @@ IN: compiler.cfg.stack-analysis.tests ] unit-test ! Sync before a back-edge, not after +! ##peeks should be inserted before a ##loop-entry [ 1 ] [ [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks [ ##add-imm? ] count -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 6d602ede76..0aa402ed66 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -184,10 +184,6 @@ M: ##dispatch-label visit , ; ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: modify-instructions ( predecessor quot -- ) - [ instructions>> building ] dip - '[ building get pop _ dip building get push ] with-variable ; inline - : with-state ( state quot -- ) [ state ] dip with-variable ; inline @@ -203,22 +199,14 @@ ERROR: must-equal-failed seq ; : insert-peek ( predecessor loc -- vreg ) ! XXX critical edges - '[ _ ^^peek ] modify-instructions ; - -SYMBOL: phi-nodes - -: find-phis ( insns -- assoc ) - [ ##phi? ] filter [ [ inputs>> ] [ dst>> ] bi ] H{ } map>assoc ; - -: insert-phi ( inputs -- vreg ) - phi-nodes get [ ^^phi ] cache ; + '[ _ ^^peek ] add-instructions ; : merge-loc ( predecessors locs>vregs loc -- vreg ) ! Insert a ##phi in the current block where the input ! is the vreg storing loc from each predecessor block [ '[ [ _ ] dip at ] map ] keep '[ [ ] [ _ insert-peek ] ?if ] 2map - dup all-equal? [ first ] [ insert-phi ] if ; + dup all-equal? [ first ] [ ^^phi ] if ; : (merge-locs) ( predecessors assocs -- assoc ) dup [ keys ] map concat prune @@ -263,7 +251,7 @@ ERROR: cannot-merge-poisoned states ; cannot-merge-poisoned ] [ [ state new ] 2dip - [ [ instructions>> find-phis phi-nodes set ] [ predecessors>> ] bi ] dip + [ predecessors>> ] dip { [ merge-locs ] [ merge-actual-locs ] From fe44ce282153ee31b1ae80678c841e9432472650 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 18:58:14 -0500 Subject: [PATCH 176/228] Better CFG checker --- basis/compiler/cfg/checker/checker.factor | 29 +++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 3a9d4a2b90..53f0557db5 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel compiler.cfg.instructions compiler.cfg.rpo sequences -combinators.short-circuit accessors ; +USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use +compiler.cfg.linearization combinators.short-circuit accessors math +sequences sets ; IN: compiler.cfg.checker ERROR: last-insn-not-a-jump insn ; -: check-basic-block ( bb -- ) +: check-last-instruction ( bb -- ) peek dup { [ ##branch? ] [ ##conditional-branch? ] @@ -18,8 +19,28 @@ ERROR: last-insn-not-a-jump insn ; [ ##dispatch-label? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; +ERROR: bad-loop-entry ; + +: check-loop-entry ( bb -- ) + dup length 2 >= [ + 2 head* [ ##loop-entry? ] any? + [ bad-loop-entry ] when + ] [ drop ] if ; + +: check-basic-block ( bb -- ) + [ check-last-instruction ] [ check-loop-entry ] bi ; + : check-rpo ( rpo -- ) [ instructions>> check-basic-block ] each ; +ERROR: undefined-values uses defs ; + +: check-mr ( mr -- ) + ! Check that every used register has a definition + instructions>> + [ [ uses-vregs ] map concat ] + [ [ defs-vregs ] map concat ] bi + 2dup subset? [ 2drop ] [ undefined-values ] if ; + : check-cfg ( cfg -- ) - reverse-post-order check-rpo ; \ No newline at end of file + [ reverse-post-order check-rpo ] [ build-mr check-mr ] bi ; From 64da54234d3f8c283ac96d8505d85e989858a11c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 18:58:41 -0500 Subject: [PATCH 177/228] Fixing local optimizations --- basis/compiler/cfg/height/height.factor | 6 +++--- basis/compiler/cfg/rpo/rpo.factor | 2 +- .../value-numbering-tests.factor | 17 +++++++++++++++-- .../cfg/value-numbering/value-numbering.factor | 2 +- .../write-barrier/write-barrier-tests.factor | 3 +-- .../cfg/write-barrier/write-barrier.factor | 2 +- 6 files changed, 22 insertions(+), 10 deletions(-) diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index 336a8a33c2..eed0aeb0b5 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -48,8 +48,8 @@ M: insn normalize-height* ; 0 rs-height set [ [ compute-heights ] each ] [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if - rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ; + ds-height get dup 0 = [ drop ] [ f \ ##inc-d boa prefix ] if + rs-height get dup 0 = [ drop ] [ f \ ##inc-r boa prefix ] if ; : normalize-height ( rpo -- ) - [ ] [ height-step ] local-optimization ; + [ drop ] [ height-step ] local-optimization ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index 32ca87de97..babea55643 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -31,7 +31,7 @@ SYMBOL: visited [ reverse-post-order ] dip each ; inline : optimize-basic-block ( bb init-quot insn-quot -- ) - [ '[ live-in keys _ each ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline + [ '[ live-in keys _ call ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline : local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- ) '[ _ _ optimize-basic-block ] each ; \ No newline at end of file diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 11c0819027..c12b5afd2e 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -14,8 +14,8 @@ sequences compiler.cfg vectors arrays ; ] map ; : test-value-numbering ( insns -- insns ) - basic-block new swap >vector >>instructions - dup value-numbering-step instructions>> >array ; + { } init-value-numbering + value-numbering-step ; [ { @@ -156,3 +156,16 @@ sequences compiler.cfg vectors arrays ; T{ ##compare-imm-branch f V int-regs 33 5 cc/= } } test-value-numbering trim-temps ] unit-test + +[ + { + T{ ##copy f V int-regs 48 V int-regs 45 } + T{ ##compare-imm-branch f V int-regs 45 7 cc/= } + } +] [ + { V int-regs 45 } init-value-numbering + { + T{ ##copy f V int-regs 48 V int-regs 45 } + T{ ##compare-imm-branch f V int-regs 48 7 cc/= } + } value-numbering-step +] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index b22c8b4388..c771d3b388 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -11,7 +11,7 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering : number-input-values ( live-in -- ) - [ [ f next-input-expr ] dip set-vn ] each ; + [ [ f next-input-expr simplify ] dip set-vn ] each ; : init-value-numbering ( live-in -- ) init-value-graph diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index fb755399dc..c1a667c004 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -4,8 +4,7 @@ arrays tools.test vectors compiler.cfg kernel accessors ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) - basic-block new swap >vector >>instructions - dup write-barriers-step instructions>> >array ; + write-barriers-step ; [ { diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index b952c062e7..e4767599a7 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -43,4 +43,4 @@ M: insn eliminate-write-barrier ; [ eliminate-write-barrier ] map sift ; : eliminate-write-barriers ( rpo -- ) - [ ] [ write-barriers-step ] local-optimization ; + [ drop ] [ write-barriers-step ] local-optimization ; From 1fc830a99e236f70de58c2dd707a9fce7ada9ceb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 18:58:54 -0500 Subject: [PATCH 178/228] Add a with-scope so that optimize-tree doesn't pollute namespace --- .../compiler/tree/optimizer/optimizer.factor | 32 ++++++++++--------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index fe3c7acb92..d1f5b03be0 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -25,18 +25,20 @@ SYMBOL: check-optimizer? ] when ; : optimize-tree ( nodes -- nodes' ) - analyze-recursive - normalize - propagate - cleanup - dup run-escape-analysis? [ - escape-analysis - unbox-tuples - ] when - apply-identities - compute-def-use - remove-dead-code - ?check - compute-def-use - optimize-modular-arithmetic - finalize ; + [ + analyze-recursive + normalize + propagate + cleanup + dup run-escape-analysis? [ + escape-analysis + unbox-tuples + ] when + apply-identities + compute-def-use + remove-dead-code + ?check + compute-def-use + optimize-modular-arithmetic + finalize + ] with-scope ; From 43a7c9a3d87c8723106c67bd7e7c124e39c1f851 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 19:36:52 -0500 Subject: [PATCH 179/228] tools.annotations: work better on generic words --- .../tools/annotations/annotations-docs.factor | 5 --- .../annotations/annotations-tests.factor | 3 ++ basis/tools/annotations/annotations.factor | 35 ++++++++----------- 3 files changed, 18 insertions(+), 25 deletions(-) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 005f5f7af8..8d73d85fb5 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -39,11 +39,6 @@ HELP: breakpoint-if { $values { "quot" { $quotation "( -- ? )" } } { "word" word } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ; -HELP: annotate-methods -{ $values - { "word" word } { "quot" quotation } } -{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ; - HELP: reset { $values { "word" word } } diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index bbd2ac2ca8..c312b54edb 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -39,6 +39,9 @@ M: object another-generic ; [ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test +! reset should do the right thing for generic words +[ ] [ \ another-generic watch ] unit-test + GENERIC: blah-generic ( a -- b ) M: string blah-generic ; diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 3cb74fb00b..3aac371a6a 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -9,8 +9,7 @@ IN: tools.annotations GENERIC: reset ( word -- ) M: generic reset - [ call-next-method ] - [ subwords [ reset ] each ] bi ; + subwords [ reset ] each ; M: word reset dup "unannotated-def" word-prop [ @@ -22,6 +21,8 @@ M: word reset ERROR: cannot-annotate-twice word ; +M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ; + > "unannotated-def" set-word-prop ; - -: (annotate) ( word quot -- ) - [ dup def>> ] dip call( old -- new ) define ; - PRIVATE> -: annotate ( word quot -- ) +GENERIC# annotate 1 ( word quot -- ) + +M: generic annotate + [ "methods" word-prop values ] dip '[ _ annotate ] each ; + +M: word annotate [ check-annotate-twice ] dip - [ over save-unannotated-def (annotate) ] with-compilation-unit ; + [ + [ dup def>> 2dup "unannotated-def" set-word-prop ] dip + call( old -- new ) define + ] with-compilation-unit ; : watch-vars ( word vars -- ) dupd '[ [ _ _ ] dip (watch-vars) ] annotate ; -GENERIC# annotate-methods 1 ( word quot -- ) - -M: generic annotate-methods - [ "methods" word-prop values ] dip [ annotate ] curry each ; - -M: word annotate-methods - annotate ; - : breakpoint ( word -- ) - [ add-breakpoint ] annotate-methods ; + [ add-breakpoint ] annotate ; : breakpoint-if ( word quot -- ) - '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ; + '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ; SYMBOL: word-timing From 7dcedeb2a37dfaa95f8d637477e6987f2744bd70 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 19:37:03 -0500 Subject: [PATCH 180/228] destructors: improve docs --- core/destructors/destructors-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 0b6ca15f31..536ee19c8b 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -26,7 +26,7 @@ HELP: with-disposal HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." } { $notes "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:" { $code From cdf5cff3a6cbd9ed92cd595ca46db955ade7238b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 May 2009 19:37:12 -0500 Subject: [PATCH 181/228] webapps.planet: fix edit-blog action --- extra/webapps/planet/planet.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 52d64f0f9e..12b7ccda24 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -166,9 +166,7 @@ posting "POSTINGS" [ f [ deposit-blog-slots ] - [ "id" value >>id ] - [ update-tuple ] - tri + [ "id" value >>id update-tuple ] bi "$planet/admin" >>path From 4292033da654ffb3b08e1ad919a5372cf6935c07 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 02:48:58 -0500 Subject: [PATCH 182/228] Fix alias analysis --- basis/compiler/cfg/alias-analysis/alias-analysis.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 6b1e0c47b6..198ffb5549 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -203,11 +203,11 @@ M: ##alien-global insn-object drop \ ##alien-global ; H{ } clone live-slots set H{ } clone constants set H{ } clone copies set - - [ set-heap-ac ] each 0 ac-counter set - next-ac heap-ac set ; + next-ac heap-ac set + + [ set-heap-ac ] each ; GENERIC: analyze-aliases* ( insn -- insn' ) From 9987f272b0edcf4f0d22a4c6a6511c286cd8227b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 02:49:51 -0500 Subject: [PATCH 183/228] CFG checker now checks consistency of successors and predecessors lists; fix long-standing bug in useless-blocks optimization --- basis/compiler/cfg/checker/checker.factor | 24 +++++++++++++---- .../useless-blocks-tests.factor | 11 ++++++++ .../cfg/useless-blocks/useless-blocks.factor | 27 +++++++++++-------- 3 files changed, 46 insertions(+), 16 deletions(-) create mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 53f0557db5..bc0eb74554 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use -compiler.cfg.linearization combinators.short-circuit accessors math -sequences sets ; +USING: kernel compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness +combinators.short-circuit accessors math sequences sets assocs ; IN: compiler.cfg.checker ERROR: last-insn-not-a-jump insn ; @@ -27,11 +27,25 @@ ERROR: bad-loop-entry ; [ bad-loop-entry ] when ] [ drop ] if ; +ERROR: bad-successors ; + +: check-successors ( bb -- ) + dup successors>> [ predecessors>> memq? ] with all? + [ bad-successors ] unless ; + : check-basic-block ( bb -- ) - [ check-last-instruction ] [ check-loop-entry ] bi ; + [ instructions>> check-last-instruction ] + [ instructions>> check-loop-entry ] + [ check-successors ] + tri ; + +ERROR: bad-live-in ; : check-rpo ( rpo -- ) - [ instructions>> check-basic-block ] each ; + [ compute-liveness ] + [ first live-in assoc-empty? [ bad-live-in ] unless ] + [ [ check-basic-block ] each ] + tri ; ERROR: undefined-values uses defs ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor new file mode 100644 index 0000000000..ebc333b537 --- /dev/null +++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor @@ -0,0 +1,11 @@ +IN: compiler.cfg.useless-blocks.tests +USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker +compiler.cfg.debugger compiler.cfg.predecessors tools.test ; + +{ + [ [ drop 1 ] when ] + [ [ drop 1 ] unless ] +} [ + [ [ ] ] dip + '[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test +] each \ No newline at end of file diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index b4999a8074..b6ec1a72ce 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences combinators classes vectors -compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +USING: kernel accessors sequences combinators combinators.short-circuit +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; IN: compiler.cfg.useless-blocks : update-predecessor-for-delete ( bb -- ) + ! We have to replace occurrences of bb with bb's successor + ! in bb's predecessor's list of successors. dup predecessors>> first [ [ 2dup eq? [ drop successors>> first ] [ nip ] if @@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks ] change-successors drop ; : update-successor-for-delete ( bb -- ) - [ predecessors>> first ] - [ successors>> first predecessors>> ] - bi set-first ; + ! We have to replace occurrences of bb with bb's predecessor + ! in bb's sucessor's list of predecessors. + dup successors>> first [ + [ + 2dup eq? [ drop predecessors>> first ] [ nip ] if + ] with map + ] change-predecessors drop ; : delete-basic-block ( bb -- ) [ update-predecessor-for-delete ] @@ -23,12 +29,11 @@ IN: compiler.cfg.useless-blocks : delete-basic-block? ( bb -- ? ) { - { [ dup instructions>> length 1 = not ] [ f ] } - { [ dup predecessors>> length 1 = not ] [ f ] } - { [ dup successors>> length 1 = not ] [ f ] } - { [ dup instructions>> first ##branch? not ] [ f ] } - [ t ] - } cond nip ; + [ instructions>> length 1 = ] + [ predecessors>> length 1 = ] + [ successors>> length 1 = ] + [ instructions>> first ##branch? ] + } 1&& ; : delete-useless-blocks ( cfg -- ) [ From 4c05bc4f1060449d86f89fe49e687d344641e955 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 02:50:07 -0500 Subject: [PATCH 184/228] Test updates --- basis/compiler/cfg/optimizer/optimizer-tests.factor | 12 +++++++++--- .../cfg/stack-analysis/stack-analysis-tests.factor | 7 +++++-- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 5cc01173ad..b81d9f81f5 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,8 +1,14 @@ USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use sets kernel ; +compiler.cfg.def-use sets kernel kernel.private fry slots.private ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests -[ ] [ [ 1array ] test-mr first check-mr ] unit-test -[ ] [ [ 1 2 ? ] test-mr first check-mr ] unit-test \ No newline at end of file +{ + [ 1array ] + [ 1 2 ? ] + [ { array } declare [ ] map ] + [ { array } declare dup 1 slot [ 1 slot ] when ] +} [ + [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test +] each diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index d43900018e..e846ebc28f 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -3,7 +3,8 @@ compiler.cfg.predecessors compiler.cfg.stack-analysis compiler.cfg.instructions sequences kernel tools.test accessors sequences.private alien math combinators.private compiler.cfg compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo -compiler.cfg.dce compiler.cfg.registers sets ; +compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks +sets ; IN: compiler.cfg.stack-analysis.tests ! Fundamental invariant: a basic block should not load or store a value more than once @@ -22,9 +23,11 @@ IN: compiler.cfg.stack-analysis.tests : test-stack-analysis ( quot -- mr ) dup cfg? [ test-cfg first ] unless dup compute-predecessors + dup delete-useless-blocks + dup delete-useless-conditionals reverse-post-order - dup stack-analysis dup normalize-height + dup stack-analysis dup check-rpo dup check-for-redundant-ops ; From 2d71c8d9933f31b8bb4c2a03b0200b62e25a8a9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 02:50:57 -0500 Subject: [PATCH 185/228] io.encodings.utf16: cleanup --- core/io/encodings/utf16/utf16.factor | 40 +++++++++++++--------------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index a6ccc95bf5..1fb5ad1116 100644 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -59,7 +59,7 @@ M: utf16be decode-char ] [ append-nums ] if ; : begin-utf16le ( stream byte -- stream char ) - over stream-read1 [ double-le ] [ drop replacement-char ] if* ; + over stream-read1 dup [ double-le ] [ 2drop replacement-char ] if ; M: utf16le decode-char drop dup stream-read1 dup [ begin-utf16le ] when nip ; @@ -68,36 +68,34 @@ M: utf16le decode-char : encode-first ( char -- byte1 byte2 ) -10 shift - dup -8 shift BIN: 11011000 bitor - swap HEX: FF bitand ; + [ -8 shift BIN: 11011000 bitor ] [ HEX: FF bitand ] bi ; : encode-second ( char -- byte3 byte4 ) BIN: 1111111111 bitand - dup -8 shift BIN: 11011100 bitor - swap BIN: 11111111 bitand ; + [ -8 shift BIN: 11011100 bitor ] [ BIN: 11111111 bitand ] bi ; -: stream-write2 ( stream char1 char2 -- ) - rot [ stream-write1 ] curry bi@ ; +: stream-write2 ( char1 char2 stream -- ) + [ stream-write1 ] curry bi@ ; -: char>utf16be ( stream char -- ) - dup HEX: FFFF > [ - HEX: 10000 - - 2dup encode-first stream-write2 - encode-second stream-write2 - ] [ h>b/b swap stream-write2 ] if ; +: char>utf16be ( char stream -- ) + over HEX: FFFF > [ + [ HEX: 10000 - ] dip + [ [ encode-first ] dip stream-write2 ] + [ [ encode-second ] dip stream-write2 ] 2bi + ] [ [ h>b/b swap ] dip stream-write2 ] if ; M: utf16be encode-char ( char stream encoding -- ) - drop swap char>utf16be ; + drop char>utf16be ; -: char>utf16le ( char stream -- ) - dup HEX: FFFF > [ - HEX: 10000 - - 2dup encode-first swap stream-write2 - encode-second swap stream-write2 - ] [ h>b/b stream-write2 ] if ; +: char>utf16le ( stream char -- ) + over HEX: FFFF > [ + [ HEX: 10000 - ] dip + [ [ encode-first swap ] dip stream-write2 ] + [ [ encode-second swap ] dip stream-write2 ] 2bi + ] [ [ h>b/b ] dip stream-write2 ] if ; M: utf16le encode-char ( char stream encoding -- ) - drop swap char>utf16le ; + drop char>utf16le ; ! UTF-16 From f67bbcbe6504fd4fd8837013568bad0f4daebda1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 02:52:05 -0500 Subject: [PATCH 186/228] descriptive: update for tools.annotations change --- extra/descriptive/descriptive.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index 9af94aa4ed..0756c5c975 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -28,7 +28,7 @@ PRIVATE> : make-descriptive ( word -- ) dup [ ] [ def>> ] [ stack-effect ] tri [descriptive] - '[ drop _ ] annotate-methods ; + '[ drop _ ] annotate ; : define-descriptive ( word def effect -- ) [ drop "descriptive-definition" set-word-prop ] From f6d139bee29a19290a358a9c191548770ae594d6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 May 2009 12:28:52 -0500 Subject: [PATCH 187/228] fix stack effect --- core/classes/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor index bd2e6ea4a0..0697537d12 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -6,7 +6,7 @@ IN: classes.parser : save-class-location ( class -- ) location remember-class ; -: create-class-in ( word -- word ) +: create-class-in ( string -- word ) current-vocab create dup save-class-location dup predicate-word dup set-word save-location ; From 6b81b3e055ac00bed0e6f36ac72644aa454ea1a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 17:54:27 -0500 Subject: [PATCH 188/228] compiler.cfg.liveness: correct handling of phi nodes --- basis/compiler/cfg/liveness/liveness.factor | 44 +++++++++++++++------ 1 file changed, 33 insertions(+), 11 deletions(-) diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 7cc6158e68..e069caa03d 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces deques accessors sets sequences assocs fry -dlists compiler.cfg.def-use ; +dlists compiler.cfg.def-use compiler.cfg.instructions ; IN: compiler.cfg.liveness ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis @@ -11,6 +11,14 @@ SYMBOL: live-ins : live-in ( basic-block -- set ) live-ins get at ; +! Assoc mapping basic blocks to sequences of sets of vregs; each sequence +! is in conrrespondence with a predecessor +SYMBOL: phi-live-ins + +: phi-live-in ( predecessor basic-block -- set ) + [ predecessors>> index ] keep phi-live-ins get at + dup [ nth ] [ 2drop f ] if ; + ! Assoc mapping basic blocks to sets of vregs SYMBOL: live-outs @@ -24,21 +32,34 @@ SYMBOL: work-list : map-unique ( seq quot -- assoc ) map concat unique ; inline -: gen-set ( basic-block -- seq ) - instructions>> [ uses-vregs ] map-unique ; +: gen-set ( instructions -- seq ) + [ ##phi? not ] filter [ uses-vregs ] map-unique ; -: kill-set ( basic-block -- seq ) - instructions>> [ defs-vregs ] map-unique ; +: kill-set ( instructions -- seq ) + [ defs-vregs ] map-unique ; + +: compute-live-in ( basic-block -- live-in ) + dup instructions>> + [ [ live-out ] [ gen-set ] bi* assoc-union ] + [ nip kill-set ] + 2bi assoc-diff ; + +: compute-phi-live-in ( basic-block -- phi-live-in ) + instructions>> [ ##phi? ] filter + [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ; : update-live-in ( basic-block -- changed? ) - [ - [ [ gen-set ] [ live-out ] bi assoc-union ] - [ kill-set ] - bi assoc-diff - ] keep live-ins get maybe-set-at ; + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] + bi and ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ phi-live-in ] with map ] bi + append assoc-combine ; : update-live-out ( basic-block -- changed? ) - [ successors>> [ live-in ] map assoc-combine ] keep + [ compute-live-out ] keep live-outs get maybe-set-at ; : liveness-step ( basic-block -- ) @@ -50,6 +71,7 @@ SYMBOL: work-list : compute-liveness ( rpo -- ) work-list set H{ } clone live-ins set + H{ } clone phi-live-ins set H{ } clone live-outs set add-to-work-list work-list get [ liveness-step ] slurp-deque ; \ No newline at end of file From cef9ac778b749c21a341809003e46c117b8d4934 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 May 2009 18:19:01 -0500 Subject: [PATCH 189/228] compiler.cfg.alias-analysis: ##peek needs to set alias class of output value --- .../cfg/alias-analysis/alias-analysis.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 198ffb5549..0a3671034d 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -63,15 +63,14 @@ IN: compiler.cfg.alias-analysis ! Map vregs -> alias classes SYMBOL: vregs>acs -: check ( obj -- obj ) - [ "BUG: static type error detected" throw ] unless* ; inline - +ERROR: vreg-ac-not-set vreg ; + : vreg>ac ( vreg -- ac ) #! Only vregs produced by ##allot, ##peek and ##slot can #! ever be used as valid inputs to ##slot and ##set-slot, #! so we assert this fact by not giving alias classes to #! other vregs. - vregs>acs get at check ; + vregs>acs get ?at [ vreg-ac-not-set ] unless ; ! Map alias classes -> sequence of vregs SYMBOL: acs>vregs @@ -117,8 +116,10 @@ SYMBOL: histories #! value. over [ live-slots get at at ] [ 2drop f ] if ; +ERROR: vreg-has-no-slots vreg ; + : load-constant-slot ( value slot# vreg -- ) - live-slots get at check set-at ; + live-slots get ?at [ vreg-has-no-slots ] unless set-at ; : load-slot ( value slot#/f vreg -- ) over [ load-constant-slot ] [ 3drop ] if ; @@ -214,6 +215,9 @@ GENERIC: analyze-aliases* ( insn -- insn' ) M: ##load-immediate analyze-aliases* dup [ val>> ] [ dst>> ] bi constants get set-at ; +M: ##peek analyze-aliases* + dup dst>> set-heap-ac ; + M: ##load-reference analyze-aliases* dup dst>> set-heap-ac ; From 5460312ba7743e08c7ac98197fc3b2db7e7de565 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 May 2009 18:57:49 -0500 Subject: [PATCH 190/228] use ${ in some nurbs tests --- extra/nurbs/nurbs-tests.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor index db606f9c5c..191c2af7ca 100644 --- a/extra/nurbs/nurbs-tests.factor +++ b/extra/nurbs/nurbs-tests.factor @@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] ! unit circle as NURBS 3 { { 1.0 0.0 1.0 } - { $ √2/2 $ √2/2 $ √2/2 } + ${ √2/2 √2/2 √2/2 } { 0.0 1.0 1.0 } - { $ -√2/2 $ √2/2 $ √2/2 } + ${ -√2/2 √2/2 √2/2 } { -1.0 0.0 1.0 } - { $ -√2/2 $ -√2/2 $ √2/2 } + ${ -√2/2 -√2/2 √2/2 } { 0.0 -1.0 1.0 } - { $ √2/2 $ -√2/2 $ √2/2 } + ${ √2/2 -√2/2 √2/2 } { 1.0 0.0 1.0 } } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } test-nurbs set @@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] [ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test From 40949800bf678fd2a41b80ce162c6deab13a11ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 May 2009 01:39:14 -0500 Subject: [PATCH 191/228] Fixing various bugs; alias analysis wasn't handling ##phi nodes, stack analysis incorrectly handled height-changing back edges and ##fixnum-*, clean up ##dispatch generation --- .../cfg/alias-analysis/alias-analysis.factor | 10 +--- basis/compiler/cfg/builder/builder.factor | 57 +------------------ basis/compiler/cfg/checker/checker.factor | 2 +- .../cfg/instructions/instructions.factor | 7 +-- .../cfg/optimizer/optimizer-tests.factor | 21 ++++++- .../cfg/stack-analysis/stack-analysis.factor | 20 ++----- .../value-numbering-tests.factor | 2 +- basis/compiler/codegen/codegen.factor | 4 +- basis/cpu/architecture/architecture.factor | 3 +- basis/cpu/ppc/ppc.factor | 7 +-- basis/cpu/x86/32/32.factor | 4 +- basis/cpu/x86/64/64.factor | 4 +- basis/cpu/x86/x86.factor | 3 - 13 files changed, 41 insertions(+), 103 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 0a3671034d..7ea02c81e5 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -215,13 +215,7 @@ GENERIC: analyze-aliases* ( insn -- insn' ) M: ##load-immediate analyze-aliases* dup [ val>> ] [ dst>> ] bi constants get set-at ; -M: ##peek analyze-aliases* - dup dst>> set-heap-ac ; - -M: ##load-reference analyze-aliases* - dup dst>> set-heap-ac ; - -M: ##alien-global analyze-aliases* +M: ##flushable analyze-aliases* dup dst>> set-heap-ac ; M: ##allocation analyze-aliases* @@ -230,7 +224,7 @@ M: ##allocation analyze-aliases* dup dst>> set-new-ac ; M: ##read analyze-aliases* - dup dst>> set-heap-ac + call-next-method dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri 2dup live-slot dup [ 2nip f \ ##copy boa analyze-aliases* nip diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 1bf5bab067..38075c24a3 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -159,63 +159,8 @@ M: #if emit-node } cond iterate-next ; ! #dispatch -: trivial-dispatch-branch? ( nodes -- ? ) - dup length 1 = [ - first dup #call? [ - word>> "intrinsic" word-prop not - ] [ drop f ] if - ] [ drop f ] if ; - -: dispatch-branch ( nodes word -- label ) - over trivial-dispatch-branch? [ - drop first word>> - ] [ - gensym [ - [ - V{ } clone node-stack set - ##prologue - begin-basic-block - emit-nodes - basic-block get [ - ##epilogue - ##return - end-basic-block - ] when - ] with-cfg-builder - ] keep - ] if ; - -: dispatch-branches ( node -- ) - children>> [ - current-word get dispatch-branch - ##dispatch-label - ] each ; - -: emit-dispatch ( node -- ) - ##epilogue - ds-pop ^^offset>slot i 0 ##dispatch - dispatch-branches ; - -! If a dispatch is not in tail position, we compile a new word where the dispatch is in -! tail position, then call this word. - -: (non-tail-dispatch) ( -- word ) - gensym dup t "inlined-block" set-word-prop ; - -: ( node -- word ) - current-word get (non-tail-dispatch) [ - [ - begin-word - emit-dispatch - ] with-cfg-builder - ] keep ; - M: #dispatch emit-node - tail-call? [ - emit-dispatch stop-iterating - ] [ - f emit-call - ] if ; + ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ; ! #call M: #call emit-node diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index bc0eb74554..65191d5ac2 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -10,13 +10,13 @@ ERROR: last-insn-not-a-jump insn ; : check-last-instruction ( bb -- ) peek dup { [ ##branch? ] + [ ##dispatch? ] [ ##conditional-branch? ] [ ##compare-imm-branch? ] [ ##return? ] [ ##callback-return? ] [ ##jump? ] [ ##call? ] - [ ##dispatch-label? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; ERROR: bad-loop-entry ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 747233dbba..6da9f797bd 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -57,13 +57,12 @@ TUPLE: stack-frame spill-counts ; INSN: ##stack-frame stack-frame ; -INSN: ##call word height ; +INSN: ##call word { height integer } ; INSN: ##jump word ; INSN: ##return ; ! Jump tables -INSN: ##dispatch src temp offset ; -INSN: ##dispatch-label label ; +INSN: ##dispatch src temp ; ! Slot access INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ; @@ -165,7 +164,7 @@ UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ; INSN: ##write-barrier < ##effect card# table ; -INSN: ##alien-global < ##read symbol library ; +INSN: ##alien-global < ##flushable symbol library ; ! FFI INSN: ##alien-invoke params ; diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index b81d9f81f5..923fe828b5 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,14 +1,33 @@ USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use sets kernel kernel.private fry slots.private ; +compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors +sequences.private math sbufs math.private slots.private strings ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests +: more? ( x -- ? ) ; + +: test-case-1 ( -- ? ) f ; + +: test-case-2 ( -- ) + test-case-1 [ test-case-2 ] [ ] if ; inline recursive + { [ 1array ] [ 1 2 ? ] [ { array } declare [ ] map ] [ { array } declare dup 1 slot [ 1 slot ] when ] + [ [ dup more? ] [ dup ] produce ] + [ vector new over test-case-1 [ test-case-2 ] [ ] if ] + [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] + [ + { fixnum sbuf } declare 2dup 3 slot fixnum> [ + over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot + ] [ ] if + ] + [ [ 2 fixnum* ] when 3 ] + [ [ 2 fixnum+ ] when 3 ] + [ [ 2 fixnum- ] when 3 ] } [ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 0aa402ed66..ffff728ece 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -91,7 +91,8 @@ UNION: neutral-insn ##branch ##loop-entry ##conditional-branch - ##compare-imm-branch ; + ##compare-imm-branch + ##dispatch ; M: neutral-insn visit , ; @@ -130,22 +131,12 @@ M: ##copy visit [ call-next-method ] [ record-copy ] bi ; M: ##call visit - [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ; - -M: ##fixnum-mul visit - call-next-method -1 adjust-d ; - -M: ##fixnum-add visit - call-next-method -1 adjust-d ; - -M: ##fixnum-sub visit - call-next-method -1 adjust-d ; + [ call-next-method ] [ height>> adjust-d ] bi ; ! Instructions that poison the stack state UNION: poison-insn ##jump ##return - ##dispatch ##callback-return ##fixnum-mul-tail ##fixnum-add-tail @@ -179,8 +170,6 @@ M: ##alien-indirect visit M: ##alien-callback visit , ; -M: ##dispatch-label visit , ; - ! Maps basic-blocks to states SYMBOLS: state-in state-out ; @@ -245,7 +234,8 @@ ERROR: cannot-merge-poisoned states ; [ drop dup [ not ] any? [ - 2drop + [ ] 2dip + sift merge-heights ] [ dup [ poisoned?>> ] any? [ cannot-merge-poisoned diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index c12b5afd2e..5063273bf4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -50,7 +50,7 @@ sequences compiler.cfg vectors arrays ; [ t ] [ { T{ ##peek f V int-regs 1 D 0 } - T{ ##dispatch f V int-regs 1 V int-regs 2 0 } + T{ ##dispatch f V int-regs 1 V int-regs 2 } } dup test-value-numbering = ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index c7b67b72b4..11b4e153f6 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -92,10 +92,8 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; -M: ##dispatch-label generate-insn label>> %dispatch-label ; - M: ##dispatch generate-insn - [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ; + [ src>> register ] [ temp>> register ] bi %dispatch ; : >slot< ( insn -- dst obj slot tag ) { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index de5d1da4e0..98d0c5326b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -51,8 +51,7 @@ HOOK: %jump cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) -HOOK: %dispatch cpu ( src temp offset -- ) -HOOK: %dispatch-label cpu ( word -- ) +HOOK: %dispatch cpu ( src temp -- ) HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 617a7c5141..934b456075 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -124,16 +124,13 @@ M: ppc %jump ( word -- ) M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; -M:: ppc %dispatch ( src temp offset -- ) +M:: ppc %dispatch ( src temp -- ) 0 temp LOAD32 - 4 offset + cells rc-absolute-ppc-2/2 rel-here + 4 cells rc-absolute-ppc-2/2 rel-here temp temp src LWZX temp MTCTR BCTR ; -M: ppc %dispatch-label ( word -- ) - B{ 0 0 0 0 } % rc-absolute-cell rel-word ; - :: (%slot) ( obj slot tag temp -- reg offset ) temp slot obj ADD temp tag neg ; inline diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0a0ac4a53e..4492a3d762 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -26,10 +26,10 @@ M: x86.32 stack-reg ESP ; M: x86.32 temp-reg-1 ECX ; M: x86.32 temp-reg-2 EDX ; -M:: x86.32 %dispatch ( src temp offset -- ) +M:: x86.32 %dispatch ( src temp -- ) ! Load jump table base. src HEX: ffffffff ADD - offset cells rc-absolute-cell rel-here + 0 rc-absolute-cell rel-here ! Go src HEX: 7f [+] JMP ! Fix up the displacement above diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index b77539b7e7..0b9b4e8ddf 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ; M: x86.64 rs-reg R15 ; M: x86.64 stack-reg RSP ; -M:: x86.64 %dispatch ( src temp offset -- ) +M:: x86.64 %dispatch ( src temp -- ) ! Load jump table base. temp HEX: ffffffff MOV - offset cells rc-absolute-cell rel-here + 0 rc-absolute-cell rel-here ! Add jump table base src temp ADD src HEX: 7f [+] JMP diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index e12cec9738..8ab247f5e5 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -79,9 +79,6 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; -M: x86 %dispatch-label ( word -- ) - 0 cell, rc-absolute-cell rel-word ; - :: (%slot) ( obj slot tag temp -- op ) temp slot obj [+] LEA temp tag neg [+] ; inline From fbefd02bfb9242aafef1e99e34474caa464a1a8b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 May 2009 05:36:04 -0500 Subject: [PATCH 192/228] Put GC checks in the right place when linearizing, and generate _dispatch-labels --- basis/compiler/cfg/def-use/def-use.factor | 5 +- .../cfg/instructions/instructions.factor | 3 ++ .../cfg/linearization/linearization.factor | 52 ++++++++++++++----- 3 files changed, 45 insertions(+), 15 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 97047a7c3e..ba2a4dac3a 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -21,6 +21,7 @@ M: ##compare-imm defs-vregs dst/tmp-vregs ; M: ##compare-float defs-vregs dst/tmp-vregs ; M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; +M: _dispatch defs-vregs temp>> 1array ; M: insn defs-vregs drop f ; M: ##unary uses-vregs src>> 1array ; @@ -42,6 +43,7 @@ M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##phi uses-vregs inputs>> ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; +M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; ! Instructions that use vregs @@ -54,4 +56,5 @@ UNION: vreg-insn ##conditional-branch ##compare-imm-branch _conditional-branch -_compare-imm-branch ; +_compare-imm-branch +_dispatch ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 6da9f797bd..5682aa668d 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -231,6 +231,9 @@ INSN: _gc live-in ; INSN: _branch label ; +INSN: _dispatch src temp ; +INSN: _dispatch-label label ; + TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ; INSN: _compare-branch < _conditional-branch ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 64507779a4..0d851ea483 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -12,8 +12,38 @@ IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. GENERIC: linearize-insn ( basic-block insn -- ) -: linearize-insns ( basic-block -- ) - dup instructions>> [ linearize-insn ] with each ; inline +: linearize-insns ( bb insns -- ) + [ linearize-insn ] with each ; + +: gc? ( bb -- ? ) + instructions>> [ ##allocation? ] any? ; + +: object-pointer-regs ( basic-block -- vregs ) + live-out keys [ reg-class>> int-regs eq? ] filter ; + +: gc-check-position ( insns -- n ) + #! We want to insert the GC check before the final branch in a basic block. + #! If there is a ##epilogue or ##loop-entry we want to insert it before that too. + dup length + dup 2 >= [ + 2 - swap nth [ ##loop-entry? ] [ ##epilogue? ] bi or + 2 1 ? + ] [ 2drop 1 ] if ; + +: linearize-basic-block/gc ( bb -- ) + dup instructions>> dup gc-check-position + [ head* linearize-insns ] + [ 2drop object-pointer-regs _gc ] + [ tail* linearize-insns ] + 3tri ; + +: linearize-basic-block ( bb -- ) + [ number>> _label ] + [ + dup gc? + [ linearize-basic-block/gc ] + [ dup instructions>> linearize-insns ] if + ] bi ; M: insn linearize-insn , drop ; @@ -32,7 +62,7 @@ M: insn linearize-insn , drop ; : emit-branch ( basic-block successor -- ) { { [ 2dup useless-branch? ] [ 2drop ] } - { [ dup branch-to-branch? ] [ nip linearize-insns ] } + { [ dup branch-to-branch? ] [ nip linearize-basic-block ] } [ nip number>> _branch ] } cond ; @@ -57,17 +87,11 @@ M: ##compare-imm-branch linearize-insn M: ##compare-float-branch linearize-insn binary-conditional _compare-float-branch emit-branch ; -: gc? ( bb -- ? ) - instructions>> [ ##allocation? ] any? ; - -: object-pointer-regs ( basic-block -- vregs ) - live-in keys [ reg-class>> int-regs eq? ] filter ; - -: linearize-basic-block ( bb -- ) - [ number>> _label ] - [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ] - [ linearize-insns ] - tri ; +M: ##dispatch linearize-insn + swap + [ [ src>> ] [ temp>> ] bi _dispatch ] + [ successors>> [ number>> _dispatch-label ] each ] + bi* ; : linearize-basic-blocks ( rpo -- insns ) [ [ linearize-basic-block ] each ] { } make ; From 61e83c2fd54b5f30695a969db2a40e3dd98f0c27 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 May 2009 05:37:48 -0500 Subject: [PATCH 193/228] fuel.xref: remove some unnecessary inlines --- extra/fuel/xref/xref.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor index 3e3279ece7..608667bae7 100644 --- a/extra/fuel/xref/xref.factor +++ b/extra/fuel/xref/xref.factor @@ -23,13 +23,13 @@ IN: fuel.xref dup dup >vocab-link where normalize-loc 4array ; : sort-xrefs ( seq -- seq' ) - [ [ first ] dip first <=> ] sort ; inline + [ [ first ] dip first <=> ] sort ; : format-xrefs ( seq -- seq' ) - [ word? ] filter [ word>xref ] map ; inline + [ word? ] filter [ word>xref ] map ; : filter-prefix ( seq prefix -- seq ) - [ drop-prefix nip length 0 = ] curry filter prune ; inline + [ drop-prefix nip length 0 = ] curry filter prune ; MEMO: (vocab-words) ( name -- seq ) >vocab-link words [ name>> ] map ; @@ -37,10 +37,10 @@ MEMO: (vocab-words) ( name -- seq ) : current-words ( -- seq ) manifest get [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@ - assoc-union keys ; inline + assoc-union keys ; : vocabs-words ( names -- seq ) - prune [ (vocab-words) ] map concat ; inline + prune [ (vocab-words) ] map concat ; PRIVATE> From 5a5afcbfaacfefb423bde49d35044f58cb92ddc1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 May 2009 05:45:40 -0500 Subject: [PATCH 194/228] On second thought, linearization will be done after SSA destruction so live-in is accurate --- .../cfg/linearization/linearization.factor | 28 ++++--------------- 1 file changed, 5 insertions(+), 23 deletions(-) diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 0d851ea483..9b328a43c0 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -13,37 +13,19 @@ IN: compiler.cfg.linearization GENERIC: linearize-insn ( basic-block insn -- ) : linearize-insns ( bb insns -- ) - [ linearize-insn ] with each ; + dup instructions>> [ linearize-insn ] with each ; : gc? ( bb -- ? ) instructions>> [ ##allocation? ] any? ; : object-pointer-regs ( basic-block -- vregs ) - live-out keys [ reg-class>> int-regs eq? ] filter ; - -: gc-check-position ( insns -- n ) - #! We want to insert the GC check before the final branch in a basic block. - #! If there is a ##epilogue or ##loop-entry we want to insert it before that too. - dup length - dup 2 >= [ - 2 - swap nth [ ##loop-entry? ] [ ##epilogue? ] bi or - 2 1 ? - ] [ 2drop 1 ] if ; - -: linearize-basic-block/gc ( bb -- ) - dup instructions>> dup gc-check-position - [ head* linearize-insns ] - [ 2drop object-pointer-regs _gc ] - [ tail* linearize-insns ] - 3tri ; + live-in keys [ reg-class>> int-regs eq? ] filter ; : linearize-basic-block ( bb -- ) [ number>> _label ] - [ - dup gc? - [ linearize-basic-block/gc ] - [ dup instructions>> linearize-insns ] if - ] bi ; + [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ] + [ linearize-insns ] + tri ; M: insn linearize-insn , drop ; From 58c9986f8755d366fb9da0e831032e556ce6f92b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 May 2009 11:20:40 -0500 Subject: [PATCH 195/228] add managed-server to extra/ --- extra/managed-server/authors.txt | 1 + extra/managed-server/chat/authors.txt | 1 + extra/managed-server/chat/chat.factor | 23 ++++++++ extra/managed-server/managed-server.factor | 63 ++++++++++++++++++++++ 4 files changed, 88 insertions(+) create mode 100644 extra/managed-server/authors.txt create mode 100644 extra/managed-server/chat/authors.txt create mode 100644 extra/managed-server/chat/chat.factor create mode 100644 extra/managed-server/managed-server.factor diff --git a/extra/managed-server/authors.txt b/extra/managed-server/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/authors.txt b/extra/managed-server/chat/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/chat/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor new file mode 100644 index 0000000000..7cd4db58f7 --- /dev/null +++ b/extra/managed-server/chat/chat.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry io kernel managed-server +namespaces sequences ; +IN: managed-server.chat + +TUPLE: chat-server < managed-server ; + +: ( port -- managed-server ) + "chat-server" chat-server new-managed-server ; + +M: chat-server handle-managed-client* + clients>> + readln dup empty? [ + 2drop + ] [ + '[ + nip output-stream>> + [ + client get username>> ": " _ 3append print flush + ] with-output-stream* + ] assoc-each + ] if ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor new file mode 100644 index 0000000000..2a9df2ae8a --- /dev/null +++ b/extra/managed-server/managed-server.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar continuations io +io.encodings.binary io.servers.connection io.sockets +io.streams.duplex kernel locals math math.ranges multiline +namespaces prettyprint random sequences sets splitting threads +tools.continuations ; +IN: managed-server + +SYMBOL: client + +TUPLE: managed-server < threaded-server clients ; + +TUPLE: managed-client input-stream output-stream local-address +remote-address username ; + +GENERIC: login ( managed-server -- username ) +GENERIC: handle-managed-client* ( threaded-server -- ) + +ERROR: already-logged-in username ; +ERROR: bad-login username ; + + ( username -- managed-client ) + managed-client new + swap >>username + input-stream get >>input-stream + output-stream get >>output-stream + local-address get >>local-address + remote-address get >>remote-address ; + +: check-logged-in ( username -- username ) + dup threaded-server get clients>> key? [ already-logged-in ] when ; + +: add-managed-client ( managed-client -- ) + dup username>> + threaded-server get clients>> set-at ; + +: delete-managed-client ( -- ) + client get username>> + threaded-server get clients>> delete-at ; + +: handle-managed-client ( -- ) + [ [ threaded-server get handle-managed-client* t ] loop ] + [ delete-managed-client ] + [ ] cleanup ; + +PRIVATE> + +M: managed-server login drop readln ; + +M: managed-server handle-client* + login + [ client set ] [ add-managed-client ] bi + handle-managed-client ; + +: new-managed-server ( port name class -- server ) + new-threaded-server + swap >>name + swap >>insecure + f >>timeout + H{ } clone >>clients ; inline From 968a9bb666b0e7cbc2ec1c3bb1ab7862515f9b82 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 May 2009 13:11:34 -0500 Subject: [PATCH 196/228] Various codegen improvements: - new-insn word to construct instructions - cache RPO in the CFG - re-organize low-level optimizer so that MR is built after register allocation - register allocation now stores instruction numbers in the instructions themselves - split defs-vregs into defs-vregs and temp-vregs --- .../cfg/alias-analysis/alias-analysis.factor | 4 +- basis/compiler/cfg/cfg.factor | 6 +-- basis/compiler/cfg/checker/checker.factor | 14 +++--- basis/compiler/cfg/dce/dce.factor | 12 +++-- basis/compiler/cfg/debugger/debugger.factor | 6 +-- basis/compiler/cfg/def-use/def-use.factor | 40 ++++++++++------ basis/compiler/cfg/height/height.factor | 8 ++-- .../cfg/instructions/instructions.factor | 4 +- .../cfg/instructions/syntax/syntax.factor | 6 +-- .../linear-scan/assignment/assignment.factor | 34 ++++++++------ .../cfg/linear-scan/linear-scan-tests.factor | 31 +++++++++---- .../cfg/linear-scan/linear-scan.factor | 17 ++++--- .../live-intervals/live-intervals.factor | 18 ++++---- .../cfg/linear-scan/numbering/authors.txt | 1 + .../linear-scan/numbering/numbering.factor | 11 +++++ .../cfg/linearization/linearization.factor | 24 ++++++---- basis/compiler/cfg/liveness/liveness.factor | 14 ++++-- basis/compiler/cfg/optimizer/optimizer.factor | 30 +++++------- .../phi-elimination/phi-elimination.factor | 8 ++-- .../cfg/predecessors/predecessors.factor | 4 +- basis/compiler/cfg/rpo/rpo.factor | 24 +++++----- .../stack-analysis-tests.factor | 46 ++++++++++--------- .../cfg/stack-analysis/stack-analysis.factor | 4 +- .../cfg/two-operand/two-operand.factor | 46 ++++++++++--------- .../useless-blocks-tests.factor | 2 +- .../cfg/useless-blocks/useless-blocks.factor | 16 ++++--- .../value-numbering/rewrite/rewrite.factor | 18 ++++---- .../value-numbering/value-numbering.factor | 4 +- .../cfg/write-barrier/write-barrier.factor | 4 +- basis/compiler/compiler.factor | 6 +-- 30 files changed, 258 insertions(+), 204 deletions(-) create mode 100644 basis/compiler/cfg/linear-scan/numbering/authors.txt create mode 100644 basis/compiler/cfg/linear-scan/numbering/numbering.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 7ea02c81e5..384fd65c1a 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -227,7 +227,7 @@ M: ##read analyze-aliases* call-next-method dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri 2dup live-slot dup [ - 2nip f \ ##copy boa analyze-aliases* nip + 2nip \ ##copy new-insn analyze-aliases* nip ] [ drop remember-slot ] if ; @@ -284,5 +284,5 @@ M: insn eliminate-dead-stores* ; compute-live-stores eliminate-dead-stores ; -: alias-analysis ( rpo -- ) +: alias-analysis ( cfg -- cfg' ) [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ; \ No newline at end of file diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 265cbb8f00..c3ae15f069 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -27,11 +27,11 @@ M: basic-block hashcode* nip id>> ; building get push ] with-variable ; inline -TUPLE: cfg { entry basic-block } word label ; +TUPLE: cfg { entry basic-block } word label spill-counts post-order ; -C: cfg +: ( entry word label -- cfg ) f f cfg boa ; -TUPLE: mr { instructions array } word label spill-counts ; +TUPLE: mr { instructions array } word label ; : ( instructions word label -- mr ) mr new diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 65191d5ac2..bf5adc2d55 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -41,20 +41,18 @@ ERROR: bad-successors ; ERROR: bad-live-in ; -: check-rpo ( rpo -- ) - [ compute-liveness ] - [ first live-in assoc-empty? [ bad-live-in ] unless ] - [ [ check-basic-block ] each ] - tri ; - ERROR: undefined-values uses defs ; : check-mr ( mr -- ) ! Check that every used register has a definition instructions>> [ [ uses-vregs ] map concat ] - [ [ defs-vregs ] map concat ] bi + [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi 2dup subset? [ 2drop ] [ undefined-values ] if ; : check-cfg ( cfg -- ) - [ reverse-post-order check-rpo ] [ build-mr check-mr ] bi ; + compute-liveness + [ entry>> live-in assoc-empty? [ bad-live-in ] unless ] + [ [ check-basic-block ] each-basic-block ] + [ build-mr check-mr ] + tri ; diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index 5db760e861..68c89be455 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sets kernel namespaces sequences -compiler.cfg.instructions compiler.cfg.def-use ; +compiler.cfg.instructions compiler.cfg.def-use +compiler.cfg.rpo ; IN: compiler.cfg.dce ! Maps vregs to sequences of vregs @@ -36,8 +37,9 @@ M: ##flushable live-insn? dst>> live-vregs get key? ; M: insn live-insn? drop t ; -: eliminate-dead-code ( rpo -- ) +: eliminate-dead-code ( cfg -- cfg' ) init-dead-code - [ [ instructions>> [ update-liveness-graph ] each ] each ] - [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ] - bi ; \ No newline at end of file + [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ] + [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ] + [ ] + tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6b0aba6813..5c106bfaee 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -23,10 +23,10 @@ SYMBOL: allocate-registers? : test-mr ( quot -- mrs ) test-cfg [ optimize-cfg - build-mr convert-two-operand - allocate-registers? get - [ linear-scan build-stack-frame ] when + allocate-registers? get [ linear-scan ] when + build-mr + allocate-registers? get [ build-stack-frame ] when ] map ; : insn. ( insn -- ) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index ba2a4dac3a..17e49f59a8 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,29 +1,39 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel compiler.cfg.instructions ; IN: compiler.cfg.def-use GENERIC: defs-vregs ( insn -- seq ) +GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ; M: ##flushable defs-vregs dst>> 1array ; -M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; -M: ##unary/temp defs-vregs dst/tmp-vregs ; -M: ##allot defs-vregs dst/tmp-vregs ; -M: ##dispatch defs-vregs temp>> 1array ; -M: ##slot defs-vregs dst/tmp-vregs ; +M: ##unary/temp defs-vregs dst>> 1array ; +M: ##allot defs-vregs dst>> 1array ; +M: ##slot defs-vregs dst>> 1array ; M: ##set-slot defs-vregs temp>> 1array ; -M: ##string-nth defs-vregs dst/tmp-vregs ; -M: ##set-string-nth-fast defs-vregs temp>> 1array ; -M: ##compare defs-vregs dst/tmp-vregs ; -M: ##compare-imm defs-vregs dst/tmp-vregs ; -M: ##compare-float defs-vregs dst/tmp-vregs ; -M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: _dispatch defs-vregs temp>> 1array ; +M: ##string-nth defs-vregs dst>> 1array ; +M: ##compare defs-vregs dst>> 1array ; +M: ##compare-imm defs-vregs dst>> 1array ; +M: ##compare-float defs-vregs dst>> 1array ; M: insn defs-vregs drop f ; +M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; +M: ##unary/temp temp-vregs temp>> 1array ; +M: ##allot temp-vregs temp>> 1array ; +M: ##dispatch temp-vregs temp>> 1array ; +M: ##slot temp-vregs temp>> 1array ; +M: ##set-slot temp-vregs temp>> 1array ; +M: ##string-nth temp-vregs temp>> 1array ; +M: ##set-string-nth-fast temp-vregs temp>> 1array ; +M: ##compare temp-vregs temp>> 1array ; +M: ##compare-imm temp-vregs temp>> 1array ; +M: ##compare-float temp-vregs temp>> 1array ; +M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; +M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; +M: _dispatch temp-vregs temp>> 1array ; +M: insn temp-vregs drop f ; + M: ##unary uses-vregs src>> 1array ; M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##binary-imm uses-vregs src1>> 1array ; diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index eed0aeb0b5..b91120ccfd 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors math namespaces sequences kernel fry compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.rpo ; +compiler.cfg.liveness ; IN: compiler.cfg.height ! Combine multiple stack height changes into one at the @@ -48,8 +48,8 @@ M: insn normalize-height* ; 0 rs-height set [ [ compute-heights ] each ] [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup 0 = [ drop ] [ f \ ##inc-d boa prefix ] if - rs-height get dup 0 = [ drop ] [ f \ ##inc-r boa prefix ] if ; + ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if + rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ; -: normalize-height ( rpo -- ) +: normalize-height ( cfg -- cfg' ) [ drop ] [ height-step ] local-optimization ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 5682aa668d..d2d444a4a5 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs accessors arrays kernel sequences namespaces words math math.order layouts classes.algebra alien byte-arrays @@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers compiler.cfg.instructions.syntax ; IN: compiler.cfg.instructions +: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline + ! Virtual CPU instructions, used by CFG and machine IRs TUPLE: insn ; diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 876ac5596c..e8f8641e7d 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax "insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect in>> but-last f ; + boa-effect in>> 2 head* f ; SYNTAX: INSN: - parse-tuple-definition "regs" suffix + parse-tuple-definition { "regs" "insn#" } append [ dup tuple eq? [ drop insn-word ] when ] dip [ define-tuple-class ] [ 2drop save-location ] - [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] + [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ] 3tri ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index da45b45aaa..f21b9e5db8 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -59,29 +59,35 @@ SYMBOL: unhandled-intervals ] [ 2drop ] if ] if ; -GENERIC: (assign-registers) ( insn -- ) +GENERIC: assign-registers-in-insn ( insn -- ) -M: vreg-insn (assign-registers) - dup - [ defs-vregs ] [ uses-vregs ] bi append - active-intervals get swap '[ vreg>> _ member? ] filter +: all-vregs ( insn -- vregs ) + [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; + +M: vreg-insn assign-registers-in-insn + active-intervals get over all-vregs '[ vreg>> _ member? ] filter [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc >>regs drop ; -M: insn (assign-registers) drop ; +M: insn assign-registers-in-insn drop ; : init-assignment ( live-intervals -- ) V{ } clone active-intervals set unhandled-intervals set init-unhandled ; -: assign-registers ( insns live-intervals -- insns' ) +: assign-registers-in-block ( bb -- ) [ - init-assignment [ - [ activate-new-intervals ] - [ drop [ (assign-registers) ] [ , ] bi ] - [ expire-old-intervals ] - tri - ] each-index - ] { } make ; + [ + [ insn#>> activate-new-intervals ] + [ [ assign-registers-in-insn ] [ , ] bi ] + [ insn#>> expire-old-intervals ] + tri + ] each + ] V{ } make + ] change-instructions drop ; + +: assign-registers ( rpo live-intervals -- ) + init-assignment + [ assign-registers-in-block ] each ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 4ddd1fdc0b..bfbc824846 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs kernel fry arrays splitting namespaces math accessors vectors math.order grouping cpu.architecture +compiler.cfg +compiler.cfg.optimizer compiler.cfg.instructions compiler.cfg.registers compiler.cfg.linear-scan @@ -264,18 +266,27 @@ SYMBOL: max-uses USING: math.private compiler.cfg.debugger ; -[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test +[ ] [ + [ float+ float>fixnum 3 fixnum*fast ] + test-cfg first optimize-cfg linear-scan drop +] unit-test [ f ] [ - T{ ##allot - f - T{ vreg f int-regs 1 } - 40 - array - T{ vreg f int-regs 2 } - f - } clone - 1array (linear-scan) first regs>> values all-equal? + T{ basic-block + { instructions + V{ + T{ ##allot + f + T{ vreg f int-regs 1 } + 40 + array + T{ vreg f int-regs 2 } + f + } + } + } + } clone [ [ clone ] map ] change-instructions + dup 1array (linear-scan) instructions>> first regs>> values all-equal? ] unit-test [ 0 1 ] [ diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 855f2a6648..1e6b9d02c8 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -1,9 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces make cpu.architecture compiler.cfg +compiler.cfg.rpo compiler.cfg.instructions +compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.assignment ; @@ -23,16 +25,13 @@ IN: compiler.cfg.linear-scan ! by Omri Traub, Glenn Holloway, Michael D. Smith ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435 -: (linear-scan) ( insns -- insns' ) +: (linear-scan) ( rpo -- ) + dup number-instructions dup compute-live-intervals machine-registers allocate-registers assign-registers ; -: linear-scan ( mr -- mr' ) +: linear-scan ( cfg -- cfg' ) [ - [ - [ - (linear-scan) % - spill-counts get _spill-counts - ] { } make - ] change-instructions + dup reverse-post-order (linear-scan) + spill-counts get >>spill-counts ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 1055a3524a..55bcdc7470 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math fry compiler.cfg.instructions compiler.cfg.registers @@ -38,27 +38,29 @@ SYMBOL: live-intervals [ [ ] keep ] dip set-at ] if ; -GENERIC# compute-live-intervals* 1 ( insn n -- ) +GENERIC: compute-live-intervals* ( insn -- ) -M: insn compute-live-intervals* 2drop ; +M: insn compute-live-intervals* drop ; M: vreg-insn compute-live-intervals* + dup insn#>> live-intervals get [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ] [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] - 3bi ; + [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ] + 3tri ; : record-copy ( insn -- ) [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ; M: ##copy compute-live-intervals* - [ call-next-method ] [ drop record-copy ] 2bi ; + [ call-next-method ] [ record-copy ] bi ; M: ##copy-float compute-live-intervals* - [ call-next-method ] [ drop record-copy ] 2bi ; + [ call-next-method ] [ record-copy ] bi ; -: compute-live-intervals ( instructions -- live-intervals ) +: compute-live-intervals ( rpo -- live-intervals ) H{ } clone [ live-intervals set - [ compute-live-intervals* ] each-index + [ instructions>> [ compute-live-intervals* ] each ] each ] keep values ; diff --git a/basis/compiler/cfg/linear-scan/numbering/authors.txt b/basis/compiler/cfg/linear-scan/numbering/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/linear-scan/numbering/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor new file mode 100644 index 0000000000..6734f6a359 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors math sequences ; +IN: compiler.cfg.linear-scan.numbering + +: number-instructions ( rpo -- ) + [ 0 ] dip [ + instructions>> [ + [ (>>insn#) ] [ drop 2 + ] 2bi + ] each + ] each drop ; \ No newline at end of file diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9b328a43c0..5ad8be2953 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -60,25 +60,31 @@ M: ##branch linearize-insn [ drop dup successors>> second useless-branch? ] 2bi [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; +: with-regs ( insn quot -- ) + over regs>> [ call ] dip building get peek (>>regs) ; inline + M: ##compare-branch linearize-insn - binary-conditional _compare-branch emit-branch ; + [ binary-conditional _compare-branch ] with-regs emit-branch ; M: ##compare-imm-branch linearize-insn - binary-conditional _compare-imm-branch emit-branch ; + [ binary-conditional _compare-imm-branch ] with-regs emit-branch ; M: ##compare-float-branch linearize-insn - binary-conditional _compare-float-branch emit-branch ; + [ binary-conditional _compare-float-branch ] with-regs emit-branch ; M: ##dispatch linearize-insn swap - [ [ src>> ] [ temp>> ] bi _dispatch ] + [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ] [ successors>> [ number>> _dispatch-label ] each ] bi* ; -: linearize-basic-blocks ( rpo -- insns ) - [ [ linearize-basic-block ] each ] { } make ; +: linearize-basic-blocks ( cfg -- insns ) + [ + [ [ linearize-basic-block ] each-basic-block ] + [ spill-counts>> _spill-counts ] + bi + ] { } make ; : build-mr ( cfg -- mr ) - [ reverse-post-order linearize-basic-blocks ] - [ word>> ] [ label>> ] - tri ; + [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri + ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index e069caa03d..72609cf4d9 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces deques accessors sets sequences assocs fry -dlists compiler.cfg.def-use compiler.cfg.instructions ; +dlists compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.rpo ; IN: compiler.cfg.liveness ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis @@ -36,7 +37,7 @@ SYMBOL: work-list [ ##phi? not ] filter [ uses-vregs ] map-unique ; : kill-set ( instructions -- seq ) - [ defs-vregs ] map-unique ; + [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ; : compute-live-in ( basic-block -- live-in ) dup instructions>> @@ -68,10 +69,13 @@ SYMBOL: work-list [ predecessors>> add-to-work-list ] [ drop ] if ] [ drop ] if ; -: compute-liveness ( rpo -- ) +: compute-liveness ( cfg -- cfg' ) work-list set H{ } clone live-ins set H{ } clone phi-live-ins set H{ } clone live-outs set - add-to-work-list - work-list get [ liveness-step ] slurp-deque ; \ No newline at end of file + dup post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; + +: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) + [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index f59e9e0b83..8ceafd1693 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -14,23 +14,17 @@ compiler.cfg.rpo compiler.cfg.phi-elimination ; IN: compiler.cfg.optimizer -: optimize-cfg ( cfg -- cfg ) +: optimize-cfg ( cfg -- cfg' ) [ - [ - [ compute-predecessors ] - [ delete-useless-blocks ] - [ delete-useless-conditionals ] tri - ] [ - reverse-post-order - { - [ normalize-height ] - [ stack-analysis ] - [ compute-liveness ] - [ alias-analysis ] - [ value-numbering ] - [ eliminate-dead-code ] - [ eliminate-write-barriers ] - [ eliminate-phis ] - } cleave - ] [ ] tri + compute-predecessors + delete-useless-blocks + delete-useless-conditionals + normalize-height + stack-analysis + compute-liveness + alias-analysis + value-numbering + eliminate-dead-code + eliminate-write-barriers + eliminate-phis ] with-scope ; diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor index d94e57f378..3ebf553a45 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors compiler.cfg compiler.cfg.instructions fry -kernel sequences ; +USING: accessors compiler.cfg compiler.cfg.instructions +compiler.cfg.rpo fry kernel sequences ; IN: compiler.cfg.phi-elimination : insert-copy ( predecessor input output -- ) @@ -17,5 +17,5 @@ IN: compiler.cfg.phi-elimination [ [ eliminate-phi ] with each ] dip ] change-instructions drop ; -: eliminate-phis ( rpo -- ) - [ eliminate-phi-step ] each ; \ No newline at end of file +: eliminate-phis ( cfg -- cfg' ) + dup [ eliminate-phi-step ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 9bc3a08f63..5be085ba5a 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -6,5 +6,5 @@ IN: compiler.cfg.predecessors : predecessors-step ( bb -- ) dup successors>> [ predecessors>> push ] with each ; -: compute-predecessors ( cfg -- ) - [ predecessors-step ] each-basic-block ; +: compute-predecessors ( cfg -- cfg' ) + dup [ predecessors-step ] each-basic-block ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index babea55643..d01f5ee864 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -16,22 +16,24 @@ SYMBOL: visited ] [ , ] bi ] if ; -: post-order ( cfg -- blocks ) - [ entry>> post-order-traversal ] { } make ; - : number-blocks ( blocks -- ) - [ >>number drop ] each-index ; + dup length iota + [ >>number drop ] 2each ; + +: post-order ( cfg -- blocks ) + dup post-order>> [ ] [ + [ + H{ } clone visited set + dup entry>> post-order-traversal + ] { } make dup number-blocks + >>post-order post-order>> + ] ?if ; : reverse-post-order ( cfg -- blocks ) - H{ } clone visited [ - post-order dup number-blocks - ] with-variable ; inline + post-order ; inline : each-basic-block ( cfg quot -- ) [ reverse-post-order ] dip each ; inline : optimize-basic-block ( bb init-quot insn-quot -- ) - [ '[ live-in keys _ call ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline - -: local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- ) - '[ _ _ optimize-basic-block ] each ; \ No newline at end of file + [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index e846ebc28f..bd0e539173 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -8,7 +8,7 @@ sets ; IN: compiler.cfg.stack-analysis.tests ! Fundamental invariant: a basic block should not load or store a value more than once -: check-for-redundant-ops ( rpo -- ) +: check-for-redundant-ops ( cfg -- ) [ instructions>> [ @@ -18,34 +18,36 @@ IN: compiler.cfg.stack-analysis.tests [ ##replace? ] filter [ loc>> ] map duplicates empty? [ "Redundant replaces" throw ] unless ] bi - ] each ; + ] each-basic-block ; -: test-stack-analysis ( quot -- mr ) +: test-stack-analysis ( quot -- cfg ) dup cfg? [ test-cfg first ] unless - dup compute-predecessors - dup delete-useless-blocks - dup delete-useless-conditionals - reverse-post-order - dup normalize-height - dup stack-analysis - dup check-rpo + compute-predecessors + delete-useless-blocks + delete-useless-conditionals + normalize-height + stack-analysis + dup check-cfg dup check-for-redundant-ops ; +: linearize ( cfg -- mr ) + build-mr instructions>> ; + [ ] [ [ ] test-stack-analysis drop ] unit-test ! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##peek? ] count ] unit-test +[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test ! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test +[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test ! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test +[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test +[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test ! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test +[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test ! Do we support the full language? [ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test @@ -63,10 +65,10 @@ IN: compiler.cfg.stack-analysis.tests [ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test ! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test +[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test ! Don't insert inc-d/inc-r; that's wrong! -[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test +[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test ! Bug in height tracking [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test @@ -81,13 +83,13 @@ IN: compiler.cfg.stack-analysis.tests ! Make sure the replace stores a value with the right height [ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks + [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi ] unit-test ! translate-loc was the wrong way round [ ] [ - [ 1 2 rot ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks + [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize [ [ ##load-immediate? ] count 2 assert= ] [ [ ##peek? ] count 1 assert= ] [ [ ##replace? ] count 3 assert= ] @@ -95,7 +97,7 @@ IN: compiler.cfg.stack-analysis.tests ] unit-test [ ] [ - [ 1 2 ? ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks + [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize [ [ ##load-immediate? ] count 2 assert= ] [ [ ##peek? ] count 1 assert= ] [ [ ##replace? ] count 1 assert= ] @@ -105,6 +107,6 @@ IN: compiler.cfg.stack-analysis.tests ! Sync before a back-edge, not after ! ##peeks should be inserted before a ##loop-entry [ 1 ] [ - [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks + [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize [ ##add-imm? ] count ] unit-test diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index ffff728ece..955630a76d 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -278,10 +278,10 @@ ERROR: cannot-merge-poisoned states ; ] 2bi ] V{ } make >>instructions drop ; -: stack-analysis ( rpo -- ) +: stack-analysis ( cfg -- cfg' ) [ H{ } clone copies set H{ } clone state-in set H{ } clone state-out set - [ visit-block ] each + dup [ visit-block ] each-basic-block ] with-scope ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index dabecaeec4..d5fb1e56cf 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel sequences compiler.utilities -compiler.cfg.instructions cpu.architecture ; +USING: accessors arrays kernel sequences make compiler.cfg.instructions +compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand ! On x86, instructions take the form x = x op y @@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand ! has a LEA instruction which is effectively a three-operand ! addition -: make-copy ( dst src -- insn ) f \ ##copy boa ; inline +: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline -: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline +: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline : convert-two-operand/integer ( insn -- insns ) - [ [ dst>> ] [ src1>> ] bi make-copy ] - [ dup dst>> >>src1 ] - bi 2array ; inline + [ [ dst>> ] [ src1>> ] bi ##copy ] + [ dup dst>> >>src1 , ] + bi ; inline : convert-two-operand/float ( insn -- insns ) - [ [ dst>> ] [ src1>> ] bi make-copy/float ] - [ dup dst>> >>src1 ] - bi 2array ; inline + [ [ dst>> ] [ src1>> ] bi ##copy-float ] + [ dup dst>> >>src1 , ] + bi ; inline -GENERIC: convert-two-operand* ( insn -- insns ) +GENERIC: convert-two-operand* ( insn -- ) M: ##not convert-two-operand* - [ [ dst>> ] [ src>> ] bi make-copy ] - [ dup dst>> >>src ] - bi 2array ; + [ [ dst>> ] [ src>> ] bi ##copy ] + [ dup dst>> >>src , ] + bi ; M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##mul convert-two-operand* convert-two-operand/integer ; @@ -50,11 +50,13 @@ M: ##sub-float convert-two-operand* convert-two-operand/float ; M: ##mul-float convert-two-operand* convert-two-operand/float ; M: ##div-float convert-two-operand* convert-two-operand/float ; -M: insn convert-two-operand* ; +M: insn convert-two-operand* , ; -: convert-two-operand ( mr -- mr' ) - [ - two-operand? [ - [ convert-two-operand* ] map-flat - ] when - ] change-instructions ; +: convert-two-operand ( cfg -- cfg' ) + two-operand? [ + dup [ + [ + [ [ convert-two-operand* ] each ] V{ } make + ] change-instructions drop + ] each-basic-block + ] when ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor index ebc333b537..1d14cef193 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor @@ -7,5 +7,5 @@ compiler.cfg.debugger compiler.cfg.predecessors tools.test ; [ [ drop 1 ] unless ] } [ [ [ ] ] dip - '[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test + '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test ] each \ No newline at end of file diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index b6ec1a72ce..91c337e43a 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -35,10 +35,11 @@ IN: compiler.cfg.useless-blocks [ instructions>> first ##branch? ] } 1&& ; -: delete-useless-blocks ( cfg -- ) - [ +: delete-useless-blocks ( cfg -- cfg' ) + dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if - ] each-basic-block ; + ] each-basic-block + f >>post-order ; : delete-conditional? ( bb -- ? ) dup instructions>> [ drop f ] [ @@ -51,10 +52,11 @@ IN: compiler.cfg.useless-blocks : delete-conditional ( bb -- ) dup successors>> first 1vector >>successors - [ but-last f \ ##branch boa suffix ] change-instructions + [ but-last \ ##branch new-insn suffix ] change-instructions drop ; -: delete-useless-conditionals ( cfg -- ) - [ +: delete-useless-conditionals ( cfg -- cfg' ) + dup [ dup delete-conditional? [ delete-conditional ] [ drop ] if - ] each-basic-block ; + ] each-basic-block + f >>post-order ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 990543ed7a..c53a001d28 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' ) M: ##mul-imm rewrite dup src2>> dup power-of-2? [ - [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa + [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn dup number-values ] [ drop ] if ; @@ -36,9 +36,9 @@ M: ##mul-imm rewrite : rewrite-boolean-comparison ( expr -- insn ) src1>> vreg>expr dup op>> { - { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] } - { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] } - { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] } + { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] } + { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] } + { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] } } case ; : tag-fixnum-expr? ( expr -- ? ) @@ -60,11 +60,11 @@ M: ##mul-imm rewrite GENERIC: rewrite-tagged-comparison ( insn -- insn' ) M: ##compare-imm-branch rewrite-tagged-comparison - (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ; + (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ; M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi - i f \ ##compare-imm boa ; + i \ ##compare-imm new-insn ; M: ##compare-imm-branch rewrite dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when @@ -96,9 +96,9 @@ M: ##compare rewrite : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri { - { \ ##compare [ >compare-expr< i f \ ##compare boa ] } - { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] } - { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] } + { \ ##compare [ >compare-expr< i \ ##compare new-insn ] } + { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] } + { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] } } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index c771d3b388..cc62c0f0c1 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs biassocs classes kernel math accessors sorting sets sequences -compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.propagate @@ -21,5 +21,5 @@ IN: compiler.cfg.value-numbering : value-numbering-step ( insns -- insns' ) [ [ number-values ] [ rewrite propagate ] bi ] map ; -: value-numbering ( rpo -- ) +: value-numbering ( cfg -- cfg' ) [ init-value-numbering ] [ value-numbering-step ] local-optimization ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index e4767599a7..52d5170138 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences locals compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.rpo ; +compiler.cfg.liveness ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -42,5 +42,5 @@ M: insn eliminate-write-barrier ; H{ } clone copies set [ eliminate-write-barrier ] map sift ; -: eliminate-write-barriers ( rpo -- ) +: eliminate-write-barriers ( cfg -- cfg' ) [ drop ] [ write-barriers-step ] local-optimization ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index c3d70fdc5b..ae58c3bd3e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -8,8 +8,8 @@ stack-checker.inlining stack-checker.errors combinators.short-circuit compiler.errors compiler.units compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen -compiler.utilities ; +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.cfg.rpo +compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -146,9 +146,9 @@ t compile-dependencies? set-global : backend ( nodes word -- ) build-cfg [ optimize-cfg - build-mr convert-two-operand linear-scan + build-mr build-stack-frame generate save-asm From 12e301cdeabcd74b8192a7678e887731f1960309 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 May 2009 13:39:24 -0500 Subject: [PATCH 197/228] refactor managed-server and chat, add hooks for when stuff happens, add /me, /who, /quit --- extra/managed-server/chat/chat.factor | 64 ++++++++++++++++----- extra/managed-server/managed-server.factor | 66 +++++++++++++++------- 2 files changed, 96 insertions(+), 34 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 7cd4db58f7..1ec22516bd 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -1,23 +1,61 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry io kernel managed-server -namespaces sequences ; +USING: accessors assocs combinators combinators.smart +destructors fry io kernel managed-server namespaces +sequences splitting unicode.case ; IN: managed-server.chat +CONSTANT: line-beginning "-!- " + TUPLE: chat-server < managed-server ; : ( port -- managed-server ) "chat-server" chat-server new-managed-server ; +: unknown-command ( string -- ) + "Unknown command: " prepend print-client ; + +: handle-who ( string -- ) + drop + clients keys ", " join print flush ; + +: handle-me ( string -- ) + [ + [ "* " username " " ] dip + ] "" append-outputs-as send-everyone ; + +: handle-quit ( string -- ) + client [ (>>object) ] [ output-stream>> dispose ] bi ; + +: handle-command ( string -- ) + " " split1 swap >lower { + { "who" [ handle-who ] } + { "me" [ handle-me ] } + { "quit" [ handle-quit ] } + [ " " glue unknown-command ] + } case ; + +: handle-chat ( string -- ) + [ + [ username ": " ] dip + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-client-join + [ + line-beginning username " has joined" + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-client-disconnect + [ + line-beginning username " has quit " + client object>> dup [ "\"" dup surround ] when + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-already-logged-in + "The username ``" username "'' is already in use; try again." + 3append print flush ; + M: chat-server handle-managed-client* - clients>> - readln dup empty? [ - 2drop - ] [ - '[ - nip output-stream>> - [ - client get username>> ": " _ 3append print flush - ] with-output-stream* - ] assoc-each - ] if ; + readln [ + "/" ?head [ handle-command ] [ handle-chat ] if + ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 2a9df2ae8a..ad09035251 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -1,24 +1,46 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs calendar continuations io +USING: accessors assocs calendar continuations destructors io io.encodings.binary io.servers.connection io.sockets -io.streams.duplex kernel locals math math.ranges multiline +io.streams.duplex fry kernel locals math math.ranges multiline namespaces prettyprint random sequences sets splitting threads tools.continuations ; IN: managed-server -SYMBOL: client - TUPLE: managed-server < threaded-server clients ; -TUPLE: managed-client input-stream output-stream local-address -remote-address username ; +TUPLE: managed-client +input-stream output-stream local-address remote-address +username object ; -GENERIC: login ( managed-server -- username ) -GENERIC: handle-managed-client* ( threaded-server -- ) +HOOK: login threaded-server ( -- username ) +HOOK: handle-already-logged-in managed-server ( -- ) +HOOK: handle-client-join managed-server ( -- ) +HOOK: handle-client-disconnect managed-server ( -- ) +HOOK: handle-managed-client* managed-server ( -- ) + +M: managed-server handle-already-logged-in ; +M: managed-server handle-client-join ; +M: managed-server handle-client-disconnect ; +M: managed-server handle-managed-client* ; + +: server ( -- managed-client ) managed-server get ; +: client ( -- managed-client ) managed-client get ; +: clients ( -- assoc ) server clients>> ; +: client-streams ( -- assoc ) clients values ; +: username ( -- string ) client username>> ; + +: send-everyone ( seq -- ) + client-streams swap '[ + output-stream>> [ _ print flush ] with-output-stream* + ] each ; + +: print-client ( string -- ) + client output-stream>> + [ stream-print ] [ stream-flush ] bi ; ERROR: already-logged-in username ; -ERROR: bad-login username ; +ERROR: normal-quit ; >remote-address ; : check-logged-in ( username -- username ) - dup threaded-server get clients>> key? [ already-logged-in ] when ; + dup server clients>> key? [ + [ server ] dip + [ handle-already-logged-in ] [ already-logged-in ] bi + ] when ; -: add-managed-client ( managed-client -- ) - dup username>> - threaded-server get clients>> set-at ; +: add-managed-client ( -- ) + client username check-logged-in clients set-at ; : delete-managed-client ( -- ) - client get username>> - threaded-server get clients>> delete-at ; + username server clients>> delete-at ; : handle-managed-client ( -- ) - [ [ threaded-server get handle-managed-client* t ] loop ] - [ delete-managed-client ] + [ [ handle-managed-client* t ] loop ] + [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; PRIVATE> -M: managed-server login drop readln ; +M: managed-server login readln ; M: managed-server handle-client* - login - [ client set ] [ add-managed-client ] bi - handle-managed-client ; + managed-server set + login managed-client set + add-managed-client + handle-client-join handle-managed-client ; : new-managed-server ( port name class -- server ) new-threaded-server From d39f0659b69195839cc4466ea42b1c622a506046 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 01:29:02 -0500 Subject: [PATCH 198/228] Fix a problem with disconnects, add a lot of features to chat server, lots of refactoring of managed-server --- extra/managed-server/chat/chat.factor | 80 +++++++++++++++++----- extra/managed-server/managed-server.factor | 17 ++--- 2 files changed, 66 insertions(+), 31 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 1ec22516bd..723814bb13 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -1,23 +1,21 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.smart -destructors fry io kernel managed-server namespaces -sequences splitting unicode.case ; +destructors fry io io.encodings.utf8 kernel managed-server +namespaces parser sequences sorting splitting strings.parser +unicode.case unicode.categories calendar calendar.format +locals multiline ; IN: managed-server.chat -CONSTANT: line-beginning "-!- " - TUPLE: chat-server < managed-server ; -: ( port -- managed-server ) - "chat-server" chat-server new-managed-server ; +SYMBOL: commands +commands [ H{ } clone ] initialize -: unknown-command ( string -- ) - "Unknown command: " prepend print-client ; +SYMBOL: chat-docs +chat-docs [ H{ } clone ] initialize -: handle-who ( string -- ) - drop - clients keys ", " join print flush ; +CONSTANT: line-beginning "-!- " : handle-me ( string -- ) [ @@ -25,21 +23,64 @@ TUPLE: chat-server < managed-server ; ] "" append-outputs-as send-everyone ; : handle-quit ( string -- ) - client [ (>>object) ] [ output-stream>> dispose ] bi ; + client [ (>>object) ] [ t >>quit? drop ] bi ; + +: handle-help ( string -- ) + [ + "Commands: " + commands get keys natural-sort ", " join append print flush + ] [ + chat-docs get ?at + [ print flush ] + [ "Unknown command: " prepend print flush ] if + ] if-empty ; + +:: add-command ( quot docs key -- ) + quot key commands get set-at + docs key chat-docs get set-at ; + +[ handle-help ] +<" Syntax: /help [command] +Displays the documentation for a command."> +"help" add-command + +[ drop clients keys ", " join print flush ] +<" Syntax: /who +Shows the list of connected users."> +"who" add-command + +[ drop gmt timestamp>rfc822 print flush ] +<" Syntax: /time +Returns the current GMT time."> "time" add-command + +[ handle-me ] +<" Syntax: /me action"> +"me" add-command + +[ handle-quit ] +<" Syntax: /quit [message] +Disconnects a user from the chat server."> "quit" add-command : handle-command ( string -- ) - " " split1 swap >lower { - { "who" [ handle-who ] } - { "me" [ handle-me ] } - { "quit" [ handle-quit ] } - [ " " glue unknown-command ] - } case ; + dup " " split1 swap >lower commands get at* [ + call( string -- ) drop + ] [ + 2drop "Unknown command: " prepend print flush + ] if ; + +: ( port -- managed-server ) + "chat-server" chat-server new-managed-server + utf8 >>encoding ; : handle-chat ( string -- ) [ [ username ": " ] dip ] "" append-outputs-as send-everyone ; +M: chat-server handle-login + "Username: " write flush + readln ; + M: chat-server handle-client-join [ line-beginning username " has joined" @@ -56,6 +97,7 @@ M: chat-server handle-already-logged-in 3append print flush ; M: chat-server handle-managed-client* - readln [ + readln dup f = [ t client (>>quit?) ] when + [ "/" ?head [ handle-command ] [ handle-chat ] if ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index ad09035251..4d7ede84dc 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -11,9 +11,9 @@ TUPLE: managed-server < threaded-server clients ; TUPLE: managed-client input-stream output-stream local-address remote-address -username object ; +username object quit? ; -HOOK: login threaded-server ( -- username ) +HOOK: handle-login threaded-server ( -- username ) HOOK: handle-already-logged-in managed-server ( -- ) HOOK: handle-client-join managed-server ( -- ) HOOK: handle-client-disconnect managed-server ( -- ) @@ -31,16 +31,11 @@ M: managed-server handle-managed-client* ; : username ( -- string ) client username>> ; : send-everyone ( seq -- ) - client-streams swap '[ + [ client-streams ] dip '[ output-stream>> [ _ print flush ] with-output-stream* ] each ; -: print-client ( string -- ) - client output-stream>> - [ stream-print ] [ stream-flush ] bi ; - ERROR: already-logged-in username ; -ERROR: normal-quit ; > delete-at ; : handle-managed-client ( -- ) - [ [ handle-managed-client* t ] loop ] + [ [ handle-managed-client* client quit?>> not ] loop ] [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; PRIVATE> -M: managed-server login readln ; - M: managed-server handle-client* managed-server set - login managed-client set + handle-login managed-client set add-managed-client handle-client-join handle-managed-client ; From da4282b0b0f7f96849109db578a35946c408a709 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 10:34:47 -0500 Subject: [PATCH 199/228] support mingw in factor.sh --- build-support/factor.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index ba5815cfc1..d5b8bd5411 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -174,6 +174,7 @@ find_os() { CYGWIN_NT-5.2-WOW64) OS=winnt;; *CYGWIN_NT*) OS=winnt;; *CYGWIN*) OS=winnt;; + MINGW32*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; From 8c51abfd061f2abb2451baa919fb8be864c6cb78 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 12:13:17 -0500 Subject: [PATCH 200/228] cleaned up slava's old cursor code --- extra/cursors/authors.txt | 1 + extra/cursors/cursors-tests.factor | 21 +++++++ extra/cursors/cursors.factor | 99 ++++++++++++++++++++++++++++++ 3 files changed, 121 insertions(+) create mode 100644 extra/cursors/authors.txt create mode 100644 extra/cursors/cursors-tests.factor create mode 100644 extra/cursors/cursors.factor diff --git a/extra/cursors/authors.txt b/extra/cursors/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/cursors/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor new file mode 100644 index 0000000000..3c98608b72 --- /dev/null +++ b/extra/cursors/cursors-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: cursors math tools.test make ; +IN: cursors.tests + +[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test +[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test +[ f f ] [ { 2 4 } [ odd? ] find ] unit-test + +[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test +[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test +[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test +[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test + +[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor new file mode 100644 index 0000000000..059129f22e --- /dev/null +++ b/extra/cursors/cursors.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math sequences sequences.private ; +IN: cursors + +GENERIC: cursor-done? ( cursor -- ? ) +GENERIC: cursor-get-unsafe ( cursor -- obj ) +GENERIC: cursor-advance ( cursor -- ) +GENERIC: cursor-valid? ( cursor -- ? ) +GENERIC: cursor-write ( obj cursor -- ) + +ERROR: cursor-ended cursor ; + +: cursor-get ( cursor -- obj ) + dup cursor-done? + [ cursor-ended ] [ cursor-get-unsafe ] if ; inline + +: find-done? ( quot cursor -- ? ) + dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline + +: cursor-until ( quot cursor -- ) + [ find-done? not ] + [ cursor-advance drop ] bi-curry bi-curry while ; inline + +: cursor-each ( cursor quot -- ) + [ f ] compose swap cursor-until ; inline + +: cursor-find ( cursor quot -- obj ? ) + swap [ cursor-until ] keep + dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline + +: cursor-any? ( cursor quot -- ? ) + cursor-find nip ; inline + +: cursor-all? ( cursor quot -- ? ) + [ not ] compose cursor-any? not ; inline + +: cursor-map-quot ( quot to -- quot' ) + [ [ call ] dip cursor-write ] 2curry ; inline + +: cursor-map ( from to quot -- ) + swap cursor-map-quot cursor-each ; inline + +: cursor-write-if ( obj quot to -- ) + [ over [ call ] dip ] dip + [ cursor-write ] 2curry when ; inline + +: cursor-filter-quot ( quot to -- quot' ) + [ cursor-write-if ] 2curry ; inline + +: cursor-filter ( from to quot -- ) + swap cursor-filter-quot cursor-each ; inline + +TUPLE: from-sequence { seq sequence } { n integer } ; + +: >from-sequence< ( from-sequence -- n seq ) + [ n>> ] [ seq>> ] bi ; inline + +M: from-sequence cursor-done? ( cursor -- ? ) + >from-sequence< length >= ; + +M: from-sequence cursor-valid? + >from-sequence< bounds-check? not ; + +M: from-sequence cursor-get-unsafe + >from-sequence< nth-unsafe ; + +M: from-sequence cursor-advance + [ 1+ ] change-n drop ; + +: >input ( seq -- cursor ) + 0 from-sequence boa ; inline + +: iterate ( seq quot iterator -- ) + [ >input ] 2dip call ; inline + +: each ( seq quot -- ) [ cursor-each ] iterate ; inline +: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline +: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline +: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline + +TUPLE: to-sequence { seq sequence } { exemplar sequence } ; + +M: to-sequence cursor-write + seq>> push ; + +: freeze ( cursor -- seq ) + [ seq>> ] [ exemplar>> ] bi like ; inline + +: >output ( seq -- cursor ) + [ [ length ] keep new-resizable ] keep + to-sequence boa ; inline + +: transform ( seq quot transformer -- newseq ) + [ [ >input ] [ >output ] bi ] 2dip + [ call ] [ 2drop freeze ] 3bi ; inline + +: map ( seq quot -- ) [ cursor-map ] transform ; inline +: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline From 2ea8212968cb0876aaa2a8c4f158079bfd186391 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 May 2009 13:22:30 -0500 Subject: [PATCH 201/228] Start cleaning up stack analysis --- .../cfg/stack-analysis/stack-analysis.factor | 65 +++++++++---------- 1 file changed, 32 insertions(+), 33 deletions(-) diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index 955630a76d..dfc99883c4 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -88,21 +88,19 @@ GENERIC: visit ( insn -- ) UNION: neutral-insn ##flushable ##effect - ##branch - ##loop-entry - ##conditional-branch - ##compare-imm-branch - ##dispatch ; + ##loop-entry ; M: neutral-insn visit , ; UNION: sync-if-back-edge ##branch ##conditional-branch - ##compare-imm-branch ; + ##compare-imm-branch + ##dispatch ; M: sync-if-back-edge visit - basic-block get [ successors>> ] [ number>> ] bi '[ number>> _ < ] any? + basic-block get [ successors>> ] [ number>> ] bi + '[ number>> _ < ] any? [ sync-state ] when , ; @@ -173,8 +171,9 @@ M: ##alien-callback visit , ; ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: with-state ( state quot -- ) - [ state ] dip with-variable ; inline +: initial-state ( bb states -- state ) 2drop ; + +: single-predecessor ( bb states -- state ) nip first clone ; ERROR: must-equal-failed seq ; @@ -225,32 +224,32 @@ ERROR: must-equal-failed seq ; ERROR: cannot-merge-poisoned states ; +: multiple-predecessors ( bb states -- state ) + dup [ not ] any? [ + [ ] 2dip + sift merge-heights + ] [ + dup [ poisoned?>> ] any? [ + cannot-merge-poisoned + ] [ + [ state new ] 2dip + [ predecessors>> ] dip + { + [ merge-locs ] + [ merge-actual-locs ] + [ merge-heights ] + [ merge-changed-locs ] + } 2cleave + ] if + ] if ; + : merge-states ( bb states -- state ) ! If any states are poisoned, save all registers ! to the stack in each branch dup length { - { 0 [ 2drop ] } - { 1 [ nip first clone ] } - [ - drop - dup [ not ] any? [ - [ ] 2dip - sift merge-heights - ] [ - dup [ poisoned?>> ] any? [ - cannot-merge-poisoned - ] [ - [ state new ] 2dip - [ predecessors>> ] dip - { - [ merge-locs ] - [ merge-actual-locs ] - [ merge-heights ] - [ merge-changed-locs ] - } 2cleave - ] if - ] if - ] + { 0 [ initial-state ] } + { 1 [ single-predecessor ] } + [ drop multiple-predecessors ] } case ; : block-in-state ( bb -- states ) @@ -269,12 +268,12 @@ ERROR: cannot-merge-poisoned states ; dup basic-block set dup block-in-state [ swap set-block-in-state ] [ - [ + state [ [ instructions>> [ visit ] each ] [ [ state get ] dip set-block-out-state ] [ ] tri - ] with-state + ] with-variable ] 2bi ] V{ } make >>instructions drop ; From d7cc9fa262f57dc0a21ad2557c2c06899546c94a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 30 May 2009 13:23:07 -0500 Subject: [PATCH 202/228] sequences.product: fix ABOUT: --- extra/sequences/product/product-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor index b7dcaa626e..add5ac8418 100644 --- a/extra/sequences/product/product-docs.factor +++ b/extra/sequences/product/product-docs.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: help.markup help.syntax multiline quotations sequences sequences.product ; -IN: sequences +USING: help.markup help.syntax multiline quotations sequences ; +IN: sequences.product HELP: product-sequence { $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link } " word." } From aa1df815dc2fdbf8c9090e274cc3a9b5c0e81ef1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 13:38:40 -0500 Subject: [PATCH 203/228] add a few utility words to managed-server --- extra/managed-server/managed-server.factor | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d7ede84dc..ac4e275c9e 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -29,11 +29,27 @@ M: managed-server handle-managed-client* ; : clients ( -- assoc ) server clients>> ; : client-streams ( -- assoc ) clients values ; : username ( -- string ) client username>> ; +: everyone-else ( -- assoc ) + clients [ drop username = not ] assoc-filter ; +: everyone-else-streams ( -- assoc ) everyone-else values ; + +ERROR: no-such-client username ; + +> '[ _ print flush ] with-output-stream* ; + +PRIVATE> + +: send-client ( seq username -- ) + clients ?at [ no-such-client ] [ (send-client) ] if ; : send-everyone ( seq -- ) - [ client-streams ] dip '[ - output-stream>> [ _ print flush ] with-output-stream* - ] each ; + [ client-streams ] dip '[ _ (send-client) ] each ; + +: send-everyone-else ( seq -- ) + [ everyone-else-streams ] dip '[ _ (send-client) ] each ; ERROR: already-logged-in username ; From a06d8bfc9a9c30be925ff60a15165dc415ef4fbd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 13:51:03 -0500 Subject: [PATCH 204/228] fix a word in managed-server --- extra/managed-server/managed-server.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index ac4e275c9e..7d75976ea5 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -37,8 +37,8 @@ ERROR: no-such-client username ; > '[ _ print flush ] with-output-stream* ; +: (send-client) ( managed-client seq -- ) + [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ; PRIVATE> From 934e4463da1b59e217e3e8a572330b9cd01b8ee1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 15:50:08 -0500 Subject: [PATCH 205/228] fix error handling in managed-server --- extra/managed-server/managed-server.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 7d75976ea5..8fc06ddf2a 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -14,15 +14,14 @@ input-stream output-stream local-address remote-address username object quit? ; HOOK: handle-login threaded-server ( -- username ) +HOOK: handle-managed-client* managed-server ( -- ) HOOK: handle-already-logged-in managed-server ( -- ) HOOK: handle-client-join managed-server ( -- ) HOOK: handle-client-disconnect managed-server ( -- ) -HOOK: handle-managed-client* managed-server ( -- ) M: managed-server handle-already-logged-in ; M: managed-server handle-client-join ; M: managed-server handle-client-disconnect ; -M: managed-server handle-managed-client* ; : server ( -- managed-client ) managed-server get ; : client ( -- managed-client ) managed-client get ; @@ -76,17 +75,17 @@ ERROR: already-logged-in username ; username server clients>> delete-at ; : handle-managed-client ( -- ) - [ [ handle-managed-client* client quit?>> not ] loop ] - [ delete-managed-client handle-client-disconnect ] - [ ] cleanup ; + handle-login managed-client set + add-managed-client handle-client-join + [ handle-managed-client* client quit?>> not ] loop ; PRIVATE> M: managed-server handle-client* managed-server set - handle-login managed-client set - add-managed-client - handle-client-join handle-managed-client ; + [ handle-managed-client ] + [ delete-managed-client handle-client-disconnect ] + [ ] cleanup ; : new-managed-server ( port name class -- server ) new-threaded-server From b61e327507eebd410d22d8b38d592c9f08164e80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 16:50:38 -0400 Subject: [PATCH 206/228] refactor a bit of the chat server, add /nick --- extra/managed-server/chat/chat.factor | 38 ++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 723814bb13..e1331f360b 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -4,7 +4,8 @@ USING: accessors assocs combinators combinators.smart destructors fry io io.encodings.utf8 kernel managed-server namespaces parser sequences sorting splitting strings.parser unicode.case unicode.categories calendar calendar.format -locals multiline ; +locals multiline io.encodings.binary io.encodings.string +prettyprint ; IN: managed-server.chat TUPLE: chat-server < managed-server ; @@ -35,6 +36,31 @@ CONSTANT: line-beginning "-!- " [ "Unknown command: " prepend print flush ] if ] if-empty ; +: usage ( string -- ) + chat-docs get at print flush ; + +: username-taken-string ( username -- string ) + "The username ``" "'' is already in use; try again." surround ; + +: warn-name-changed ( old new -- ) + [ + [ line-beginning "``" ] 2dip + [ "'' is now known as ``" ] dip "''" + ] "" append-outputs-as send-everyone ; + +: handle-nick ( string -- ) + [ + "nick" usage + ] [ + dup clients key? [ + username-taken-string print flush + ] [ + [ username swap warn-name-changed ] + [ username clients rename-at ] + [ client (>>username) ] tri + ] if + ] if-empty ; + :: add-command ( quot docs key -- ) quot key commands get set-at docs key chat-docs get set-at ; @@ -44,7 +70,7 @@ CONSTANT: line-beginning "-!- " Displays the documentation for a command."> "help" add-command -[ drop clients keys ", " join print flush ] +[ drop clients keys [ "``" "''" surround ] map ", " join print flush ] <" Syntax: /who Shows the list of connected users."> "who" add-command @@ -53,6 +79,11 @@ Shows the list of connected users."> <" Syntax: /time Returns the current GMT time."> "time" add-command +[ handle-nick ] +<" Syntax: /nick nickname +Changes your nickname."> +"nick" add-command + [ handle-me ] <" Syntax: /me action"> "me" add-command @@ -93,8 +124,7 @@ M: chat-server handle-client-disconnect ] "" append-outputs-as send-everyone ; M: chat-server handle-already-logged-in - "The username ``" username "'' is already in use; try again." - 3append print flush ; + username username-taken-string print flush ; M: chat-server handle-managed-client* readln dup f = [ t client (>>quit?) ] when From 8b2e7b72dbd7c1cedab3cc4a8e337e7037d500a4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:15:53 -0500 Subject: [PATCH 207/228] change threaded-server and managed-server to take an encoding --- basis/concurrency/distributed/distributed.factor | 3 +-- basis/ftp/server/server.factor | 5 ++--- basis/http/server/server.factor | 2 +- basis/io/servers/connection/connection-docs.factor | 4 ++-- basis/io/servers/connection/connection-tests.factor | 10 +++++----- basis/io/servers/connection/connection.factor | 6 +++--- extra/fuel/remote/remote.factor | 3 +-- extra/managed-server/chat/chat.factor | 3 +-- extra/managed-server/managed-server.factor | 13 +++++-------- extra/mongodb/mmm/mmm.factor | 5 ++--- extra/time-server/time-server.factor | 6 +++--- extra/tty-server/tty-server.factor | 3 +-- 12 files changed, 27 insertions(+), 36 deletions(-) diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index ca1c5762f6..52627f2ed9 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -13,9 +13,8 @@ SYMBOL: local-node [ first2 get-process send ] [ stop-this-server ] if* ; : ( addrspec -- threaded-server ) - + binary swap >>insecure - binary >>encoding "concurrency.distributed" >>name [ handle-node-client ] >>handler ; diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 8438aae94e..c9518bdef1 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- ) ] with-destructors ; : ( directory port -- server ) - ftp-server new-threaded-server + latin1 ftp-server new-threaded-server swap >>insecure swap canonicalize-path >>serving-directory "ftp.server" >>name - 5 minutes >>timeout - latin1 >>encoding ; + 5 minutes >>timeout ; : ftpd ( directory port -- ) start-server ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c838471e3f..8682c97c73 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -269,7 +269,7 @@ M: http-server handle-client* ] with-destructors ; : ( -- server ) - http-server new-threaded-server + ascii http-server new-threaded-server "http.server" >>name "http" protocol-port >>insecure "https" protocol-port >>secure ; diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 67c7cb13dd..872f3166c2 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -83,8 +83,8 @@ HELP: new-threaded-server { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ; HELP: -{ $values { "threaded-server" threaded-server } } -{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ; +{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } } +{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ; HELP: remote-address { $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ; diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ab99531eb4..14100d3f04 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -3,10 +3,10 @@ USING: tools.test io.servers.connection io.sockets namespaces io.servers.connection.private kernel accessors sequences concurrency.promises io.encodings.ascii io threads calendar ; -[ t ] [ listen-on empty? ] unit-test +[ t ] [ ascii listen-on empty? ] unit-test [ f ] [ - + ascii 25 internet-server >>insecure listen-on empty? @@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ; and ] unit-test -[ ] [ init-server drop ] unit-test +[ ] [ ascii init-server drop ] unit-test [ 10 ] [ - + ascii 10 >>max-connections init-server semaphore>> count>> ] unit-test [ ] [ - + ascii 5 >>max-connections 0 >>insecure [ "Hello world." write stop-this-server ] >>handler diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 8eafe1b5bf..df6c21e7cc 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -27,18 +27,18 @@ ready ; : internet-server ( port -- addrspec ) f swap ; -: new-threaded-server ( class -- threaded-server ) +: new-threaded-server ( encoding class -- threaded-server ) new + swap >>encoding "server" >>name DEBUG >>log-level - ascii >>encoding 1 minutes >>timeout V{ } clone >>sockets >>secure-config [ "No handler quotation" throw ] >>handler >>ready ; inline -: ( -- threaded-server ) +: ( encoding -- threaded-server ) threaded-server new-threaded-server ; GENERIC: handle-client* ( threaded-server -- ) diff --git a/extra/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor index d13aff800a..d3b48efac6 100644 --- a/extra/fuel/remote/remote.factor +++ b/extra/fuel/remote/remote.factor @@ -11,9 +11,8 @@ IN: fuel.remote [ [ print-error-and-restarts ] error-hook set listener ] with-scope ; : server ( port -- server ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ start-listener ] >>handler f >>timeout ; diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index e1331f360b..8835e3d8a6 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -100,8 +100,7 @@ Disconnects a user from the chat server."> "quit" add-command ] if ; : ( port -- managed-server ) - "chat-server" chat-server new-managed-server - utf8 >>encoding ; + "chat-server" utf8 chat-server new-managed-server ; : handle-chat ( string -- ) [ diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 8fc06ddf2a..4d4a440525 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -19,7 +19,9 @@ HOOK: handle-already-logged-in managed-server ( -- ) HOOK: handle-client-join managed-server ( -- ) HOOK: handle-client-disconnect managed-server ( -- ) -M: managed-server handle-already-logged-in ; +ERROR: already-logged-in username ; + +M: managed-server handle-already-logged-in already-logged-in ; M: managed-server handle-client-join ; M: managed-server handle-client-disconnect ; @@ -50,8 +52,6 @@ PRIVATE> : send-everyone-else ( seq -- ) [ everyone-else-streams ] dip '[ _ (send-client) ] each ; -ERROR: already-logged-in username ; - ( username -- managed-client ) @@ -63,10 +63,7 @@ ERROR: already-logged-in username ; remote-address get >>remote-address ; : check-logged-in ( username -- username ) - dup server clients>> key? [ - [ server ] dip - [ handle-already-logged-in ] [ already-logged-in ] bi - ] when ; + dup clients key? [ handle-already-logged-in ] when ; : add-managed-client ( -- ) client username check-logged-in clients set-at ; @@ -87,7 +84,7 @@ M: managed-server handle-client* [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; -: new-managed-server ( port name class -- server ) +: new-managed-server ( port name encoding class -- server ) new-threaded-server swap >>name swap >>insecure diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor index 25c4c88203..8e56143664 100644 --- a/extra/mongodb/mmm/mmm.factor +++ b/extra/mongodb/mmm/mmm.factor @@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- ) : start-mmm-server ( -- ) output-stream get mmm-dump-output set - [ mmm-t-srv set ] keep + binary [ mmm-t-srv set ] keep "127.0.0.1" mmm-port get >>insecure - binary >>encoding [ handle-mmm-connection ] >>handler start-server* ; @@ -99,4 +98,4 @@ M: mdb-msg dump-message ( message -- ) check-options start-mmm-server ; -MAIN: run-mmm \ No newline at end of file +MAIN: run-mmm diff --git a/extra/time-server/time-server.factor b/extra/time-server/time-server.factor index 28debf17cd..500f0276d7 100644 --- a/extra/time-server/time-server.factor +++ b/extra/time-server/time-server.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.servers.connection accessors threads -calendar calendar.format ; +USING: accessors calendar calendar.format io io.encodings.ascii +io.servers.connection threads ; IN: time-server : handle-time-client ( -- ) now timestamp>rfc822 print ; : ( -- threaded-server ) - + ascii "time-server" >>name 1234 >>insecure [ handle-time-client ] >>handler ; diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index 4ba38ad06a..0c7395f7f0 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -3,9 +3,8 @@ accessors kernel ; IN: tty-server : ( port -- ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ listener ] >>handler start-server ; From 9db1c993cb93df79dabfccc8f5e2d676b0c9fb47 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:16:23 -0500 Subject: [PATCH 208/228] clean up formatting of rpc-server in unmaintained --- .../modules/rpc-server/rpc-server.factor | 42 +++++++++++-------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/unmaintained/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor index 525ff35a09..0c881adef6 100644 --- a/unmaintained/modules/rpc-server/rpc-server.factor +++ b/unmaintained/modules/rpc-server/rpc-server.factor @@ -2,36 +2,44 @@ USING: accessors assocs continuations effects io io.encodings.binary io.servers.connection kernel memoize namespaces parser sets sequences serialize threads vocabs vocabs.parser words ; - IN: modules.rpc-server SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global : do-rpc ( args word -- bytes ) - [ execute ] curry with-datastack object>bytes ; inline + [ execute ] curry with-datastack object>bytes ; inline MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline -: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize - swap at "executer" get execute( args word -- bytes ) write flush ; +: process ( vocabspec -- ) + vocab-words [ deserialize ] dip deserialize + swap at "executer" get execute( args word -- bytes ) write flush ; -: (serve) ( -- ) deserialize dup serving-vocabs get-global index - [ process ] [ drop ] if ; +: (serve) ( -- ) + deserialize dup serving-vocabs get-global index + [ process ] [ drop ] if ; -: start-serving-vocabs ( -- ) [ - 5000 >>insecure binary >>encoding [ (serve) ] >>handler - start-server ] in-thread ; +: start-serving-vocabs ( -- ) + [ + binary + 5000 >>insecure + [ (serve) ] >>handler + start-server + ] in-thread ; -: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when - current-vocab serving-vocabs get-global adjoin - "get-words" create-in - in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry - (( -- words )) define-inline ; +: (service) ( -- ) + serving-vocabs get-global empty? [ start-serving-vocabs ] when + current-vocab serving-vocabs get-global adjoin + "get-words" create-in + in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry + (( -- words )) define-inline ; SYNTAX: service \ do-rpc "executer" set (service) ; SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ; load-vocab-hook [ - [ dup words>> values - \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ] -append ] change-global \ No newline at end of file + [ + dup words>> values + \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each + ] append +] change-global From 6a8e975c5d153eeb2a295ede10792d842d23716a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:24:11 -0500 Subject: [PATCH 209/228] fix help for new-threaded-server --- basis/io/servers/connection/connection-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 872f3166c2..0e8a8576fb 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -79,7 +79,7 @@ HELP: threaded-server { $class-description "The class of threaded servers. New instances are created with " { $link } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ; HELP: new-threaded-server -{ $values { "class" class } { "threaded-server" threaded-server } } +{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } } { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ; HELP: From a0ea002a748d14b696b305d1dbc4978fb499476d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 May 2009 08:53:42 -0500 Subject: [PATCH 210/228] clean up some stack shuffling --- extra/cursors/cursors.factor | 56 +++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 059129f22e..11b9bf4bf4 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- ) ERROR: cursor-ended cursor ; : cursor-get ( cursor -- obj ) - dup cursor-done? - [ cursor-ended ] [ cursor-get-unsafe ] if ; inline + dup cursor-done? + [ cursor-ended ] [ cursor-get-unsafe ] if ; inline -: find-done? ( quot cursor -- ? ) - dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline - -: cursor-until ( quot cursor -- ) - [ find-done? not ] - [ cursor-advance drop ] bi-curry bi-curry while ; inline +: find-done? ( cursor quot -- ? ) + over cursor-done? + [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline +: cursor-until ( cursor quot -- ) + [ find-done? not ] + [ drop cursor-advance ] bi-curry bi-curry while ; inline + : cursor-each ( cursor quot -- ) - [ f ] compose swap cursor-until ; inline + [ f ] compose cursor-until ; inline : cursor-find ( cursor quot -- obj ? ) - swap [ cursor-until ] keep - dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline + [ cursor-until ] [ drop ] 2bi + dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline : cursor-any? ( cursor quot -- ? ) - cursor-find nip ; inline + cursor-find nip ; inline : cursor-all? ( cursor quot -- ? ) - [ not ] compose cursor-any? not ; inline + [ not ] compose cursor-any? not ; inline : cursor-map-quot ( quot to -- quot' ) - [ [ call ] dip cursor-write ] 2curry ; inline + [ [ call ] dip cursor-write ] 2curry ; inline : cursor-map ( from to quot -- ) swap cursor-map-quot cursor-each ; inline @@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ; [ cursor-write ] 2curry when ; inline : cursor-filter-quot ( quot to -- quot' ) - [ cursor-write-if ] 2curry ; inline + [ cursor-write-if ] 2curry ; inline : cursor-filter ( from to quot -- ) - swap cursor-filter-quot cursor-each ; inline + swap cursor-filter-quot cursor-each ; inline TUPLE: from-sequence { seq sequence } { n integer } ; @@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? ) >from-sequence< length >= ; M: from-sequence cursor-valid? - >from-sequence< bounds-check? not ; + >from-sequence< bounds-check? not ; M: from-sequence cursor-get-unsafe - >from-sequence< nth-unsafe ; + >from-sequence< nth-unsafe ; M: from-sequence cursor-advance - [ 1+ ] change-n drop ; + [ 1+ ] change-n drop ; : >input ( seq -- cursor ) - 0 from-sequence boa ; inline + 0 from-sequence boa ; inline : iterate ( seq quot iterator -- ) - [ >input ] 2dip call ; inline + [ >input ] 2dip call ; inline : each ( seq quot -- ) [ cursor-each ] iterate ; inline : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline @@ -82,18 +83,19 @@ M: from-sequence cursor-advance TUPLE: to-sequence { seq sequence } { exemplar sequence } ; M: to-sequence cursor-write - seq>> push ; + seq>> push ; : freeze ( cursor -- seq ) - [ seq>> ] [ exemplar>> ] bi like ; inline + [ seq>> ] [ exemplar>> ] bi like ; inline : >output ( seq -- cursor ) - [ [ length ] keep new-resizable ] keep - to-sequence boa ; inline + [ [ length ] keep new-resizable ] keep + to-sequence boa ; inline : transform ( seq quot transformer -- newseq ) - [ [ >input ] [ >output ] bi ] 2dip - [ call ] [ 2drop freeze ] 3bi ; inline + [ [ >input ] [ >output ] bi ] 2dip + [ call ] + [ 2drop freeze ] 3bi ; inline : map ( seq quot -- ) [ cursor-map ] transform ; inline : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline From 57d9d9f961cad772d425915d8a4043d30f78c6af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 12:20:46 -0500 Subject: [PATCH 211/228] Split off local-optimization combinator into compiler.cfg.local, factor out CFG -> MR into compiler.cfg.mr, split off GC check insertion into a new compiler.cfg.gc-checks pass --- .../cfg/alias-analysis/alias-analysis.factor | 2 +- basis/compiler/cfg/checker/checker.factor | 2 +- basis/compiler/cfg/debugger/debugger.factor | 11 +++------ basis/compiler/cfg/def-use/def-use.factor | 4 +++- basis/compiler/cfg/gc-checks/authors.txt | 1 + basis/compiler/cfg/gc-checks/gc-checks.factor | 22 +++++++++++++++++ basis/compiler/cfg/height/height.factor | 2 +- .../cfg/linearization/linearization.factor | 16 +++---------- basis/compiler/cfg/liveness/liveness.factor | 3 --- basis/compiler/cfg/local/authors.txt | 1 + basis/compiler/cfg/local/local.factor | 10 ++++++++ basis/compiler/cfg/mr/authors.txt | 1 + basis/compiler/cfg/mr/mr.factor | 14 +++++++++++ basis/compiler/cfg/rpo/rpo.factor | 3 --- .../stack-analysis-tests.factor | 2 +- .../cfg/stack-analysis/stack-analysis.factor | 6 ++++- .../value-numbering/value-numbering.factor | 1 + .../cfg/write-barrier/write-barrier.factor | 2 +- basis/compiler/compiler.factor | 24 +++++++++++-------- 19 files changed, 83 insertions(+), 44 deletions(-) create mode 100644 basis/compiler/cfg/gc-checks/authors.txt create mode 100644 basis/compiler/cfg/gc-checks/gc-checks.factor create mode 100644 basis/compiler/cfg/local/authors.txt create mode 100644 basis/compiler/cfg/local/local.factor create mode 100644 basis/compiler/cfg/mr/authors.txt create mode 100644 basis/compiler/cfg/mr/mr.factor diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 384fd65c1a..2385a4c65a 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -4,7 +4,7 @@ USING: kernel math namespaces assocs hashtables sequences arrays accessors vectors combinators sets classes compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.copy-prop compiler.cfg.rpo -compiler.cfg.liveness ; +compiler.cfg.liveness compiler.cfg.local ; IN: compiler.cfg.alias-analysis ! We try to eliminate redundant slot operations using some simple heuristics. diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index bf5adc2d55..b0a279c11b 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -54,5 +54,5 @@ ERROR: undefined-values uses defs ; compute-liveness [ entry>> live-in assoc-empty? [ bad-live-in ] unless ] [ [ check-basic-block ] each-basic-block ] - [ build-mr check-mr ] + [ flatten-cfg check-mr ] tri ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 5c106bfaee..cb56937758 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -7,7 +7,8 @@ parser compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.linear-scan compiler.cfg.two-operand -compiler.cfg.optimizer ; +compiler.cfg.liveness compiler.cfg.optimizer +compiler.cfg.mr ; IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) @@ -18,20 +19,14 @@ M: callable test-cfg M: word test-cfg [ build-tree optimize-tree ] keep build-cfg ; -SYMBOL: allocate-registers? - : test-mr ( quot -- mrs ) test-cfg [ optimize-cfg - convert-two-operand - allocate-registers? get [ linear-scan ] when build-mr - allocate-registers? get [ build-stack-frame ] when ] map ; : insn. ( insn -- ) - tuple>array allocate-registers? get [ but-last ] unless - [ pprint bl ] each nl ; + tuple>array [ pprint bl ] each nl ; : mr. ( mrs -- ) [ diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 17e49f59a8..28351ca7b2 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -54,6 +54,7 @@ M: ##phi uses-vregs inputs>> ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; +M: _gc uses-vregs live-in>> ; M: insn uses-vregs drop f ; ! Instructions that use vregs @@ -67,4 +68,5 @@ UNION: vreg-insn ##compare-imm-branch _conditional-branch _compare-imm-branch -_dispatch ; +_dispatch +_gc ; diff --git a/basis/compiler/cfg/gc-checks/authors.txt b/basis/compiler/cfg/gc-checks/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/gc-checks/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor new file mode 100644 index 0000000000..7a47da00a8 --- /dev/null +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences assocs +cpu.architecture compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.instructions ; +IN: compiler.cfg.gc-checks + +: gc? ( bb -- ? ) + instructions>> [ ##allocation? ] any? ; + +: object-pointer-regs ( basic-block -- vregs ) + live-in keys [ reg-class>> int-regs eq? ] filter ; + +: insert-gc-check ( basic-block -- ) + dup gc? [ + dup + [ swap object-pointer-regs \ _gc new-insn suffix ] + change-instructions drop + ] [ drop ] if ; + +: insert-gc-checks ( cfg -- cfg' ) + dup [ insert-gc-check ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index b91120ccfd..14a0a54715 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors math namespaces sequences kernel fry compiler.cfg compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.liveness ; +compiler.cfg.liveness compiler.cfg.local ; IN: compiler.cfg.height ! Combine multiple stack height changes into one at the diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 5ad8be2953..2e09e493db 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -12,20 +12,10 @@ IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. GENERIC: linearize-insn ( basic-block insn -- ) -: linearize-insns ( bb insns -- ) - dup instructions>> [ linearize-insn ] with each ; - -: gc? ( bb -- ? ) - instructions>> [ ##allocation? ] any? ; - -: object-pointer-regs ( basic-block -- vregs ) - live-in keys [ reg-class>> int-regs eq? ] filter ; - : linearize-basic-block ( bb -- ) [ number>> _label ] - [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ] - [ linearize-insns ] - tri ; + [ dup instructions>> [ linearize-insn ] with each ] + bi ; M: insn linearize-insn , drop ; @@ -85,6 +75,6 @@ M: ##dispatch linearize-insn bi ] { } make ; -: build-mr ( cfg -- mr ) +: flatten-cfg ( cfg -- mr ) [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 72609cf4d9..6c40bb3782 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -76,6 +76,3 @@ SYMBOL: work-list H{ } clone live-outs set dup post-order add-to-work-list work-list get [ liveness-step ] slurp-deque ; - -: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) - [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/local/authors.txt b/basis/compiler/cfg/local/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/local/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor new file mode 100644 index 0000000000..bf336a8d2a --- /dev/null +++ b/basis/compiler/cfg/local/local.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ; +IN: compiler.cfg.local + +: optimize-basic-block ( bb init-quot insn-quot -- ) + [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline + +: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) + [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/mr/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor new file mode 100644 index 0000000000..49f7c793e5 --- /dev/null +++ b/basis/compiler/cfg/mr/mr.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan +compiler.cfg.stack-frame compiler.cfg.rpo ; +IN: compiler.cfg.mr + +: build-mr ( cfg -- mr ) + convert-two-operand + compute-liveness + insert-gc-checks + linear-scan + flatten-cfg + build-stack-frame ; \ No newline at end of file diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index d01f5ee864..c6ea2ee8b1 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -34,6 +34,3 @@ SYMBOL: visited : each-basic-block ( cfg quot -- ) [ reverse-post-order ] dip each ; inline - -: optimize-basic-block ( bb init-quot insn-quot -- ) - [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index bd0e539173..383bd2e637 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -31,7 +31,7 @@ IN: compiler.cfg.stack-analysis.tests dup check-for-redundant-ops ; : linearize ( cfg -- mr ) - build-mr instructions>> ; + flatten-cfg instructions>> ; [ ] [ [ ] test-stack-analysis drop ] unit-test diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index dfc99883c4..c1ed2615c3 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -98,9 +98,13 @@ UNION: sync-if-back-edge ##compare-imm-branch ##dispatch ; +SYMBOL: local-only? + +t local-only? set-global + M: sync-if-back-edge visit basic-block get [ successors>> ] [ number>> ] bi - '[ number>> _ < ] any? + '[ number>> _ < local-only? get or ] any? [ sync-state ] when , ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index cc62c0f0c1..9f5473c62f 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs biassocs classes kernel math accessors sorting sets sequences +compiler.cfg.local compiler.cfg.liveness compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index 52d5170138..b260b0464e 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors namespaces assocs sets sequences locals compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.liveness ; +compiler.cfg.liveness compiler.cfg.local ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ae58c3bd3e..eee00bfccb 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -3,13 +3,20 @@ USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic generic.single combinators deques search-deques macros -source-files.errors stack-checker stack-checker.state -stack-checker.inlining stack-checker.errors combinators.short-circuit -compiler.errors compiler.units compiler.tree.builder -compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer -compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.cfg.rpo -compiler.codegen compiler.utilities ; +source-files.errors combinators.short-circuit + +stack-checker stack-checker.state stack-checker.inlining stack-checker.errors + +compiler.errors compiler.units compiler.utilities + +compiler.tree.builder +compiler.tree.optimizer + +compiler.cfg.builder +compiler.cfg.optimizer +compiler.cfg.mr + +compiler.codegen ; IN: compiler SYMBOL: compile-queue @@ -146,10 +153,7 @@ t compile-dependencies? set-global : backend ( nodes word -- ) build-cfg [ optimize-cfg - convert-two-operand - linear-scan build-mr - build-stack-frame generate save-asm ] each ; From e2b8b04d15fbe3cb146bb07e04e307ffb2f4aa78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 15:02:14 -0500 Subject: [PATCH 212/228] cpu.x86.features: add RDTSC support. This is a new vocabulary with words: sse2? instruction-counter count-instructions --- basis/cpu/x86/32/32.factor | 5 +--- basis/cpu/x86/features/authors.txt | 1 + basis/cpu/x86/features/features-tests.factor | 7 ++++++ basis/cpu/x86/features/features.factor | 25 ++++++++++++++++++++ vm/cpu-x86.32.S | 4 ++++ vm/cpu-x86.64.S | 7 ++++++ 6 files changed, 45 insertions(+), 4 deletions(-) create mode 100644 basis/cpu/x86/features/authors.txt create mode 100644 basis/cpu/x86/features/features-tests.factor create mode 100644 basis/cpu/x86/features/features.factor diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0a0ac4a53e..95b65912d1 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -305,10 +305,7 @@ os windows? [ 4 "double" c-type (>>align) ] unless -FUNCTION: bool check_sse2 ( ) ; - -: sse2? ( -- ? ) - check_sse2 ; +USING: cpu.x86.features cpu.x86.features.private ; "-no-sse2" (command-line) member? [ [ { check_sse2 } compile ] with-optimizer diff --git a/basis/cpu/x86/features/authors.txt b/basis/cpu/x86/features/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/cpu/x86/features/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/cpu/x86/features/features-tests.factor b/basis/cpu/x86/features/features-tests.factor new file mode 100644 index 0000000000..69847cacfa --- /dev/null +++ b/basis/cpu/x86/features/features-tests.factor @@ -0,0 +1,7 @@ +IN: cpu.x86.features.tests +USING: cpu.x86.features tools.test kernel sequences math system ; + +cpu x86? [ + [ t ] [ sse2? { t f } member? ] unit-test + [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test +] when \ No newline at end of file diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor new file mode 100644 index 0000000000..bc4818d6af --- /dev/null +++ b/basis/cpu/x86/features/features.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system kernel math alien.syntax ; +IN: cpu.x86.features + + + +HOOK: sse2? cpu ( -- ? ) + +M: x86.32 sse2? check_sse2 ; + +M: x86.64 sse2? t ; + +HOOK: instruction-count cpu ( -- n ) + +M: x86 instruction-count read_timestamp_counter ; + +: count-instructions ( quot -- n ) + instruction-count [ call ] dip instruction-count swap - ; inline diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index afda9d31cd..1a9fd6165e 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -55,6 +55,10 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret +DEF(long long,read_timestamp_counter,(void)): + rdtsc + ret + DEF(void,primitive_inline_cache_miss,(void)): mov (%esp),%ebx DEF(void,primitive_inline_cache_miss_tail,(void)): diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 8cf7423239..5cc3c98f33 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -72,6 +72,13 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ +DEF(long long,read_timestamp_counter,(void)): + mov $0,%rax + rdtsc + shl $32,%rdx + or %rdx,%rax + ret + DEF(void,primitive_inline_cache_miss,(void)): mov (%rsp),%rbx DEF(void,primitive_inline_cache_miss_tail,(void)): From ac0bd37a6b1e4e1d6f16fd6d37ce126014a0d7f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 15:16:40 -0500 Subject: [PATCH 213/228] Fix rdtsc on Windows --- vm/cpu-x86.32.S | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 1a9fd6165e..a879712190 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -73,4 +73,5 @@ DEF(void,primitive_inline_cache_miss_tail,(void)): #ifdef WINDOWS .section .drectve .ascii " -export:check_sse2" + .ascii " -export:read_timestamp_counter" #endif From fd70adf39e6f3bdc8420dcb000b6e375aabd5a58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 18:21:11 -0500 Subject: [PATCH 214/228] Rename _gc to ##gc --- basis/compiler/cfg/def-use/def-use.factor | 7 ++++--- basis/compiler/cfg/gc-checks/gc-checks.factor | 2 +- basis/compiler/cfg/instructions/instructions.factor | 4 ++-- basis/compiler/cfg/stack-frame/stack-frame.factor | 2 +- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 28351ca7b2..1484b3ec72 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -51,10 +51,10 @@ M: ##alien-getter uses-vregs src>> 1array ; M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ; M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##phi uses-vregs inputs>> ; +M: ##gc uses-vregs live-in>> ; M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; -M: _gc uses-vregs live-in>> ; M: insn uses-vregs drop f ; ! Instructions that use vregs @@ -66,7 +66,8 @@ UNION: vreg-insn ##fixnum-overflow ##conditional-branch ##compare-imm-branch +##phi +##gc _conditional-branch _compare-imm-branch -_dispatch -_gc ; +_dispatch ; diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 7a47da00a8..91e79ea2dd 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -14,7 +14,7 @@ IN: compiler.cfg.gc-checks : insert-gc-check ( basic-block -- ) dup gc? [ dup - [ swap object-pointer-regs \ _gc new-insn suffix ] + [ swap object-pointer-regs \ ##gc new-insn prefix ] change-instructions drop ] [ drop ] if ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d2d444a4a5..314a66ba9c 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -223,14 +223,14 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; +INSN: ##gc live-in ; + ! Instructions used by machine IR only. INSN: _prologue stack-frame ; INSN: _epilogue stack-frame ; INSN: _label id ; -INSN: _gc live-in ; - INSN: _branch label ; INSN: _dispatch src temp ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index d545b6d15c..fd11260f97 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -32,8 +32,8 @@ M: insn compute-stack-frame* frame-required? on ] when ; -\ _gc t frame-required? set-word-prop \ _spill t frame-required? set-word-prop +\ ##gc t frame-required? set-word-prop \ ##fixnum-add t frame-required? set-word-prop \ ##fixnum-sub t frame-required? set-word-prop \ ##fixnum-mul t frame-required? set-word-prop From 0375ce6bb4bfad712d891f4e42a42136cb4c6824 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 18:21:23 -0500 Subject: [PATCH 215/228] Fix scoping issue in compiler.cfg.linear-scan.assignment --- .../cfg/linear-scan/assignment/assignment.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index f21b9e5db8..c7e3380f83 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -13,13 +13,13 @@ IN: compiler.cfg.linear-scan.assignment ! but since we never have too many machine registers (around 30 ! at most) and we probably won't have that many live at any one ! time anyway, it is not a problem to check each element. -SYMBOL: active-intervals +TUPLE: active-intervals seq ; : add-active ( live-interval -- ) - active-intervals get push ; + active-intervals get seq>> push ; : lookup-register ( vreg -- reg ) - active-intervals get [ vreg>> = ] with find nip reg>> ; + active-intervals get seq>> [ vreg>> = ] with find nip reg>> ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals : expire-old-intervals ( n -- ) active-intervals get - swap '[ end>> _ = ] partition - active-intervals set + [ swap '[ end>> _ = ] partition ] change-seq drop [ insert-spill ] each ; : insert-reload ( live-interval -- ) @@ -65,14 +64,17 @@ GENERIC: assign-registers-in-insn ( insn -- ) [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; M: vreg-insn assign-registers-in-insn - active-intervals get over all-vregs '[ vreg>> _ member? ] filter + active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc >>regs drop ; M: insn assign-registers-in-insn drop ; +: ( -- obj ) + V{ } clone active-intervals boa ; + : init-assignment ( live-intervals -- ) - V{ } clone active-intervals set + active-intervals set unhandled-intervals set init-unhandled ; From 6ac52761c6ebc47c10b6036935d4f842ffcefb9a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 19:04:26 -0500 Subject: [PATCH 216/228] Fix loop handling in stack-analysis --- .../cfg/optimizer/optimizer-tests.factor | 1 + .../stack-analysis-tests.factor | 5 +++-- .../cfg/stack-analysis/stack-analysis.factor | 19 ++++++++++++------- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 923fe828b5..b95a8c79ea 100644 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -28,6 +28,7 @@ IN: compiler.cfg.optimizer.tests [ [ 2 fixnum* ] when 3 ] [ [ 2 fixnum+ ] when 3 ] [ [ 2 fixnum- ] when 3 ] + [ 10000 [ ] times ] } [ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index 383bd2e637..4455d5e208 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -106,7 +106,8 @@ IN: compiler.cfg.stack-analysis.tests ! Sync before a back-edge, not after ! ##peeks should be inserted before a ##loop-entry -[ 1 ] [ +! Don't optimize out the constants +[ 1 t ] [ [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ ##add-imm? ] count + [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi ] unit-test diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index c1ed2615c3..4ebdf7012f 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -87,8 +87,7 @@ GENERIC: visit ( insn -- ) ! Instructions which don't have any effect on the stack UNION: neutral-insn ##flushable - ##effect - ##loop-entry ; + ##effect ; M: neutral-insn visit , ; @@ -96,17 +95,23 @@ UNION: sync-if-back-edge ##branch ##conditional-branch ##compare-imm-branch - ##dispatch ; + ##dispatch + ##loop-entry ; SYMBOL: local-only? t local-only? set-global +: back-edge? ( from to -- ? ) + [ number>> ] bi@ > ; + +: sync-state? ( -- ? ) + basic-block get successors>> + [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? + local-only? get or ; + M: sync-if-back-edge visit - basic-block get [ successors>> ] [ number>> ] bi - '[ number>> _ < local-only? get or ] any? - [ sync-state ] when - , ; + sync-state? [ sync-state ] when , ; : adjust-d ( n -- ) state get [ + ] change-ds-height drop ; From 64114947d21165f7bb30f3b48cd6179d42f75005 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 23:28:08 -0500 Subject: [PATCH 217/228] Various improvements aimed at getting local optimization regressions fixed: - Rename _gc to ##gc - Absolute labels are now supported - Generate _dispatch-label --- basis/compiler/codegen/codegen.factor | 7 +++-- basis/compiler/codegen/fixup/fixup.factor | 35 ++++++++++++---------- basis/cpu/architecture/architecture.factor | 1 + basis/cpu/x86/x86.factor | 3 ++ vm/code_block.cpp | 2 +- 5 files changed, 29 insertions(+), 19 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 11b4e153f6..223fc8edff 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -92,9 +92,12 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; -M: ##dispatch generate-insn +M: _dispatch generate-insn [ src>> register ] [ temp>> register ] bi %dispatch ; +M: _dispatch-label generate-insn + label>> lookup-label %dispatch-label ; + : >slot< ( insn -- dst obj slot tag ) { [ dst>> register ] @@ -234,7 +237,7 @@ M: ##write-barrier generate-insn [ table>> register ] tri %write-barrier ; -M: _gc generate-insn drop %gc ; +M: ##gc generate-insn drop %gc ; M: ##loop-entry generate-insn drop %loop-entry ; diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index d0c874feb0..bd1364dde1 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -16,30 +16,33 @@ SYMBOL: label-table M: label fixup* compiled-offset >>offset drop ; -TUPLE: label-fixup label class ; +: offset-for-class ( class -- n ) + rc-absolute-cell = cell 4 ? compiled-offset swap - ; + +TUPLE: label-fixup { label label } { class integer } ; : label-fixup ( label class -- ) \ label-fixup boa , ; -M: label-fixup fixup* - dup class>> rc-absolute? - [ "Absolute labels not supported" throw ] when - [ class>> ] [ label>> ] bi compiled-offset 4 - swap - 3array label-table get push ; - -TUPLE: rel-fixup class type ; - -: rel-fixup ( class type -- ) \ rel-fixup boa , ; - : push-4 ( value vector -- ) [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri swap set-alien-unsigned-4 ; +: add-relocation-entry ( type class offset -- ) + { 0 24 28 } bitfield relocation-table get push-4 ; + +M: label-fixup fixup* + [ class>> dup offset-for-class ] [ label>> ] bi + [ drop [ rt-here ] 2dip add-relocation-entry ] + [ 3array label-table get push ] + 3bi ; + +TUPLE: rel-fixup { class integer } { type integer } ; + +: rel-fixup ( class type -- ) \ rel-fixup boa , ; + M: rel-fixup fixup* - [ type>> ] - [ class>> ] - [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri - { 0 24 28 } bitfield - relocation-table get push-4 ; + [ type>> ] [ class>> dup offset-for-class ] bi + add-relocation-entry ; M: integer fixup* , ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 98d0c5326b..e0e4343a60 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -52,6 +52,7 @@ HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) HOOK: %dispatch cpu ( src temp -- ) +HOOK: %dispatch-label cpu ( src temp -- ) HOOK: %slot cpu ( dst obj slot tag temp -- ) HOOK: %slot-imm cpu ( dst obj slot tag -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 8ab247f5e5..24832ac227 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -79,6 +79,9 @@ M: x86 %return ( -- ) 0 RET ; : align-code ( n -- ) 0 % ; +M: x86 %dispatch-label ( label -- ) + 0 cell, rc-absolute-cell label-fixup ; + :: (%slot) ( obj slot tag temp -- op ) temp slot obj [+] LEA temp tag neg [+] ; inline diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 2ce69ebfde..050e154c28 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -159,7 +159,7 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) case RT_XT_PIC_TAIL: return (cell)word_xt_pic_tail(untag(ARG)); case RT_HERE: - return offset + (short)untag_fixnum(ARG); + return offset + untag_fixnum(ARG); case RT_THIS: return (cell)(compiled + 1); case RT_STACK_CHAIN: From 921de6ba3f70fbff7da284bf7648deb546e2b9b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 May 2009 23:28:29 -0500 Subject: [PATCH 218/228] math.functions: fix ^ for complex numbers --- basis/math/functions/functions-tests.factor | 1 + basis/math/functions/functions.factor | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 66d813bab8..0bdc6ce00b 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -162,3 +162,4 @@ IN: math.functions.tests [ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test [ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test +[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test \ No newline at end of file diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a1bf9480d5..5d88eba9fa 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -34,8 +34,9 @@ M: integer ^n M: ratio ^n [ >fraction ] dip [ ^n ] curry bi@ / ; -M: float ^n - (^n) ; +M: float ^n (^n) ; + +M: complex ^n (^n) ; : integer^ ( x y -- z ) dup 0 > [ ^n ] [ neg ^n recip ] if ; inline From 096803e58f3dfc4a9b77b20a501987b93b5f6dcb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 1 Jun 2009 02:32:36 -0500 Subject: [PATCH 219/228] Redo compiler.codegen.fixup and get %dispatch to work --- basis/compiler/codegen/codegen-tests.factor | 14 ++++ basis/compiler/codegen/codegen.factor | 25 +++--- basis/compiler/codegen/fixup/fixup.factor | 91 +++++++++++---------- basis/cpu/architecture/architecture.factor | 9 +- basis/cpu/x86/x86.factor | 2 +- vm/code_block.cpp | 5 +- 6 files changed, 81 insertions(+), 65 deletions(-) create mode 100644 basis/compiler/codegen/codegen-tests.factor diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor new file mode 100644 index 0000000000..9c3817bad6 --- /dev/null +++ b/basis/compiler/codegen/codegen-tests.factor @@ -0,0 +1,14 @@ +IN: compiler.codegen.tests +USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make +compiler.constants ; + +[ ] [ [ ] with-fixup drop ] unit-test +[ ] [ [ \ + %call ] with-fixup drop ] unit-test + +[ ] [ [