! 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: <int>
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
-T in get
+T current-vocab
{ { N "real" } { N "imaginary" } }
define-struct
: 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 ;
-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"
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 ;
io.streams.byte-array ;
IN: bitstreams.tests
-[ 1 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
-[ 254 8 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ BIN: 1111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 10 swap peek
+] unit-test
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+[ BIN: 111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 9 swap peek
+] unit-test
+
+[ BIN: 11111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 8 swap peek
+] unit-test
+
+[ BIN: 1111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 7 swap peek
+] unit-test
+
+[ BIN: 111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 6 swap peek
+] unit-test
-[ B{ 254 } ]
+[ BIN: 11111 ]
[
- binary <byte-writer> <bitstream-writer> 254 8 rot
- [ write-bits ] keep stream>> >byte-array
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 5 swap peek
] unit-test
-[ 255 8 t ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
-[ 255 8 f ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
! 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 )
+: 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 ;
+
+: <widthed> ( bits #bits -- widthed )
+ check-widthed
+ widthed boa ;
+
+: zero-widthed ( -- widthed ) 0 0 <widthed> ;
+: zero-widthed? ( widthed -- ? ) zero-widthed = ;
+
+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 ;
+
+: new-bit-writer ( class -- bs )
new
- swap >>stream
- reset-bitstream ; inline
+ BV{ } clone >>bytes
+ 0 0 <widthed> >>widthed ; inline
-M: bitstream-reader dispose ( stream -- )
- stream>> dispose ;
+: <msb0-bit-writer> ( -- bs )
+ msb0-bit-writer new-bit-writer ;
-: <bitstream-reader> ( stream -- bitstream )
- bitstream-reader new-bitstream ; inline
+: <lsb0-bit-writer> ( -- bs )
+ lsb0-bit-writer new-bit-writer ;
-: read-next-byte ( bitstream -- bitstream )
- dup stream>> stream-read1 [
- >>current-bits 8 >>#bits
- ] [
- 0 >>#bits
- t >>end-of-stream?
- ] if* ;
+GENERIC: peek ( n bitstream -- value )
+GENERIC: poke ( value n bitstream -- )
-: maybe-read-next-byte ( bitstream -- bitstream )
- dup #bits>> 0 = [ read-next-byte ] when ; inline
+: seek ( n bitstream -- )
+ {
+ [ byte-pos>> 8 * ]
+ [ bit-pos>> + + 8 /mod ]
+ [ (>>bit-pos) ]
+ [ (>>byte-pos) ]
+ } cleave ; inline
-: shift-one-bit ( bitstream -- n )
- [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
+: read ( n bitstream -- value )
+ [ peek ] [ seek ] 2bi ; 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
+<PRIVATE
+
+ERROR: not-enough-bits widthed n ;
+
+: widthed-bits ( widthed n -- bits )
+ dup 0 < [ not-enough-bits ] when
+ 2dup [ #bits>> ] dip < [ not-enough-bits ] when
+ [ [ bits>> ] [ #bits>> ] bi ] dip
+ [ - neg shift ] keep <widthed> ;
+
+: split-widthed ( widthed n -- widthed1 widthed2 )
+ 2dup [ #bits>> ] dip < [
+ drop zero-widthed
] [
- 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 ;
-
-: <bitstream-writer> ( 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
+ [ widthed-bits ]
+ [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
+ ] if ;
+
+: widthed>bytes ( widthed -- bytes widthed )
+ [ 8 split-widthed dup zero-widthed? not ]
+ [ swap bits>> ] 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 + <widthed> ;
+
+PRIVATE>
+
+M:: lsb0-bit-writer poke ( value n bs -- )
+ value n <widthed> :> widthed
+ widthed
+ bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+ byte bs widthed>> |widthed :> new-byte
+ new-byte #bits>> 8 = [
+ new-byte bits>> bs bytes>> push
+ zero-widthed bs (>>widthed)
+ remainder widthed>bytes
+ [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
] [
- drop
- ] if ; inline
+ byte bs (>>widthed)
+ ] if ;
-ERROR: invalid-bit-width n ;
+: enough-bits? ( n bs -- ? )
+ [ bytes>> length ]
+ [ byte-pos>> - 8 * ]
+ [ bit-pos>> - ] tri <= ;
-:: write-bits ( n width bitstream -- )
- n 0 < [ n invalid-bit-width ] when
- n 0 = [
- width [ 0 bitstream write-bit ] times
+ERROR: not-enough-bits n bit-reader ;
+
+: #bits>#bytes ( #bits -- #bytes )
+ 8 /mod 0 = [ 1 + ] unless ; inline
+
+:: 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 ;
+
+:: 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
] [
- 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
+ bs (>>bit-pos)
] if ;
-: flush-bits ( bitstream -- ) stream>> stream-flush ;
+:: (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 endian> execute( seq -- x ) :> bignum
+ bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
+
+M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
-: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
+M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>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>> ;
! 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
"." write flush
{
- new-sequence nth push pop peek flip
+ new-sequence nth push pop last flip
} compile-unoptimized
"." write flush
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic assocs hashtables assocs
-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 )
! See http://factorcode.org/license.txt for BSD license.\r
USING: math math.order math.parser math.functions kernel\r
sequences io accessors arrays io.streams.string splitting\r
-combinators accessors calendar calendar.format.macros present ;\r
+combinators calendar calendar.format.macros present ;\r
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
!
! Channels - based on ideas from newsqueak
USING: kernel sequences threads continuations
-random math accessors random ;
+random math accessors ;
IN: channels
TUPLE: channel receivers senders ;
M: adler-32 checksum-bytes ( bytes checksum -- value )
drop
- [ sum 1+ ]
+ [ sum 1 + ]
[ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
[ adler-32-modulus mod ] bi@ 16 shift bitor ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel io strings byte-arrays sequences namespaces math
+parser checksums.hmac tools.test checksums.md5 checksums.sha
+checksums ;
+IN: checksums.hmac.tests
+
+[
+ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
+] [
+ "Hi There" 16 11 <string> md5 hmac-bytes >string ] unit-test
+
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
+[ "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"
+]
+[
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> md5 hmac-bytes >string
+] unit-test
+
+[
+ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
+] [
+ "Hi There" 16 11 <string> sha1 hmac-bytes >string
+] unit-test
+
+[
+ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
+] [
+ "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"
+] [
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> sha1 hmac-bytes >string
+] unit-test
+
+[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
+[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
+
+[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
+[
+ "what do ya want for nothing?"
+ "JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+<PRIVATE
+
+: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
+
+: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
+
+: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
+
+:: 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 ( 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 ( path key checksum -- value )
+ [ binary <file-reader> ] 2dip hmac-stream ;
+
+: hmac-bytes ( seq key checksum -- value )
+ [ binary <byte-reader> ] 2dip hmac-stream ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test checksums.interleave checksums.sha ;
+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
+
--- /dev/null
+! 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 ;
-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
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
+
+[
+ t
+] [
+ <md5-state> "asdf" add-checksum-bytes
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <md5-state> "" add-checksum-bytes
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <md5-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
! 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
-checksums.common checksums.stream combinators ;
+io.encodings.binary math.bitwise checksums accessors
+checksums.common checksums.stream combinators combinators.smart
+specialized-arrays.uint literals hints ;
IN: checksums.md5
-! See http://www.faqs.org/rfcs/rfc1321.html
+SINGLETON: md5
-<PRIVATE
+INSTANCE: md5 stream-checksum
-SYMBOLS: a b c d old-a old-b old-c old-d ;
+TUPLE: md5-state < checksum-state state old-state ;
-: T ( N -- Y )
- sin abs 32 2^ * >integer ; foldable
+: <md5-state> ( -- md5 )
+ md5-state new-checksum-state
+ 64 >>block-size
+ uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+ [ clone >>state ] [ >>old-state ] bi ;
-: 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 ;
+M: md5 initialize-checksum-state drop <md5-state> ;
-: 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 ;
+<PRIVATE
-:: (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
+: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
+
+: update-md5 ( md5 -- )
+ [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
+ [ (>>old-state) ] [ (>>state) ] bi ;
-: F ( X Y Z -- FXYZ )
+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
- pick bitnot bitand [ bitand ] [ bitor ] bi* ;
+ X Y bitand X bitnot Z bitand bitor ; inline
-: 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 ; 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 -- IXYZ )
#! I(X,Y,Z) = Y xor (X v not(Z))
- rot swap bitnot bitor bitxor ;
+ Z bitnot X bitor Y bitxor ; inline
CONSTANT: S11 7
CONSTANT: S12 12
CONSTANT: S43 15
CONSTANT: S44 21
-MACRO: with-md5-round ( ops func -- )
- '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
+CONSTANT: a 0
+CONSTANT: b 1
+CONSTANT: c 2
+CONSTANT: d 3
+
+:: (ABCD) ( x state a b c d k s i quot -- )
+ #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
+ 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 state nth-unsafe w+ 32 bits
+ ] change-nth-unsafe ; inline
-: (process-md5-block-F) ( block -- )
+MACRO: with-md5-round ( ops quot -- )
+ '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
+
+: (process-md5-block-F) ( block state -- )
{
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
[ b c d a 15 S14 16 ]
} [ F ] with-md5-round ;
-: (process-md5-block-G) ( block -- )
+: (process-md5-block-G) ( block state -- )
{
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
[ b c d a 12 S24 32 ]
} [ G ] with-md5-round ;
-: (process-md5-block-H) ( block -- )
+: (process-md5-block-H) ( block state -- )
{
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
[ b c d a 2 S34 48 ]
} [ H ] with-md5-round ;
-: (process-md5-block-I) ( block -- )
+: (process-md5-block-I) ( block state -- )
{
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ;
-: (process-md5-block) ( block -- )
- 4 <groups> [ 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)
+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 } ;
+
+: byte-array>le ( byte-array -- byte-array )
+ little-endian? [
+ dup 4 <sliced-groups> [
+ [ [ 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-le ] [ 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
- ] if ;
-
-: stream>md5 ( -- )
- 64 read [ process-md5-block ] keep
- length 64 = [ stream>md5 ] when ;
+ nip update-md5
+ ] 2bi ;
-: get-md5 ( -- str )
- [ a b c d ] [ get 4 >le ] map concat >byte-array ;
+: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
-PRIVATE>
+M: md5-state clone ( md5 -- new-md5 )
+ call-next-method
+ [ clone ] change-state
+ [ clone ] change-old-state ;
-SINGLETON: md5
+M: md5-state get-checksum ( md5 -- bytes )
+ clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
+ [ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
-INSTANCE: md5 stream-checksum
+M: md5 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <md5-state> ] dip add-checksum-stream get-checksum ;
-M: md5 checksum-stream ( stream -- byte-array )
- drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
+PRIVATE>
"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.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
ABOUT: "checksums.openssl"
+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 }
"Bad checksum test" >byte-array
"no such checksum" <openssl-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
--- /dev/null
+Doug Coleman
--- /dev/null
+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"
--- /dev/null
+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 )
+ 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 <array> concat sha1 checksum-bytes hex-string ] unit-test
+
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+ sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ sha-256 test-checksum
+] unit-test
+
+
+! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
+! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
+
+[
+ t
+] [
+ <sha1-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <sha-256-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <sha-224-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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 literals
+generalizations ;
+IN: checksums.sha
+
+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 <repetition>
+ 20 HEX: 6ed9eba1 <repetition>
+ 20 HEX: 8f1bbcdc <repetition>
+ 20 HEX: ca62c1d6 <repetition>
+ 4 { } nappend-as
+ ]
+
+TUPLE: sha2-state < checksum-state K H word-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+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 ;
+
+<PRIVATE
+
+CONSTANT: a 0
+CONSTANT: b 1
+CONSTANT: c 2
+CONSTANT: d 3
+CONSTANT: e 4
+CONSTANT: f 5
+CONSTANT: g 6
+CONSTANT: h 7
+
+CONSTANT: initial-H-224
+ {
+ HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+ HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+ }
+
+CONSTANT: initial-H-256
+ {
+ HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
+ HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
+ }
+
+CONSTANT: initial-H-384
+ {
+ HEX: cbbb9d5dc1059ed8
+ HEX: 629a292a367cd507
+ HEX: 9159015a3070dd17
+ HEX: 152fecd8f70e5939
+ HEX: 67332667ffc00b31
+ HEX: 8eb44a8768581511
+ HEX: db0c2e0d64f98fa7
+ HEX: 47b5481dbefa4fa4
+ }
+
+CONSTANT: initial-H-512
+ {
+ HEX: 6a09e667f3bcc908
+ HEX: bb67ae8584caa73b
+ HEX: 3c6ef372fe94f82b
+ HEX: a54ff53a5f1d36f1
+ HEX: 510e527fade682d1
+ HEX: 9b05688c2b3e6c1f
+ HEX: 1f83d9abfb41bd6b
+ HEX: 5be0cd19137e2179
+ }
+
+CONSTANT: K-256
+ {
+ HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
+ HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
+ HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
+ HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
+ HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
+ HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
+ HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
+ HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
+ HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
+ HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
+ HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
+ HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
+ HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
+ HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
+ HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
+ HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
+ }
+
+CONSTANT: K-384
+ {
+
+ HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
+ HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
+ HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
+ HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
+ HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
+ HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
+ HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
+ HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
+ HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
+ HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
+ HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
+ HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
+ HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
+ HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
+ HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
+ HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
+ HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
+ HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
+ HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
+ HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+ }
+
+ALIAS: K-512 K-384
+
+: <sha1-state> ( -- sha1-state )
+ sha1-state new-checksum-state
+ 64 >>block-size
+ K-sha1 >>K
+ initial-H-sha1 >>H
+ 4 >>word-size ;
+
+: <sha-224-state> ( -- sha2-state )
+ sha-224-state new-checksum-state
+ 64 >>block-size
+ K-256 >>K
+ initial-H-224 >>H
+ 4 >>word-size ;
+
+: <sha-256-state> ( -- sha2-state )
+ sha-256-state new-checksum-state
+ 64 >>block-size
+ K-256 >>K
+ initial-H-256 >>H
+ 4 >>word-size ;
+
+M: sha1 initialize-checksum-state drop <sha1-state> ;
+
+M: sha-224 initialize-checksum-state drop <sha-224-state> ;
+
+M: sha-256 initialize-checksum-state drop <sha-256-state> ;
+
+: s0-256 ( x -- x' )
+ [
+ [ -7 bitroll-32 ]
+ [ -18 bitroll-32 ]
+ [ -3 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s1-256 ( x -- x' )
+ [
+ [ -17 bitroll-32 ]
+ [ -19 bitroll-32 ]
+ [ -10 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-256 ( x -- x' )
+ [
+ [ -2 bitroll-32 ]
+ [ -13 bitroll-32 ]
+ [ -22 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-256 ( x -- x' )
+ [
+ [ -6 bitroll-32 ]
+ [ -11 bitroll-32 ]
+ [ -25 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s0-512 ( x -- x' )
+ [
+ [ -1 bitroll-64 ]
+ [ -8 bitroll-64 ]
+ [ -7 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s1-512 ( x -- x' )
+ [
+ [ -19 bitroll-64 ]
+ [ -61 bitroll-64 ]
+ [ -6 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-512 ( x -- x' )
+ [
+ [ -28 bitroll-64 ]
+ [ -34 bitroll-64 ]
+ [ -39 bitroll-64 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-512 ( x -- x' )
+ [
+ [ -14 bitroll-64 ]
+ [ -18 bitroll-64 ]
+ [ -41 bitroll-64 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: prepare-M-256 ( n seq -- )
+ {
+ [ [ 16 - ] dip nth ]
+ [ [ 15 - ] dip nth s0-256 ]
+ [ [ 7 - ] dip nth ]
+ [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+ [ ]
+ } 2cleave set-nth ; inline
+
+: prepare-M-512 ( n seq -- )
+ {
+ [ [ 16 - ] dip nth ]
+ [ [ 15 - ] dip nth s0-512 ]
+ [ [ 7 - ] dip nth ]
+ [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+ [ ]
+ } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+ [ bitxor bitand ] keep bitxor ; inline
+
+: maj ( x y z -- x' )
+ [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
+
+: slice3 ( n seq -- a b c )
+ [ dup 3 + ] dip <slice> first3 ; inline
+
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+:: T1-256 ( n M H sha2 -- T1 )
+ n M nth
+ n sha2 K>> nth +
+ e H slice3 ch w+
+ e H nth S1-256 w+
+ h H nth w+ ; inline
+
+: T2-256 ( H -- T2 )
+ [ a swap nth S0-256 ]
+ [ a swap slice3 maj w+ ] bi ; inline
+
+:: T1-512 ( n M H sha2 -- T1 )
+ n M nth
+ n sha2 K>> nth +
+ e H slice3 ch w+
+ e H nth S1-512 w+
+ h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+ [ a swap nth S0-512 ]
+ [ a swap slice3 maj w+ ] bi ; inline
+
+: update-H ( T1 T2 H -- )
+ h g pick exchange
+ g f pick exchange
+ f e pick exchange
+ pick d pick nth w+ e pick set-nth
+ d c pick exchange
+ c b pick exchange
+ b a pick exchange
+ [ w+ a ] dip set-nth ; inline
+
+: prepare-message-schedule ( seq sha2 -- w-seq )
+ [ word-size>> <sliced-groups> [ be> ] map ]
+ [
+ block-size>> [ 0 pad-tail 16 ] keep [a,b) over
+ '[ _ prepare-M-256 ] each
+ ] bi ; inline
+
+:: process-chunk ( M block-size cloned-H sha2 -- )
+ block-size [
+ M cloned-H sha2 T1-256
+ cloned-H T2-256
+ cloned-H update-H
+ ] each
+ 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 ;
+
+: sha-256>checksum ( sha2 -- bytes )
+ H>> 4 seq>byte-array ;
+
+: pad-last-short-block ( state -- )
+ [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
+ [ checksum-block ] curry each ;
+
+PRIVATE>
+
+M: sha-224-state get-checksum
+ clone
+ [ pad-last-short-block ] [ sha-224>checksum ] 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
+ [ <sha-224-state> ] dip add-checksum-stream get-checksum ;
+
+M: sha-256 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <sha-256-state> ] 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 <sliced-groups> [ 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
+ [ <sha1-state> ] dip add-checksum-stream get-checksum ;
--- /dev/null
+SHA checksum algorithms
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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"
+++ /dev/null
-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 <array> 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
+++ /dev/null
-! 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
-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 <array> %
- 20 HEX: 6ed9eba1 <array> %
- 20 HEX: 8f1bbcdc <array> %
- 20 HEX: ca62c1d6 <array> %
- ] { } 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 <slice> 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 <slice> [ 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 <vector> 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 ;
+++ /dev/null
-SHA1 checksum algorithm
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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"
+++ /dev/null
-USING: arrays kernel math namespaces sequences tools.test
-checksums.sha2 checksums ;
-IN: checksums.sha2.tests
-
-: test-checksum ( text identifier -- checksum )
- checksum-bytes hex-string ;
-
-[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
-[
- "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
- sha-224 test-checksum
-] unit-test
-
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
-[ "" sha-256 test-checksum ] unit-test
-
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
-[ "abc" sha-256 test-checksum ] unit-test
-
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
-[ "message digest" sha-256 test-checksum ] unit-test
-
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
-[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
-
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
-[
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
- sha-256 test-checksum
-] unit-test
-
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
-[
- "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
- sha-256 test-checksum
-] unit-test
-
-
-
-
-! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
-! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-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 ;
-IN: checksums.sha2
-
-SINGLETON: sha-224
-SINGLETON: sha-256
-
-INSTANCE: sha-224 checksum
-INSTANCE: sha-256 checksum
-
-TUPLE: sha2-state K H word-size block-size ;
-
-TUPLE: sha2-short < sha2-state ;
-
-TUPLE: sha2-long < sha2-state ;
-
-TUPLE: sha-224-state < sha2-short ;
-
-TUPLE: sha-256-state < sha2-short ;
-
-<PRIVATE
-
-CONSTANT: a 0
-CONSTANT: b 1
-CONSTANT: c 2
-CONSTANT: d 3
-CONSTANT: e 4
-CONSTANT: f 5
-CONSTANT: g 6
-CONSTANT: h 7
-
-CONSTANT: initial-H-224
- {
- HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
- HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
- }
-
-CONSTANT: initial-H-256
- {
- HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
- HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
- }
-
-CONSTANT: initial-H-384
- {
- HEX: cbbb9d5dc1059ed8
- HEX: 629a292a367cd507
- HEX: 9159015a3070dd17
- HEX: 152fecd8f70e5939
- HEX: 67332667ffc00b31
- HEX: 8eb44a8768581511
- HEX: db0c2e0d64f98fa7
- HEX: 47b5481dbefa4fa4
- }
-
-CONSTANT: initial-H-512
- {
- HEX: 6a09e667f3bcc908
- HEX: bb67ae8584caa73b
- HEX: 3c6ef372fe94f82b
- HEX: a54ff53a5f1d36f1
- HEX: 510e527fade682d1
- HEX: 9b05688c2b3e6c1f
- HEX: 1f83d9abfb41bd6b
- HEX: 5be0cd19137e2179
- }
-
-CONSTANT: K-256
- {
- HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
- HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
- HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
- HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
- HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
- HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
- HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
- HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
- HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
- HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
- HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
- HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
- HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
- HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
- HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
- HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
- }
-
-CONSTANT: K-384
- {
-
- HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
- HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
- HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
- HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
- HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
- HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
- HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
- HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
- HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
- HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
- HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
- HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
- HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
- HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
- HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
- HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
- HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
- HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
- HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
- HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
- }
-
-ALIAS: K-512 K-384
-
-: s0-256 ( x -- x' )
- [
- [ -7 bitroll-32 ]
- [ -18 bitroll-32 ]
- [ -3 shift ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: s1-256 ( x -- x' )
- [
- [ -17 bitroll-32 ]
- [ -19 bitroll-32 ]
- [ -10 shift ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: S0-256 ( x -- x' )
- [
- [ -2 bitroll-32 ]
- [ -13 bitroll-32 ]
- [ -22 bitroll-32 ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: S1-256 ( x -- x' )
- [
- [ -6 bitroll-32 ]
- [ -11 bitroll-32 ]
- [ -25 bitroll-32 ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: s0-512 ( x -- x' )
- [
- [ -1 bitroll-64 ]
- [ -8 bitroll-64 ]
- [ -7 shift ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: s1-512 ( x -- x' )
- [
- [ -19 bitroll-64 ]
- [ -61 bitroll-64 ]
- [ -6 shift ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: S0-512 ( x -- x' )
- [
- [ -28 bitroll-64 ]
- [ -34 bitroll-64 ]
- [ -39 bitroll-64 ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: S1-512 ( x -- x' )
- [
- [ -14 bitroll-64 ]
- [ -18 bitroll-64 ]
- [ -41 bitroll-64 ] tri
- ] [ bitxor ] reduce-outputs ; inline
-
-: process-M-256 ( n seq -- )
- {
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-256 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
- [ ]
- } 2cleave set-nth ; inline
-
-: process-M-512 ( n seq -- )
- {
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-512 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
- [ ]
- } 2cleave set-nth ; inline
-
-: ch ( x y z -- x' )
- [ bitxor bitand ] keep bitxor ; inline
-
-: maj ( x y z -- x' )
- [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
-
-: slice3 ( n seq -- a b c )
- [ dup 3 + ] dip <slice> first3 ; inline
-
-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 <string> % ]
- [ 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 <string> % ]
- [ 3 shift 8 >be % ] bi
- ] "" make append ;
-
-: seq>byte-array ( seq n -- string )
- '[ _ >be ] map B{ } join ;
-
-:: T1-256 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
- e H slice3 ch w+
- e H nth S1-256 w+
- h H nth w+ ; inline
-
-: T2-256 ( H -- T2 )
- [ a swap nth S0-256 ]
- [ a swap slice3 maj w+ ] bi ; inline
-
-:: T1-512 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
- e H slice3 ch w+
- e H nth S1-512 w+
- h H nth w+ ; inline
-
-: T2-512 ( H -- T2 )
- [ a swap nth S0-512 ]
- [ a swap slice3 maj w+ ] bi ; inline
-
-: update-H ( T1 T2 H -- )
- h g pick exchange
- g f pick exchange
- f e pick exchange
- pick d pick nth w+ e pick set-nth
- d c pick exchange
- c b pick exchange
- b a pick exchange
- [ w+ a ] dip set-nth ; inline
-
-: prepare-message-schedule ( seq sha2 -- w-seq )
- [ word-size>> <sliced-groups> [ be> ] map ]
- [
- block-size>> [ 0 pad-tail 16 ] keep [a,b) over
- '[ _ process-M-256 ] each
- ] bi ; inline
-
-:: process-chunk ( M block-size cloned-H sha2 -- )
- block-size [
- M cloned-H sha2 T1-256
- cloned-H T2-256
- cloned-H update-H
- ] 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 ;
-
-: byte-array>sha2 ( bytes state -- )
- [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
- [ sha2-steps ] bi ;
-
-: <sha-224-state> ( -- sha2-state )
- sha-224-state new
- K-256 >>K
- initial-H-224 >>H
- 4 >>word-size
- 64 >>block-size ;
-
-: <sha-256-state> ( -- sha2-state )
- sha-256-state new
- K-256 >>K
- initial-H-256 >>H
- 4 >>word-size
- 64 >>block-size ;
-
-PRIVATE>
-
-M: sha-224 checksum-bytes
- drop <sha-224-state>
- [ byte-array>sha2 ]
- [ H>> 7 head 4 seq>byte-array ] bi ;
-
-M: sha-256 checksum-bytes
- drop <sha-256-state>
- [ byte-array>sha2 ]
- [ H>> 4 seq>byte-array ] bi ;
+++ /dev/null
-SHA2 checksum algorithm
{ "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:"
{ $subsection <growing-circular> }
"Changing the start index:"
{ $subsection change-circular-start }
+{ $subsection rotate-circular }
"Pushing new elements:"
{ $subsection push-circular }
{ $subsection push-growing-circular } ;
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
+[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
#! 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 ;
: 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 ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
! 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
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
-: script-mode ( -- ) ;
-
[ default-cli-args ] "command-line" add-init-hook
-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
-! 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 compiler.cfg.local ;
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
!
! 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
! 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
#! 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 ;
: 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 ;
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 ( live-in -- )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
-
+
0 ac-counter set
next-ac heap-ac set
- ds-loc next-ac set-ac
- rs-loc next-ac set-ac ;
+ [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##load-reference analyze-aliases*
+M: ##flushable analyze-aliases*
dup dst>> set-heap-ac ;
-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 ;
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
+ 2nip \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
] 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) ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
-: alias-analysis ( insns -- insns' )
- init-alias-analysis
+: alias-analysis-step ( insns -- insns' )
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
+
+: alias-analysis ( cfg -- cfg' )
+ [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
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 ] }
+ { [ terminate-call? ] [ ##call stop-iterating ] }
{ [ 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
+ ##branch
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 )
} 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 ;
-
-: <dispatch-block> ( -- word )
- gensym dup t "inlined-block" set-word-prop ;
-
M: #dispatch emit-node
- tail-call? [
- emit-dispatch stop-iterating
- ] [
- current-word get <dispatch-block> [
- [
- begin-word
- emit-dispatch
- ] with-cfg-builder
- ] keep emit-call
- ] if ;
+ ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
! #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
-! 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
{ successors vector }
{ predecessors vector } ;
-: <basic-block> ( -- basic-block )
+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 ;
-TUPLE: cfg { entry basic-block } word label ;
+: add-instructions ( bb quot -- )
+ [ instructions>> building ] dip '[
+ building get pop
+ _ dip
+ building get push
+ ] with-variable ; inline
+
+TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
-C: <cfg> cfg
+: <cfg> ( entry word label -- cfg ) f f cfg boa ;
-TUPLE: mr { instructions array } word label spill-counts ;
+TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )
mr new
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 compiler.cfg.liveness
+combinators.short-circuit accessors math sequences sets assocs ;
+IN: compiler.cfg.checker
+
+ERROR: last-insn-not-a-jump insn ;
+
+: check-last-instruction ( bb -- )
+ last dup {
+ [ ##branch? ]
+ [ ##dispatch? ]
+ [ ##conditional-branch? ]
+ [ ##compare-imm-branch? ]
+ [ ##return? ]
+ [ ##callback-return? ]
+ [ ##jump? ]
+ [ ##call? ]
+ } 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 ;
+
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+ dup successors>> [ predecessors>> memq? ] with all?
+ [ bad-successors ] unless ;
+
+: check-basic-block ( bb -- )
+ [ instructions>> check-last-instruction ]
+ [ instructions>> check-loop-entry ]
+ [ check-successors ]
+ tri ;
+
+ERROR: bad-live-in ;
+
+ERROR: undefined-values uses defs ;
+
+: check-mr ( mr -- )
+ ! Check that every used register has a definition
+ instructions>>
+ [ [ uses-vregs ] map concat ]
+ [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+ 2dup subset? [ 2drop ] [ undefined-values ] if ;
+
+: check-cfg ( cfg -- )
+ compute-liveness
+ [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
+ [ [ check-basic-block ] each-basic-block ]
+ [ flatten-cfg check-mr ]
+ tri ;
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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.rpo ;
+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: update-liveness-graph ( insn -- )
+
+M: ##flushable update-liveness-graph
+ [ 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 update-liveness-graph 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 ( cfg -- cfg' )
+ init-dead-code
+ [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+ [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
+ [ ]
+ tri ;
\ No newline at end of file
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
+++ /dev/null
-Dead-code elimination
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 )
M: word test-cfg
[ build-tree optimize-tree ] keep build-cfg ;
-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
] map ;
: insn. ( insn -- )
- tuple>array allocate-registers? get [ but-last ] unless
- [ pprint bl ] each nl ;
+ tuple>array [ pprint bl ] each nl ;
: mr. ( mrs -- )
[
-! 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: ##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 ;
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: insn uses-vregs drop f ;
+! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
##fixnum-overflow
##conditional-branch
##compare-imm-branch
+##phi
+##gc
_conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+ 2dup [ number>> ] 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 reverse-post-order
+ unclip dup set-idom drop '[ _ iterate ] loop ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 prefix ]
+ change-instructions drop
+ ] [ drop ] if ;
+
+: insert-gc-checks ( cfg -- cfg' )
+ dup [ insert-gc-check ] each-basic-block ;
\ No newline at end of file
: ^^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
-! 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.liveness compiler.cfg.local ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
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 ;
+ 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 ( cfg -- cfg' )
+ [ drop ] [ height-step ] local-optimization ;
-! 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
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 ;
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 } ;
spill-counts ;
INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+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 } ;
! 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 ;
+INSN: ##alien-global < ##flushable symbol library ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##loop-entry ;
+INSN: ##phi < ##pure inputs ;
+
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
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 ;
-
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 ;
"insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect in>> but-last f <effect> ;
+ boa-effect in>> 2 head* f <effect> ;
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 ;
[ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
- dup node-input-infos peek literal>>
+ dup node-input-infos last literal>>
dup array? [
nip
ds-drop
: >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 ;
: 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 last
+ rest-slice [ f ] [ first #terminate? ] if-empty ;
! 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
: 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 -- )
] [ 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 seq>> 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 ;
+
+: <active-intervals> ( -- obj )
+ V{ } clone active-intervals boa ;
: init-assignment ( live-intervals -- )
- V{ } clone active-intervals set
+ <active-intervals> active-intervals set
<min-heap> 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 ;
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
- dup peek 1 + CHAR: space <string>
+ dup last 1 + CHAR: space <string>
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
: interval-picture ( interval -- str )
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
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 ;
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 ] [
-! 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 ;
! 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 ;
-! 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
[ [ <live-interval> ] 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
-! 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
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
-: linearize-insns ( basic-block -- )
- dup instructions>> [ linearize-insn ] with each ; inline
+: linearize-basic-block ( bb -- )
+ [ number>> _label ]
+ [ dup instructions>> [ linearize-insn ] with each ]
+ bi ;
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.
: 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 ;
[ 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 last (>>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 ;
-
-: gc? ( bb -- ? )
- instructions>> [
- class {
- ##allot
- ##integer>bignum
- ##box-float
- ##box-alien
- } memq?
- ] any? ;
-
-: linearize-basic-block ( bb -- )
- [ number>> _label ]
- [ gc? [ _gc ] when ]
- [ linearize-insns ]
- tri ;
-
-: linearize-basic-blocks ( rpo -- insns )
- [ [ linearize-basic-block ] each ] { } make ;
-
-: build-mr ( cfg -- mr )
- [ entry>> reverse-post-order linearize-basic-blocks ]
- [ word>> ] [ label>> ]
- tri <mr> ;
+ [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+
+M: ##dispatch linearize-insn
+ swap
+ [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
+ [ successors>> [ number>> _dispatch-label ] each ]
+ bi* ;
+
+: linearize-basic-blocks ( cfg -- insns )
+ [
+ [ [ linearize-basic-block ] each-basic-block ]
+ [ spill-counts>> _spill-counts ]
+ bi
+ ] { } make ;
+
+: flatten-cfg ( cfg -- mr )
+ [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
+ <mr> ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
+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 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
+
+: 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 ( instructions -- seq )
+ [ ##phi? not ] filter [ uses-vregs ] map-unique ;
+
+: kill-set ( instructions -- seq )
+ [ [ defs-vregs ] [ temp-vregs ] bi append ] 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? )
+ [ [ 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? )
+ [ compute-live-out ] 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 ( cfg -- cfg' )
+ <hashed-dlist> work-list set
+ H{ } clone live-ins set
+ H{ } clone phi-live-ins set
+ H{ } clone live-outs set
+ dup post-order add-to-work-list
+ work-list get [ liveness-step ] slurp-deque ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ; inline
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+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 ]
+ [ 10000 [ ] times ]
+} [
+ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+] each
-! 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 namespaces
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
+compiler.cfg.phi-elimination ;
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
[
- 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
+ normalize-height
+ stack-analysis
+ compute-liveness
+ alias-analysis
+ value-numbering
+ eliminate-dead-code
+ eliminate-write-barriers
+ eliminate-phis
+ ] with-scope ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo 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 ( cfg -- cfg' )
+ dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
-! 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 ;
+ dup [ predecessors-step ] each-basic-block ;
-! 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.instructions ;
+assocs fry compiler.cfg compiler.cfg.instructions ;
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>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
-: post-order ( bb -- blocks )
- [ post-order-traversal ] { } make ;
-
: number-blocks ( blocks -- )
- [ >>number drop ] each-index ;
+ dup length iota <reversed>
+ [ >>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 ( bb -- blocks )
- H{ } clone visited [
- post-order <reversed> dup number-blocks
- ] with-variable ; inline
+: reverse-post-order ( cfg -- blocks )
+ post-order <reversed> ; 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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.height compiler.cfg.rpo
+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
+: check-for-redundant-ops ( cfg -- )
+ [
+ instructions>>
+ [
+ [ ##peek? ] filter [ loc>> ] map duplicates empty?
+ [ "Redundant peeks" throw ] unless
+ ] [
+ [ ##replace? ] filter [ loc>> ] map duplicates empty?
+ [ "Redundant replaces" throw ] unless
+ ] bi
+ ] each-basic-block ;
+
+: test-stack-analysis ( quot -- cfg )
+ dup cfg? [ test-cfg first ] unless
+ compute-predecessors
+ delete-useless-blocks
+ delete-useless-conditionals
+ normalize-height
+ stack-analysis
+ dup check-cfg
+ dup check-for-redundant-ops ;
+
+: linearize ( cfg -- mr )
+ flatten-cfg instructions>> ;
+
+[ ] [ [ ] 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!
+[ 1 ] [ [ 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
+
+! Make sure the replace stores a value with the right height
+[ ] [
+ [ [ . ] [ 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 eliminate-dead-code linearize
+ [ [ ##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
+ [ [ ##load-immediate? ] count 2 assert= ]
+ [ [ ##peek? ] count 1 assert= ]
+ [ [ ##replace? ] count 1 assert= ]
+ tri
+] unit-test
+
+! Sync before a back-edge, not after
+! ##peeks should be inserted before a ##loop-entry
+! Don't optimize out the constants
+[ 1 t ] [
+ [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
+ [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+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 actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
+
+: <state> ( -- state )
+ state new
+ H{ } clone >>locs>vregs
+ H{ } clone >>actual-locs>vregs
+ H{ } clone >>changed-locs
+ 0 >>ds-height
+ 0 >>rs-height ;
+
+M: state clone
+ call-next-method
+ [ clone ] change-locs>vregs
+ [ 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 ] [ actual-locs>vregs>> set-at ] 3bi ;
+
+: changed-loc ( loc -- )
+ state get changed-locs>> conjoin ;
+
+: 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 ds-height>> ;
+M: rs-loc height-for drop state get rs-height>> ;
+
+: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
+M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
+
+GENERIC: untranslate-loc ( loc -- loc' )
+
+M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
+M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+
+: redundant-replace? ( vreg loc -- ? )
+ 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 ] [ untranslate-loc ##replace ] if
+ ] assoc-each ;
+
+: clear-state ( state -- )
+ [ locs>vregs>> clear-assoc ]
+ [ actual-locs>vregs>> clear-assoc ]
+ [ changed-locs>> clear-assoc ]
+ tri ;
+
+ERROR: poisoned-state state ;
+
+: sync-state ( -- )
+ state get {
+ [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+ [ save-changed-locs ]
+ [ clear-state ]
+ } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+ ##flushable
+ ##effect ;
+
+M: neutral-insn visit , ;
+
+UNION: sync-if-back-edge
+ ##branch
+ ##conditional-branch
+ ##compare-imm-branch
+ ##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
+ sync-state? [ sync-state ] when , ;
+
+: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
+
+M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
+
+: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
+
+M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
+
+: 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 ] bi ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+ ##jump
+ ##return
+ ##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 ;
+
+M: ##alien-callback visit , ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
+
+ERROR: must-equal-failed seq ;
+
+: must-equal ( seq -- elt )
+ dup all-equal? [ first ] [ must-equal-failed ] if ;
+
+: merge-heights ( state predecessors states -- state )
+ nip
+ [ [ ds-height>> ] map must-equal >>ds-height ]
+ [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+
+: insert-peek ( predecessor loc -- vreg )
+ ! XXX critical edges
+ '[ _ ^^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 ] [ ^^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 (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 )
+ 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 ;
+
+ERROR: cannot-merge-poisoned states ;
+
+: multiple-predecessors ( bb states -- state )
+ dup [ not ] any? [
+ [ <state> ] 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 [ initial-state ] }
+ { 1 [ single-predecessor ] }
+ [ drop multiple-predecessors ]
+ } case ;
+
+: block-in-state ( bb -- states )
+ dup predecessors>> state-out get '[ _ at ] map merge-states ;
+
+: set-block-in-state ( state bb -- )
+ [ clone ] dip state-in get set-at ;
+
+: 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
+ ! so we wrap the whole thing with a 'make'
+ [
+ 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-variable
+ ] 2bi
+ ] V{ } make >>instructions drop ;
+
+: stack-analysis ( cfg -- cfg' )
+ [
+ H{ } clone copies set
+ H{ } clone state-in set
+ H{ } clone state-out set
+ dup [ visit-block ] each-basic-block
+ ] with-scope ;
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
-! 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
! 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
+: convert-two-operand/integer ( insn -- )
+ [ [ 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
+: convert-two-operand/float ( insn -- )
+ [ [ 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 ;
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 ;
--- /dev/null
+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 compute-predecessors delete-useless-blocks check-cfg ] unit-test
+] each
\ No newline at end of file
-! 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 ;
+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
] 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 ]
: 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 -- 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 ] [
- peek class {
+ last class {
##compare-branch
##compare-imm-branch
##compare-float-branch
: 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 -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
- ] each-basic-block ;
+ ] each-basic-block
+ f >>post-order ;
: 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 ;
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 ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- 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 ;
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 ;
: 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 -- ? )
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
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
- cc= f i \ ##compare-imm boa ;
+ cc= i \ ##compare-imm new-insn ;
M: ##compare rewrite
dup flip-comparison? [
: 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 ;
] when
] when ;
-: dispatch-offset ( expr -- n )
- [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
- \ ##sub-imm eq? [ neg ] when ;
-
-: add-dispatch-offset? ( insn -- expr ? )
- src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
-
-M: ##dispatch rewrite
- dup add-dispatch-offset? [
- [ clone ] dip
- [ in1>> vn>vreg >>src ]
- [ dispatch-offset '[ _ + ] change-offset ] bi
- ] [ drop ] if ;
-
M: insn rewrite ;
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 )
[
} 1|| [ f >>temp ] when
] map ;
+: test-value-numbering ( insns -- insns )
+ { } init-value-numbering
+ value-numbering-step ;
+
[
{
T{ ##peek f V int-regs 45 D 1 }
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
[
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 =
+ T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ } dup test-value-numbering =
] unit-test
[ t ] [
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
[
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
[
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
[
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
[
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
[
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
+
+[
+ {
+ 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
! 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
compiler.cfg.value-numbering.propagate
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
-: value-numbering ( insns -- insns' )
+: number-input-values ( live-in -- )
+ [ [ f next-input-expr simplify ] dip set-vn ] each ;
+
+: init-value-numbering ( live-in -- )
init-value-graph
init-expressions
+ number-input-values ;
+
+: value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite propagate ] bi ] map ;
+
+: value-numbering ( cfg -- cfg' )
+ [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
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 )
+ write-barriers-step ;
+
[
{
T{ ##peek f V int-regs 4 D 0 f }
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
[
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
[
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
-! 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 ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
M: insn eliminate-write-barrier ;
-: eliminate-write-barriers ( insns -- insns' )
+: write-barriers-step ( insns -- insns' )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
+
+: eliminate-write-barriers ( cfg -- cfg' )
+ [ drop ] [ write-barriers-step ] local-optimization ;
--- /dev/null
+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
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
-: generate-insns ( insns -- code )
- [
- [
- dup regs>> registers set
- generate-insn
- ] each
- ] { } make fixup ;
-
TUPLE: asm label code calls ;
SYMBOL: calls
: init-generator ( word -- )
H{ } clone labels set
- V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ;
-: generate ( mr -- asm )
+: generate-insns ( asm -- code )
[
- [ label>> ]
[ word>> init-generator ]
- [ instructions>> generate-insns ] tri
- calls get
+ [
+ instructions>>
+ [ [ regs>> registers set ] [ generate-insn ] bi ] each
+ ] bi
+ ] with-fixup ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ] [ generate-insns ] bi calls get
asm boa
] with-scope ;
M: ##return generate-insn drop %return ;
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
+M: _dispatch generate-insn
+ [ src>> register ] [ temp>> register ] bi %dispatch ;
-M: ##dispatch generate-insn
- [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+M: _dispatch-label generate-insn
+ label>> lookup-label %dispatch-label ;
: >slot< ( insn -- dst obj slot tag )
{
[ 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 ;
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
- id>> lookup-label , ;
+ id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
IN: compiler.codegen.fixup
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
-: compiled-offset ( -- n ) building get length ;
+: add-literal ( obj -- ) literal-table get push ;
-SYMBOL: relocation-table
+! Labels
SYMBOL: label-table
-M: label fixup* compiled-offset >>offset drop ;
+TUPLE: label offset ;
-TUPLE: label-fixup label class ;
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
-: label-fixup ( label class -- ) \ label-fixup boa , ;
+: compiled-offset ( -- n ) building get length ;
-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 ;
+: resolve-label ( label/name -- )
+ dup label? [ get ] unless
+ compiled-offset >>offset drop ;
-TUPLE: rel-fixup class type ;
+: offset-for-class ( class -- n )
+ rc-absolute-cell = cell 4 ? compiled-offset swap - ;
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+ dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
+SYMBOL: relocation-table
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
-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 ;
-
-M: integer fixup* , ;
+: add-relocation-entry ( type class offset -- )
+ { 0 24 28 } bitfield relocation-table get push-4 ;
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+ swap dup offset-for-class add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-here ( offset class -- )
[ add-literal ] dip rt-here rel-fixup ;
-: init-fixup ( -- )
- BV{ } clone relocation-table set
- V{ } clone label-table set ;
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+ label>> offset>> [ "Unresolved label" throw ] unless* ;
-: resolve-labels ( labels -- labels' )
- [
- first3 offset>>
- [ "Unresolved label" throw ] unless*
- 3array
- ] map concat ;
+: resolve-absolute-label ( label-fixup -- )
+ dup resolve-offset neg add-literal
+ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- label )
+ [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+ [ class>> rc-absolute? ] partition
+ [ [ resolve-absolute-label ] each ]
+ [ [ resolve-relative-label ] map concat ]
+ bi* ;
+
+: init-fixup ( -- )
+ V{ } clone literal-table set
+ V{ } clone label-table set
+ BV{ } clone relocation-table set ;
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
[
init-fixup
- [ fixup* ] each
+ call
+ label-table [ resolve-labels ] change
literal-table get >array
relocation-table get >byte-array
- label-table get resolve-labels
- ] B{ } make 4array ;
+ label-table get
+ ] B{ } make 4array ; inline
! 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
-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.codegen
-compiler.utilities ;
+generic.single combinators deques search-deques macros
+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
: not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ;
+: deoptimize* ( word -- * )
+ dup def>> deoptimize-with ;
+
: ignore-error ( word error -- * )
- drop
- [ clear-compiler-error ]
- [ dup def>> deoptimize-with ]
- bi ;
+ drop [ clear-compiler-error ] [ deoptimize* ] bi ;
: remember-error ( word error -- * )
[ swap <compiler-error> compiler-error ]
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
-: frontend ( word -- nodes )
+: frontend ( word -- tree )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
- contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
- ] [ dup def>> deoptimize-with ] if ;
+ contains-breakpoints? [ nip deoptimize* ] [ drop ] if
+ ] [ deoptimize* ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
[ compile-dependencies ]
bi ;
-: backend ( nodes word -- )
+: backend ( tree word -- )
build-cfg [
optimize-cfg
build-mr
- convert-two-operand
- linear-scan
- build-stack-frame
generate
save-asm
] each ;
-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
-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
[ 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 ;
[ 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 ]
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
\ +-integer-fixnum inlined?
] unit-test
-[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
-
[ t ] [
[
[ no-cond ] 1
: 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 )
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker ;
+FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger
propagate
compute-def-use
dup check-nodes
- peek node-input-infos ;
+ last node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
! 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
[ 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
: 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 -- )
! 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
: 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 ;
] 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 ;
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*
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
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< ;
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>> \ <tuple-boa> eq? [
- dup in-d>> peek node-value-info
+ dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
! 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 ;
{ 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
] 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 } ] [
[ ] [ 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
[ 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, ;
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
[ 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 ;
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays assocs constructors fry\r
+hashtables io kernel locals math math.order math.parser\r
+math.ranges multiline sequences ;\r
+IN: compression.huffman\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+<PRIVATE\r
+\r
+! huffman codes\r
+\r
+TUPLE: huffman-code\r
+ { value }\r
+ { size }\r
+ { code } ;\r
+\r
+: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
+: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;\r
+: next-code ( code -- ) [ 1+ ] change-code drop ;\r
+\r
+:: all-patterns ( huff n -- seq )\r
+ n log2 huff size>> - :> free-bits\r
+ free-bits 0 >\r
+ [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]\r
+ [ huff code>> free-bits neg 2^ /i 1array ] if ;\r
+\r
+:: huffman-each ( tdesc quot: ( huff -- ) -- )\r
+ <huffman-code> :> code\r
+ tdesc\r
+ [\r
+ code next-size\r
+ [ code (>>value) code clone quot call code next-code ] each\r
+ ] each ; inline\r
+\r
+: update-reverse-table ( huff n table -- )\r
+ [ drop all-patterns ]\r
+ [ nip '[ _ swap _ set-at ] each ] 3bi ;\r
+\r
+:: reverse-table ( tdesc n -- rtable )\r
+ n f <array> <enum> :> table\r
+ tdesc [ n table update-reverse-table ] huffman-each\r
+ table seq>> ;\r
+\r
+:: huffman-table ( tdesc max -- table )\r
+ max f <array> :> table\r
+ tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each\r
+ table ;\r
+\r
+PRIVATE>\r
+\r
+! decoder\r
+\r
+TUPLE: huffman-decoder\r
+ { bs }\r
+ { tdesc }\r
+ { rtable }\r
+ { bits/level } ;\r
+\r
+CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )\r
+ 16 >>bits/level\r
+ [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;\r
+\r
+: read1-huff ( decoder -- elt )\r
+ 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last\r
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
+\r
+! %remove\r
+: reverse-bits ( value bits -- value' )\r
+ [ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;\r
+\r
+: read1-huff2 ( decoder -- elt )\r
+ 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last\r
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
+\r
+/*\r
+: huff>string ( code -- str )\r
+ [ value>> number>string ]\r
+ [ [ code>> ] [ size>> bits>string ] bi ] bi\r
+ " = " glue ;\r
+\r
+: huff. ( code -- ) huff>string print ;\r
+\r
+:: rtable. ( rtable -- )\r
+ rtable length>> log2 :> n\r
+ rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;\r
+*/\r
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays assocs byte-arrays\r
+byte-vectors combinators constructors fry grouping hashtables\r
+compression.huffman images io.binary kernel locals\r
+math math.bitwise math.order math.ranges multiline sequences\r
+sorting ;\r
+IN: compression.inflate\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+<PRIVATE\r
+\r
+: enum>seq ( assoc -- seq )\r
+ dup keys [ ] [ max ] map-reduce 1 + f <array>\r
+ [ '[ swap _ set-nth ] assoc-each ] keep ;\r
+\r
+ERROR: zlib-unimplemented ;\r
+ERROR: bad-zlib-data ;\r
+ERROR: bad-zlib-header ;\r
+ \r
+:: check-zlib-header ( data -- )\r
+ 16 data bs:peek 2 >le be> 31 mod ! checksum\r
+ 0 assert= \r
+ 4 data bs:read 8 assert= ! compression method: deflate\r
+ 4 data bs:read ! log2(max length)-8, 32K max\r
+ 7 <= [ bad-zlib-header ] unless \r
+ 5 data bs:seek ! drop check bits \r
+ 1 data bs:read 0 assert= ! dictionnary - not allowed in png\r
+ 2 data bs:seek ! compression level; ignore\r
+ ;\r
+\r
+:: default-table ( -- table )\r
+ 0 <hashtable> :> table\r
+ 0 143 [a,b] 280 287 [a,b] append 8 table set-at\r
+ 144 255 [a,b] >array 9 table set-at\r
+ 256 279 [a,b] >array 7 table set-at \r
+ table enum>seq 1 tail ;\r
+\r
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }\r
+\r
+: get-table ( values size -- table ) \r
+ 16 f <array> clone <enum> \r
+ [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;\r
+\r
+:: decode-huffman-tables ( bitstream -- tables )\r
+ 5 bitstream bs:read 257 +\r
+ 5 bitstream bs:read 1 +\r
+ 4 bitstream bs:read 4 +\r
+ clen-shuffle swap head\r
+ dup [ drop 3 bitstream bs:read ] map\r
+ get-table\r
+ bitstream swap <huffman-decoder> \r
+ [ 2dup + ] dip swap :> k!\r
+ '[\r
+ _ read1-huff2\r
+ {\r
+ { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }\r
+ { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }\r
+ { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }\r
+ [ ]\r
+ } cond\r
+ dup array? [ dup second ] [ 1 ] if\r
+ k swap - dup k! 0 >\r
+ ] \r
+ [ ] produce swap suffix\r
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce\r
+ [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat\r
+ nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;\r
+ \r
+CONSTANT: length-table\r
+ {\r
+ 3 4 5 6 7 8 9 10\r
+ 11 13 15 17\r
+ 19 23 27 31\r
+ 35 43 51 59\r
+ 67 83 99 115\r
+ 131 163 195 227 258\r
+ }\r
+\r
+CONSTANT: dist-table\r
+ {\r
+ 1 2 3 4 \r
+ 5 7 9 13 \r
+ 17 25 33 49\r
+ 65 97 129 193\r
+ 257 385 513 769\r
+ 1025 1537 2049 3073\r
+ 4097 6145 8193 12289\r
+ 16385 24577\r
+ }\r
+\r
+: nth* ( n seq -- elt )\r
+ [ length 1- swap - ] [ nth ] bi ;\r
+\r
+:: inflate-lz77 ( seq -- bytes )\r
+ 1000 <byte-vector> :> bytes\r
+ seq\r
+ [\r
+ dup array?\r
+ [ first2 '[ _ 1- bytes nth* bytes push ] times ]\r
+ [ bytes push ] if\r
+ ] each \r
+ bytes ;\r
+\r
+:: inflate-dynamic ( bitstream -- bytes )\r
+ bitstream decode-huffman-tables\r
+ bitstream '[ _ swap <huffman-decoder> ] map :> tables\r
+ [\r
+ tables first read1-huff2\r
+ dup 256 >\r
+ [\r
+ dup 285 = \r
+ [ ]\r
+ [ \r
+ dup 264 > \r
+ [ \r
+ dup 261 - 4 /i dup 5 > \r
+ [ bad-zlib-data ] when \r
+ bitstream bs:read 2array \r
+ ]\r
+ when \r
+ ] if\r
+ ! 5 bitstream read-bits ! distance\r
+ tables second read1-huff2\r
+ dup 3 > \r
+ [ \r
+ dup 2 - 2 /i dup 13 >\r
+ [ bad-zlib-data ] when\r
+ bitstream bs:read 2array\r
+ ] \r
+ when\r
+ 2array\r
+ ]\r
+ when\r
+ dup 256 = not\r
+ ]\r
+ [ ] produce nip\r
+ [\r
+ dup array? [\r
+ first2\r
+ [ \r
+ dup array? [ first2 ] [ 0 ] if\r
+ [ 257 - length-table nth ] [ + ] bi*\r
+ ] \r
+ [\r
+ dup array? [ first2 ] [ 0 ] if\r
+ [ dist-table nth ] [ + ] bi*\r
+ ] bi*\r
+ 2array\r
+ ] when\r
+ ] map ;\r
+ \r
+: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;\r
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;\r
+\r
+:: inflate-loop ( bitstream -- bytes )\r
+ [ 1 bitstream bs:read 0 = ]\r
+ [\r
+ bitstream\r
+ 2 bitstream bs:read\r
+ { \r
+ { 0 [ inflate-raw ] }\r
+ { 1 [ inflate-static ] }\r
+ { 2 [ inflate-dynamic ] }\r
+ { 3 [ bad-zlib-data f ] }\r
+ }\r
+ case\r
+ ]\r
+ [ produce ] keep call suffix concat ;\r
+ \r
+ ! [ produce ] keep dip swap suffix\r
+\r
+:: paeth ( a b c -- p ) \r
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map \r
+ sort-keys first second ;\r
+ \r
+:: png-unfilter-line ( prev curr filter -- curr' )\r
+ prev :> c\r
+ prev 3 tail-slice :> b\r
+ curr :> a\r
+ curr 3 tail-slice :> x\r
+ x length [0,b)\r
+ filter\r
+ {\r
+ { 0 [ drop ] }\r
+ { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }\r
+ { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }\r
+ { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }\r
+ { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }\r
+ \r
+ } case \r
+ curr 3 tail ;\r
+\r
+PRIVATE>\r
+\r
+! for debug -- shows residual values\r
+: reverse-png-filter' ( lines -- filtered )\r
+ [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip\r
+ concat [ 128 + 256 wrap ] map ;\r
+ \r
+: reverse-png-filter ( lines -- filtered )\r
+ dup first [ 0 ] replicate prefix\r
+ [ { 0 0 } prepend ] map\r
+ 2 clump [\r
+ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line\r
+ ] map concat ;\r
+\r
+: zlib-inflate ( bytes -- bytes )\r
+ bs:<lsb0-bit-reader>\r
+ [ check-zlib-header ] [ inflate-loop ] bi\r
+ inflate-lz77 ;\r
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bitstreams byte-vectors combinators io
+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 ] }
[ 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 ;
-
-: <lzw-compress> ( input -- obj )
- lzw new
- swap >>input
- binary <byte-writer> <bitstream-writer> >>output
- reset-lzw-compress ;
+ initial-uncompress-table >>table ;
: <lzw-uncompress> ( input -- obj )
lzw new
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>> write-bits ] 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>> write-bits ] bi
- ]
- [ (lzw-compress-chars) ]
- [
- [ k>> ]
- [ lzw-bit-width-compress ]
- [ output>> write-bits ] tri
- ]
- [
- [ end-of-information ] dip
- [ lzw-bit-width-compress ]
- [ output>> write-bits ] bi
- ]
- [ ]
- } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
-
-: lzw-compress ( byte-array -- seq )
- binary <byte-reader> <lzw-compress>
- [ lzw-compress-chars ] [ output>> stream>> ] bi ;
-
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
: 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:read ;
DEFER: lzw-uncompress-char
: handle-clear-code ( lzw -- )
] if* ;
: lzw-uncompress ( seq -- byte-array )
- binary <byte-reader> <bitstream-reader>
- <lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
+ bs:<msb0-bit-reader>
+ <lzw-uncompress>
+ [ lzw-uncompress-char ] [ output>> ] bi ;
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 )
{
[ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
- <threaded-server>
+ binary <threaded-server>
swap >>insecure
- binary >>encoding
"concurrency.distributed" >>name
[ handle-node-client ] >>handler ;
IN: concurrency.exchangers.tests\r
-USING: sequences tools.test concurrency.exchangers\r
+USING: tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
+FROM: sequences => 3append ;\r
\r
:: exchanger-test ( -- string )\r
[let |\r
! 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
{ $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 ;"
! 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
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 ) ;
+FUNCTION: uint GetCurrentButtonState ( ) ;
+
<PRIVATE
: bitmap-flags ( -- flags )
}
: font-name ( string -- string' )
- font-names at-default ;
+ font-names ?at drop ;
: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
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: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
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 ;
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
compiler.constants math math.private layouts words\r
vocabs slots.private locals.backend ;\r
+FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
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:
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
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
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
! 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
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel math alien.syntax ;
+IN: cpu.x86.features
+
+<PRIVATE
+
+FUNCTION: bool check_sse2 ( ) ;
+
+FUNCTION: longlong read_timestamp_counter ( ) ;
+
+PRIVATE>
+
+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
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )
- [ building get [ integer? ] count dup ] dip align swap - ;
+ [ building get length dup ] dip align swap - ;
: align-code ( n -- )
0 <repetition> % ;
-M: x86 %dispatch-label ( word -- )
- 0 cell, rc-absolute-cell rel-word ;
+M: x86 %dispatch-label ( label -- )
+ 0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream
- dup peek { "" } = [ but-last ] when ;
+ dup last { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv )
<file-reader> csv ;
! 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
! 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
! 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
! 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
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
[ "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
[ ] [ "Hello world" "d" get set-doc-string ] unit-test
-[ { "" } ] [ "value" get ] unit-test
\ No newline at end of file
+[ { "" } ] [ "value" get ] unit-test
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 ;
] [
first swap length 1- + 0
] if
- ] dip peek length + 2array ;
+ ] dip last length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
[ 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 ;
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 ;
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
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
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
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
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
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
IN: editors.vim
SYMBOL: vim-path
-
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
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
! 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* )
! 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
[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
-[ "<p><img src=\"lol.jpg\" alt=\"image:lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src=\"lol.jpg\" alt=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ convert-farkup drop t ] [ drop print f ] recover
] all?
] unit-test
+
+[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test
{ 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 ;
: 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
! 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
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 )
] with-destructors ;
: <ftp-server> ( 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 -- )
<ftp-server> start-server ;
} ;
: 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
furnace.chloe-tags\r
html.forms\r
html.components\r
-html.components\r
html.templates.chloe\r
html.templates.chloe.syntax\r
html.templates.chloe.compiler ;\r
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
USING: accessors assocs namespaces kernel sequences sets\r
destructors combinators fry logging\r
io.encodings.utf8 io.encodings.string io.binary random\r
-checksums checksums.sha2 urls\r
+checksums checksums.sha urls\r
html.forms\r
http.server\r
http.server.filters\r
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
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 ;
+alien.c-types math parser game-input vectors bit-arrays ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
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 )
[
: ?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 )
<NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value )
rot ?set-nth
] [ 3drop ] if ;
-HINTS: record-keyboard { array alien } ;
+HINTS: record-keyboard { bit-array alien } ;
: record-mouse ( mouse-state value -- )
dup IOHIDValueGetElement {
4 <vector> +controller-states+ set-global
0 0 0 0 2 <vector> mouse-state boa
+mouse-state+ set-global
- 256 f <array> +keyboard-state+ set-global ;
+ 256 <bit-array> +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
MACRO: nspread ( quots n -- )
over empty? [ 2drop [ ] ] [
[ [ but-last ] dip ]
- [ [ peek ] dip ] 2bi
+ [ [ last ] dip ] 2bi
swap
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
data>> pop* ; inline
: data-peek ( heap -- entry )
- data>> peek ; inline
+ data>> last ; inline
: data-first ( heap -- entry )
data>> first ; inline
-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
} ;
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" }
"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"
} ;
{ $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." }
{ $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." ;
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
! 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 ascii unicode.case math.order
+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 -- )
[ (eval>string) ] call( code -- output )
"\n" ?tail drop
] keep
- peek assert=
+ last assert=
] vocabs-quot get call( quot -- ) ;
: check-examples ( element -- )
] 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 ;
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
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 "
] dip remember-definition ;
SYNTAX: ABOUT:
- in get vocab scan-object >>help changed-definition ;
+ current-vocab scan-object >>help changed-definition ;
$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
! 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 )
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
-{ peek pop* pop } [
+{ last pop* pop } [
{ vector } "specializer" set-word-prop
] each
io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
+FROM: html.components => inspector ;
[ ] [ begin-form ] unit-test
IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
+FROM: html.forms => values ;
: with-validation ( quot -- messages )
[
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
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: <chloe>
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
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
! 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
! 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
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
[
[ ] [ "<%\n%>" parse-template drop ] unit-test
] with-file-vocabs
+
+[
+ [ ] [
+ <"
+ <%
+ IN: html.templates.fhtml.tests
+ : test-word ( -- ) ;
+ %>
+ "> parse-template drop
+ ] unit-test
+] with-file-vocabs
! 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
-io.streams.string io.encodings.utf8 html.templates ;
+assocs fry vocabs.parser parser parser.notes lexer io io.files
+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
: parse-template ( string -- quot )
[
+ [
"quiet" on
parser-notes off
- "html.templates.fhtml" use+
+ "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( -- ) ;
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
! 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
] 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 ;
! 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 )
'space' ,
'attr' ,
'space' ,
- [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
+ [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional ,
'space' ,
] seq* ;
io.timeouts
io.crlf
fry logging logging.insomniac calendar urls urls.encoding
-mime.multipart
unicode.categories
http
http.parsers
html.streams
html
xml.writer ;
+FROM: mime.multipart => parse-multipart ;
IN: http.server
: check-absolute ( url -- url )
] with-destructors ;
: <http-server> ( -- server )
- http-server new-threaded-server
+ ascii http-server new-threaded-server
"http.server" >>name
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;
-USE: vocabs.loader
-
"http.server.filters" require
"http.server.dispatchers" require
"http.server.redirection" require
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
[
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
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays byte-arrays combinators\r
+constructors grouping compression.huffman images\r
+images.processing io io.binary io.encodings.binary io.files\r
+io.streams.byte-array kernel locals math math.bitwise\r
+math.constants math.functions math.matrices math.order\r
+math.ranges math.vectors memoize multiline namespaces\r
+sequences sequences.deep ;\r
+IN: images.jpeg\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+TUPLE: jpeg-image < image\r
+ { headers }\r
+ { bitstream }\r
+ { color-info initial: { f f f f } }\r
+ { quant-tables initial: { f f } }\r
+ { huff-tables initial: { f f f f } }\r
+ { components } ;\r
+\r
+<PRIVATE\r
+\r
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;\r
+\r
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP\r
+APP JPG COM TEM RES ;\r
+\r
+! ISO/IEC 10918-1 Table B.1\r
+:: >marker ( byte -- marker )\r
+ byte\r
+ {\r
+ { [ dup HEX: CC = ] [ { DAC } ] }\r
+ { [ dup HEX: C4 = ] [ { DHT } ] }\r
+ { [ dup HEX: C9 = ] [ { JPG } ] }\r
+ { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }\r
+\r
+ { [ dup HEX: D8 = ] [ { SOI } ] }\r
+ { [ dup HEX: D9 = ] [ { EOI } ] }\r
+ { [ dup HEX: DA = ] [ { SOS } ] }\r
+ { [ dup HEX: DB = ] [ { DQT } ] }\r
+ { [ dup HEX: DC = ] [ { DNL } ] }\r
+ { [ dup HEX: DD = ] [ { DRI } ] }\r
+ { [ dup HEX: DE = ] [ { DHP } ] }\r
+ { [ dup HEX: DF = ] [ { EXP } ] }\r
+ { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }\r
+\r
+ { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }\r
+ { [ dup HEX: FE = ] [ { COM } ] }\r
+ { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }\r
+\r
+ { [ dup HEX: 01 = ] [ { TEM } ] }\r
+ [ { RES } ]\r
+ }\r
+ cond nip ;\r
+\r
+TUPLE: jpeg-chunk length type data ;\r
+\r
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;\r
+\r
+TUPLE: jpeg-color-info\r
+ h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;\r
+\r
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;\r
+\r
+: jpeg> ( -- jpeg-image ) jpeg-image get ;\r
+\r
+: apply-diff ( dc color -- dc' )\r
+ [ diff>> + dup ] [ (>>diff) ] bi ;\r
+\r
+: fetch-tables ( component -- )\r
+ [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]\r
+ [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]\r
+ [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;\r
+\r
+: read4/4 ( -- a b ) read1 16 /mod ;\r
+\r
+\r
+! headers\r
+\r
+: decode-frame ( header -- )\r
+ data>>\r
+ binary\r
+ [\r
+ read1 8 assert=\r
+ 2 read be>\r
+ 2 read be>\r
+ swap 2array jpeg> (>>dim)\r
+ read1\r
+ [\r
+ read1 read4/4 read1 <jpeg-color-info>\r
+ swap [ >>id ] keep jpeg> color-info>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-quant-table ( chunk -- )\r
+ dup data>>\r
+ binary\r
+ [\r
+ length>>\r
+ 2 - 65 /\r
+ [\r
+ read4/4 [ 0 assert= ] dip\r
+ 64 read\r
+ swap jpeg> quant-tables>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-huff-table ( chunk -- )\r
+ data>>\r
+ binary\r
+ [\r
+ 1 ! %fixme: Should handle multiple tables at once\r
+ [\r
+ read4/4 swap 2 * +\r
+ 16 read\r
+ dup [ ] [ + ] map-reduce read\r
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader\r
+ swap jpeg> huff-tables>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-scan ( chunk -- )\r
+ data>>\r
+ binary\r
+ [\r
+ read1 [0,b)\r
+ [ drop\r
+ read1 jpeg> color-info>> nth clone\r
+ read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*\r
+ ] map jpeg> (>>components)\r
+ read1 0 assert=\r
+ read1 63 assert=\r
+ read1 16 /mod [ 0 assert= ] bi@\r
+ ] with-byte-reader ;\r
+\r
+: singleton-first ( seq -- elt )\r
+ [ length 1 assert= ] [ first ] bi ;\r
+\r
+: baseline-parse ( -- )\r
+ jpeg> headers>>\r
+ {\r
+ [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]\r
+ [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]\r
+ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]\r
+ [ [ type>> { SOS } = ] filter singleton-first decode-scan ]\r
+ } cleave ;\r
+\r
+: parse-marker ( -- marker )\r
+ read1 HEX: FF assert=\r
+ read1 >marker ;\r
+\r
+: parse-headers ( -- chunks )\r
+ [ parse-marker dup { SOS } = not ]\r
+ [\r
+ 2 read be>\r
+ dup 2 - read <jpeg-chunk>\r
+ ] [ produce ] keep dip swap suffix ;\r
+\r
+MEMO: zig-zag ( -- zz )\r
+ {\r
+ { 0 1 5 6 14 15 27 28 }\r
+ { 2 4 7 13 16 26 29 42 }\r
+ { 3 8 12 17 25 30 41 43 }\r
+ { 9 11 18 24 31 40 44 53 }\r
+ { 10 19 23 32 39 45 52 54 }\r
+ { 20 22 33 38 46 51 55 60 }\r
+ { 21 34 37 47 50 56 59 61 }\r
+ { 35 36 48 49 57 58 62 63 }\r
+ } flatten ;\r
+\r
+MEMO: yuv>bgr-matrix ( -- m )\r
+ {\r
+ { 1 2.03211 0 }\r
+ { 1 -0.39465 -0.58060 }\r
+ { 1 0 1.13983 }\r
+ } ;\r
+\r
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;\r
+\r
+:: dct-vect ( u v -- basis )\r
+ { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2\r
+ 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;\r
+\r
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;\r
+\r
+: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;\r
+\r
+: all-macroblocks ( quot: ( mb -- ) -- )\r
+ [\r
+ jpeg>\r
+ [ dim>> 8 v/n ]\r
+ [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi\r
+ [ ceiling ] map\r
+ coord-matrix flip concat\r
+ ]\r
+ [ each ] bi* ; inline\r
+\r
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;\r
+\r
+: idct-factor ( b -- b' ) dct-matrix v.m ;\r
+\r
+USE: math.blas.vectors\r
+USE: math.blas.matrices\r
+\r
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;\r
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;\r
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;\r
+\r
+: idct ( b -- b' ) idct-blas ;\r
+\r
+:: draw-block ( block x,y color jpeg-image -- )\r
+ block dup length>> sqrt >fixnum group flip\r
+ dup matrix-dim coord-matrix flip\r
+ [\r
+ [ first2 spin nth nth ]\r
+ [ x,y v+ color id>> 1- jpeg-image draw-color ] bi\r
+ ] with each^2 ;\r
+\r
+: sign-extend ( bits v -- v' )\r
+ swap [ ] [ 1- 2^ < ] 2bi\r
+ [ -1 swap shift 1+ + ] [ drop ] if ;\r
+\r
+: read1-jpeg-dc ( decoder -- dc )\r
+ [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;\r
+\r
+: read1-jpeg-ac ( decoder -- run/ac )\r
+ [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;\r
+\r
+:: decode-block ( pos color -- )\r
+ color dc-huff-table>> read1-jpeg-dc color apply-diff\r
+ 64 0 <array> :> coefs\r
+ 0 coefs set-nth\r
+ 0 :> k!\r
+ [\r
+ color ac-huff-table>> read1-jpeg-ac\r
+ [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri\r
+ { 0 0 } = not\r
+ k 63 < and\r
+ ] loop\r
+ coefs color quant-table>> v*\r
+ reverse-zigzag idct\r
+ ! %fixme: color hack\r
+ ! this eat 50% cpu time\r
+ color h>> 2 =\r
+ [ 8 group 2 matrix-zoom concat ] unless\r
+ pos { 8 8 } v* color jpeg> draw-block ;\r
+\r
+: decode-macroblock ( mb -- )\r
+ jpeg> components>>\r
+ [\r
+ [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]\r
+ [ [ decode-block ] curry each ] bi\r
+ ] with each ;\r
+\r
+: cleanup-bitstream ( bytes -- bytes' )\r
+ binary [\r
+ [\r
+ { HEX: FF } read-until\r
+ read1 tuck HEX: 00 = and\r
+ ]\r
+ [ drop ] produce\r
+ swap >marker { EOI } assert=\r
+ swap suffix\r
+ { HEX: FF } join\r
+ ] with-byte-reader ;\r
+\r
+: setup-bitmap ( image -- )\r
+ dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim\r
+ BGR >>component-order\r
+ f >>upside-down?\r
+ dup dim>> first2 * 3 * 0 <array> >>bitmap\r
+ drop ;\r
+\r
+: baseline-decompress ( -- )\r
+ jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append\r
+ >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)\r
+ jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi\r
+ jpeg> components>> [ fetch-tables ] each\r
+ jpeg> setup-bitmap\r
+ [ decode-macroblock ] all-macroblocks ;\r
+\r
+! this eats ~25% cpu time\r
+: color-transform ( yuv -- rgb )\r
+ { 128 0 0 } v+ yuv>bgr-matrix swap m.v\r
+ [ 0 max 255 min >fixnum ] map ;\r
+\r
+PRIVATE>\r
+\r
+: load-jpeg ( path -- image )\r
+ binary [\r
+ parse-marker { SOI } assert=\r
+ parse-headers\r
+ contents <jpeg-image>\r
+ ] with-file-reader\r
+ dup jpeg-image [\r
+ baseline-parse\r
+ baseline-decompress\r
+ jpeg> bitmap>> 3 <groups> [ color-transform ] change-each\r
+ jpeg> [ >byte-array ] change-bitmap drop\r
+ ] with-variable ;\r
+\r
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )\r
+ drop load-jpeg ;\r
! 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.png ;
IN: images.loader
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 ;
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
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 ;
: fill-image-data ( image -- image )
dup [ width>> ] [ height>> ] bi 2array >>dim ;
+: zlib-data ( png-image -- bytes )
+ chunks>> [ type>> "IDAT" = ] find nip data>> ;
+
+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 )
+ {
+ [ 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-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
read-png-chunks
parse-ihdr-chunk
fill-image-data
+ decode-png
] with-input-stream ;
+
+M: png-image load-image*
+ drop load-png ;
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays byte-arrays combinators grouping images\r
+kernel locals math math.order\r
+math.ranges math.vectors sequences sequences.deep fry ;\r
+IN: images.processing\r
+\r
+: coord-matrix ( dim -- m )\r
+ [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;\r
+\r
+: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
+: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
+\r
+: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;\r
+ \r
+: matrix>image ( m -- image )\r
+ <image> over matrix-dim >>dim\r
+ swap flip flatten\r
+ [ 128 * 128 + 0 max 255 min >fixnum ] map\r
+ >byte-array >>bitmap L >>component-order ;\r
+\r
+:: matrix-zoom ( m f -- m' )\r
+ m matrix-dim f v*n coord-matrix\r
+ [ [ f /i ] map first2 swap m nth nth ] map^2 ;\r
+\r
+:: image-offset ( x,y image -- xy )\r
+ image dim>> first\r
+ x,y second * x,y first + ;\r
+ \r
+:: draw-grey ( value x,y image -- )\r
+ x,y image image-offset 3 * { 0 1 2 }\r
+ [\r
+ + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth\r
+ ] with each ;\r
+\r
+:: draw-color ( value x,y color-id image -- )\r
+ x,y image image-offset 3 * color-id + value >fixnum\r
+ swap image bitmap>> set-nth ;\r
+\r
+! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;\r
! 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 )
: &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 ;
! 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
! 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
\ 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
! 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 ? -- )
! 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
{
{ +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 -- )
! 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
-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
! 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
{ [ 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 ;
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
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
: 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 ;
+
<PRIVATE
: make-timeval-array ( array -- byte-array )
: try-output-process ( command -- )
>process
+stdout+ >>stderr
- +closed+ >>stdin
+ [ +closed+ or ] change-stdin
utf8 <process-reader*>
[ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;
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 ;
! 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
! 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
{ $code\r
"USE: io.monitors"\r
": watch-loop ( monitor -- )"\r
- " dup next-change . nl nl flush watch-loop ;"\r
+ " dup next-change path>> print nl nl flush watch-loop ;"\r
""\r
": watch-directory ( path -- )"\r
- " [ t [ watch-loop ] with-monitor ] with-monitors"\r
+ " [ t [ watch-loop ] with-monitor ] with-monitors ;"\r
} ;\r
\r
ABOUT: "io.monitors"\r
: 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 ] }
{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". 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: <threaded-server>
-{ $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" } "." } ;
io.servers.connection.private kernel accessors sequences
concurrency.promises io.encodings.ascii io threads calendar ;
-[ t ] [ <threaded-server> listen-on empty? ] unit-test
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
[ f ] [
- <threaded-server>
+ ascii <threaded-server>
25 internet-server >>insecure
listen-on
empty?
and
] unit-test
-[ ] [ <threaded-server> init-server drop ] unit-test
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
[ 10 ] [
- <threaded-server>
+ ascii <threaded-server>
10 >>max-connections
init-server semaphore>> count>>
] unit-test
[ ] [
- <threaded-server>
+ ascii <threaded-server>
5 >>max-connections
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
: internet-server ( port -- addrspec ) f swap <inet> ;
-: 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> >>secure-config
[ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline
-: <threaded-server> ( -- threaded-server )
+: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
GENERIC: handle-client* ( threaded-server -- )
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 ;
! 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 use+ >>
+} cond use-vocab >>
! Addressing
GENERIC: protocol-family ( addrspec -- af )
! 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 ;
-
-EXCLUDE: io => read write close ;
+USING: alien alien.c-types alien.strings generic kernel math threads
+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 ;
EXCLUDE: io.sockets => accept ;
IN: io.sockets.unix
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
\r
: levenshtein ( old new -- n )\r
[ levenshtein-initialize ] [ levenshtein-step ]\r
- run-lcs peek peek ;\r
+ run-lcs last last ;\r
\r
TUPLE: retain item ;\r
TUPLE: delete item ;\r
] with-file-vocabs
[
- "debugger" use+
-
[ [ \ + 1 2 3 4 ] ]
[
[
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 ] [
] [ 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 -- )
-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
! 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 ;
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 }
{ $subsection 1lazy-list }
{ $subsection 2lazy-list }
{ $subsection 3lazy-list }
-{ $subsection seq>list }
+{ $subsection sequence-tail>list }
{ $subsection >list }
{ $subsection lfrom } ;
{ $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 <lazy-while> } " 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 <lazy-append> } " 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
{ $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 the 'index' offset into the sequence." }
+{ $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
{ $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
! 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 } ] [
[ [ drop ] foldl ] must-infer
[ [ drop ] leach ] must-infer
[ lnth ] must-infer
+
+[ ] [ "resource:license.txt" utf8 <file-reader> llines list>array drop ] unit-test
+[ ] [ "resource:license.txt" utf8 <file-reader> lcontents list>array drop ] unit-test
! 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 )
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 ;
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 )
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? ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
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
] [
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] 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 ;
C: <lazy-take> lazy-take
: ltake ( n list -- result )
- over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+ over zero? [ 2drop nil ] [ <lazy-take> ] if ;
M: lazy-take car ( lazy-take -- car )
cons>> car ;
[ 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 ;
[ 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 ;
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 ;
dup skip cdr
] if ;
-M: lazy-filter nil? ( lazy-filter -- bool )
+M: lazy-filter nil? ( lazy-filter -- ? )
dup cons>> nil? [
drop t
] [
] if
] if ;
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
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 ;
[ 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 ;
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> sequence-cons
-: seq>list ( index seq -- list )
+: sequence-tail>list ( index seq -- list )
2dup length >= [
2drop nil
] [
] 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 ;
DEFER: lconcat
: (lconcat) ( car cdr -- list )
- over nil? [
- nip lconcat
- ] [
- <lazy-concat>
- ] if ;
+ over nil? [ nip lconcat ] [ <lazy-concat> ] 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 ;
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 ;
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 ;
: 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 ;
f f [ stream-readln ] <lazy-io> ;
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 <lazy-io> [ >>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
{ $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 }
"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 } ;
{ $subsection foldl }
{ $subsection foldr }
{ $subsection lmap>array }
-{ $subsection lmap-as }
{ $subsection traverse } ;
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
{ 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
{ $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." } ;
-
-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 "Convert a list into an array." } ;
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." } ;
{ $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." } ;
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 } } [
+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 } sequence>list [ 1+ ] lmap
] unit-test
{ 15 } [
- { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr
+ { 1 2 3 4 5 } sequence>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 } sequence>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 } sequence>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 } sequence>list { 4 5 6 } sequence>list lappend list>array
] unit-test
-[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test
+[ { 1 } { 2 } ] [ { 1 2 } sequence>list 1 lcut [ list>array ] bi@ ] unit-test
-! 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 ;
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
<PRIVATE
+
: (leach) ( list quot -- cdr quot )
[ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+
PRIVATE>
: leach ( list quot: ( elt -- ) -- )
: lcut ( list index -- before after )
[ nil ] dip
- [ [ [ cdr ] [ car ] bi ] dip cons ] times
+ [ [ unswons ] dip cons ] times
lreverse swap ;
-: sequence>cons ( sequence -- list )
- <reversed> nil [ swap cons ] reduce ;
-
-<PRIVATE
-: same? ( obj1 obj2 -- ? )
- [ class ] bi@ = ;
-PRIVATE>
-
-: deep-sequence>cons ( sequence -- cons )
- [ <reversed> ] keep nil
- [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
- with reduce ;
-
-<PRIVATE
-:: (lmap>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 )
+ <reversed> nil [ swons ] reduce ;
: lmap>array ( list quot -- array )
- { } lmap-as ; inline
-
-: deep-list>array ( list -- array )
- [
- {
- { [ dup nil? ] [ drop { } ] }
- { [ dup list? ] [ deep-list>array ] }
- [ ]
- } cond
- ] lmap>array ;
-
-: list>array ( list -- array )
+ accumulator [ leach ] dip { } like ; inline
+
+: list>array ( list -- array )
[ ] lmap>array ;
:: traverse ( list pred quot: ( list/elt -- result ) -- result )
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
[ 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
[ <local-word> [ 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
'[
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 )
: parse-bindings* ( end -- words assoc )
[
- namespace push-locals
+ namespace use-words
(parse-bindings)
- namespace pop-locals
+ namespace unuse-words
] with-bindings ;
: parse-let* ( -- form )
building get empty? [\r
"Warning: log begins with multiline entry" print drop\r
] [\r
- message>> first building get peek message>> push\r
+ message>> first building get last message>> push\r
] if ;\r
\r
: parse-log ( lines -- entries )\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: namespaces kernel io io.files io.pathnames io.directories\r
-io.sockets io.encodings.utf8\r
-calendar calendar.format sequences continuations destructors\r
-prettyprint assocs math.parser words debugger math combinators\r
-concurrency.messaging threads arrays init math.ranges strings ;\r
+io.encodings.utf8 calendar calendar.format sequences continuations\r
+destructors prettyprint assocs math.parser words debugger math\r
+combinators concurrency.messaging threads arrays init math.ranges\r
+strings ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
] 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
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"
"Incrementing, decrementing:"
{ $subsection 1+ }
{ $subsection 1- }
-"Minimum, maximum:"
+"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
+{ $subsection clamp }
"Complex conjugation:"
{ $subsection conjugate }
"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
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
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
- [ peek ] bi@ / ;
+ [ last ] bi@ / ;
: (p/mod) ( p p -- p p )
2dup /-last
USING: help.syntax help.markup arrays sequences ;
-
IN: math.ranges
ARTICLE: "math.ranges" "Numeric ranges"
{ $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"
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >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
INSTANCE: range immutable-sequence
+<PRIVATE
+
: twiddle ( a b -- a b step ) 2dup > -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 <range> ; inline
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
: [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-peek ( seq head? -- elt )
- [ first ] [ peek ] if ;
-
-: range-min ( range -- min )
- dup range-increasing? first-or-peek ;
-
-: range-max ( range -- max )
- dup range-decreasing? first-or-peek ;
-
-: clamp-to-range ( n range -- n )
- [ range-min max ] [ range-max min ] bi ;
-
-: sequence-index-range ( seq -- range )
- length [0,b) ;
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" }
{ $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" }
[ 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
+
+[ 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
! 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 assocs fry ;
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 ;
-: 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 ;
+
+: 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 ;
-: range ( seq -- n )
+: range ( seq -- x )
minmax swap - ;
: var ( seq -- x )
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))
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
swap / * ! stack is mean(x) mean(y) beta
[ swapd * - ] keep ;
-
: 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* ;
+
+: v~ ( a b epsilon -- ? )
+ [ ~ ] curry 2all? ;
+
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;
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 ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors kernel models arrays sequences math math.order\r
models.product ;\r
+FROM: models.product => product ;\r
IN: models.range\r
\r
TUPLE: range < product ;\r
{ 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 ;
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 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
[ unknown-gl-platform ]
-} cond use+ >>
+} cond use-vocab >>
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
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
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
+
! 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
[
! 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
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel compiler.units words arrays strings math.parser\r
+USING: kernel words arrays strings math.parser\r
sequences quotations vectors namespaces make math assocs\r
continuations peg peg.parsers unicode.categories multiline\r
splitting accessors effects sequences.deep peg.search\r
combinators.short-circuit lexer io.streams.string stack-checker\r
io combinators parser summary ;\r
+FROM: compiler.units => with-compilation-unit ;\r
+FROM: vocabs.parser => search ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
] bind ;\r
\r
M: ebnf (transform) ( ast -- parser )\r
- rules>> [ (transform) ] map peek ;\r
+ rules>> [ (transform) ] map last ;\r
\r
M: ebnf-tokenizer (transform) ( ast -- parser )\r
elements>> dup "default" = [\r
drop \r
] [ \r
[\r
- "USING: locals sequences ; [let* | " %\r
+ "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %\r
dup length swap [\r
dup ebnf-var? [\r
name>> % \r
\r
M: ebnf-var build-locals ( code ast -- )\r
[\r
- "USING: locals kernel ; [let* | " %\r
+ "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %\r
name>> % " [ dup ] " %\r
" | " %\r
% \r
! 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
! 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
+quotations memoize accessors locals splitting
combinators.short-circuit generalizations ;
IN: peg
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 ;
: 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 ]
: consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ;
-: last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
+: last-is? ( str possibilities -- ? ) [ last ] dip member? ;
: cvc? ( str -- ? )
{
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 ] }
[ 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 ] }
[ ]
! 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
[ 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 ;
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
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" } "." }
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
: 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 )
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
-<PRIVATE
-
-: 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 <object
- call
- pprinter-block
- pprinter-in get
- pprinter-use get keys
- ] with-scope ; inline
-
-: with-pprint ( obj quot -- )
- make-pprint 2drop do-pprint ; inline
-
-: pprint-vocab ( vocab -- )
- dup vocab present-text ;
-
-: write-in ( vocab -- )
- [ \ IN: pprint-word pprint-vocab ] with-pprint ;
-
-: in. ( vocab -- )
- [ write-in ] when* ;
-
-: use. ( seq -- )
- [
- natural-sort [
- \ USING: pprint-word
- [ pprint-vocab ] each
- \ ; pprint-word
- ] with-pprint
- ] unless-empty ;
-
-: use/in. ( in use -- )
- over "syntax" 2array diff
- [ nip use. ]
- [ empty? not and [ nl ] when ]
- [ drop in. ]
- 2tri ;
-
-: vocab-names ( words -- vocabs )
- dictionary get
- [ [ words>> 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 ;
USING: prettyprint io kernel help.markup help.syntax
prettyprint.config words hashtables math
-strings definitions ;
+strings definitions quotations ;
IN: prettyprint.sections
HELP: position
{ $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 } "." } ;
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 } "." } ;
-! 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
: <pprinter> ( -- 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? ( -- ? )
: <block> ( 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 ;
! 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
] { } 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 <fresh-line ] [ drop ] if ;
] each
] each
] if-nonempty ;
+
+: pprinter-manifest ( -- 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
+ V{ } clone recursion-check set
+ V{ } clone pprinter-stack set
+ over <object
+ call
+ pprinter-block
+ pprinter-manifest
+ ] with-scope ; inline
+
+: with-pprint ( obj quot -- )
+ make-pprint drop do-pprint ; inline
! 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 ;
[ 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
{
[ 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 ;
-USING: kernel random math accessors random ;
+USING: kernel math accessors random ;
IN: random.dummy
TUPLE: random-dummy i ;
[ seq>> nth-unsafe mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
-USE: init
-
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
[ 1.0 swap - log -2.0 * sqrt ]
bi* * * + ;
-USE: vocabs.loader
-
{
{ [ os windows? ] [ "random.windows" require ] }
{ [ os unix? ] [ "random.unix" require ] }
-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 math.bitwise ;
IN: random.windows
TUPLE: windows-rng provider type ;
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" <c-object> ] |
- handle
- factor-crypto-container
- provider
- type
- flags
- CryptAcquireContextW win32-error=0/f
- handle *void* ] ;
+:: (acquire-crypto-context) ( provider type flags -- handle ret )
+ "HCRYPTPROV" <c-object> :> 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 ;
+ CRYPT_MACHINE_KEYSET
+ (acquire-crypto-context)
+ 0 = [
+ GetLastError NTE_BAD_KEYSET =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [
+ *void*
+ ] if ;
+: create-crypto-context ( provider type -- handle )
+ { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
+ (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 <windows-crypto-context> ;
+ attempt-crypto-context <windows-crypto-context> ;
M: windows-rng random-bytes* ( n tuple -- bytes )
[
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
- MS_STRONG_PROV
- PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+ [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
+ [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
+ secure-random-generator set-global
- ! MS_ENH_RSA_AES_PROV
- ! PROV_RSA_AES <windows-rng> secure-random-generator set-global
] "random.windows" add-init-hook
! 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
"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"
+USING: help.markup help.syntax strings definitions generic words classes ;
+FROM: prettyprint.sections => 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 } }
{ $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 ;"
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" ]
[ "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
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 -- )
<PRIVATE
: seeing-word ( word -- )
- vocabulary>> pprinter-in set ;
+ vocabulary>> dup [ vocab ] when pprinter-in set ;
: word-synopsis ( word -- )
{
! 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 ;
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
: 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 ;
{ 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 ] }
{ 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 ] }
-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
! 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 )
[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 >>
"The Beatles"
"A river runs through it"
"Another"
+ "The"
+ "A"
+ "Los"
"la vida loca"
"Basketball"
"racquetball"
} ;
[
{
+ "A"
"Another"
"Basketball"
"The Beatles"
"for the horde"
"Los Fujis"
"los Fujis"
+ "Los"
"of mice and men"
"on belay"
"racquetball"
"A river runs through it"
+ "The"
"la vida loca"
}
] [
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 >>
! 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
<PRIVATE
-: ,, ( obj -- ) building get peek push ;
+: ,, ( obj -- ) building get last push ;
: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
+: ,v ( -- ) building get dup last empty? [ dup pop* ] when drop ;
: (monotonic-split) ( seq quot -- newseq )
[
: 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+ <repetition> ] dip append ] [ 3drop f ] if ;
+ ! Introduced values can be anything, and don't unify with
+ ! literals.
+ dup [ [ - +top+ <repetition> ] 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
-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
! 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
! 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
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
\ 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 -- )
[ [ 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
: compose-n ( quot n -- ) "OOPS" throw ;
<<
-: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
+: compose-n-quot ( n word -- quot' ) <repetition> >quotation ;
\ compose-n [ compose-n-quot ] 2 define-transform
\ compose-n t "no-compile" set-word-prop
>>
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
[
[ no-case ]
] [
- dup peek callable? [
- dup peek swap but-last
+ dup last callable? [
+ dup last swap but-last
] [
[ no-case ] swap
] if case>quot
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" }
{ $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 } }
[ "" ] [ [ 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 ;
GENERIC: reset ( word -- )
M: generic reset
- [ call-next-method ]
- [ subwords [ reset ] each ] bi ;
+ subwords [ reset ] each ;
M: word reset
dup "unannotated-def" word-prop [
ERROR: cannot-annotate-twice word ;
+M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
+
<PRIVATE
: check-annotate-twice ( word -- word )
cannot-annotate-twice
] when ;
-: save-unannotated-def ( word -- )
- dup def>> "unannotated-def" set-word-prop ;
+PRIVATE>
-: (annotate) ( word quot -- )
- [ dup def>> ] dip call( old -- new ) define ;
+GENERIC# annotate 1 ( word quot -- )
-PRIVATE>
+M: generic annotate
+ [ "methods" word-prop values ] dip '[ _ annotate ] each ;
-: annotate ( word quot -- )
+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 ;
<PRIVATE
: 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
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
1+
- ] keep pick peek push
+ ] keep pick last push
] each ;
: runs ( seq -- newseq )
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 ;
! 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
! 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
: 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 )
[ 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" ] }
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
<PRIVATE
[ 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
[
! 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
! 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 ;
--- /dev/null
+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
[ 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<sequence-unsafe ; inline
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 -- )
dup { 0 0 } = [
drop
windows get length 1 <= [ -> center ] [
- windows get peek second window-loc>>
+ windows get last second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
] if
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 -- )
- 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 -- )
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
CGMainDisplayID CGDisplayHideCursor drop
window>> -> frame CGRect>rect rect-center
- first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+ NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h
+ [ drop first ] [ swap second - ] 2bi <CGPoint>
+ [ GetCurrentButtonState zero? not ] [ yield ] while
+ CGWarpMouseCursorPosition drop ;
M: cocoa-ui-backend (ungrab-input) ( handle -- )
drop
{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
[
forget-rollover
- 2nip -> object -> contentView window unfocus-world
+ 2nip -> object -> contentView
+ dup -> isInFullScreenMode zero?
+ [ window unfocus-world ]
+ [ drop ] if
]
}
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
{ 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 <int> 0 <int>
[ DispatchMessage drop ] bi
] if ;
-: register-wndclassex ( -- class )
- "WNDCLASSEX" <c-object>
- f GetModuleHandle
- class-name-ptr get-global
- pick GetClassInfoEx zero? [
+:: register-window-class ( class-name-ptr -- )
+ "WNDCLASSEX" <c-object> 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
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 ;
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
: 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 ( -- )
[ 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 -- ? )
+ [ handle>> hWnd>> hwnd>RECT ]
+ [ handle>> hWnd>> fullscreen-RECT ] bi
+ [ get-RECT-dimensions 2array 2nip ] bi@ = ;
windows-ui-backend ui-backend set-global
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- handle>> window>> "XClientMessageEvent" <c-object>
- [ set-XClientMessageEvent-window ] keep
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+ [
+ handle>> window>> "XClientMessageEvent" <c-object>
+ [ 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
! 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
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 ;
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
-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 } ]
! 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 ;
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 -- )
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
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
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
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" (use+)
+ "ui.gadgets.worlds" vocab-words use-words
>>
ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
] with each
] do-matrix ;
-USING: vocabs.loader namespaces system combinators ;
+USING: vocabs.loader system combinators ;
{
{ [ os macosx? ] [ "core-text" ] }
! 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 ;
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
USING: ui.gadgets help.markup help.syntax kernel quotations
-continuations debugger ui continuations ;
+continuations debugger ui ;
IN: ui.tools.debugger
HELP: <debugger>
! 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
-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
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 ;
! 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 ;
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 ;
[ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
<reversed> ;
-TUPLE: word-completion vocabs ;
+TUPLE: word-completion manifest ;
C: <word-completion> word-completion
SINGLETONS: vocab-completion char-completion history-completion ;
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 ;
[ { 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 ] }
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
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
-[ ] [ \ + <interactor> vocabs>> use-if-necessary ] unit-test
+[ ] [ \ + <interactor> manifest>> use-if-necessary ] unit-test
[ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test
[ 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 -- ? )
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
M: word-completion (word-at-caret)
- vocabs>> assoc-stack ;
+ manifest>> dup [
+ '[ _ _ search-manifest ] [ drop f ] recover
+ ] [ 2drop f ] if ;
M: char-completion (word-at-caret)
2drop f ;
: 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 ;
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 use+ ;
+: com-use-vocab ( vocab -- ) vocab-name use-vocab ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }
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 => <arrow> ;
FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
{ { $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?
-{ $values { "?" "a boolean" } { "gadget" gadget } }
+HELP: set-fullscreen
+{ $values { "gadget" gadget } { "?" "a boolean" } }
{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
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 } } }
! 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
: open-window ( gadget title/attributes -- )
?attributes <world> 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 -- )
+ dup fullscreen? not set-fullscreen ;
: raise-window ( gadget -- )
find-world raise-window* ;
: 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
! Copyright (C) 2008 Daniel Ehrenberg.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: combinators.short-circuit sequences io.files\r
-io.encodings.ascii kernel values splitting accessors math.parser\r
-ascii io assocs strings math namespaces make sorting combinators\r
-math.order arrays unicode.normalize unicode.data locals\r
-macros sequences.deep words unicode.breaks\r
-quotations combinators.short-circuit simple-flat-file ;\r
+USING: sequences io.files io.encodings.ascii kernel values splitting\r
+accessors math.parser ascii io assocs strings math namespaces make\r
+sorting combinators math.order arrays unicode.normalize unicode.data\r
+locals macros sequences.deep words unicode.breaks quotations\r
+combinators.short-circuit simple-flat-file ;\r
IN: unicode.collation\r
\r
<PRIVATE\r
[ drop { } ]\r
[ [ AAAA ] [ BBBB ] bi 2array ] if ;\r
\r
-: last ( -- char )\r
- building get empty? [ 0 ] [ building get peek peek ] if ;\r
+: building-last ( -- char )\r
+ building get empty? [ 0 ] [ building get last last ] if ;\r
\r
: blocked? ( char -- ? )\r
combining-class dup { 0 f } member?\r
- [ drop last non-starter? ]\r
- [ last combining-class = ] if ;\r
+ [ drop building-last non-starter? ]\r
+ [ building-last combining-class = ] if ;\r
\r
: possible-bases ( -- slice-of-building )\r
building get dup [ first non-starter? not ] find-last\r
! 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 ;
: 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
! 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.
-USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
-vectors kernel 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
{ 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 ) ;
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" } ;
-USING: kernel system alien.syntax combinators vocabs.loader
-system ;
+USING: kernel system alien.syntax combinators vocabs.loader ;
IN: unix.types
TYPEDEF: char int8_t
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
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 ) ;
! 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 ;
[ "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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: vocabs.prettyprint.tests
+USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
+
+: manifest-test-1 ( -- string )
+ <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+
+ << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces 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 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 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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: sort-vocabs ( seq -- seq' )
+ [ [ vocab-name ] compare ] sort ;
+
+: pprint-using ( seq -- )
+ [ "syntax" vocab = not ] filter
+ sort-vocabs [
+ \ USING: pprint-word
+ [ pprint-vocab ] each
+ \ ; pprint-word
+ ] with-pprint ;
+
+GENERIC: pprint-qualified ( qualified -- )
+
+M: qualified pprint-qualified ( qualified -- )
+ [
+ dup [ vocab>> 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 -- quots )
+ [
+ [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
+ [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+ [ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
+ tri
+ ] { } make ;
+
+: pprint-manifest) ( quots -- )
+ [ nl ] [ call( -- ) ] interleave ;
+
+: pprint-manifest ( manifest -- )
+ (pprint-manifest pprint-manifest) ;
+
+[
+ 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 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
+ nl nl
+] print-use-hook set-global
\ No newline at end of file
-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
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
{ "sans-serif" "Tahoma" }\r
{ "serif" "Times New Roman" }\r
{ "monospace" "Courier New" }\r
- } at-default ;\r
+ } ?at drop ;\r
\r
MEMO:: (cache-font) ( font -- HFONT )\r
font size>> neg ! nHeight\r
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
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
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
0 <paragraph> ;
: post-process ( paragraph -- array )
- lines>> deep-list>array
- [ [ contents>> ] map ] map ;
+ lines>> [ [ contents>> ] lmap>array ] lmap>array ;
: initialize ( elements -- elements paragraph )
<reversed> unclip-slice 1paragraph 1array ;
! 8.7 - Transferring Images between Client and Server
-CONSTANT: XYBitmap 0
-CONSTANT: XYPixmap 1
-CONSTANT: ZPixmap 2
CONSTANT: AllPlanes -1
C-STRUCT: XImage-funcs
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> 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 <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
{" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
"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 <a><-></a> XML] ] [ "a" prepend ] }
[ "" ] [ [XML XML] concat ] unit-test
-USE: inverse
-
[ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
[ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
[ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser effects.parser
-sequences summary lexer splitting combinators locals xml.data
+USING: words assocs kernel accessors parser vocabs.parser effects.parser
+sequences summary lexer splitting combinators locals
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
inverse combinators.short-circuit sorting fry unicode.categories
<PRIVATE
: add-child ( object -- )
- xml-stack get peek second push ;
+ xml-stack get last second push ;
: push-xml ( object -- )
V{ } clone 2array xml-stack get push ;
-USING: xmode.tokens xmode.marker xmode.catalog kernel locals
-io io.files sequences words io.encodings.utf8
-namespaces xml.entities accessors xml.syntax locals xml.writer ;
+USING: xmode.tokens xmode.marker xmode.catalog kernel io io.files
+sequences words io.encodings.utf8 namespaces xml.entities accessors
+xml.syntax locals xml.writer ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- xml )
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
-regexp splitting unicode.case ascii
-combinators.short-circuit accessors ;
+regexp splitting ascii combinators.short-circuit accessors ;
IN: xmode.marker
! Next two words copied from parser-combinators
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;;
{ $subsection enum }
{ $subsection <enum> }
"Inverting a permutation using enumerations:"
-{ $example "USING: assocs sorting prettyprint ;" "IN: scratchpad" ": invert ( perm -- perm' )" " <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
+{ $example "IN: scratchpad" ": invert ( perm -- perm' )" " <enum> >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."
{ $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? }
{ $subsection assoc-any? }
{ $subsection assoc-all? }
"Additional combinators:"
+{ $subsection assoc-partition }
{ $subsection cache }
+{ $subsection 2cache }
{ $subsection map>assoc }
{ $subsection assoc>map }
{ $subsection assoc-map-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." } ;
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
} 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 ] }
[ 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
: ?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 ;
+
<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )
: 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 ;
-! 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 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
"Bootstrap stage 1..." print flush
] if
] %
] [ ] make
-bootstrap-boot-quot set
+bootstrap.image.private:bootstrap-boot-quot set
"UNION:"
"INTERSECTION:"
"USE:"
+ "UNUSE:"
"USING:"
"QUALIFIED:"
"QUALIFIED-WITH:"
"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" } ;
! 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 byte-arrays byte-vectors quotations ;
IN: checksums
MIXIN: checksum
+TUPLE: checksum-state
+ { bytes-read integer } { block-size integer } { bytes byte-vector } ;
+
+: new-checksum-state ( class -- checksum-state )
+ new
+ BV{ } clone >>bytes ; inline
+
+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 )
+
+: add-checksum-bytes ( checksum-state data -- checksum-state )
+ over bytes>> [ push-all ] keep
+ [ dup length pick block-size>> >= ]
+ [
+ 64 cut-slice [ >byte-array ] dip [
+ over [ checksum-block ]
+ [ [ 64 + ] change-bytes-read drop ] bi
+ ] dip
+ ] while
+ >byte-vector
+ [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
+
+: add-checksum-stream ( checksum-state stream -- checksum-state )
+ [
+ [ [ swap add-checksum-bytes drop ] curry each-block ] keep
+ ] with-input-stream ;
+
+: add-checksum-file ( checksum-state path -- checksum-state )
+ normalize-path (file-reader) add-checksum-stream ;
+
GENERIC: checksum-bytes ( bytes checksum -- value )
GENERIC: checksum-stream ( stream checksum -- value )
USING: alien arrays definitions generic assocs hashtables io\r
kernel math namespaces parser prettyprint sequences strings\r
-tools.test vectors words quotations classes classes.algebra\r
+tools.test words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
vectors definitions source-files compiler.units growable\r
random stack-checker effects kernel.private sbufs math.order\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
[ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if\r
+ [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
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
-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
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
-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
! 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 -- )
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 ;
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"
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
! 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 )
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 ;
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"
{ $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 }"
{ $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 }"
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
[ \ drop prefix ] bi*
] assoc-map alist>quot ;
+<PRIVATE
+
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
drop [ swap adjoin ] curry each
] [ ] make , , \ if ,
] [ ] make ;
+PRIVATE>
+
: case>quot ( default assoc -- quot )
dup keys {
{ [ dup empty? ] [ 2drop ] }
[ drop linear-case-quot ]
} cond ;
-! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
- ] { } make peek swap [ rethrow ] when
+ ] { } make last swap [ rethrow ] when
] if ; inline
TUPLE: condition error restarts continuation ;
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
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
- ] { } make [ peek rethrow ] unless-empty ;
+ ] { } make [ last rethrow ] unless-empty ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
<PRIVATE
-: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
+: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
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 ;
quote-methods
prune-redundant-predicates
class-predicates
- [ peek ] [ alist>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
! 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
! 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
] [ 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 ;
: 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
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
{ $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
"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"
}
[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
[ t ] [ 0 <fp-nan> 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
: 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
{ $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]" } "." }
{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
+{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
[ +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
: 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
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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." } ;
+
--- /dev/null
+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
--- /dev/null
+! 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
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
{ $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:"
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." ;
{ $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." } ;
-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 ;
-
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." }
{ $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." }
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" } "." } ;
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
[
[ "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( -- )
[ "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 ;
[ 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"
+ <string-reader> "forward-ref-1" parse-stream
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests.forward-ref-2 DEFER: x DEFER: y"
+ <string-reader> "forward-ref-2" parse-stream
+] unit-test
+
+[ [ ] ] [
+ "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 ;"
+ <string-reader> "forward-ref-3" parse-stream
+] unit-test
+
+[ t ] [
+ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
+] unit-test
+
+[ [ ] ] [
+ "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 ;"
+ <string-reader> "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 FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; : z ( -- ) x y ;"
+ <string-reader> "forward-ref-3" parse-stream
+] unit-test
+
+[ t ] [
+ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
+] unit-test
+
+[ [ dup ] ] [
+ "USE: kernel dup" <string-reader> "unuse-test" parse-stream
+] unit-test
+
+[
+ "dup" <string-reader> "unuse-test" parse-stream
+] [ error>> error>> error>> no-word-error? ] must-fail-with
+
+[
+ "USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
+] [ 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
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 )
: 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 )) ;
-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 ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-SYMBOL: amended-use
-
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
dup vocabulary>>
- [ (use+) ]
- [ 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 )
[ <no-word-error> 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 [ ] [
: with-file-vocabs ( quot -- )
[
- f in set { "syntax" } set-use
- bootstrap-syntax get [ use get push ] when*
+ <manifest> manifest set
+ "syntax" use-vocab
+ bootstrap-syntax get [ use-words ] when*
call
] with-scope ; inline
: with-interactive-vocabs ( quot -- )
[
- "scratchpad" in set
- interactive-vocabs get set-use
+ <manifest> manifest set
+ "scratchpad" set-current-vocab
+ interactive-vocabs get only-use-vocabs
call
] with-scope ; inline
: 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 -- )
! 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
{ 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
+{ pop pop* } related-words
HELP: pop*
{ $values { "seq" "a resizable mutable sequence" } }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
+"Extracting the last element:"
+{ $subsection last }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
-{ $see-also nth peek } ;
+{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
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 ;
[ 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 ;
[ 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
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
-: map-find ( seq quot -- result elt )
- [ f ] 2dip
- [ [ nip ] dip call dup ] curry find
+<PRIVATE
+
+: (map-find) ( seq quot find-quot -- result elt )
+ [ [ f ] 2dip [ [ nip ] dip call dup ] curry ] dip call
[ [ drop f ] unless ] dip ; inline
+PRIVATE>
+
+: 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
+ [ but-last-slice ] [ last ] bi ; inline
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when
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 ;
+kernel quotations namespaces sequences arrays effects
+generic.standard classes.builtin slots.private classes strings math
+assocs byte-arrays alien classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
! 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
-! 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:
[ <reversed> ] bi@ split1-slice [ <reversed> ] bi@
[ f ] [ swap ] if-empty ;
+<PRIVATE
+
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
: split, ( seq separators -- ) 0 rot (split) ;
+PRIVATE>
+
: split ( seq separators -- pieces )
[ split, ] { } make ;
but-last-slice [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split suffix concat
+ ] keep last "\r" split suffix concat
] [
1array
] if ;
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 ;
+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"
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" }
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"
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"
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 => -"
HELP: <PRIVATE
{ $syntax "<PRIVATE ... PRIVATE>" }
-{ $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
HELP: PRIVATE>
{ $syntax "<PRIVATE ... PRIVATE>" }
-{ $description "Marks the end of a block of private word definitions." } ;
+{ $description "Ends a block of private word definitions." } ;
{ POSTPONE: <PRIVATE POSTPONE: PRIVATE> } related-words
"#!" [ 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
+ "<PRIVATE" [ begin-private ] define-core-syntax
- "<PRIVATE" [
- POSTPONE: PRIVATE> in get ".private" append set-in
- ] define-core-syntax
+ "PRIVATE>" [ end-private ] define-core-syntax
+
+ "USE:" [ scan use-vocab ] define-core-syntax
- "USE:" [ scan use+ ] define-core-syntax
+ "UNUSE:" [ scan unuse-vocab ] define-core-syntax
- "USING:" [ ";" parse-tokens add-use ] 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:" [
"))" 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
"<<" [
[
[ ] [ 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
[ 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
: 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 )
--- /dev/null
+IN: vocabs.loader.test.l
+USE: kernel
+
+"Oops" throw
\ No newline at end of file
--- /dev/null
+unportable
-USING: help.markup help.syntax parser ;
+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."
"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
+"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
-"Private words can be defined; note that this is just a convention and they can be called from other vocabularies anyway:"
+"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: <PRIVATE } }
+ { "Make good use of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } }
+} ;
+
+ARTICLE: "word-search-private" "Private words"
+"Words which only serve as implementation detail should be defined in a private code block. Words in a private code blocks get defined in a vocabulary whose name is the name of the current vocabulary suffixed with " { $snippet ".private" } ". Privacy is not enforced by the system; private words can be called from other vocabularies, and from the listener. However, this should be avoided where possible."
{ $subsection POSTPONE: <PRIVATE }
-{ $subsection POSTPONE: PRIVATE> }
-{ $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 } ;
+
+ABOUT: "word-search"
+
+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: <manifest>
+{ $values { "manifest" manifest } }
+{ $description "Creates a new manifest." } ;
+
+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." }
+{ $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: <PRIVATE } "." } ;
+
+HELP: end-private
+{ $description "Ends a block of private word definitions." }
+{ $notes "This word is used to implement " { $link POSTPONE: PRIVATE> } "." } ;
+
+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 { "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 ;
! 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
+combinators vectors splitting continuations math
+parser.notes ;
IN: vocabs.parser
ERROR: no-word-error name ;
-: word-restarts ( name possibilities -- restarts )
+: word-restarts ( possibilities -- restarts )
natural-sort
- [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
+ [ [ 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 ;
: <no-word-error> ( name possibilities -- error restarts )
- [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
+ [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
-SYMBOL: use
-SYMBOL: in
+TUPLE: manifest
+current-vocab
+{ search-vocab-names hashtable }
+{ search-vocabs vector }
+{ qualified-vocabs vector }
+{ extra-words vector }
+{ auto-used vector } ;
-: (use+) ( vocab -- )
- vocab-words use get push ;
+: <manifest> ( -- manifest )
+ manifest new
+ H{ } clone >>search-vocab-names
+ V{ } clone >>search-vocabs
+ V{ } clone >>qualified-vocabs
+ V{ } clone >>extra-words
+ V{ } clone >>auto-used ;
-: use+ ( vocab -- )
- load-vocab (use+) ;
+M: manifest clone
+ call-next-method
+ [ clone ] change-search-vocab-names
+ [ clone ] change-search-vocabs
+ [ clone ] change-qualified-vocabs
+ [ clone ] change-extra-words
+ [ clone ] change-auto-used ;
-: add-use ( seq -- ) [ use+ ] each ;
+TUPLE: extra-words words ;
-: set-use ( seq -- )
- [ vocab-words ] V{ } map-as sift use set ;
+M: extra-words equal?
+ over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
-: add-qualified ( vocab prefix -- )
- [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
+C: <extra-words> extra-words
+
+<PRIVATE
+
+: clear-manifest ( -- )
+ manifest get
+ [ search-vocab-names>> clear-assoc ]
+ [ search-vocabs>> delete-all ]
+ [ qualified-vocabs>> delete-all ]
+ tri ;
+
+: (add-qualified) ( qualified -- )
+ manifest get qualified-vocabs>> push ;
+
+: (from) ( vocab words -- vocab words words' assoc )
+ 2dup swap load-vocab 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 ;
+
+: (use-words) ( assoc -- extra-words seq )
+ <extra-words> manifest get qualified-vocabs>> ;
+
+PRIVATE>
+
+: set-current-vocab ( name -- )
+ create-vocab
+ [ manifest get (>>current-vocab) ]
+ [ words>> <extra-words> (add-qualified) ] bi ;
+
+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 ;
+
+: using-vocab? ( vocab -- ? )
+ vocab-name manifest get search-vocab-names>> key? ;
+
+: use-vocab ( vocab -- )
+ dup using-vocab?
+ [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
+ manifest get
+ [ [ load-vocab ] dip search-vocabs>> push ]
+ [ [ vocab-name ] dip search-vocab-names>> conjoin ]
+ 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 -- )
+ dup using-vocab? [
+ manifest get
+ [ [ load-vocab ] dip search-vocabs>> delq ]
+ [ [ vocab-name ] dip search-vocab-names>> delete-at ]
+ 2bi
+ ] [ drop ] if ;
+
+: only-use-vocabs ( vocabs -- )
+ clear-manifest [ vocab ] filter [ use-vocab ] each ;
+
+TUPLE: qualified vocab prefix words ;
+
+: <qualified> ( vocab prefix -- qualified )
+ 2dup
+ [ load-vocab words>> ] [ CHAR: : suffix ] bi*
[ swap [ prepend ] dip ] curry assoc-map
- use get push ;
+ qualified boa ;
+
+: add-qualified ( vocab prefix -- )
+ <qualified> (add-qualified) ;
+
+TUPLE: from vocab names words ;
+
+: <from> ( vocab words -- from )
+ (from) extract-words from boa ;
+
+: add-words-from ( vocab words -- )
+ <from> (add-qualified) ;
+
+TUPLE: exclude vocab names words ;
-: partial-vocab ( words vocab -- assoc )
- load-vocab vocab-words
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+: <exclude> ( vocab words -- from )
+ (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
-: add-words-from ( words vocab -- )
- partial-vocab use get push ;
+: add-words-excluding ( vocab words -- )
+ <exclude> (add-qualified) ;
-: partial-vocab-excluding ( words vocab -- assoc )
- load-vocab [ vocab-words keys swap diff ] keep partial-vocab ;
+TUPLE: rename word vocab words ;
-: add-words-excluding ( words vocab -- )
- partial-vocab-excluding use get push ;
+: <rename> ( 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 -- )
- [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip
- associate use get push ;
+ <rename> (add-qualified) ;
+
+: use-words ( assoc -- ) (use-words) push ;
+
+: unuse-words ( assoc -- ) (use-words) delete ;
+
+TUPLE: ambiguous-use-error words ;
+
+: <ambiguous-use-error> ( words -- error restarts )
+ [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
+
+<PRIVATE
+
+: (vocab-search) ( name assocs -- words n )
+ [ 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> throw-restarts
+ dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
+ ]
+ } case ;
+
+: qualified-search ( name manifest -- word/f )
+ qualified-vocabs>>
+ (vocab-search) 0 = [ drop f ] [ last ] if ;
+
+PRIVATE>
-: check-vocab-string ( name -- name )
- dup string? [ "Vocabulary name must be a string" throw ] unless ;
+: search-manifest ( name manifest -- word/f )
+ 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
-: set-in ( name -- )
- check-vocab-string dup in set create-vocab (use+) ;
\ No newline at end of file
+: search ( name -- word/f )
+ manifest get search-manifest ;
: 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 [ <vocab> ] cache
notify-vocab-observers ;
$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 } ;
{ $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
! 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
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 <word> dup reveal ] if ;
+ dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;
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!" ]
-USING: kernel math arrays math.vectors math.matrices
-namespaces make
-math.constants math.functions
-math.vectors
-splitting grouping math.trig
- sequences accessors 4DNav.deep models vars ;
+USING: kernel math arrays math.vectors math.matrices namespaces make
+math.constants math.functions splitting grouping math.trig sequences
+accessors 4DNav.deep models vars ;
IN: 4DNav.turtle
! replacement of self
namespaces\r
adsoda \r
models\r
-accessors\r
prettyprint\r
;\r
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: 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
--- /dev/null
+! 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
--- /dev/null
+! 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
\r
<PRIVATE\r
\r
+: preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline\r
+\r
+: amb-preserve ( quot -- ) failure preserve ; inline\r
+\r
: unsafe-number-from-to ( to from -- to from+n )\r
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
\r
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
'[ _ 0 unsafe-number-from-to nip _ case ] ;\r
\r
-: if-amb ( true false -- )\r
+: if-amb ( true false -- ? )\r
[\r
[ { t f } amb ]\r
[ '[ @ require t ] ]\r
[ '[ @ f ] ]\r
tri* if\r
- ] with-scope ; inline\r
+ ] amb-preserve ; inline\r
\r
: cut-amb ( -- )\r
f failure set ;\r
+\r
+: amb-all ( quot -- )\r
+ [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline\r
+\r
+: bag-of ( quot -- seq )\r
+ V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline\r
USING: accessors arrays bank calendar kernel math math.functions
namespaces make tools.test tools.walker ;
+FROM: bank => balance>> ;
IN: bank.tests
SYMBOL: my-account
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: backtrack shuffle math math.ranges quotations locals fry
-kernel words io memoize macros io prettyprint sequences assocs
+kernel words io memoize macros prettyprint sequences assocs
combinators namespaces ;
IN: benchmark.backtrack
-USING: checksums checksums.sha1 sequences byte-arrays kernel ;
+USING: checksums checksums.sha sequences byte-arrays kernel ;
IN: benchmark.sha1
: sha1-file ( -- )
[ 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 <bloom-filter> ] [ capacity-error? ] must-fail-with
+[ 0.00000001 max-array-capacity size-bloom-filter ] [ capacity-error? ] must-fail-with
! Other error conditions.
[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
get-state element>> pop ; inline
: peek-scope ( -- ht )
- get-state scope>> peek ; inline
+ get-state scope>> last ; inline
: read-elements ( -- )
read-element-type
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) ;
opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry
opengl.capabilities sequences ui.gadgets combinators accessors
macros locals ;
+FROM: opengl.demo-support => rect-vertices ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel io strings byte-arrays sequences namespaces math
-parser crypto.hmac tools.test ;
-IN: crypto.hmac.tests
-
-[
- "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
-] [
- 16 11 <string> "Hi There" sequence>md5-hmac >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
-
-[
- "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
-]
-[
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> sequence>md5-hmac >string
-] unit-test
-
-[
- "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
-] [
- 16 11 <string> "Hi There" sequence>sha1-hmac >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
-] unit-test
-
-[
- "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
-] [
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> sequence>sha1-hmac >string
-] unit-test
+++ /dev/null
-! 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
-
-<PRIVATE
-
-: sha1-hmac ( Ko Ki -- hmac )
- initialize-sha1 process-sha1-block
- stream>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 <array> ;
-
-MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
-
-: 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 <file-reader> stream>sha1-hmac ;
-
-: sequence>sha1-hmac ( K sequence -- hmac )
- binary <byte-reader> stream>sha1-hmac ;
-
-: stream>md5-hmac ( K stream -- hmac )
- [ init-hmac md5-hmac ] with-input-stream ;
-
-: file>md5-hmac ( K path -- hmac )
- binary <file-reader> stream>md5-hmac ;
-
-: sequence>md5-hmac ( K sequence -- hmac )
- binary <byte-reader> stream>md5-hmac ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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? ( 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 cursor-until ; inline
+
+: cursor-find ( cursor quot -- obj ? )
+ [ cursor-until ] [ drop ] 2bi
+ 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
: 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 ]
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
+ { [ dup last CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;
! 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 ;
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
! 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 ;
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
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 ;
: 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 ;
[ print-error ] recover ;
: (fuel-eval-usings) ( usings -- )
- [ [ 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)
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
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 -- )
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
: server ( port -- server )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ start-listener ] >>handler
f >>timeout ;
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 ;
: current-words ( -- seq )
- use get [ keys ] map concat ; inline
+ manifest get
+ [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
+ assoc-union keys ;
: vocabs-words ( names -- seq )
- prune [ (vocab-words) ] map concat ; inline
+ prune [ (vocab-words) ] map concat ;
PRIVATE>
! 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
swap >>tick-slice draw-world ;
M: game-world begin-world
+ open-game-input
dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
- drop
- open-game-input ;
+ drop ;
M: game-world end-world
- close-game-input
[ [ stop-loop ] when* f ] change-game-loop
+ close-game-input
drop ;
: gesture-logger ( -- )
[
<pane> t >>scrolls? dup <scroller>
+ { 450 500 } >>pref-dim
"Gesture log" open-window
<pane-stream> <gesture-logger>
"Gesture input" open-window
! 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
--- /dev/null
+! (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 ;
+
+<PRIVATE
+
+: vertex-array-vertex ( dim x z -- vertex )
+ [ swap first /f ]
+ [ swap second /f ] bi-curry* bi
+ [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( dim z -- vertices )
+ dup 1 + 2array
+ over first 1 + iota
+ 2array [ first2 swap vertex-array-vertex ] with product-map
+ concat ;
+
+: vertex-array ( dim -- vertices )
+ dup second iota
+ [ vertex-array-row ] with map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+ [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: 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 ;
+
+: <grid-mesh> ( 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 ;
+
! 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
! 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
T{ tag f "head" H{ } f t }
}
] [ "<head<title>Spagna</title></head" parse-html ] unit-test
+
+[
+V{
+ T{ tag
+ { name dtd }
+ { text
+ "DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\""
+ }
+ }
+}
+]
+[
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\">"
+ parse-html
+] unit-test
+
+[
+V{
+ T{ tag { name comment } { text "comment" } }
+}
+] [
+ "<!--comment-->" parse-html
+] unit-test
! 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
: closing-tag? ( string -- ? )
[ f ]
- [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
+ [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
[ 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&&
! 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
--- /dev/null
+Kobi Lurie
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors fry images.loader images.normalization\r
+images.processing.rotation kernel literals math sequences\r
+tools.test images.processing.rotation.private ;\r
+IN: images.processing.rotation.tests\r
+\r
+: first-row ( seq^2 -- seq ) first ;\r
+: first-col ( seq^2 -- item ) harvest [ first ] map ;\r
+: last-row ( seq^2 -- item ) last ;\r
+: last-col ( seq^2 -- item ) harvest [ last ] map ;\r
+: end-of-first-row ( seq^2 -- item ) first-row last ;\r
+: first-of-first-row ( seq^2 -- item ) first-row first ;\r
+: end-of-last-row ( seq^2 -- item ) last-row last ;\r
+: first-of-last-row ( seq^2 -- item ) last-row first ;\r
+\r
+<<\r
+\r
+: clone-image ( image -- new-image )\r
+ clone [ clone ] change-bitmap ;\r
+\r
+>>\r
+\r
+CONSTANT: pasted-image\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
+ load-image normalize-image clone-image\r
+ ]\r
+\r
+CONSTANT: pasted-image90\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
+ load-image normalize-image clone-image\r
+ ]\r
+\r
+CONSTANT: lake-image\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/lake.bmp"\r
+ load-image preprocess\r
+ ]\r
+\r
+[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test\r
+[ t ] [\r
+ pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =\r
+] unit-test\r
+\r
+[ t ] [\r
+ pasted-image 90 rotate\r
+ pasted-image90 = \r
+] unit-test\r
+\r
+[ t ] [\r
+ "vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
+ load-image 90 rotate \r
+ "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
+ load-image normalize-image =\r
+] unit-test\r
+ \r
+[ t ] [\r
+ lake-image\r
+ [ first-of-first-row ]\r
+ [ 90 (rotate) end-of-first-row ] bi =\r
+] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test\r
--- /dev/null
+! 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
+images.loader images.normalization kernel locals math sequences ;
+IN: images.processing.rotation
+
+ERROR: unsupported-rotation degrees ;
+
+<PRIVATE
+
+: rotate-90 ( seq^3 -- seq^3 ) flip [ reverse ] map ;
+: rotate-180 ( seq^3 -- seq^3 ) reverse [ reverse ] map ;
+: rotate-270 ( seq^3 -- seq^3 ) flip reverse ;
+
+: (rotate) ( seq n -- seq' )
+ {
+ { 0 [ ] }
+ { 90 [ rotate-90 ] }
+ { 180 [ rotate-180 ] }
+ { 270 [ rotate-270 ] }
+ [ unsupported-rotation ]
+ } case ;
+
+: rows-remove-pad ( byte-rows -- pixels' )
+ [ dup length 4 mod head* ] map ;
+
+: row-length ( image -- n )
+ [ bitmap>> 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 ;
}
"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"
}
"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] ."
$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 ."
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
<PRIVATE
"infix]" [infix-parse parsed \ call parsed ;
<PRIVATE
+
: parse-infix-locals ( assoc end -- quot )
- [
- in-lambda? on
- [ dup [ locals set ] [ push-locals ] bi ] dip
- [infix-parse prepare-operand swap pop-locals
- ] with-scope ;
+ '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
+
PRIVATE>
SYNTAX: [infix|
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 -- )
[ 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 ;
[ 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 ] }
{ 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 ] }
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>> * ;
! 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
CONSTANT: n-segments 5000
: 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 <rgba> ;
: (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
: 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 <slice> ;
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
] 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 ;
! 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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 io.encodings.binary io.encodings.string
+prettyprint ;
+IN: managed-server.chat
+
+TUPLE: chat-server < managed-server ;
+
+SYMBOL: commands
+commands [ H{ } clone ] initialize
+
+SYMBOL: chat-docs
+chat-docs [ H{ } clone ] initialize
+
+CONSTANT: line-beginning "-!- "
+
+: send-line ( string -- )
+ write "\r\n" write flush ;
+
+: handle-me ( string -- )
+ [
+ [ "* " username " " ] dip
+ ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+ client [ (>>object) ] [ t >>quit? drop ] bi ;
+
+: handle-help ( string -- )
+ [
+ "Commands: "
+ commands get keys natural-sort ", " join append send-line
+ ] [
+ chat-docs get ?at
+ [ send-line ]
+ [ "Unknown command: " prepend send-line ] if
+ ] if-empty ;
+
+: usage ( string -- )
+ chat-docs get at send-line ;
+
+: 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 send-line
+ ] [
+ [ 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 ;
+
+[ handle-help ]
+<" Syntax: /help [command]
+Displays the documentation for a command.">
+"help" add-command
+
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
+<" Syntax: /who
+Shows the list of connected users.">
+"who" add-command
+
+[ drop gmt timestamp>rfc822 send-line ]
+<" 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
+
+[ handle-quit ]
+<" Syntax: /quit [message]
+Disconnects a user from the chat server."> "quit" add-command
+
+: handle-command ( string -- )
+ dup " " split1 swap >lower commands get at* [
+ call( string -- ) drop
+ ] [
+ 2drop "Unknown command: " prepend send-line
+ ] if ;
+
+: <chat-server> ( port -- managed-server )
+ "chat-server" utf8 chat-server new-managed-server ;
+
+: 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"
+ ] "" 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
+ username username-taken-string send-line ;
+
+M: chat-server handle-managed-client*
+ readln dup f = [ t client (>>quit?) ] when
+ [
+ "/" ?head [ handle-command ] [ handle-chat ] if
+ ] unless-empty ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar continuations destructors io
+io.encodings.binary io.servers.connection io.sockets
+io.streams.duplex fry kernel locals math math.ranges multiline
+namespaces prettyprint random sequences sets splitting threads
+tools.continuations ;
+IN: managed-server
+
+TUPLE: managed-server < threaded-server clients ;
+
+TUPLE: managed-client
+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 ( -- )
+
+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 ;
+
+: 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>> ;
+: everyone-else ( -- assoc )
+ clients [ drop username = not ] assoc-filter ;
+: everyone-else-streams ( -- assoc ) everyone-else values ;
+
+ERROR: no-such-client username ;
+
+<PRIVATE
+
+: (send-client) ( managed-client seq -- )
+ [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
+
+PRIVATE>
+
+: send-client ( seq username -- )
+ clients ?at [ no-such-client ] [ (send-client) ] if ;
+
+: send-everyone ( seq -- )
+ [ client-streams ] dip '[ _ (send-client) ] each ;
+
+: send-everyone-else ( seq -- )
+ [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
+
+<PRIVATE
+
+: <managed-client> ( 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 clients key? [ handle-already-logged-in ] when ;
+
+: add-managed-client ( -- )
+ client username check-logged-in clients set-at ;
+
+: delete-managed-client ( -- )
+ username server clients>> delete-at ;
+
+: handle-managed-client ( -- )
+ handle-login <managed-client> 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-managed-client ]
+ [ delete-managed-client handle-client-disconnect ]
+ [ ] cleanup ;
+
+: new-managed-server ( port name encoding class -- server )
+ new-threaded-server
+ swap >>name
+ swap >>insecure
+ f >>timeout
+ H{ } clone >>clients ; inline
! 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
"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
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
-! 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
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system debugger fry
-continuations strings ;
+calendar.format arrays mason.config locals debugger fry
+continuations strings io.sockets ;
IN: mason.common
+: short-host-name ( -- string )
+ host-name "." split1 drop ;
+
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 -- )
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 )
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 ;
! 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 -- )
[
"ssh" , status-host get , "-l" , status-username get ,
"./mason-notify" ,
- host-name ,
+ short-host-name ,
target-cpu get ,
target-os get ,
] { } make prepend
[ 5 ] 2dip '[
<process>
- _ [ +closed+ ] unless* >>stdin
+ _ >>stdin
_ >>command
short-running-process
] retry
: 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 -- )
- "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
+ [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
+ [ f swap "release" swap 2array status-notify ]
+ bi ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 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+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+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
+
+SYMBOLS: host-name target-os target-cpu message message-arg ;
+
+: parse-args ( command-line -- )
+ dup last message-arg set
+ [
+ {
+ [ host-name set ]
+ [ target-cpu set ]
+ [ target-os set ]
+ [ message set ]
+ } spread
+ ] input<sequence ;
+
+: find-builder ( -- builder )
+ builder new
+ host-name get >>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 ( builder -- ) +boot+ >>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
+ 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 -- )
+ message get {
+ { "git-id" [ message-arg get git-id ] }
+ { "make-vm" [ make-vm ] }
+ { "boot" [ boot ] }
+ { "test" [ test ] }
+ { "report" [ message-arg get contents report ] }
+ { "release" [ message-arg get release ] }
+ } case ;
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: handle-update ( command-line timestamp -- )
+ mason-db [
+ [ 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 now [ log-update ] [ handle-update ] 2bi ;
+
+MAIN: main
! 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" ? ;
! 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 ;
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
: common-report ( -- xml )
target-os get
target-cpu get
- host-name
+ short-host-name
build-dir
current-git-id get
[XML
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-contents 400 short tail* :> output
+ file utf8 400 file-tail :> output
[XML
<h2><-what-></h2>
"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 <tr><td><-></td><td><-></td></tr> XML]
] 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
} 2cleave
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
-: v~ ( a b epsilon -- ? )
- [ ~ ] curry 2all? ;
-
: a~ ( a b epsilon -- ? )
{
[ [ [ x>> ] bi@ ] dip v~ ]
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" } "." } ;
-
[ 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
-
: negmin ( a b -- x )
0 min min ;
-
-: clamp ( a value b -- x )
- min max ;
! 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
-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
--- /dev/null
+! (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
--- /dev/null
+! (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 )
+ last ; 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 ;
+
--- /dev/null
+Homogeneous coordinate math
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize ;
+sequences kernel parser memoize ;
IN: minneapolis-talk
CONSTANT: minneapolis-slides
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
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
: start-mmm-server ( -- )
output-stream get mmm-dump-output set
- <threaded-server> [ mmm-t-srv set ] keep
+ binary <threaded-server> [ mmm-t-srv set ] keep
"127.0.0.1" mmm-port get <inet4> >>insecure
- binary >>encoding
[ handle-mmm-connection ] >>handler
start-server* ;
check-options
start-mmm-server ;
-MAIN: run-mmm
\ No newline at end of file
+MAIN: run-mmm
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
--- /dev/null
+! (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 } <nurbs-curve> 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
--- /dev/null
+! (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) ;
+
+: <nurbs-curve> ( 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 <clumps> :> 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) ;
+
+
--- /dev/null
+NURBS curve evaluation
! 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
! 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
#! 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 )
! 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:
: (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) [
] { } 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
[ 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 ;
[ 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>
<PRIVATE
: next-keys ( key -- keys )
- [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
SYNTAX: SOLUTION:
scan-word
[ name>> "-main" append create-in ] keep
- [ drop in get vocab (>>main) ]
+ [ drop current-vocab (>>main) ]
[ [ . ] swap prefix (( -- )) define-declared ]
2bi ;
! (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 ;
+++ /dev/null
-Maxim Savchenko
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel accessors continuations lexer vocabs vocabs.parser
- combinators.short-circuit sandbox tools.test ;
-
-IN: sandbox.tests
-
-<< "sandbox.syntax" load-vocab drop >>
-USE: sandbox.syntax.private
-
-: run-script ( x lines -- y )
- H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
- parse-sandbox call( x -- x! ) ;
-
-[ 120 ]
-[
- 5
- {
- "! Simple factorial example"
- "APPLYING: kernel math sequences ;"
- "1 swap [ 1+ * ] each"
- } run-script
-] unit-test
-
-[
- 5
- {
- "! Jailbreak attempt with USE:"
- "USE: io"
- "\"Hello world!\" print"
- } run-script
-]
-[
- {
- [ lexer-error? ]
- [ error>> condition? ]
- [ error>> error>> no-word-error? ]
- [ error>> error>> name>> "USE:" = ]
- } 1&&
-] must-fail-with
-
-[
- 5
- {
- "! Jailbreak attempt with unauthorized APPLY:"
- "APPLY: io"
- "\"Hello world!\" print"
- } run-script
-]
-[
- {
- [ lexer-error? ]
- [ error>> sandbox-error? ]
- [ error>> vocab>> "io" = ]
- } 1&&
-] must-fail-with
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences vectors assocs namespaces parser lexer vocabs
- combinators.short-circuit vocabs.parser ;
-
-IN: sandbox
-
-SYMBOL: whitelist
-
-: with-sandbox-vocabs ( quot -- )
- "sandbox.syntax" load-vocab vocab-words 1vector
- use [ auto-use? off call ] with-variable ; inline
-
-: parse-sandbox ( lines assoc -- quot )
- whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
-
-: reveal-in ( name -- )
- [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
-
-SYNTAX: REVEAL: scan reveal-in ;
-
-SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
+++ /dev/null
-Basic sandboxing
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
-IN: sandbox.syntax
-
-<PRIVATE
-
-ERROR: sandbox-error vocab ;
-
-: sandbox-use+ ( alias -- )
- dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
-
-PRIVATE>
-
-SYNTAX: APPLY: scan sandbox-use+ ;
-
-SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
-
-REVEALING:
- ! #!
- HEX: OCT: BIN: f t CHAR: "
- [ { T{
- ] } ;
-
-REVEAL: ;
! (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 <product-sequence> } " word." }
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 )
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
[ 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
} 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 ]
--- /dev/null
+Joe Groff
+Doug Coleman
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;
+ 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)
--- /dev/null
+Walk around on procedurally generated terrain
+! (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
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 combinators.short-circuit
+destructors grid-meshes ;
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 / ]
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
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 ;
+ 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-mesh
+ history ;
+
+: <player> ( -- 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 ;
[ 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 <gl-buffer> ;
-
-: 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 / * ;
: 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 90.0 clamp ;
: walk-forward ( player -- )
dup forward-vector [ v+ ] curry change-velocity drop ;
: 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 ;
+
+
+terrain-world H{
+ { T{ key-down { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] }
+} set-gestures
:: handle-input ( world -- )
world player>> :> player
read-keyboard keys>> :> keys
+
+ 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
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-space keys nth [ player jump ] when
key-escape keys nth [ world close-window ] when
player read-mouse rotate-with-mouse
reset-mouse ;
: apply-friction ( velocity -- velocity' )
- FRICTION v*n ;
+ FRICTION v* ;
: apply-gravity ( velocity -- velocity' )
1 over [ GRAVITY - ] change-nth ;
[ [ 1 ] 2dip [ max ] with change-nth ]
[ ] tri ;
-: tick-player ( world player -- )
+: scaled-velocity ( player -- velocity )
+ [ velocity>> ] [ velocity-modifier>> ] bi v* ;
+
+: 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 velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+ 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 ;
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> >>player
+ V{ } clone >>history
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
>>sky-program
terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
>>terrain-program
- vertex-array >vertex-buffer >>terrain-vertex-buffer
+ terrain-vertex-size <grid-mesh> >>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 ]
[ 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 ;
USING: accessors kernel tetris.game tetris.board tetris.piece tools.test
sequences ;
+FROM: tetris.game => level>> ;
[ t ] [ <default-tetris> [ current-piece ] [ next-piece ] bi and t f ? ] unit-test
[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
! 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 } ;
! 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 ;
: <time-server> ( -- threaded-server )
- <threaded-server>
+ ascii <threaded-server>
"time-server" >>name
1234 >>insecure
[ handle-time-client ] >>handler ;
IN: tty-server
: <tty-server> ( port -- )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ listener ] >>handler
start-server ;
USING: accessors kernel fry math models ui.gadgets ui.gadgets.books ui.gadgets.buttons ;
+FROM: models => change-model ;
IN: ui.gadgets.book-extras
: <book*> ( pages -- book ) 0 <model> <book> ;
: |<< ( book -- ) 0 swap set-control-value ;
! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+ <title>Factor binary package for <t:label t:name="platform" /></title>
+ </head>
+ <body>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+
+ <h1>Factor binary package for <t:label t:name="platform" /></h1>
+
+ <p>Requirements:</p>
+ <t:xml t:name="requirements" />
+
+ <h2>Download <t:xml t:name="package" /></h2>
+
+ <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
+
+ <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
+
+ <h1>Build machine information</h1>
+
+ <table border="1">
+ <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
+ <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
+ <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
+ <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
+ <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
+ <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
+ </table>
+
+ <p><t:xml t:name="last-report" /></p>
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+! 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 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 urls ;
+FROM: assocs => at keys values ;
+IN: webapps.mason
+
+TUPLE: mason-app < dispatcher ;
+
+: link ( url label -- xml )
+ [XML <a href=<->><-></a> XML] ;
+
+: download-link ( builder label -- xml )
+ [
+ [ URL" http://builds.factorcode.org/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 last-release>> dup
+ [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
+ [XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
+ ] [
+ [XML <td class="doesnotexist" /> XML]
+ ] if* ;
+
+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 <th align='center' scope='col'><-></th> XML] ] map ]
+ [
+ keys
+ cpus [
+ [ nip second ] [ first ] 2bi [
+ swap download-grid-cell
+ ] curry map
+ [XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
+ ] with map
+ ] bi
+ [XML
+ <table id="downloads" cellspacing="0">
+ <tr><th class="nobg">OS/CPU</th><-></tr>
+ <->
+ </table>
+ XML] ;
+
+: <download-grid-action> ( -- action )
+ <action>
+ [ download-grid xml>string "text/html" <content> ] >>display ;
+
+: 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 ;
+
+: <build-report-action> ( -- action )
+ <action>
+ [ validate-os/cpu ] >>init
+ [ current-builder last-report>> "text/html" <content> ] >>display ;
+
+: git-link ( id -- link )
+ [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
+ [XML <a href=<->><-></a> XML] ;
+
+: building ( builder string -- xml )
+ 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 )
+ [ 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 ;
+
+: binaries-url ( builder -- url )
+ [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
+
+: latest-binary-link ( builder -- xml )
+ [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
+
+: binaries-link ( builder -- 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 dup link ;
+
+: report-link ( builder -- xml )
+ [ URL" report" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ [XML <a href=<->>Latest build report</a> XML] ;
+
+: requirements ( builder -- xml )
+ [
+ os>> {
+ { "winnt" "Windows XP (also tested on Vista)" }
+ { "macosx" "Mac OS X 10.5 Leopard" }
+ { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
+ { "freebsd" "FreeBSD 7.0" }
+ { "netbsd" "NetBSD 4.0" }
+ { "openbsd" "OpenBSD 4.4" }
+ } at
+ ] [
+ dup cpu>> "x86.32" = [
+ os>> {
+ { [ 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
+ ] bi
+ 2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> 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 ;
+
+: <download-binary-action> ( -- action )
+ <page-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 ]
+ [ 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 ;
+
+: <mason-app> ( -- dispatcher )
+ mason-app new-dispatcher
+ <build-report-action> "report" add-responder
+ <download-binary-action> "download" add-responder
+ <download-grid-action> "grid" add-responder
+ mason-db <db-persistence> ;
+
[
f <blog>
[ deposit-blog-slots ]
- [ "id" value >>id ]
- [ update-tuple ]
- tri
+ [ "id" value >>id update-tuple ] bi
<url>
"$planet/admin" >>path
"twitter" value >>twitter
"sms" value >>sms
update-tuple
- site-list-url <redirect>
+ f <redirect>
] >>submit
<protected>
"update notification details" >>description ;
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 )
webapps.planet
webapps.wiki
webapps.user-admin
-webapps.help ;
+webapps.help
+webapps.mason ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
+ <mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
-<% USING: kernel io prettyprint vocabs sequences ;
-%>" Vim syntax file
-" Language: factor
-" Maintainer: Alex Chapman <chapman.alex@gmail.com>
-" 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 <chapman.alex@gmail.com>
+" Last Change: 2009 May 19
+" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" <fhtml> 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.
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=/\<C{\>/ 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=/\<C{\>/ end=/\<}\>/ contains=@factorReal
syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
syn match factorBinary /\<BIN:\s\+[01]\+\>/
syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
syn match factorOctal /\<OCT:\s\+\o\+\>/
-syn match factorIn /\<IN:\s\+\S\+\>/
-syn match factorUse /\<USE:\s\+\S\+\>/
+syn match factorIn /\<IN:\s\+\S\+\>/
+syn match factorUse /\<USE:\s\+\S\+\>/
+syn match factorUnuse /\<UNUSE:\s\+\S\+\>/
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match factorCharErr /\<CHAR:\s\+\S\+/
+syn match factorChar /\<CHAR:\s\+\\\=\S\>/
-syn match factorBackslash /\<\\\>\s\+\S\+\>/
+syn match factorBackslash /\<\\\>\s\+\S\+\>/
-syn region factorUsing start=/\<USING:\>/ end=/;/
-syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
+syn region factorUsing start=/\<USING:\>/ end=/;/
+syn region factorSingletons start=/\<SINGLETONS:\>/ end=/;/
+syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
+syn region factorSymbols start=/\<SYMBOLS:\>/ end=/;/
+syn region factorConstructor2 start=/\<CONSTRUCTOR:\?/ end=/;/
+syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
-syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
-syn match factorDefer /\<DEFER:\s\+\S\+\>/
-syn match factorForget /\<FORGET:\s\+\S\+\>/
-syn match factorMixin /\<MIXIN:\s\+\S\+\>/
-syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
-syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
-syn match factorMain /\<MAIN:\s\+\S\+\>/
-syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match factorConstant /\<CONSTANT:\s\+\S\+\>/
+syn match factorSingleton /\<SINGLETON:\s\+\S\+\>/
+syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
+syn match factorDefer /\<DEFER:\s\+\S\+\>/
+syn match factorForget /\<FORGET:\s\+\S\+\>/
+syn match factorMixin /\<MIXIN:\s\+\S\+\>/
+syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
+syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
+syn match factorMain /\<MAIN:\s\+\S\+\>/
+syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
+syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"TODO:
"misc:
" 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
if version >= 508 || !exists("did_factor_syn_inits")
if version <= 508
- let did_factor_syn_inits = 1
- command -nargs=+ HiLink hi link <args>
+ let did_factor_syn_inits = 1
+
command -nargs=+ HiLink hi link <args>
else
- command -nargs=+ HiLink hi def link <args>
+
command -nargs=+ HiLink hi def link <args>
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
" Vim syntax file
-" Language: factor
-" Maintainer: Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2008 Apr 28
+" Language: factor
+" Maintainer: Alex Chapman <chapman.alex@gmail.com>
+" Last Change: 2009 May 19
+" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" <fhtml> 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.
syn keyword factorBoolean boolean f general-t t
syn keyword factorCompileDirective inline foldable parsing
-
-
-" 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 <wrapper> 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? <enum> 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 <buckets> 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? <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 <flat-slice> second change-each join set-repetition-len <reversed> 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 <repetition> 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 <array> 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 <string> 1string string string?
-syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
-syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> 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 <condition> 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=/\<C{\>/ end=/\<}\>/ contains=@factorReal
+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 <wrapper> 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 <enum> 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 <buckets> 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 <fp-nan> < 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? <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 <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> 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? <repetition> 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 <array> 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 <string> 1string string string?
+syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
+syn keyword factorKeyword with-return restarts return-continuation with-datastack recover rethrow-restarts <restart> ifcc set-catchstack >continuation< cleanup ignore-errors restart? compute-restarts attempt-all-error error-thread continue <continuation> attempt-all-error? condition? <condition> throw-restarts error catchstack continue-with thread-error-hook continuation rethrow callcc1 error-continuation callcc0 attempt-all condition continuation? restart return
+
+
+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=/\<C{\>/ end=/\<}\>/ contains=@factorReal
syn match factorBinErr /\<BIN:\s\+[01]*[^\s01]\S*\>/
syn match factorBinary /\<BIN:\s\+[01]\+\>/
syn match factorHexErr /\<HEX:\s\+\x*[^\x\s]\S*\>/
syn match factorOctErr /\<OCT:\s\+\o*[^\o\s]\S*\>/
syn match factorOctal /\<OCT:\s\+\o\+\>/
-syn match factorIn /\<IN:\s\+\S\+\>/
-syn match factorUse /\<USE:\s\+\S\+\>/
+syn match factorIn /\<IN:\s\+\S\+\>/
+syn match factorUse /\<USE:\s\+\S\+\>/
+syn match factorUnuse /\<UNUSE:\s\+\S\+\>/
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match factorCharErr /\<CHAR:\s\+\S\+/
+syn match factorChar /\<CHAR:\s\+\\\=\S\>/
-syn match factorBackslash /\<\\\>\s\+\S\+\>/
+syn match factorBackslash /\<\\\>\s\+\S\+\>/
-syn region factorUsing start=/\<USING:\>/ end=/;/
-syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
+syn region factorUsing start=/\<USING:\>/ end=/;/
+syn region factorSingletons start=/\<SINGLETONS:\>/ end=/;/
+syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
+syn region factorSymbols start=/\<SYMBOLS:\>/ end=/;/
+syn region factorConstructor2 start=/\<CONSTRUCTOR:\?/ end=/;/
+syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
-syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
-syn match factorDefer /\<DEFER:\s\+\S\+\>/
-syn match factorForget /\<FORGET:\s\+\S\+\>/
-syn match factorMixin /\<MIXIN:\s\+\S\+\>/
-syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
-syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
-syn match factorMain /\<MAIN:\s\+\S\+\>/
-syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match factorConstant /\<CONSTANT:\s\+\S\+\>/
+syn match factorSingleton /\<SINGLETON:\s\+\S\+\>/
+syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
+syn match factorDefer /\<DEFER:\s\+\S\+\>/
+syn match factorForget /\<FORGET:\s\+\S\+\>/
+syn match factorMixin /\<MIXIN:\s\+\S\+\>/
+syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
+syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
+syn match factorMain /\<MAIN:\s\+\S\+\>/
+syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match factorAlien /\<ALIEN:\s\+\d\+\>/
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
+syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
"TODO:
"misc:
" 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
"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")
if version >= 508 || !exists("did_factor_syn_inits")
if version <= 508
- let did_factor_syn_inits = 1
- command -nargs=+ HiLink hi link <args>
+ let did_factor_syn_inits = 1
+
command -nargs=+ HiLink hi link <args>
else
- command -nargs=+ HiLink hi def link <args>
+
command -nargs=+ HiLink hi def link <args>
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
set autoindent " annoying?
" vim: syntax=vim
-
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 ;
-
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- ) [
- <threaded-server> 5000 >>insecure binary >>encoding [ (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 ;
+: 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 ;
+
+: start-serving-vocabs ( -- )
+ [
+ binary <threaded-server>
+ 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 ;
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
--- /dev/null
+Maxim Savchenko
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+ combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+ H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+ parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+ 5
+ {
+ "! Simple factorial example"
+ "APPLYING: kernel math sequences ;"
+ "1 swap [ 1+ * ] each"
+ } run-script
+] unit-test
+
+[
+ 5
+ {
+ "! Jailbreak attempt with USE:"
+ "USE: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> condition? ]
+ [ error>> error>> no-word-error? ]
+ [ error>> error>> name>> "USE:" = ]
+ } 1&&
+] must-fail-with
+
+[
+ 5
+ {
+ "! Jailbreak attempt with unauthorized APPLY:"
+ "APPLY: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> sandbox-error? ]
+ [ error>> vocab>> "io" = ]
+ } 1&&
+] must-fail-with
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+ combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+ "sandbox.syntax" load-vocab vocab-words 1vector
+ use [ auto-use? off call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+ whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+ [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
--- /dev/null
+Basic sandboxing
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+ dup whitelist get at [ add-use ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+ ! #!
+ HEX: OCT: BIN: f t CHAR: "
+ [ { T{
+ ] } ;
+
+REVEAL: ;
else
{
array *literals = untag<array>(compiled->literals);
- return array_nth(literals,0);
+ cell executing = array_nth(literals,0);
+ check_data_pointer((object *)executing);
+ return executing;
}
}
return (stack_frame *)((cell)frame - frame->size);
}
+/* Allocates memory */
cell frame_scan(stack_frame *frame)
{
- if(frame_type(frame) == QUOTATION_TYPE)
+ switch(frame_type(frame))
{
- cell quot = frame_executing(frame);
- if(quot == F)
- return F;
- else
+ case QUOTATION_TYPE:
{
- 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)));
+ 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)));
+ }
}
- }
- 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;
- array *frames;
- stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal<array>(count)) {}
+ growable_array frames;
+
void operator()(stack_frame *frame)
{
- set_array_nth(frames,index++,frame_executing(frame));
- set_array_nth(frames,index++,frame_scan(frame));
+ gc_root<object> executing(frame_executing(frame));
+ gc_root<object> scan(frame_scan(frame));
+
+ frames.add(executing.value());
+ frames.add(scan.value());
}
};
{
gc_root<callstack> 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(tag<array>(accum.frames));
+ dpush(accum.frames.elements.value());
}
stack_frame *innermost_stack_frame(callstack *stack)
}
}
-template<typename T> 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<typename T> void iterate_callstack_object(callstack *stack_, T &iterator)
{
- iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
+ gc_root<callstack> 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);
+ }
}
}
case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE:
- return offset + (short)untag_fixnum(ARG);
+ {
+ fixnum arg = untag_fixnum(ARG);
+ return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+ }
case RT_THIS:
return (cell)(compiled + 1);
case RT_STACK_CHAIN:
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)):
#ifdef WINDOWS
.section .drectve
.ascii " -export:check_sse2"
+ .ascii " -export:read_timestamp_counter"
#endif
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)):
/* 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)); }
};
template <typename T>
struct gc_root : public tagged<T>
{
- void push() { gc_local_push((cell)this); }
+ void push() { check_tagged_pointer(tagged<T>::value()); gc_local_push((cell)this); }
explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
projects / factor.git / commitdiff
