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

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

db4
Slava Pestov 2009-05-11 14:38:45 -05:00
parent 25b743a64a 87717fa78c
commit cff70d6a9f
377 changed files with 4779 additions and 2148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
README.txt
View File

@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
* Compiling the Factor VM
The Factor runtime is written in GNU C++, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org>.
Factor requires gcc 3.4 or later.
On x86, Factor /will not/ build using gcc 3.3 or earlier.
If you are using gcc 4.3, you might get an unusable Factor binary unless
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
arguments for make.
The Factor VM is written in C++ and uses GNU extensions. When compiling
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
uses std::tr1::unordered_map which is shipped as part of GCC.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor
Once you have compiled the Factor VM, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Boot images can be obtained from <http://factorcode.org/images/latest/>.
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
Then bootstrap with the following switches:
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
vm/ - sources for the Factor VM, written in C++
vm/ - Factor VM
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications

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

@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: c-bool> ( int -- ? )
0 = not ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
@ -409,10 +410,10 @@ CONSTANT: primitive-types
"uchar" define-primitive-type
<c-type>
[ alien-unsigned-4 zero? not ] >>getter
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type

2
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
SYMBOL: libraries

2
basis/base64/base64-tests.factor
View File

@ -4,7 +4,7 @@ IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test

2
basis/bootstrap/compiler/compiler.factor Normal file → Executable file
View File

@ -41,7 +41,7 @@ nl
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
roll -roll declare not
not
array? hashtable? vector?
tuple? sbuf? tombstone?

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

@ -9,7 +9,7 @@ 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 ;
fry bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
M: integer (eql?) = ;
M: float (eql?)
over float? [ fp-bitwise= ] [ 2drop f ] if ;
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
@ -93,24 +96,19 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives
SYMBOL: jit-define-rc
SYMBOL: jit-define-rt
SYMBOL: jit-define-offset
SYMBOL: jit-relocations
: compute-offset ( -- offset )
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
: compute-offset ( rc -- offset )
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
: jit-rel ( rc rt -- )
jit-define-rt set
jit-define-rc set
compute-offset jit-define-offset set ;
over compute-offset 3array jit-relocations get push-all ;
: make-jit ( quot -- quad )
: make-jit ( quot -- jit-data )
[
V{ } clone jit-relocations set
call( -- )
jit-define-rc get
jit-define-rt get
jit-define-offset get 3array
jit-relocations get >array
] B{ } make prefix ;
: jit-define ( quot name -- )
@ -128,98 +126,59 @@ SYMBOL: big-endian
! Bootstrap architecture name
SYMBOL: architecture
! Bootstrap global namesapce
SYMBOL: bootstrap-global
RESET
! Boot quotation, set in stage1.factor
SYMBOL: bootstrap-boot-quot
USERENV: bootstrap-boot-quot 20
! Bootstrap global namesapce
USERENV: bootstrap-global 21
! JIT parameters
SYMBOL: jit-prolog
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-1
SYMBOL: jit-if-2
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
SYMBOL: jit-execute-word
SYMBOL: jit-execute-jump
SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-save-stack
USERENV: jit-prolog 23
USERENV: jit-primitive-word 24
USERENV: jit-primitive 25
USERENV: jit-word-jump 26
USERENV: jit-word-call 27
USERENV: jit-word-special 28
USERENV: jit-if-word 29
USERENV: jit-if 30
USERENV: jit-epilog 31
USERENV: jit-return 32
USERENV: jit-profiling 33
USERENV: jit-push-immediate 34
USERENV: jit-dip-word 35
USERENV: jit-dip 36
USERENV: jit-2dip-word 37
USERENV: jit-2dip 38
USERENV: jit-3dip-word 39
USERENV: jit-3dip 40
USERENV: jit-execute-word 41
USERENV: jit-execute-jump 42
USERENV: jit-execute-call 43
! PIC stubs
SYMBOL: pic-load
SYMBOL: pic-tag
SYMBOL: pic-hi-tag
SYMBOL: pic-tuple
SYMBOL: pic-hi-tag-tuple
SYMBOL: pic-check-tag
SYMBOL: pic-check
SYMBOL: pic-hit
SYMBOL: pic-miss-word
USERENV: pic-load 47
USERENV: pic-tag 48
USERENV: pic-hi-tag 49
USERENV: pic-tuple 50
USERENV: pic-hi-tag-tuple 51
USERENV: pic-check-tag 52
USERENV: pic-check 53
USERENV: pic-hit 54
USERENV: pic-miss-word 55
USERENV: pic-miss-tail-word 56
! Megamorphic dispatch
SYMBOL: mega-lookup
SYMBOL: mega-lookup-word
SYMBOL: mega-miss-word
USERENV: mega-lookup 57
USERENV: mega-lookup-word 58
USERENV: mega-miss-word 59
! Default definition for undefined words
SYMBOL: undefined-quot
: userenvs ( -- assoc )
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-save-stack 38 }
{ jit-dip-word 39 }
{ jit-dip 40 }
{ jit-2dip-word 41 }
{ jit-2dip 42 }
{ jit-3dip-word 43 }
{ jit-3dip 44 }
{ jit-execute-word 45 }
{ jit-execute-jump 46 }
{ jit-execute-call 47 }
{ pic-load 48 }
{ pic-tag 49 }
{ pic-hi-tag 50 }
{ pic-tuple 51 }
{ pic-hi-tag-tuple 52 }
{ pic-check-tag 53 }
{ pic-check 54 }
{ pic-hit 55 }
{ pic-miss-word 56 }
{ mega-lookup 57 }
{ mega-lookup-word 58 }
{ mega-miss-word 59 }
{ undefined-quot 60 }
} ; inline
USERENV: undefined-quot 60
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
userenvs get at header-size + ;
: emit ( cell -- ) image get push ;
@ -351,7 +310,8 @@ M: f '
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
[ direct-entry-def>> , ] ! direct-entry-def
[ pic-def>> , ]
[ pic-tail-def>> , ]
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
@ -510,11 +470,7 @@ M: quotation '
class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set
bootstrap-global emit-userenv ;
: emit-boot-quot ( -- )
bootstrap-boot-quot emit-userenv ;
bootstrap-global set ;
: emit-jit-data ( -- )
\ if jit-if-word set
@ -524,46 +480,13 @@ M: quotation '
\ 3dip jit-3dip-word set
\ (execute) jit-execute-word set
\ inline-cache-miss \ pic-miss-word set
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set
{
jit-prolog
jit-primitive-word
jit-primitive
jit-word-jump
jit-word-call
jit-push-immediate
jit-if-word
jit-if-1
jit-if-2
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-execute-word
jit-execute-jump
jit-execute-call
jit-epilog
jit-return
jit-profiling
jit-save-stack
pic-load
pic-tag
pic-hi-tag
pic-tuple
pic-hi-tag-tuple
pic-check-tag
pic-check
pic-hit
pic-miss-word
mega-lookup
mega-lookup-word
mega-miss-word
undefined-quot
} [ emit-userenv ] each ;
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
userenvs get keys [ emit-userenv ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
@ -580,8 +503,8 @@ M: quotation '
emit-jit-data
"Serializing global namespace..." print flush
emit-global
"Serializing boot quotation..." print flush
emit-boot-quot
"Serializing user environment..." print flush
emit-userenvs
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush

1
basis/bootstrap/image/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/bootstrap/image/syntax/syntax.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces assocs words.symbol ;
IN: bootstrap.image.syntax
SYMBOL: userenvs
SYNTAX: RESET H{ } clone userenvs set-global ;
SYNTAX: USERENV:
CREATE-WORD scan-word
[ swap userenvs get set-at ]
[ drop define-symbol ]
2bi ;

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

@ -9,6 +9,9 @@ SYMBOL: bytes-read
: calculate-pad-length ( length -- length' )
[ 56 < 55 119 ? ] keep - ;
: calculate-pad-length-long ( length -- length' )
[ 120 < 119 247 ? ] keep - ;
: pad-last-block ( str big-endian? length -- str )
[
[ % ] 2dip HEX: 80 ,

49
basis/checksums/sha2/sha2-tests.factor
View File

@ -1,7 +1,42 @@
USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
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

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

@ -2,12 +2,27 @@
! 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 ;
sbufs strings combinators.smart math.ranges fry combinators
accessors locals ;
IN: checksums.sha2
<PRIVATE
SINGLETON: sha-224
SINGLETON: sha-256
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
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
@ -18,13 +33,43 @@ CONSTANT: f 5
CONSTANT: g 6
CONSTANT: h 7
: initial-H-256 ( -- seq )
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
} ;
}
: K-256 ( -- seq )
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
@ -42,62 +87,163 @@ CONSTANT: h 7
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 ] keep
[ -18 bitroll-32 ] keep
-3 shift bitxor bitxor ; inline
[
[ -7 bitroll-32 ]
[ -18 bitroll-32 ]
[ -3 shift ] tri
] [ bitxor ] reduce-outputs ; inline
: s1-256 ( x -- x' )
[ -17 bitroll-32 ] keep
[ -19 bitroll-32 ] keep
-10 shift bitxor bitxor ; inline
: process-M-256 ( seq n -- )
[ 16 - swap nth ] 2keep
[ 15 - swap nth s0-256 ] 2keep
[ 7 - swap nth ] 2keep
[ 2 - swap nth s1-256 ] 2keep
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
word-size get group [ be> ] map block-size get 0 pad-tail
dup 16 64 dup <slice> [
process-M-256
] with each ;
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ;
: maj ( x y z -- x' )
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
[
[ -17 bitroll-32 ]
[ -19 bitroll-32 ]
[ -10 shift ] tri
] [ bitxor ] reduce-outputs ; inline
: S0-256 ( x -- x' )
[ -2 bitroll-32 ] keep
[ -13 bitroll-32 ] keep
-22 bitroll-32 bitxor bitxor ; inline
[
[ -2 bitroll-32 ]
[ -13 bitroll-32 ]
[ -22 bitroll-32 ] tri
] [ bitxor ] reduce-outputs ; inline
: S1-256 ( x -- x' )
[ -6 bitroll-32 ] keep
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
[
[ -6 bitroll-32 ]
[ -11 bitroll-32 ]
[ -25 bitroll-32 ] tri
] [ bitxor ] reduce-outputs ; inline
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
: s0-512 ( x -- x' )
[
[ -1 bitroll-64 ]
[ -8 bitroll-64 ]
[ -7 shift ] tri
] [ bitxor ] reduce-outputs ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
K get nth +
e vars get slice3 ch +
e vars get nth S1-256 +
h vars get nth w+ ;
: s1-512 ( x -- x' )
[
[ -19 bitroll-64 ]
[ -61 bitroll-64 ]
[ -6 shift ] tri
] [ bitxor ] reduce-outputs ; inline
: T2 ( -- T2 )
a vars get nth S0-256
a vars get slice3 maj w+ ;
: S0-512 ( x -- x' )
[
[ -28 bitroll-64 ]
[ -34 bitroll-64 ]
[ -39 bitroll-64 ] tri
] [ bitxor ] reduce-outputs ; inline
: update-vars ( T1 T2 -- )
vars get
: 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
@ -105,42 +251,56 @@ CONSTANT: h 7
d c pick exchange
c b pick exchange
b a pick exchange
[ w+ a ] dip set-nth ;
[ w+ a ] dip set-nth ; inline
: process-chunk ( M -- )
H get clone vars set
prepare-message-schedule block-size get [
T1 T2 update-vars
] with each vars get H get [ w+ ] 2map H set ;
: 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
: seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] B{ } make ;
:: 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
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
[ >sbuf ] dip over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %
length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make over push-all ;
: sha2-steps ( sliced-groups state -- )
'[
_
[ prepare-message-schedule ]
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
] each ;
: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each
4 H get seq>byte-array ;
: 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>
SINGLETON: sha-256
INSTANCE: sha-256 checksum
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 [
K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
byte-array>sha2
] with-scope ;
drop <sha-256-state>
[ byte-array>sha2 ]
[ H>> 4 seq>byte-array ] bi ;

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

@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
: NSApp ( -- app ) NSApplication -> sharedApplication ;

12
basis/cocoa/cocoa.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006 Slava Pestov
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
@ -27,22 +27,16 @@ SYMBOL: frameworks
frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ;
"Compiling Objective C bridge..." print
"Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop
{
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
} [ words ] map concat compile
"Importing Cocoa classes..." print
[
{
"NSApplication"

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

@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
'[ _ call _ execute ] ;
1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline

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

@ -4,7 +4,7 @@
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types words core-foundation
combinators alien.c-types words core-foundation quotations
core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
@ -41,10 +41,16 @@ DEFER: plist>
*void* [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
[
dup callable?
[ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
unless
] map '[ _ cond ] ;
PRIVATE>
ERROR: invalid-plist-object object ;
: plist> ( plist -- value )
{
{ NSString [ (plist-NSString>) ] }
@ -53,6 +59,7 @@ PRIVATE>
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
[ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )

5
basis/compiler/codegen/codegen.factor
View File

@ -88,7 +88,7 @@ M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ;
@ -444,8 +444,7 @@ TUPLE: callback-context ;
: do-callback ( quot token -- )
init-catchstack
dup 2 setenv
slip
[ 2 setenv call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )

7
basis/compiler/codegen/fixup/fixup.factor
View File

@ -56,8 +56,11 @@ SYMBOL: literal-table
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
: rel-word-direct ( word class -- )
[ add-literal ] dip rt-xt-direct rel-fixup ;
: rel-word-pic ( word class -- )
[ add-literal ] dip rt-xt-pic rel-fixup ;
: rel-word-pic-tail ( word class -- )
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ;

17
basis/compiler/compiler.factor
View File

@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
} cond ;
: optimize? ( word -- ? )
{
[ predicate-engine-word? ]
[ contains-breakpoints? ]
[ single-generic? ]
} 1|| not ;
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup optimize?
[ [ build-tree ] [ deoptimize ] recover optimize-tree ]
[ dup def>> deoptimize-with ]
if ;
dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
] [ dup def>> deoptimize-with ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.

54
basis/compiler/constants/constants.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays
alien arrays ;
alien arrays literals sequences ;
IN: compiler.constants
! These constants must match vm/memory.h
@ -14,42 +14,42 @@ CONSTANT: deck-bits 18
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
CONSTANT: rc-absolute 1
CONSTANT: rc-relative 2
CONSTANT: rc-absolute-cell 0
CONSTANT: rc-absolute 1
CONSTANT: rc-relative 2
CONSTANT: rc-absolute-ppc-2/2 3
CONSTANT: rc-relative-ppc-2 4
CONSTANT: rc-relative-ppc-3 5
CONSTANT: rc-relative-arm-3 6
CONSTANT: rc-indirect-arm 7
CONSTANT: rc-indirect-arm-pc 8
CONSTANT: rc-absolute-ppc-2 4
CONSTANT: rc-relative-ppc-2 5
CONSTANT: rc-relative-ppc-3 6
CONSTANT: rc-relative-arm-3 7
CONSTANT: rc-indirect-arm 8
CONSTANT: rc-indirect-arm-pc 9
! Relocation types
CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-xt-direct 4
CONSTANT: rt-here 5
CONSTANT: rt-this 6
CONSTANT: rt-immediate 7
CONSTANT: rt-stack-chain 8
CONSTANT: rt-untagged 9
CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-xt-pic 4
CONSTANT: rt-xt-pic-tail 5
CONSTANT: rt-here 6
CONSTANT: rt-this 7
CONSTANT: rt-immediate 8
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
CONSTANT: rt-megamorphic-cache-hits 11
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

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

@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
C{ 1.0 2.0 }
C{ 1.5 1.0 } ffi_test_47
] unit-test
! Reported by jedahu
C-STRUCT: bool-field-test
{ "char*" "name" }
{ "bool" "on" }
{ "short" "parents" } ;
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
ffi_test_48
] unit-test

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

@ -33,7 +33,7 @@ IN: compiler.tests.curry
] unit-test
: foobar ( quot: ( -- ) -- )
dup slip swap [ foobar ] [ drop ] if ; inline recursive
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test

8
basis/compiler/tests/optimizer.factor
View File

@ -389,4 +389,10 @@ DEFER: loop-bbb
[ f ] [ \ broken-declaration optimized? ] unit-test
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
! Modular arithmetic bug
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test

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

@ -65,5 +65,3 @@ PRIVATE>
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

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

@ -302,7 +302,7 @@ C: <ro-box> ro-box
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
dup slip impeach-node ; inline recursive
[ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive

10
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
>fixnum 256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
dup 0 >= [ 256 mod ] when
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
[ [ >fixnum 255 fixnum-bitand ] ]
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test

8
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math math.partial-dispatch namespaces sequences sets
accessors assocs words kernel memoize fry combinators
combinators.short-circuit
compiler.tree
compiler.tree.combinators
compiler.tree.def-use
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
: optimize->integer ( #call -- nodes )
dup out-d>> first actually-used-by dup length 1 = [
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
[ drop { } ] when
] [ drop ] if ;
MEMO: fixnum-coercion ( flags -- nodes )
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
M: #call optimize-modular-arithmetic*
dup word>> {
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
[ drop ]
} cond ;

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

@ -157,11 +157,7 @@ DEFER: (flat-length)
] sum-outputs ;
: should-inline? ( #call word -- ? )
{
{ [ dup contains-breakpoints? ] [ 2drop f ] }
{ [ dup "inline" word-prop ] [ 2drop t ] }
[ inlining-rank 5 >= ]
} cond ;
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history

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

@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
comparison-ops
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
! generic-comparison-ops [
! dup specific-comparison define-comparison-constraints
! ] each
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )
[ [ interval>> ] bi@ ] dip interval-comparison {
@ -217,6 +213,8 @@ generic-comparison-ops [
{ >float float }
{ fixnum>float float }
{ bignum>float float }
{ >integer integer }
} [
'[
_
@ -228,19 +226,26 @@ generic-comparison-ops [
] "outputs" set-word-prop
] assoc-each
: rem-custom-inlining ( #call -- quot/f )
second value-info literal>> dup integer?
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
{
mod-integer-integer
mod-integer-fixnum
mod-fixnum-integer
fixnum-mod
rem
} [
[
in-d>> second value-info >literal<
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
in-d>> dup first value-info interval>> [0,inf] interval-subset?
[ rem-custom-inlining ] [ drop f ] if
] "custom-inlining" set-word-prop
] each
\ rem [
in-d>> rem-custom-inlining
] "custom-inlining" set-word-prop
{
bitand-integer-integer
bitand-integer-fixnum

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

@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
! Joe found an oversight
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

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

@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
! A more complicated example
: impeach-node ( quot: ( node -- ) -- )
dup slip impeach-node ; inline recursive
[ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive

9
basis/core-graphics/core-graphics.factor
View File

@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
<PRIVATE
: bitmap-flags ( -- flags )

5
basis/core-graphics/types/types.factor
View File

@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
TYPEDEF: int CGError
TYPEDEF: uint CGDirectDisplayID
TYPEDEF: int boolean_t
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter
TYPEDEF: int CGLContextParameter

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

@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )

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

@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
{ HEX: 48000001 } [ 1 B ] test-assembler
{ HEX: 48000001 } [ 1 BL ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler
{ HEX: 41810004 } [ 1 BGT ] test-assembler
{ HEX: 40810004 } [ 1 BLE ] test-assembler
{ HEX: 40800004 } [ 1 BGE ] test-assembler
{ HEX: 41800004 } [ 1 BLT ] test-assembler
{ HEX: 40820004 } [ 1 BNE ] test-assembler
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
{ HEX: 41830004 } [ 1 BO ] test-assembler
{ HEX: 40830004 } [ 1 BNO ] test-assembler
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
{ HEX: 4e800020 } [ BLR ] test-assembler
{ HEX: 4e800021 } [ BLRL ] test-assembler
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
{ HEX: 4e800420 } [ BCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler

4
basis/cpu/ppc/assembler/assembler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.codegen.fixup kernel namespaces words
io.binary math math.order cpu.ppc.assembler.backend ;
USING: kernel namespaces words io.binary math math.order
cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
! See the Motorola or IBM documentation for details. The opcode

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

@ -1,11 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.codegen.fixup cpu.architecture
compiler.constants kernel namespaces make sequences words math
math.bitwise io.binary parser lexer ;
USING: kernel namespaces make sequences words math
math.bitwise io.binary parser lexer fry ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
: a-insn ( d a b c xo rc opcode -- )
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
SYNTAX: BC:
CREATE-B scan-word scan-word
[ rot BC ] 2curry (( c -- )) define-declared ;
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
[ b-insn ] curry curry curry curry curry
(( bo -- )) define-declared ;
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;

163
basis/cpu/ppc/bootstrap.factor
View File

@ -9,8 +9,8 @@ IN: bootstrap.ppc
4 \ cell set
big-endian on
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
: factor-area-size ( -- n ) 4 bootstrap-cells ;
@ -21,46 +21,48 @@ CONSTANT: rs-reg 30
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 6 profile-count-offset LWZ
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 3 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW
11 6 word-code-offset LWZ
11 3 profile-count-offset STW
11 3 word-code-offset LWZ
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
] jit-profiling jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
6 1 xt-save STW
stack-frame 6 LI
6 1 next-save STW
3 1 xt-save STW
stack-frame 3 LI
3 1 next-save STW
0 1 lr-save stack-frame + STW
] jit-prolog jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
6 ds-reg 4 STWU
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
3 ds-reg 4 STWU
] jit-push-immediate jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ
1 7 0 STW
] jit-save-stack jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
4 3 0 LWZ
1 4 0 STW
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
3 MTCTR
BCTR
] jit-primitive jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
] jit-word-jump jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
[
3 ds-reg 0 LWZ
@ -68,11 +70,8 @@ CONSTANT: rs-reg 30
0 3 \ f tag-number CMPI
2 BEQ
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-1 jit-define
[
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-2 jit-define
] jit-if jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ
@ -138,6 +137,16 @@ CONSTANT: rs-reg 30
jit-3r>
] jit-3dip jit-define
: prepare-(execute) ( -- operand )
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ
4 ;
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
[
0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI
@ -146,7 +155,99 @@ CONSTANT: rs-reg 30
[ BLR ] jit-return jit-define
! Sub-primitives
! ! ! Polymorphic inline caches
! Don't touch r6 here; it's used to pass the tail call site
! address for tail PICs
! Load a value from a stack position
[
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
] pic-load jit-define
! Tag
: load-tag ( -- )
4 4 tag-mask get ANDI
4 4 tag-bits get SLWI ;
[ load-tag ] pic-tag jit-define
! Hi-tag
[
3 4 MR
load-tag
0 4 object tag-number tag-fixnum CMPI
2 BNE
4 3 object tag-number neg LWZ
] pic-hi-tag jit-define
! Tuple
[
3 4 MR
load-tag
0 4 tuple tag-number tag-fixnum CMPI
2 BNE
4 3 tuple tag-number neg bootstrap-cell + LWZ
] pic-tuple jit-define
! Hi-tag and tuple
[
3 4 MR
load-tag
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
0 4 BIN: 110 tag-fixnum CMPI
5 BLT
! Untag r3
3 3 0 0 31 tag-bits get - RLWINM
! Set r4 to 0 for objects, and bootstrap-cell for tuples
4 4 1 tag-fixnum ANDI
4 4 1 SRAWI
! Load header cell or tuple layout cell
4 4 3 LWZX
] pic-hi-tag-tuple jit-define
[
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
] pic-check-tag jit-define
[
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
4 0 5 CMP
] pic-check jit-define
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches
[
! cache = ...
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
! key = class
5 4 MR
! key &= cache.length - 1
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
! cache += array-start-offset
3 3 array-start-offset ADDI
! cache += key
3 3 5 ADD
! if(get(cache) == class)
6 3 0 LWZ
6 0 4 CMP
10 BNE
! megamorphic_cache_hits++
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
5 4 0 LWZ
5 5 1 ADDI
5 4 0 STW
! ... goto get(cache + bootstrap-cell)
3 3 4 LWZ
3 3 word-xt-offset LWZ
3 MTCTR
BCTR
! fall-through on miss
] mega-lookup jit-define
! ! ! Sub-primitives
! Quotations and words
[
@ -157,14 +258,6 @@ CONSTANT: rs-reg 30
BCTR
] \ (call) define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ
4 MTCTR
BCTR
] \ (execute) define-sub-primitive
! Objects
[
3 ds-reg 0 LWZ

64
basis/cpu/ppc/ppc.factor
View File

@ -1,33 +1,39 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
alien alien.c-types cpu.architecture cpu.ppc.assembler
compiler.cfg.registers compiler.cfg.instructions
compiler.constants compiler.codegen compiler.codegen.fixup
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
alien alien.accessors alien.c-types literals cpu.architecture
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.units ;
IN: cpu.ppc
! PowerPC register assignments:
! r2-r27: integer vregs
! r28: integer scratch
! r29: data stack
! r30: retain stack
! r2-r12: integer vregs
! r15-r29
! r30: integer scratch
! f0-f29: float vregs
! f30, f31: float scratch
! f30: float scratch
! Add some methods to the assembler that are useful to us
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
enable-float-intrinsics
<< \ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop >>
<<
\ ##integer>float t frame-required? set-word-prop
\ ##float>integer t frame-required? set-word-prop
>>
M: ppc machine-registers
{
{ int-regs T{ range f 2 26 1 } }
{ double-float-regs T{ range f 0 29 1 } }
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
{ double-float-regs $[ 0 29 [a,b] ] }
} ;
CONSTANT: scratch-reg 28
CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
M: ppc two-operand? f ;
@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
GENERIC: loc-reg ( loc -- reg )
@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
factor-area-size +
4 cells align ;
M: ppc %call ( label -- ) BL ;
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
M: ppc %jump ( word -- )
0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
0 B rc-relative-ppc-3 rel-word-pic-tail ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
BCTR ;
M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
15 3 MR ;
M: ppc %alien-indirect ( -- )
13 MTLR BLRL ;
15 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
@ -702,3 +713,14 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
[
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
] with-compilation-unit

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

@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
M: x86.32 param-reg-1 EAX ;
M: x86.32 param-reg-2 EDX ;
M: x86.32 pic-tail-reg EBX ;
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type

8
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ;
@ -26,10 +26,8 @@ IN: bootstrap.x86
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
(JMP) drop rc-relative rt-primitive jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>

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

@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;

5
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
@ -25,9 +25,6 @@ IN: bootstrap.x86
temp0 temp0 [] MOV
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! go

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

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays cpu.architecture compiler.constants
compiler.codegen.fixup io.binary kernel combinators
kernel.private math namespaces make sequences words system
layouts math.order accessors cpu.x86.assembler.syntax ;
USING: arrays io.binary kernel combinators
kernel.private math namespaces make sequences words system layouts
math.order accessors cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
! A postfix assembler for x86-32 and x86-64.
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
@ -296,36 +295,23 @@ M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
! Control flow
GENERIC: JMP ( op -- )
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: f JMP (JMP) 2drop ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: integer JMP HEX: e9 , 4, ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ;
M: callable CALL (CALL) rel-word-direct ;
M: label CALL (CALL) label-fixup ;
M: integer CALL HEX: e8 , 4, ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
M: integer JUMPcc (JUMPcc) drop ;
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
M: integer JUMPcc extended-opcode, 4, ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;

44
basis/cpu/x86/bootstrap.factor
View File

@ -42,13 +42,18 @@ big-endian off
] jit-push-immediate jit-define
[
f JMP rc-relative rt-xt jit-rel
temp3 0 MOV rc-absolute-cell rt-here jit-rel
0 JMP rc-relative rt-xt-pic-tail jit-rel
] jit-word-jump jit-define
[
f CALL rc-relative rt-xt-direct jit-rel
0 CALL rc-relative rt-xt-pic jit-rel
] jit-word-call jit-define
[
0 JMP rc-relative rt-xt jit-rel
] jit-word-special jit-define
[
! load boolean
temp0 ds-reg [] MOV
@ -57,13 +62,10 @@ big-endian off
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
f JNE rc-relative rt-xt jit-rel
] jit-if-1 jit-define
[
0 JNE rc-relative rt-xt jit-rel
! jump to false branch if equal
f JMP rc-relative rt-xt jit-rel
] jit-if-2 jit-define
0 JMP rc-relative rt-xt jit-rel
] jit-if jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
@ -115,19 +117,19 @@ big-endian off
[
jit->r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-r>
] jit-dip jit-define
[
jit-2>r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-2r>
] jit-2dip jit-define
[
jit-3>r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-3r>
] jit-3dip jit-define
@ -152,8 +154,7 @@ big-endian off
! ! ! Polymorphic inline caches
! temp0 contains the object being dispatched on
! temp1 contains its class
! The PIC and megamorphic code stubs are not permitted to touch temp3.
! Load a value from a stack position
[
@ -197,7 +198,7 @@ big-endian off
[
! Untag temp0
temp0 tag-mask get bitnot AND
! Set temp1 to 0 for objects, and 8 for tuples
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
temp1 1 tag-fixnum AND
bootstrap-cell 4 = [ temp1 1 SHR ] when
! Load header cell or tuple layout cell
@ -214,7 +215,7 @@ big-endian off
temp1 temp2 CMP
] pic-check jit-define
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches
@ -232,12 +233,13 @@ big-endian off
temp0 temp2 ADD
! if(get(cache) == class)
temp0 [] temp1 CMP
! ... goto get(cache + bootstrap-cell)
[
temp0 temp0 bootstrap-cell [+] MOV
temp0 word-xt-offset [+] JMP
] [ ] make
[ length JNE ] [ % ] bi
bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
! megamorphic_cache_hits++
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
temp1 [] 1 ADD
! goto get(cache + bootstrap-cell)
temp0 temp0 bootstrap-cell [+] MOV
temp0 word-xt-offset [+] JMP
! fall-through on miss
] mega-lookup jit-define

20
basis/cpu/x86/x86.factor
View File

@ -11,6 +11,10 @@ IN: cpu.x86
<< enable-fixnum-log2 >>
! Add some methods to the assembler to be more useful to the backend
M: label JMP 0 JMP rc-relative label-fixup ;
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
M: x86 two-operand? t ;
HOOK: temp-reg-1 cpu ( -- reg )
@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 %load-immediate MOV ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
reserved-area-size +
align-stack ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n )
#! See the comment in vm/cpu-x86.hpp
cell 4 + 1 + ; inline
M: x86 %jump ( word -- )
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
0 JMP rc-relative rel-word-pic-tail ;
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )

6
basis/dlists/dlists-docs.factor
View File

@ -15,6 +15,7 @@ $nl
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
{ $subsection dlist-filter }
{ $subsection dlist-any? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
@ -40,6 +41,11 @@ HELP: dlist-find
"This operation is O(n)."
} ;
HELP: dlist-filter
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
{ $side-effects { "dlist" } } ;
HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }

5
basis/dlists/dlists-tests.factor
View File

@ -79,3 +79,8 @@ IN: dlists.tests
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
[ V{ } ] [ <dlist> dlist>seq ] unit-test
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test

7
basis/dlists/dlists.factor
View File

@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
[
[
[ empty-dlist ] unless*
[ f ] change-next drop
next>>
f over set-prev-when
] change-front drop
] keep
@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
[
[
[ empty-dlist ] unless*
[ f ] change-prev drop
prev>>
f over set-next-when
] change-back drop
] keep
@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
: dlist-filter ( dlist quot -- dlist )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone
<dlist> [ '[ _ push-back ] dlist-each ] keep ;

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

@ -57,7 +57,6 @@ $nl
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
{ { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }

17
basis/generalizations/generalizations-docs.factor
View File

@ -161,22 +161,6 @@ HELP: ndip
}
} ;
HELP: nslip
{ $values { "n" integer } }
{ $description "A generalization of " { $link slip } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"removed from the stack, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
"Some core words expressed in terms of " { $link nslip } ":"
{ $table
{ { $link slip } { $snippet "1 nslip" } }
{ { $link 2slip } { $snippet "2 nslip" } }
{ { $link 3slip } { $snippet "3 nslip" } }
}
} ;
HELP: nkeep
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link keep } " that can work "
@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
ARTICLE: "combinator-generalizations" "Generalized combinators"
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection napply }
{ $subsection ncleave }

2
basis/generalizations/generalizations-tests.factor
View File

@ -26,8 +26,6 @@ IN: generalizations.tests
[ [ 1 ] 5 ndip ] must-infer
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test

3
basis/generalizations/generalizations.factor
View File

@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;
MACRO: nslip ( n -- )
'[ [ call ] _ ndip ] ;
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;

69
basis/images/tiff/tiff.factor
View File

@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays.float ;
strings math.vectors specialized-arrays.float locals ;
IN: images.tiff
TUPLE: tiff-image < image ;
@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
software date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc fill-order document-name page-number page-name
x-position y-position host-computer copyright artist
min-sample-value max-sample-value make model cell-width cell-length
min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
gray-response-unit gray-response-curve color-map threshholding
image-description free-offsets free-byte-counts tile-width tile-length
matteing data-type image-depth tile-depth
@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
ERROR: no-tag class ;
: find-tag ( idf class -- tag )
swap processed-tags>> ?at [ no-tag ] unless ;
: find-tag* ( ifd class -- tag/class ? )
swap processed-tags>> ?at ;
: tag? ( idf class -- tag )
: find-tag ( ifd class -- tag )
find-tag* [ no-tag ] unless ;
: tag? ( ifd class -- tag )
swap processed-tags>> key? ;
: read-strips ( ifd -- ifd )
@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
{ 266 [ fill-order ] }
{ 269 [ ascii decode document-name ] }
{ 270 [ ascii decode image-description ] }
{ 271 [ ascii decode make ] }
{ 272 [ ascii decode model ] }
{ 271 [ ascii decode tiff-make ] }
{ 272 [ ascii decode tiff-model ] }
{ 273 [ strip-offsets ] }
{ 274 [ orientation ] }
{ 277 [ samples-per-pixel ] }
@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
{ 281 [ max-sample-value ] }
{ 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] }
{ 284 [ lookup-planar-configuration planar-configuration ] }
{ 285 [ page-name ] }
{ 286 [ x-position ] }
{ 287 [ y-position ] }
@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
[ samples-per-pixel find-tag ] tri
[ * ] keep
'[
_ group [ _ group [ rest ] [ first ] bi
[ v+ ] accumulate swap suffix concat ] map
_ group
[ _ group unclip [ v+ ] accumulate swap suffix concat ] map
concat >byte-array
] change-bitmap ;
@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
] with-tiff-endianness
] with-file-reader ;
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
dup ifds>> [
read-strips
uncompress-strips
strips>bitmap
fix-bitmap-endianness
strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop
] each ;
: process-chunky-ifd ( ifd -- )
read-strips
uncompress-strips
strips>bitmap
fix-bitmap-endianness
strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop ;
: process-planar-ifd ( ifd -- )
"planar ifd not supported" throw ;
: dispatch-planar-configuration ( ifd planar-configuration -- )
{
{ planar-configuration-chunky [ process-chunky-ifd ] }
{ planar-configuration-planar [ process-planar-ifd ] }
} case ;
: process-ifd ( ifd -- )
dup planar-configuration find-tag* [
dispatch-planar-configuration
] [
drop "no planar configuration" throw
] if ;
: process-tif-ifds ( parsed-tiff -- )
ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff )
[ load-tiff-ifds ] [
binary [
[ process-tif-ifds ] with-tiff-endianness
] with-file-reader
] bi ;
[ load-tiff-ifds dup ] keep
binary [
[ process-tif-ifds ] with-tiff-endianness
] with-file-reader ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )

4
basis/io/backend/windows/privileges/privileges-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.backend.windows.privileges.tests
USING: io.backend.windows.privileges tools.test ;
[ [ ] with-privileges ] must-infer

9
basis/io/backend/windows/privileges/privileges.factor Normal file → Executable file
View File

@ -1,12 +1,13 @@
USING: io.backend kernel continuations sequences
system vocabs.loader combinators ;
system vocabs.loader combinators fry ;
IN: io.backend.windows.privileges
HOOK: set-privilege io-backend ( name ? -- ) inline
HOOK: set-privilege io-backend ( name ? -- )
: with-privileges ( seq quot -- )
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

35
basis/io/directories/search/search-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations ;
USING: help.markup help.syntax kernel quotations sequences ;
IN: io.directories.search
HELP: each-file
@ -57,6 +57,32 @@ HELP: find-all-in-directories
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
HELP: find-by-extension
{ $values
{ "path" "a pathname string" } { "extension" "a file extension" }
{ "seq" sequence }
}
{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
{ $examples
{ $unchecked-example
"USING: io.directories.search ;"
"\"/\" \".mp3\" find-by-extension"
}
} ;
HELP: find-by-extensions
{ $values
{ "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
{ "seq" sequence }
}
{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
{ $examples
{ $unchecked-example
"USING: io.directories.search ;"
"\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
}
} ;
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
ARTICLE: "io.directories.search" "Searching directories"
@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories"
{ $subsection recursive-directory-files }
{ $subsection recursive-directory-entries }
{ $subsection each-file }
"Finding files:"
"Finding files by name:"
{ $subsection find-file }
{ $subsection find-all-files }
{ $subsection find-in-directories }
{ $subsection find-all-in-directories } ;
{ $subsection find-all-in-directories }
"Finding files by extension:"
{ $subsection find-by-extension }
{ $subsection find-by-extensions } ;
ABOUT: "io.directories.search"

9
basis/io/directories/search/search.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
sequences system vocabs.loader locals math namespaces
sorting assocs calendar threads io math.parser ;
sorting assocs calendar threads io math.parser unicode.case ;
IN: io.directories.search
: qualified-directory-entries ( path -- seq )
@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
] { } map>assoc
] with-qualified-directory-entries sort-values ;
: find-by-extensions ( path extensions -- seq )
[ >lower ] map
'[ >lower _ [ tail? ] with any? ] find-all-files ;
: find-by-extension ( path extension -- seq )
1array find-by-extensions ;
os windows? [ "io.directories.search.windows" require ] when

3
basis/io/files/unique/unique.factor
View File

@ -35,6 +35,9 @@ SYMBOL: unique-retries
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
: retry ( quot: ( -- ? ) n -- )
swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
_ _ _ random-name glue append-path

2
basis/io/launcher/unix/unix-tests.factor
View File

@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
try-process
] unit-test
[ f ] [
[ "" ] [
"cat"
"launcher-test-1" temp-file
2array

12
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ input-stream get contents ] with-process-reader
ascii [ contents ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> lines first
ascii <process-reader> stream-lines first
] with-directory
] unit-test
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =

2
basis/io/streams/string/string-tests.factor
View File

@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
tools.test ;
IN: io.streams.string.tests
[ "" ] [ "" [ contents ] with-string-reader ] unit-test
[ "line 1" CHAR: l ]
[
"line 1\nline 2\nline 3" <string-reader>

24
basis/literals/literals-docs.factor
View File

@ -21,7 +21,7 @@ CONSTANT: five 5
USING: kernel literals prettyprint ;
IN: scratchpad
<< : seven-eleven ( -- a b ) 7 11 ; >>
: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
"> "{ 7 11 }" }
@ -43,7 +43,24 @@ IN: scratchpad
} ;
{ POSTPONE: $ POSTPONE: $[ } related-words
HELP: ${
{ $syntax "${ code }" }
{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples
{ $example <"
USING: kernel literals math prettyprint ;
IN: scratchpad
CONSTANT: five 5
CONSTANT: six 6
${ five six 7 } .
"> "{ 5 6 7 }"
}
} ;
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
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."
@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values"
USING: kernel literals math prettyprint ;
IN: scratchpad
<< CONSTANT: five 5 >>
CONSTANT: five 5
{ $ five $[ five dup 1+ dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $subsection POSTPONE: ${ }
;
ABOUT: "literals"

6
basis/literals/literals-tests.factor Normal file → Executable file
View File

@ -20,8 +20,10 @@ IN: literals.tests
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
<<
CONSTANT: constant-a 3
>>
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test

19
basis/literals/literals.factor Normal file → Executable file
View File

@ -1,8 +1,21 @@
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations
combinators.smart vectors sequences ;
combinators.smart vectors sequences fry ;
IN: literals
SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
<PRIVATE
! Use def>> call so that CONSTANT:s defined in the same file can
! be called
: expand-literal ( seq obj -- seq' )
'[ _ dup word? [ def>> call ] when ] with-datastack ;
: expand-literals ( seq -- seq' )
[ [ { } ] dip expand-literal ] map concat ;
PRIVATE>
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;

2
basis/math/bits/bits.factor
View File

@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
C: <bits> bits
: make-bits ( number -- bits )
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
M: bits length length>> ;

24
basis/math/bitwise/bitwise.factor
View File

@ -13,10 +13,10 @@ IN: math.bitwise
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: wrap ( m n -- m' ) 1 - bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline
: on-bits ( n -- m ) 2^ 1- ; inline
: on-bits ( n -- m ) 2^ 1 - ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
: shift-mod ( n s w -- n )
@ -35,6 +35,11 @@ IN: math.bitwise
: w- ( int int -- int ) - 32 bits ; inline
: w* ( int int -- int ) * 32 bits ; inline
! 64-bit arithmetic
: W+ ( int int -- int ) + 64 bits ; inline
: W- ( int int -- int ) - 64 bits ; inline
: W* ( int int -- int ) * 64 bits ; inline
! flags
MACRO: flags ( values -- )
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
@ -64,8 +69,8 @@ DEFER: byte-bit-count
<<
\ byte-bit-count
256 [
8 <bits> 0 [ [ 1+ ] when ] reduce
256 iota [
8 <bits> 0 [ [ 1 + ] when ] reduce
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
(( byte -- table )) define-declared
@ -97,12 +102,19 @@ PRIVATE>
! Signed byte array to integer conversion
: signed-le> ( bytes -- x )
[ le> ] [ length 8 * 1- on-bits ] bi
[ le> ] [ length 8 * 1 - on-bits ] bi
2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x )
<reversed> signed-le> ;
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
: >odd ( n -- int ) 0 set-bit ; foldable
: >even ( n -- int ) 0 clear-bit ; foldable
: next-even ( m -- n ) >even 2 + ; foldable
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable

2
basis/math/blas/vectors/vectors.factor
View File

@ -164,7 +164,7 @@ M: VECTOR element-type
M: VECTOR Vswap
(prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax
(prepare-nrm2) IXAMAX 1- ;
(prepare-nrm2) IXAMAX 1 - ;
M: VECTOR (blas-vector-like)
drop <VECTOR> ;

70
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -1,37 +1,93 @@
USING: help.markup help.syntax kernel math math.order sequences ;
USING: help.markup help.syntax kernel math math.order multiline sequences ;
IN: math.combinatorics
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"4 factorial ." "24" }
} ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nPk ." "5040" }
} ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nCk ." "210" }
} ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
} ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
} ;
HELP: each-permutation
{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
} ;
HELP: combination
{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
{ $example "USING: math.combinatorics sequences prettyprint ;"
"6 7 iota 4 combination ." "{ 0 1 3 6 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
} ;
HELP: all-combinations
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
<" {
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
}"> } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
IN: math.combinatorics.private

53
basis/math/combinatorics/combinatorics-tests.factor
View File

@ -1,18 +1,6 @@
USING: math.combinatorics math.combinatorics.private tools.test ;
USING: math.combinatorics math.combinatorics.private tools.test sequences ;
IN: math.combinatorics.tests
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
@ -31,6 +19,19 @@ IN: math.combinatorics.tests
[ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 nCk ] unit-test
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
@ -43,3 +44,29 @@ IN: math.combinatorics.tests
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { { "a" "b" } { "a" "c" }
{ "a" "d" } { "b" "c" }
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test

106
basis/math/combinatorics/combinatorics.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
namespaces sequences sorting fry ;
USING: accessors assocs binary-search fry kernel locals math math.order
math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
@ -12,14 +12,27 @@ IN: math.combinatorics
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
PRIVATE>
: factorial ( n -- n! )
1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
! Factoradic-based permutation methodology
<PRIVATE
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
[ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
@ -29,27 +42,84 @@ IN: math.combinatorics
PRIVATE>
: factorial ( n -- n! )
1 [ 1+ * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
[ length factorial ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq initial quot -- result )
: reduce-permutations ( seq identity quot -- result )
swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
! Combinadic-based combination methodology
<PRIVATE
TUPLE: combo
{ seq sequence }
{ k integer } ;
C: <combo> combo
: choose ( combo -- nCk )
[ seq>> length ] [ k>> ] bi nCk ;
: largest-value ( a b x -- v )
dup 0 = [
drop 1 - nip
] [
[ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
] if ;
:: next-values ( a b x -- a' b' x' v )
a b x largest-value dup :> v ! a'
b 1 - ! b'
x v b nCk - ! x'
v ; ! v == a'
: dual-index ( m combo -- m' )
choose 1 - swap - ;
: initial-values ( combo m -- n k m )
[ [ seq>> length ] [ k>> ] bi ] dip ;
: combinadic ( combo m -- combinadic )
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
: combination-indices ( m combo -- seq )
[ tuck dual-index combinadic ] keep
seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
PRIVATE>
: combination ( m seq k -- seq )
<combo> apply-combination ;
: all-combinations ( seq k -- seq )
<combo> [ choose [0,b) ] keep
'[ _ apply-combination ] map ;
: each-combination ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] each ; inline
: map-combinations ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] map ; inline
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline

1
basis/math/constants/constants.factor
View File

@ -7,6 +7,7 @@ IN: math.constants
: euler ( -- gamma ) 0.57721566490153286060 ; inline
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: 2pi ( -- pi ) 2 pi * ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

5
basis/math/functions/functions-tests.factor
View File

@ -157,3 +157,8 @@ IN: math.functions.tests
2135623355842621559
[ >bignum ] tri@ ^mod
] unit-test
[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test
[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test

15
basis/math/functions/functions.factor
View File

@ -18,12 +18,12 @@ M: real sqrt
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
] if ; inline
<PRIVATE
GENERIC# ^n 1 ( z w -- z^w )
GENERIC# ^n 1 ( z w -- z^w ) foldable
: (^n) ( z w -- z^w )
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
@ -216,17 +216,17 @@ M: real tanh ftanh ;
: coth ( x -- y ) tanh recip ; inline
: acosh ( x -- y )
dup sq 1- sqrt + log ; inline
dup sq 1 - sqrt + log ; inline
: asech ( x -- y ) recip acosh ; inline
: asinh ( x -- y )
dup sq 1+ sqrt + log ; inline
dup sq 1 + sqrt + log ; inline
: acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y )
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline
[ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline
@ -259,6 +259,9 @@ M: real atan fatan ;
: floor ( x -- y )
dup 1 mod dup zero?
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
[ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline

12
basis/math/intervals/intervals.factor
View File

@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
: interval-abs ( i1 -- i2 )
{
{ [ dup empty-interval eq? ] [ ] }
{ [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
{ [ dup full-interval eq? ] [ drop [0,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
[ (interval-abs) points>interval ]
} cond ;
@ -376,11 +378,11 @@ SYMBOL: incomparable
: interval-log2 ( i1 -- i2 )
{
{ empty-interval [ empty-interval ] }
{ full-interval [ 0 [a,inf] ] }
{ full-interval [ [0,inf] ] }
[
to>> first 1 max dup most-positive-fixnum >
[ drop full-interval interval-log2 ]
[ 1+ >integer log2 0 swap [a,b] ]
[ 1 + >integer log2 0 swap [a,b] ]
if
]
} case ;
@ -407,7 +409,7 @@ SYMBOL: incomparable
: integral-closure ( i1 -- i2 )
dup special-interval? [
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
[ from>> first2 [ 1 + ] unless ]
[ to>> first2 [ 1 - ] unless ]
bi [a,b]
] unless ;

76
basis/math/miller-rabin/miller-rabin.factor
View File

@ -1,76 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel locals math math.functions math.ranges
random sequences sets ;
IN: math.miller-rabin
<PRIVATE
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
TUPLE: positive-even-expected n ;
:: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ]
s [ n 1- factor-2s nip ]
prime?! [ t ]
a! [ 0 ]
count! [ 0 ] |
trials [
n 1- [1,b] random a!
a s n ^mod 1 = [
0 count!
r [
2^ s * a swap n ^mod n - -1 =
[ count 1+ count! r + ] when
] each
count zero? [ f prime?! trials + ] when
] unless drop
] each prime? ] ;
PRIVATE>
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
[ drop (miller-rabin) ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
: next-prime ( n -- p )
next-odd dup miller-rabin [ next-prime ] unless ;
: random-prime ( numbits -- p )
random-bits next-prime ;
ERROR: no-relative-prime n ;
<PRIVATE
: (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
PRIVATE>
: find-relative-prime* ( n guess -- p )
#! find a prime relative to n with initial guess
>odd (find-relative-prime) ;
: find-relative-prime ( n -- p )
dup random find-relative-prime* ;
ERROR: too-few-primes ;
: unique-primes ( numbits n -- seq )
#! generate two primes
swap
dup 5 < [ too-few-primes ] when
2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

10
basis/math/polynomials/polynomials-docs.factor
View File

@ -93,7 +93,13 @@ HELP: pdiff
{ $description "Finds the derivative of " { $snippet "p" } "." } ;
HELP: polyval
{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } }
{ $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ;
HELP: polyval*
{ $values { "p" "a literal polynomial" } }
{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ;
{ polyval polyval* } related-words

18
basis/math/polynomials/polynomials.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel make math math.order math.vectors sequences
splitting vectors ;
splitting vectors macros combinators ;
IN: math.polynomials
<PRIVATE
@ -16,7 +16,7 @@ IN: math.polynomials
PRIVATE>
: powers ( n x -- seq )
<array> 1 [ * ] accumulate nip ;
<repetition> 1 [ * ] accumulate nip ;
: p= ( p q -- ? ) pextend = ;
@ -29,7 +29,7 @@ PRIVATE>
: n*p ( n p -- n*p ) n*v ;
: pextend-conv ( p q -- p q )
2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
2unempty pextend-conv <reversed> dup length
@ -44,7 +44,7 @@ PRIVATE>
2ptrim
2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
[ over length + 0 pad-head pextend ] keep 1+ ;
[ over length + 0 pad-head pextend ] keep 1 + ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
@ -80,6 +80,12 @@ PRIVATE>
: pdiff ( p -- p' )
dup length v* { 0 } ?head drop ;
: polyval ( p x -- p[x] )
[ dup length ] dip powers v. ;
: polyval ( x p -- p[x] )
[ length swap powers ] [ nip ] 2bi v. ;
MACRO: polyval* ( p -- )
reverse
[ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
[ first \ drop swap [ ] 2sequence ] bi
prefix \ cleave [ ] 2sequence ;

3
basis/math/primes/factors/factors.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel make math math.functions math.primes sequences ;
USING: arrays combinators kernel make math math.functions
math.primes sequences ;
IN: math.primes.factors
<PRIVATE

1
basis/math/primes/lucas-lehmer/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

25
basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor Normal file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: math.primes.lucas-lehmer
HELP: lucas-lehmer
{ $values
{ "p" "a prime number" }
{ "?" "a boolean" }
}
{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
{ $examples
{ $example "! Test that (2 ^ 61) - 1 is prime:"
"USING: math.primes.lucas-lehmer prettyprint ;"
"61 lucas-lehmer ."
"t"
}
} ;
ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
"Run the Lucas-Lehmer test:"
{ $subsection lucas-lehmer } ;
ABOUT: "math.primes.lucas-lehmer"

13
basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test math.primes.lucas-lehmer ;
IN: math.primes.lucas-lehmer.tests
[ t ] [ 2 lucas-lehmer ] unit-test
[ t ] [ 3 lucas-lehmer ] unit-test
[ f ] [ 4 lucas-lehmer ] unit-test
[ t ] [ 5 lucas-lehmer ] unit-test
[ f ] [ 6 lucas-lehmer ] unit-test
[ f ] [ 11 lucas-lehmer ] unit-test
[ t ] [ 13 lucas-lehmer ] unit-test
[ t ] [ 61 lucas-lehmer ] unit-test

27
basis/math/primes/lucas-lehmer/lucas-lehmer.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators fry kernel locals math
math.primes combinators.short-circuit ;
IN: math.primes.lucas-lehmer
ERROR: invalid-lucas-lehmer-candidate obj ;
<PRIVATE
: do-lucas-lehmer ( p -- ? )
[ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
'[ sq 2 - _ mod ] times 0 = ;
: lucas-lehmer-guard ( obj -- obj )
dup { [ integer? ] [ 0 > ] } 1&&
[ invalid-lucas-lehmer-candidate ] unless ;
PRIVATE>
: lucas-lehmer ( p -- ? )
lucas-lehmer-guard
{
{ [ dup 2 = ] [ drop t ] }
{ [ dup prime? ] [ do-lucas-lehmer ] }
[ drop f ]
} cond ;

0
basis/math/miller-rabin/authors.txt → basis/math/primes/miller-rabin/authors.txt
View File

28
basis/math/primes/miller-rabin/miller-rabin-docs.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences math ;
IN: math.primes.miller-rabin
HELP: miller-rabin
{ $values
{ "n" integer }
{ "?" "a boolean" }
}
{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
{ miller-rabin miller-rabin* } related-words
HELP: miller-rabin*
{ $values
{ "n" integer } { "numtrials" integer }
{ "?" "a boolean" }
}
{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
"The Miller-Rabin probabilistic primality test:"
{ $subsection miller-rabin }
{ $subsection miller-rabin* } ;
ABOUT: "math.primes.miller-rabin"

8
basis/math/miller-rabin/miller-rabin-tests.factor → basis/math/primes/miller-rabin/miller-rabin-tests.factor
View File

@ -1,11 +1,11 @@
USING: math.miller-rabin tools.test ;
IN: math.miller-rabin.tests
USING: kernel math.primes.miller-rabin sequences tools.test ;
IN: math.primes.miller-rabin.tests
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ t ] [ 2 miller-rabin ] unit-test
[ t ] [ 3 miller-rabin ] unit-test
[ f ] [ 36 miller-rabin ] unit-test
[ t ] [ 37 miller-rabin ] unit-test
[ 101 ] [ 100 next-prime ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test

35
basis/math/primes/miller-rabin/miller-rabin.factor Executable file
View File

@ -0,0 +1,35 @@
! Copyright (c) 2008-2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators combinators.short-circuit kernel locals math
math.functions math.ranges random sequences sets ;
IN: math.primes.miller-rabin
<PRIVATE
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1
n-1 factor-2s :> s :> r
0 :> a!
trials [
drop
2 n 2 - [a,b] random a!
a s n ^mod 1 = [
f
] [
r iota [
2^ s * a swap n ^mod n - -1 =
] any? not
] if
] any? not ;
PRIVATE>
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
[ drop (miller-rabin) ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;

0
basis/math/miller-rabin/summary.txt → basis/math/primes/miller-rabin/summary.txt
View File

49
basis/math/primes/primes-docs.factor
View File

@ -1,10 +1,10 @@
USING: help.markup help.syntax ;
USING: help.markup help.syntax math sequences ;
IN: math.primes
{ next-prime prime? } related-words
HELP: next-prime
{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
{ $values { "n" integer } { "p" "a prime number" } }
{ $description "Return the next prime number greater than " { $snippet "n" } "." } ;
HELP: prime?
@ -20,3 +20,48 @@ HELP: primes-upto
HELP: primes-between
{ $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
{ $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
HELP: find-relative-prime
{ $values
{ "n" integer }
{ "p" integer }
}
{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
HELP: find-relative-prime*
{ $values
{ "n" integer } { "guess" integer }
{ "p" integer }
}
{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
HELP: random-prime
{ $values
{ "numbits" integer }
{ "p" integer }
}
{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
HELP: unique-primes
{ $values
{ "numbits" integer } { "n" integer }
{ "seq" sequence }
}
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
ARTICLE: "math.primes" "Prime numbers"
"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
"Testing if a number is prime:"
{ $subsection prime? }
"Generating prime numbers:"
{ $subsection next-prime }
{ $subsection primes-upto }
{ $subsection primes-between }
{ $subsection random-prime }
"Generating relative prime numbers:"
{ $subsection find-relative-prime }
{ $subsection find-relative-prime* }
"Make a sequence of random prime numbers:"
{ $subsection unique-primes } ;
ABOUT: "math.primes"

13
basis/math/primes/primes-tests.factor
View File

@ -1,4 +1,6 @@
USING: arrays math.primes tools.test ;
USING: arrays math math.primes math.primes.miller-rabin
tools.test ;
IN: math.primes.tests
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
{ { 4999963 4999999 5000011 5000077 5000081 } }
[ 4999962 5000082 primes-between >array ] unit-test
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
[ 101 ] [ 100 next-prime ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ 49 ] [ 50 random-prime log2 ] unit-test

42
basis/math/primes/primes.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math math.functions math.miller-rabin
math.order math.primes.erato math.ranges sequences ;
USING: combinators kernel math math.bitwise math.functions
math.order math.primes.erato math.primes.miller-rabin
math.ranges random sequences sets fry ;
IN: math.primes
<PRIVATE
@ -21,7 +22,11 @@ PRIVATE>
} cond ; foldable
: next-prime ( n -- p )
next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
dup 2 < [
drop 2
] [
next-odd [ dup really-prime? ] [ 2 + ] until
] if ; foldable
: primes-between ( low high -- seq )
[ dup 3 max dup even? [ 1 + ] when ] dip
@ -31,3 +36,34 @@ PRIVATE>
: primes-upto ( n -- seq ) 2 swap primes-between ;
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: random-prime ( numbits -- p )
random-bits* next-prime ;
: estimated-primes ( m -- n )
dup log / ; foldable
ERROR: no-relative-prime n ;
<PRIVATE
: (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
PRIVATE>
: find-relative-prime* ( n guess -- p )
#! find a prime relative to n with initial guess
>odd (find-relative-prime) ;
: find-relative-prime ( n -- p )
dup random find-relative-prime* ;
ERROR: too-few-primes n numbits ;
: unique-primes ( n numbits -- seq )
2dup 2^ estimated-primes > [ too-few-primes ] when
2dup '[ _ random-prime ] replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

1
basis/math/primes/safe/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

38
basis/math/primes/safe/safe-docs.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit help.markup help.syntax kernel
math math.functions math.primes random ;
IN: math.primes.safe
HELP: next-safe-prime
{ $values
{ "n" integer }
{ "q" integer }
}
{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
HELP: random-safe-prime
{ $values
{ "numbits" integer }
{ "p" integer }
}
{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
HELP: safe-prime?
{ $values
{ "q" integer }
{ "?" "a boolean" }
}
{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
ARTICLE: "math.primes.safe" "Safe prime numbers"
"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
"Testing if a number is a safe prime:"
{ $subsection safe-prime? }
"Generating safe prime numbers:"
{ $subsection next-safe-prime }
{ $subsection random-safe-prime } ;
ABOUT: "math.primes.safe"

14
basis/math/primes/safe/safe-tests.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math.primes.safe math.primes.safe.private tools.test ;
IN: math.primes.safe.tests
[ 863 ] [ 862 next-safe-prime ] unit-test
[ f ] [ 862 safe-prime? ] unit-test
[ t ] [ 7 safe-prime? ] unit-test
[ f ] [ 31 safe-prime? ] unit-test
[ t ] [ 47 safe-prime-candidate? ] unit-test
[ t ] [ 47 safe-prime? ] unit-test
[ t ] [ 863 safe-prime? ] unit-test
[ 47 ] [ 31 next-safe-prime ] unit-test

29
basis/math/primes/safe/safe.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit kernel math math.functions
math.primes random ;
IN: math.primes.safe
<PRIVATE
: safe-prime-candidate? ( n -- ? )
1 + 6 divisor? ;
: next-safe-prime-candidate ( n -- candidate )
next-prime dup safe-prime-candidate?
[ next-safe-prime-candidate ] unless ;
PRIVATE>
: safe-prime? ( q -- ? )
{
[ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
[ prime? ]
} 1&& ;
: next-safe-prime ( n -- q )
next-safe-prime-candidate
dup safe-prime? [ next-safe-prime ] unless ;
: random-safe-prime ( numbits -- p )
random-bits* next-safe-prime ;

2
basis/math/ranges/ranges.factor
View File

@ -10,7 +10,7 @@ TUPLE: range
{ step read-only } ;
: <range> ( a b step -- range )
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
M: range length ( seq -- n )
length>> ;

1
basis/math/rectangles/prettyprint/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

7
basis/math/rectangles/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
IN: math.rectangles.prettyprint
M: rect pprint*
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;

11
basis/math/rectangles/rectangles.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.vectors accessors
parser prettyprint.custom prettyprint.backend ;
parser ;
IN: math.rectangles
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
M: rect pprint*
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
: <zero-rect> ( -- rect ) rect new ; inline
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@ -21,6 +18,8 @@ M: rect pprint*
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
@ -62,3 +61,7 @@ M: rect contains-point?
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when

6
basis/math/statistics/statistics.factor
View File

@ -15,7 +15,7 @@ IN: math.statistics
: median ( seq -- n )
natural-sort dup length even? [
[ midpoint@ dup 1- 2array ] keep nths mean
[ midpoint@ dup 1 - 2array ] keep nths mean
] [
[ midpoint@ ] keep nth
] if ;
@ -33,7 +33,7 @@ IN: math.statistics
drop 0
] [
[ [ mean ] keep [ - sq ] with sigma ] keep
length 1- /
length 1 - /
] if ;
: std ( seq -- x )
@ -47,7 +47,7 @@ IN: math.statistics
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
* recip [ [ ((r)) ] keep length 1- / ] dip * ;
* recip [ [ ((r)) ] keep length 1 - / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;

7
basis/math/vectors/vectors-tests.factor
View File

@ -9,3 +9,10 @@ USING: math.vectors tools.test ;
[ 5 ] [ { 1 2 } norm-sq ] unit-test
[ 13 ] [ { 2 3 } norm-sq ] unit-test
[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test
[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test
[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test

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