* 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/>.
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.
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
[ 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 ]
"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
: 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
[ "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
! 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?
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 )
M: integer (eql?) = ;
+M: float (eql?)
+ over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
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 -- )
! 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 ;
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
- [ direct-entry-def>> , ] ! direct-entry-def
+ [ pic-def>> , ]
+ [ pic-tail-def>> , ]
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
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
\ 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 ;
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: 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 ;
\ No newline at end of file
: 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 ,
-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
! 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
+
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+<PRIVATE
CONSTANT: a 0
CONSTANT: b 1
CONSTANT: 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
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 ;
+ [
+ [ -17 bitroll-32 ]
+ [ -19 bitroll-32 ]
+ [ -10 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-256 ( x -- x' )
+ [
+ [ -2 bitroll-32 ]
+ [ -13 bitroll-32 ]
+ [ -22 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-256 ( x -- x' )
+ [
+ [ -6 bitroll-32 ]
+ [ -11 bitroll-32 ]
+ [ -25 bitroll-32 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s0-512 ( x -- x' )
+ [
+ [ -1 bitroll-64 ]
+ [ -8 bitroll-64 ]
+ [ -7 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: s1-512 ( x -- x' )
+ [
+ [ -19 bitroll-64 ]
+ [ -61 bitroll-64 ]
+ [ -6 shift ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S0-512 ( x -- x' )
+ [
+ [ -28 bitroll-64 ]
+ [ -34 bitroll-64 ]
+ [ -39 bitroll-64 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: S1-512 ( x -- x' )
+ [
+ [ -14 bitroll-64 ]
+ [ -18 bitroll-64 ]
+ [ -41 bitroll-64 ] tri
+ ] [ bitxor ] reduce-outputs ; inline
+
+: process-M-256 ( n seq -- )
+ {
+ [ [ 16 - ] dip nth ]
+ [ [ 15 - ] dip nth s0-256 ]
+ [ [ 7 - ] dip nth ]
+ [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+ [ ]
+ } 2cleave set-nth ; inline
+
+: process-M-512 ( n seq -- )
+ {
+ [ [ 16 - ] dip nth ]
+ [ [ 15 - ] dip nth s0-512 ]
+ [ [ 7 - ] dip nth ]
+ [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+ [ ]
+ } 2cleave set-nth ; inline
: ch ( x y z -- x' )
- [ bitxor bitand ] keep bitxor ;
+ [ bitxor bitand ] keep bitxor ; inline
: maj ( x y z -- x' )
- [ [ bitand ] 2keep bitor ] dip bitand bitor ;
+ [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
-: S0-256 ( x -- x' )
- [ -2 bitroll-32 ] keep
- [ -13 bitroll-32 ] keep
- -22 bitroll-32 bitxor bitxor ; inline
+: slice3 ( n seq -- a b c )
+ [ dup 3 + ] dip <slice> first3 ; inline
-: S1-256 ( x -- x' )
- [ -6 bitroll-32 ] keep
- [ -11 bitroll-32 ] keep
- -25 bitroll-32 bitxor bitxor ; inline
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+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 ;
-: 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+ ;
+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 ( -- T2 )
- a vars get nth S0-256
- a vars get slice3 maj w+ ;
+: T2-256 ( H -- T2 )
+ [ a swap nth S0-256 ]
+ [ a swap slice3 maj w+ ] bi ; inline
-: update-vars ( T1 T2 -- )
- vars get
+:: 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
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 ;
-PRIVATE>
+: <sha-224-state> ( -- sha2-state )
+ sha-224-state new
+ K-256 >>K
+ initial-H-224 >>H
+ 4 >>word-size
+ 64 >>block-size ;
-SINGLETON: sha-256
+: <sha-256-state> ( -- sha2-state )
+ sha-256-state new
+ K-256 >>K
+ initial-H-256 >>H
+ 4 >>word-size
+ 64 >>block-size ;
-INSTANCE: sha-256 checksum
+PRIVATE>
+
+M: sha-224 checksum-bytes
+ drop <sha-224-state>
+ [ byte-array>sha2 ]
+ [ H>> 7 head 4 seq>byte-array ] bi ;
M: sha-256 checksum-bytes
- drop [
- 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 ;
NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
- NSAutoreleasePool -> new slip -> release ; inline
+ NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
: NSApp ( -- app ) NSApplication -> sharedApplication ;
-! 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
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"
[ 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
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
*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>) ] }
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
+ [ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )
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 ;
: do-callback ( quot token -- )
init-catchstack
- dup 2 setenv
- slip
+ [ 2 setenv call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
: 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 ;
} 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.
! 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
: 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? ;
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
\ No newline at end of file
] 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
[ f ] [ \ broken-declaration optimized? ] unit-test
-[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
\ No newline at end of file
+[ ] [ [ \ 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
\ No newline at end of file
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
-: contains-breakpoints? ( word -- ? )
- def>> [ word? ] filter [ "break?" word-prop ] any? ;
[ 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
] { 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
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
+
+[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
\ No newline at end of file
! 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
: 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 ;
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 ;
] 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
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 {
{ >float float }
{ fixnum>float float }
{ bignum>float float }
+
+ { >integer integer }
} [
'[
_
] "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
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
-[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
\ No newline at end of file
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
\ No newline at end of file
! 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
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 )
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
\ No newline at end of file
+TYPEDEF: int CGLContextParameter
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
+HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
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
! 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
-! 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 ;
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 ;
4 \ cell set\r
big-endian on\r
\r
-CONSTANT: ds-reg 29\r
-CONSTANT: rs-reg 30\r
+CONSTANT: ds-reg 13\r
+CONSTANT: rs-reg 14\r
\r
: factor-area-size ( -- n ) 4 bootstrap-cells ;\r
\r
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
- 11 6 profile-count-offset LWZ\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 11 3 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
- 11 6 profile-count-offset STW\r
- 11 6 word-code-offset LWZ\r
+ 11 3 profile-count-offset STW\r
+ 11 3 word-code-offset LWZ\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
] jit-profiling jit-define\r
\r
[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
- 6 1 xt-save STW\r
- stack-frame 6 LI\r
- 6 1 next-save STW\r
+ 3 1 xt-save STW\r
+ stack-frame 3 LI\r
+ 3 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
] jit-prolog jit-define\r
\r
[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
- 6 ds-reg 4 STWU\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 3 ds-reg 4 STWU\r
] jit-push-immediate jit-define\r
\r
[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
- 7 6 0 LWZ\r
- 1 7 0 STW\r
-] jit-save-stack jit-define\r
-\r
-[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
- 6 MTCTR\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
+ 4 3 0 LWZ\r
+ 1 4 0 STW\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
+ 3 MTCTR\r
BCTR\r
] jit-primitive jit-define\r
\r
-[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define\r
+[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define\r
+\r
+[\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
+ 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel\r
+] jit-word-jump jit-define\r
\r
-[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define\r
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define\r
\r
[\r
3 ds-reg 0 LWZ\r
0 3 \ f tag-number CMPI\r
2 BEQ\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
-] jit-if-1 jit-define\r
-\r
-[\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
-] jit-if-2 jit-define\r
+] jit-if jit-define\r
\r
: jit->r ( -- )\r
4 ds-reg 0 LWZ\r
jit-3r>\r
] jit-3dip jit-define\r
\r
+: prepare-(execute) ( -- operand )\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 3 word-xt-offset LWZ\r
+ 4 ;\r
+\r
+[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define\r
+\r
+[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define\r
+\r
[\r
0 1 lr-save stack-frame + LWZ\r
1 1 stack-frame ADDI\r
\r
[ BLR ] jit-return jit-define\r
\r
-! Sub-primitives\r
+! ! ! Polymorphic inline caches\r
\r
-! Quotations and words\r
+! Don't touch r6 here; it's used to pass the tail call site\r
+! address for tail PICs\r
+\r
+! Load a value from a stack position\r
[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 3 quot-xt-offset LWZ\r
- 4 MTCTR\r
+ 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
+] pic-load jit-define\r
+\r
+! Tag\r
+: load-tag ( -- )\r
+ 4 4 tag-mask get ANDI\r
+ 4 4 tag-bits get SLWI ;\r
+\r
+[ load-tag ] pic-tag jit-define\r
+\r
+! Hi-tag\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ 0 4 object tag-number tag-fixnum CMPI\r
+ 2 BNE\r
+ 4 3 object tag-number neg LWZ\r
+] pic-hi-tag jit-define\r
+\r
+! Tuple\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ 0 4 tuple tag-number tag-fixnum CMPI\r
+ 2 BNE\r
+ 4 3 tuple tag-number neg bootstrap-cell + LWZ\r
+] pic-tuple jit-define\r
+\r
+! Hi-tag and tuple\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
+ 0 4 BIN: 110 tag-fixnum CMPI\r
+ 5 BLT\r
+ ! Untag r3\r
+ 3 3 0 0 31 tag-bits get - RLWINM\r
+ ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
+ 4 4 1 tag-fixnum ANDI\r
+ 4 4 1 SRAWI\r
+ ! Load header cell or tuple layout cell\r
+ 4 4 3 LWZX\r
+] pic-hi-tag-tuple jit-define\r
+\r
+[\r
+ 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
+] pic-check-tag jit-define\r
+\r
+[\r
+ 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 4 0 5 CMP\r
+] pic-check jit-define\r
+\r
+[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
+\r
+! ! ! Megamorphic caches\r
+\r
+[\r
+ ! cache = ...\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ ! key = class\r
+ 5 4 MR\r
+ ! key &= cache.length - 1\r
+ 5 5 mega-cache-size get 1- bootstrap-cell * ANDI\r
+ ! cache += array-start-offset\r
+ 3 3 array-start-offset ADDI\r
+ ! cache += key\r
+ 3 3 5 ADD\r
+ ! if(get(cache) == class)\r
+ 6 3 0 LWZ\r
+ 6 0 4 CMP\r
+ 10 BNE\r
+ ! megamorphic_cache_hits++\r
+ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
+ 5 4 0 LWZ\r
+ 5 5 1 ADDI\r
+ 5 4 0 STW\r
+ ! ... goto get(cache + bootstrap-cell)\r
+ 3 3 4 LWZ\r
+ 3 3 word-xt-offset LWZ\r
+ 3 MTCTR\r
BCTR\r
-] \ (call) define-sub-primitive\r
+ ! fall-through on miss\r
+] mega-lookup jit-define\r
\r
+! ! ! Sub-primitives\r
+\r
+! Quotations and words\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 4 3 word-xt-offset LWZ\r
+ 4 3 quot-xt-offset LWZ\r
4 MTCTR\r
BCTR\r
-] \ (execute) define-sub-primitive\r
+] \ (call) define-sub-primitive\r
\r
! Objects\r
[\r
-! 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 ;
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 )
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 ;
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
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
} 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
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
-! 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 ;
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 >>
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 ;
-! 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 ;
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
-! 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.
{ 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 ;
] 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
! 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
[
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
! ! ! 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
[
[
! 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
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
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
<< 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 )
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 ;
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 )
"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* }
"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." }
[ 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
[
[
[ empty-dlist ] unless*
- [ f ] change-next drop
+ next>>
f over set-prev-when
] change-front drop
] keep
[
[
[ empty-dlist ] unless*
- [ f ] change-prev drop
+ prev>>
f over set-next-when
] change-back drop
] keep
: 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 ;
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
- { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }\r
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
}\r
} ;\r
\r
-HELP: nslip\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link slip } " that can work " \r
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
-"removed from the stack, the quotation called, and the items restored."\r
-} \r
-{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }\r
- "Some core words expressed in terms of " { $link nslip } ":"\r
- { $table\r
- { { $link slip } { $snippet "1 nslip" } }\r
- { { $link 2slip } { $snippet "2 nslip" } }\r
- { { $link 3slip } { $snippet "3 nslip" } }\r
- }\r
-} ;\r
-\r
HELP: nkeep\r
{ $values { "quot" quotation } { "n" integer } }\r
{ $description "A generalization of " { $link keep } " that can work " \r
\r
ARTICLE: "combinator-generalizations" "Generalized combinators"\r
{ $subsection ndip }\r
-{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
{ $subsection ncleave }\r
[ [ 1 ] 5 ndip ] must-infer\r
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
\r
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer\r
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;
-MACRO: nslip ( n -- )
- '[ [ call ] _ ndip ] ;
-
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;
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 ;
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
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 )
{ 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 ] }
{ 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 ] }
[ 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 ;
] 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 )
--- /dev/null
+IN: io.backend.windows.privileges.tests\r
+USING: io.backend.windows.privileges tools.test ;\r
+\r
+[ [ ] with-privileges ] must-infer\r
USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators ;\r
+system vocabs.loader combinators fry ;\r
IN: io.backend.windows.privileges\r
\r
-HOOK: set-privilege io-backend ( name ? -- ) inline\r
+HOOK: set-privilege io-backend ( name ? -- )\r
\r
: with-privileges ( seq quot -- )\r
- over [ [ t set-privilege ] each ] curry compose\r
- swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
+ [ '[ _ [ t set-privilege ] each @ ] ]\r
+ [ drop '[ _ [ f set-privilege ] each ] ]\r
+ 2bi [ ] cleanup ; inline\r
\r
{\r
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\r
! 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
}
{ $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"
{ $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"
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 )
] { } 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
: 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
try-process
] unit-test
-[ f ] [
+[ "" ] [
"cat"
"launcher-test-1" temp-file
2array
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 )
<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
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 =
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 =
<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
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" =
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>
USING: kernel literals prettyprint ;
IN: scratchpad
-<< : seven-eleven ( -- a b ) 7 11 ; >>
+: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
"> "{ 7 11 }" }
} ;
-{ 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."
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"
[ { 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
! (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 ;
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>> ;
: 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 )
: 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 ;
<<
\ 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
! 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
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> ;
-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
-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
[ 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
[ { 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
-! 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
: 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 ;
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
+
: 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
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
+
: 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
: 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
: 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
+
: (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 -- ? )
: 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 ;
: 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 ;
: 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: math.miller-rabin tools.test ;
-IN: math.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
\ No newline at end of file
+++ /dev/null
-! 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 ;
+++ /dev/null
-Miller-Rabin probabilistic primality test
{ $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
! 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
PRIVATE>
: powers ( n x -- seq )
- <array> 1 [ * ] accumulate nip ;
+ <repetition> 1 [ * ] accumulate nip ;
: p= ( p q -- ? ) pextend = ;
: 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
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
: 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 ;
! 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
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: 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"
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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"
--- /dev/null
+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
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+
+[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
--- /dev/null
+! 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* ;
--- /dev/null
+Miller-Rabin probabilistic primality test
-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?
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"
-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
{ { 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
! 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
} 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
: 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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: 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"
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
{ 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>> ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
+IN: math.rectangles.prettyprint
+
+M: rect pprint*
+ \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
! 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 } } ;
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
: 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
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
\ No newline at end of file
: 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 ;
drop 0
] [
[ [ mean ] keep [ - sq ] with sigma ] keep
- length 1- /
+ length 1 - /
] if ;
: std ( seq -- x )
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@ ;
[ 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
: vneg ( u -- v ) [ neg ] map ;
+: v+n ( u n -- v ) [ + ] curry map ;
+: n+v ( n u -- v ) [ + ] with map ;
+: v-n ( u n -- v ) [ - ] curry map ;
+: n-v ( n u -- v ) [ - ] with map ;
+
: v*n ( u n -- v ) [ * ] curry map ;
: n*v ( n u -- v ) [ * ] with map ;
: v/n ( u n -- v ) [ / ] curry map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
+: vfloor ( v -- _v_ ) [ floor ] map ;
+: vceiling ( v -- ^v^ ) [ ceiling ] map ;
+: vtruncate ( v -- -v- ) [ truncate ] map ;
+
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+: 2tetra@ ( p q r s t u v w quot -- )
+ dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+
+: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
+ [ first lerp ] [ second lerp ] [ third lerp ] tri-curry
+ [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
+
+: bilerp ( aa ba ab bb {t,u} -- a_tu )
+ [ first lerp ] [ second lerp ] bi-curry
+ [ 2bi@ ] [ call ] bi* ;
+
+: vlerp ( a b t -- a_t )
+ [ lerp ] 3map ;
+
+: vnlerp ( a b t -- a_t )
+ [ lerp ] curry 2map ;
+
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;
HINTS: vmax { array array } ;
HINTS: vmin { array array } ;
HINTS: v. { array array } ;
+
+HINTS: vlerp { array array array } ;
+HINTS: vnlerp { array array object } ;
+
+HINTS: bilerp { object object object object array } ;
+HINTS: trilerp { object object object object object object object object array } ;
{ deploy-name "none" }
{ "stop-after-last-window?" t }
{ deploy-c-types? f }
- { deploy-compiler? f }
{ deploy-io 1 }
{ deploy-ui? f }
{ deploy-reflection 1 }
GENERIC: draw-scaled-texture ( dim texture -- )
+DEFER: make-texture
+
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glTexSubImage2D ;
-: make-texture ( image -- id )
- #! We use glTexSubImage2D to work around the power of 2 texture size
- #! limitation
- gen-texture [
- GL_TEXTURE_BIT [
- GL_TEXTURE_2D swap glBindTexture
- non-power-of-2-textures? get
- [ dup bitmap>> (tex-image) ]
- [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
- ] do-attribs
- ] keep ;
-
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
PRIVATE>
+: make-texture ( image -- id )
+ #! We use glTexSubImage2D to work around the power of 2 texture size
+ #! limitation
+ gen-texture [
+ GL_TEXTURE_BIT [
+ GL_TEXTURE_2D swap glBindTexture
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+ ] do-attribs
+ ] keep ;
+
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ; inline
+ [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
} ;
HELP: random-bits
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $values { "numbits" integer } { "r" "a random integer" } }
{ $description "Outputs an random integer n bits in length." } ;
+HELP: random-bits*
+{ $values
+ { "numbits" integer }
+ { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+
HELP: with-random
{ $values { "tuple" "a random generator" } { "quot" "a quotation" } }
{ $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
"Randomizing a sequence:"
{ $subsection randomize }
"Deleting a random element from a sequence:"
-{ $subsection delete-random } ;
+{ $subsection delete-random }
+"Random numbers with " { $snippet "n" } " bits:"
+{ $subsection random-bits }
+{ $subsection random-bits* } ;
ABOUT: "random"
[ f ]
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test
USING: alien.c-types kernel math namespaces sequences
io.backend io.binary combinators system vocabs.loader
summary math.bitwise byte-vectors fry byte-arrays
-math.ranges ;
+math.ranges math.constants math.functions accessors ;
IN: random
SYMBOL: system-random-generator
PRIVATE>
-: random-bits ( n -- r ) 2^ random-integer ;
+: random-bits ( numbits -- r ) 2^ random-integer ;
+
+: random-bits* ( numbits -- n )
+ 1 - [ random-bits ] keep set-bit ;
: random ( seq -- elt )
[ f ] [
: with-secure-random ( quot -- )
secure-random-generator get swap with-random ; inline
+: uniform-random-float ( min max -- n )
+ 4 random-bytes underlying>> *uint >float
+ 4 random-bytes underlying>> *uint >float
+ 2.0 32 ^ * +
+ [ over - 2.0 -64 ^ * ] dip
+ * + ; inline
+
+: normal-random-float ( mean sigma -- n )
+ 0.0 1.0 uniform-random-float
+ 0.0 1.0 uniform-random-float
+ [ 2 pi * * cos ]
+ [ 1.0 swap - log -2.0 * sqrt ]
+ bi* * * + ;
+
USE: vocabs.loader
{
USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int arrays ;
+specialized-arrays.direct.int specialized-arrays.char
+specialized-arrays.uint arrays combinators ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
+[ t ] [
+ { t f t } >bool-array underlying>>
+ { 1 0 1 } "bool" heap-size {
+ { 1 [ >char-array ] }
+ { 4 [ >uint-array ] }
+ } case underlying>> =
+] unit-test
[ ushort-array{ 1234 } ] [
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
M: object infer-call*
"literal quotation" literal-expected ;
-: infer-nslip ( n -- )
- [ infer->r infer-call ] [ infer-r> ] bi ;
-
-: infer-slip ( -- ) 1 infer-nslip ;
-
-: infer-2slip ( -- ) 2 infer-nslip ;
-
-: infer-3slip ( -- ) 3 infer-nslip ;
-
: infer-ndip ( word n -- )
[ literals get ] 2dip
[ '[ _ def>> infer-quot-here ] ]
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
- { \ slip [ infer-slip ] }
- { \ 2slip [ infer-2slip ] }
- { \ 3slip [ infer-3slip ] }
{ \ dip [ infer-dip ] }
{ \ 2dip [ infer-2dip ] }
{ \ 3dip [ infer-3dip ] }
"local-word-def" word-prop infer-quot-here ;
{
- declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
+ declare call (call) dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
\ become { array array } { } define-primitive
-\ innermost-frame-quot { callstack } { quotation } define-primitive
+\ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive
over [
2drop
] [
- [ swap slip ] keep swap bad-combinator
+ [ dip ] keep swap bad-combinator
] if ; inline recursive
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
-generic generic.single definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref fry ;
IN: tools.continuations
<PRIVATE
(step-into-call-next-method)
} [ t "no-compile" set-word-prop ] each >>
+: >innermost-frame< ( callstack -- n quot )
+ [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
+
+: (change-frame) ( callstack quot -- callstack' )
+ [ dup innermost-frame-executing quotation? ] dip '[
+ clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
+ ] when ; inline
+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- [ clone ] dip [
- [ clone ] dip
- [
- [
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- ] dip call
- ]
- [ drop set-innermost-frame-quot ]
- [ drop ]
- 2tri
- ] curry change-call ; inline
+ [ clone ] dip '[ _ (change-frame) ] change-call ; inline
PRIVATE>
[
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
- swap 1+ cut [ break ] glue
+ swap 1 + cut [ break ] glue
] if
] if
] change-frame ;
: continuation-step-out ( continuation -- continuation' )
[ nip \ break suffix ] change-frame ;
-
{
{ call [ (step-into-quot) ] }
{ dip [ (step-into-dip) ] }
! Never step into these words
: don't-step-into ( word -- )
- dup [ execute break ] curry "step-into" set-word-prop ;
+ dup '[ _ execute break ] "step-into" set-word-prop ;
{
>n ndrop >c c>
] change-frame ;
: continuation-current ( continuation -- obj )
- call>>
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi ?nth ;
+ call>> >innermost-frame< ?nth ;
[ my-arch make-image ] unless ;
: bootstrap-profile ( -- profile )
- {
- { "math" deploy-math? }
- { "compiler" deploy-compiler? }
- { "threads" deploy-threads? }
- { "ui" deploy-ui? }
- { "unicode" deploy-unicode? }
- } [ nip get ] assoc-filter keys
- native-io? [ "io" suffix ] when ;
+ [
+ deploy-math? get [ "math" , ] when
+ deploy-threads? get [ "threads" , ] when
+ "compiler" ,
+ deploy-ui? get [ "ui" , ] when
+ deploy-unicode? get [ "unicode" , ] when
+ native-io? [ "io" , ] when
+ ] { } make ;
: staging-image-name ( profile -- name )
"staging."
ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
-{ $subsection deploy-compiler? }
{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
-HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
-$nl
-"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-
HELP: deploy-unicode?
{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
SYMBOL: deploy-name
SYMBOL: deploy-ui?
-SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ deploy-math? t }
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }
\r
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
-[ "staging.math-compiler-threads-ui-strip.image" ] [\r
+[ "staging.math-threads-compiler-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
+\r
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test\r
+\r
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
os macosx? [\r
{\r
"tools.deploy.test.6"\r
"tools.deploy.test.7"\r
- "tools.deploy.test.8"\r
"tools.deploy.test.9"\r
"tools.deploy.test.10"\r
"tools.deploy.test.11"\r
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+make assocs kernel parser lexer strings.parser vocabs sequences words
+memory kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units definitions
+generic generic.standard tools.deploy.config combinators classes ;
QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors
QUALIFIED: continuations
: strip-init-hooks ( -- )
"Stripping startup hooks" show
- { "cpu.x86" "command-line" "libc" "system" "environment" }
+ {
+ "command-line"
+ "cpu.x86"
+ "environment"
+ "libc"
+ "alien.strings"
+ }
[ init-hooks get delete-at ] each
deploy-threads? get [
"threads" init-hooks get delete-at
"io.backend" init-hooks get delete-at
] when
strip-dictionary? [
- "compiler.units" init-hooks get delete-at
- "vocabs.cache" init-hooks get delete-at
+ {
+ "compiler.units"
+ "vocabs"
+ "vocabs.cache"
+ "source-files.errors"
+ } [ init-hooks get delete-at ] each
] when ;
: strip-debugger ( -- )
strip-word-names? [ dup strip-word-names ] when
2drop ;
+: strip-compiler-classes ( -- )
+ "Stripping compiler classes" show
+ "compiler" child-vocabs [ words ] map concat [ class? ] filter
+ [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
: strip-default-methods ( -- )
strip-debugger? [
"Stripping default methods" show
{
gensym
name>char-hook
- classes:next-method-quot-cache
- classes:class-and-cache
- classes:class-not-cache
- classes:class-or-cache
- classes:class<=-cache
- classes:classes-intersect-cache
- classes:implementors-map
- classes:update-map
+ next-method-quot-cache
+ class-and-cache
+ class-not-cache
+ class-or-cache
+ class<=-cache
+ classes-intersect-cache
+ implementors-map
+ update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
compiler.errors:compiler-errors
definition-observers
interactive-vocabs
- layouts:num-tags
- layouts:num-types
- layouts:tag-mask
- layouts:tag-numbers
- layouts:type-numbers
lexer-factory
print-use-hook
root-cache
source-files.errors:error-types
+ source-files.errors:error-observers
vocabs:dictionary
vocabs:load-vocab-hook
+ vocabs:vocab-observers
word
parser-notes
} %
+ { } { "layouts" } strip-vocab-globals %
+
{ } { "math.partial-dispatch" } strip-vocab-globals %
{ } { "peg" } strip-vocab-globals %
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
-: compress-byte-arrays ( -- )
- [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-object? ( obj -- ? )
+ {
+ { [ dup array? ] [ empty? ] }
+ { [ dup byte-array? ] [ drop t ] }
+ { [ dup string? ] [ drop t ] }
+ { [ dup wrapper? ] [ drop t ] }
+ [ drop f ]
+ } cond ;
+
+: compress-objects ( -- )
+ [ compress-object? ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
[ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
-: compress-strings ( -- )
- [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
- [ wrapper? ] [ ] "wrappers" compress ;
-
-: finish-deploy ( final-image -- )
- "Finishing up" show
- V{ } set-namestack
- V{ } set-catchstack
- "Saving final image" show
- save-image-and-exit ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
t "quiet" set-global
f output-stream set-global ;
+: unsafe-next-method-quot ( method -- quot )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ next-method 1quotation ;
+
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
- nip
- dup next-method-quot "next-method-quot" set-word-prop
+ nip dup
+ unsafe-next-method-quot
+ "next-method-quot" set-word-prop
] assoc-each
] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
: strip ( -- )
init-stripper
- strip-default-methods
strip-libc
strip-call
strip-cocoa
compute-next-methods
strip-init-hooks
strip-c-io
+ strip-compiler-classes
+ strip-default-methods
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot
stripped-word-props
stripped-globals strip-globals
- compress-byte-arrays
+ compress-objects
compress-quotations
- compress-strings
- compress-wrappers
strip-words ;
: deploy-error-handler ( quot -- )
"Vocabulary has no MAIN: word." print flush 1 exit
] unless
strip
- finish-deploy
+ "Saving final image" show
+ save-image-and-exit
] deploy-error-handler
] bind ;
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
[ get values compile ] each
] bind
] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc
\ No newline at end of file
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-word-props? f }
- { deploy-compiler? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-math? f }
{ deploy-unicode? f }
{ deploy-threads? f }
- { deploy-compiler? f }
{ deploy-io 2 }
{ deploy-ui? f }
}
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.12" }
- { deploy-compiler? f }
{ deploy-word-defs? f }
{ deploy-threads? f }
}
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-io 2 }
{ "stop-after-last-window?" t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-io 3 }
{ deploy-math? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-math? t }
{ "stop-after-last-window?" t }
- { deploy-compiler? t }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }
+++ /dev/null
-USING: kernel ;
-IN: tools.deploy.test.8
-
-: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
-: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
-
-: literal-merge-test ( -- )
- literal-merge-test-1
- literal-merge-test-2 eq? t assert= ;
-
-MAIN: literal-merge-test
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-name "tools.deploy.test.8" }
- { deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
- { deploy-compiler? f }
- { deploy-unicode? f }
- { deploy-io 1 }
- { deploy-word-defs? f }
- { deploy-threads? f }
- { "stop-after-last-window?" t }
- { deploy-math? f }
-}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? f }
{ deploy-io 1 }
{ deploy-math? t }
--- /dev/null
+IN: tools.disassembler.udis.tests
+USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
+
+{
+ { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ [ ]
+} cond
\ No newline at end of file
LIBRARY: libudis86
-TYPEDEF: char[592] ud
+C-STRUCT: ud_operand
+ { "int" "type" }
+ { "uchar" "size" }
+ { "ulonglong" "lval" }
+ { "int" "base" }
+ { "int" "index" }
+ { "uchar" "offset" }
+ { "uchar" "scale" } ;
+
+C-STRUCT: ud
+ { "void*" "inp_hook" }
+ { "uchar" "inp_curr" }
+ { "uchar" "inp_fill" }
+ { "FILE*" "inp_file" }
+ { "uchar" "inp_ctr" }
+ { "uchar*" "inp_buff" }
+ { "uchar*" "inp_buff_end" }
+ { "uchar" "inp_end" }
+ { "void*" "translator" }
+ { "ulonglong" "insn_offset" }
+ { "char[32]" "insn_hexcode" }
+ { "char[64]" "insn_buffer" }
+ { "uint" "insn_fill" }
+ { "uchar" "dis_mode" }
+ { "ulonglong" "pc" }
+ { "uchar" "vendor" }
+ { "struct map_entry*" "mapen" }
+ { "int" "mnemonic" }
+ { "ud_operand[3]" "operand" }
+ { "uchar" "error" }
+ { "uchar" "pfx_rex" }
+ { "uchar" "pfx_seg" }
+ { "uchar" "pfx_opr" }
+ { "uchar" "pfx_adr" }
+ { "uchar" "pfx_lock" }
+ { "uchar" "pfx_rep" }
+ { "uchar" "pfx_repe" }
+ { "uchar" "pfx_repne" }
+ { "uchar" "pfx_insn" }
+ { "uchar" "default64" }
+ { "uchar" "opr_mode" }
+ { "uchar" "adr_mode" }
+ { "uchar" "br_far" }
+ { "uchar" "br_near" }
+ { "uchar" "implicit_addr" }
+ { "uchar" "c1" }
+ { "uchar" "c2" }
+ { "uchar" "c3" }
+ { "uchar[256]" "inp_cache" }
+ { "uchar[64]" "inp_sess" }
+ { "ud_itab_entry*" "itab_entry" } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors memory io io.styles prettyprint
+USING: kernel math memory io io.styles prettyprint
namespaces system sequences splitting grouping assocs strings
generic.single combinators ;
IN: tools.time
IN: tools.trace.tests
-USING: tools.trace tools.test sequences ;
+USING: tools.trace tools.test tools.continuations kernel math combinators
+sequences ;
-[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
\ No newline at end of file
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
+
+GENERIC: method-breakpoint-test ( x -- y )
+
+TUPLE: method-breakpoint-tuple ;
+
+M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
+
+\ method-breakpoint-test don't-step-into
+
+[ 3 ]
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
+
+: case-breakpoint-test ( -- x )
+ 5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
+
+: call(-breakpoint-test ( -- x )
+ [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test
sequences concurrency.messaging locals continuations threads
namespaces namespaces.private make assocs accessors io strings
prettyprint math math.parser words effects summary io.styles classes
-generic.math combinators.short-circuit ;
+generic.math combinators.short-circuit kernel.private quotations ;
IN: tools.trace
-: callstack-depth ( callstack -- n )
- callstack>array length 2/ ;
-
-SYMBOL: end
-
SYMBOL: exclude-vocabs
SYMBOL: include-vocabs
exclude-vocabs { "math" "accessors" } swap set-global
+<PRIVATE
+
+: callstack-depth ( callstack -- n )
+ callstack>array length 2/ ;
+
+SYMBOL: end
+
: include? ( vocab -- ? )
include-vocabs get dup [ member? ] [ 2drop t ] if ;
[ CHAR: \s <string> write ]
[ number>string write ": " write ] bi ;
+: trace-into? ( continuation -- ? )
+ continuation-current into? ;
+
: trace-step ( continuation -- continuation' )
- dup continuation-current end eq? [
- [ print-depth ]
- [ print-step ]
- [
- dup continuation-current into?
- [ continuation-step-into ] [ continuation-step ] if
- ] tri
- ] unless ;
+ dup call>> innermost-frame-executing quotation? [
+ dup continuation-current end eq? [
+ [ print-depth ]
+ [ print-step ]
+ [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
+ tri
+ ] unless
+ ] when ;
+
+PRIVATE>
: trace ( quot -- data )
[ [ trace-step ] break-hook ] dip
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug
generic.single sequences.private kernel.private
-tools.continuations accessors words ;
+tools.continuations accessors words combinators ;
IN: tools.walker.tests
[ { } ] [
\ method-breakpoint-test don't-step-into
[ { 3 } ]
-[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
\ No newline at end of file
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+
+: case-breakpoint-test ( -- x )
+ 5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
+
+: call(-breakpoint-test ( -- x )
+ [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test
'[ select-gl-context @ ]
[ flush-gl-context gl-error ] bi ; inline
-HOOK: (with-ui) ui-backend ( quot -- )
\ No newline at end of file
+HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )
{ fullscreen { $ NSOpenGLPFAFullScreen } }
{ windowed { $ NSOpenGLPFAWindow } }
{ accelerated { $ NSOpenGLPFAAccelerated } }
- { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
+ { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } }
{ backing-store { $ NSOpenGLPFABackingStore } }
{ multisampled { $ NSOpenGLPFAMultisample } }
{ supersampled { $ NSOpenGLPFASupersample } }
M: cocoa-ui-backend (close-window) ( handle -- )
window>> -> release ;
+M: cocoa-ui-backend (grab-input) ( handle -- )
+ 0 CGAssociateMouseAndMouseCursorPosition drop
+ CGMainDisplayID CGDisplayHideCursor drop
+ window>> -> frame CGRect>rect rect-center
+ first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+
+M: cocoa-ui-backend (ungrab-input) ( handle -- )
+ drop
+ CGMainDisplayID CGDisplayShowCursor drop
+ 1 CGAssociateMouseAndMouseCursorPosition drop ;
+
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
handle>> [
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
io.encodings.utf16n windows.errors literals ui.pixel-formats
-ui.pixel-formats.private memoize classes ;
+ui.pixel-formats.private memoize classes struct-arrays ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
GetDoubleClickTime milliseconds double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- f class-name-ptr set-global
- f msg-obj set-global ;
+ class-name-ptr [
+ [ [ f UnregisterClass drop ] [ free ] bi ] when* f
+ ] change-global
+ msg-obj change-global [ [ free ] when* f ] ;
-: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
+: get-dc ( world -- )
+ handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
: get-rc ( world -- )
handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
[ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
: set-pixel-format ( pixel-format hdc -- )
- swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
+ swap handle>>
+ "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
: setup-gl ( world -- )
[ get-dc ] keep
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
+: client-area>RECT ( hwnd -- RECT )
+ "RECT" <c-object>
+ [ GetClientRect win32-error=0/f ]
+ [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+ [ nip ] 2tri ;
+
: hwnd>RECT ( hwnd -- RECT )
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
+M: windows-ui-backend (grab-input) ( handle -- )
+ 0 ShowCursor drop
+ hWnd>> client-area>RECT ClipCursor drop ;
+
+M: windows-ui-backend (ungrab-input) ( handle -- )
+ drop
+ f ClipCursor drop
+ 1 ShowCursor drop ;
+
: fullscreen-flags ( -- n )
{ WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals
-prettyprint.backend prettyprint.custom ;
+concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets
! Values for orientation slot
boundary
model ;
-! Don't print gadgets with RECT: syntax
-M: gadget pprint* pprint-tuple ;
-
M: gadget equal? 2drop f ;
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
: focus-path ( gadget -- seq )
[ focus>> ] follow ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets prettyprint.backend prettyprint.custom ;
+IN: ui.gadgets.prettyprint
+
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;
\ No newline at end of file
HELP: hand-world
{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
+HELP: grab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." }
+{ $notes "Normal mouse gestures may not be available while input is grabbed." } ;
+
+HELP: ungrab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ;
+
+{ grab-input ungrab-input } related-words
+
HELP: set-title
{ $values { "string" string } { "world" world } }
{ $description "Sets the title bar of the native window containing the world." }
{ { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
{ { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
{ { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." }
+ { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
}
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.commands ui.pixel-formats destructors literals strings ;
IN: ui.gadgets.worlds
CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
TUPLE: world < track
- active? focused?
+ active? focused? grab-input?
layers
title status status-owner
text-handle handle images
TUPLE: world-attributes
{ world-class initial: world }
- title
+ grab-input?
+ { title string initial: "Factor Window" }
status
gadgets
{ pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
+: grab-input ( gadget -- )
+ find-world dup grab-input?>>
+ [ drop ] [
+ t >>grab-input?
+ dup focused?>> [ handle>> (grab-input) ] [ drop ] if
+ ] if ;
+
+: ungrab-input ( gadget -- )
+ find-world dup grab-input?>>
+ [
+ f >>grab-input?
+ dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
+ ] [ drop ] if ;
+
: show-status ( string/f gadget -- )
dup find-world dup [
dup status>> [
: new-world ( class -- world )
vertical swap new-track
t >>root?
- t >>active?
- { 0 0 } >>window-loc ;
+ f >>active?
+ { 0 0 } >>window-loc
+ f >>grab-input? ;
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
M: macosx modifiers>string
[
{
- { A+ [ "\u{place-of-interest-sign}" ] }
- { M+ [ "\u{option-key}" ] }
- { S+ [ "\u{upwards-white-arrow}" ] }
- { C+ [ "\u{up-arrowhead}" ] }
+ { A+ [ "\u002318" ] }
+ { M+ [ "\u002325" ] }
+ { S+ [ "\u0021e7" ] }
+ { C+ [ "\u002303" ] }
} case
] map "" join ;
USING: accessors assocs classes destructors functors kernel
lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
IN: ui.pixel-formats
SYMBOLS:
M: object >PFA
drop { } ;
-M: symbol >PFA
+M: word >PFA
TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA
dup class TABLE at
: advanced-settings ( parent -- parent )
"Advanced:" <label> add-gadget
- deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $values { "world" world } { "handle" "a backend-specific handle" } }
{ $description "Adds a window to the global " { $link windows } " variable." }
{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
+{ $values { "handle" "a backend-specific handle" } }
{ $description "Removes a window from the global " { $link windows } " variable." }
{ $notes "This word should only be called only by the UI backend, and not user code." } ;
lose-focus swap each-gesture
gain-focus swap each-gesture ;
+: ?grab-input ( world -- )
+ dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
+
+: ?ungrab-input ( world -- )
+ dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
+
: focus-world ( world -- )
t >>focused?
- dup raised-window
- focus-path f focus-gestures ;
+ [ ?grab-input ] [
+ dup raised-window
+ focus-path f focus-gestures
+ ] bi ;
: unfocus-world ( world -- )
f >>focused?
- focus-path f swap focus-gestures ;
+ [ ?ungrab-input ]
+ [ focus-path f swap focus-gestures ] bi ;
-: try-to-open-window ( world -- )
+: set-up-window ( world -- )
{
- [ (open-window) ]
[ handle>> select-gl-context ]
- [
- [ begin-world ]
- [ [ handle>> (close-window) ] [ ui-error ] bi* ]
- recover
- ]
+ [ [ title>> ] keep set-title ]
+ [ begin-world ]
[ resize-world ]
+ [ t >>active? drop ]
+ [ request-focus ]
} cleave ;
+: clean-up-broken-window ( world -- )
+ [
+ dup { [ focused?>> ] [ grab-input?>> ] } 1&&
+ [ handle>> (ungrab-input) ] [ drop ] if
+ ] [ handle>> (close-window) ] bi ;
+
M: world graft*
- [ try-to-open-window ]
- [ [ title>> ] keep set-title ]
- [ request-focus ] tri ;
+ [ (open-window) ]
+ [
+ [ set-up-window ]
+ [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
+ ] bi ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
PRIVATE>
: find-window ( quot -- world )
- [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
+ [ windows get values ] dip
+ '[ dup children>> [ ] [ nip first ] if-empty @ ]
+ find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
] if ;
: parse-host ( string -- host port )
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi* ;
+ [
+ ":" split1 [ url-decode ] [
+ dup [
+ string>number
+ dup [ "Invalid port" throw ] unless
+ ] when
+ ] bi*
+ ] [ f f ] if* ;
GENERIC: >url ( obj -- url )
IUnknown::Release drop ; inline\r
\r
: with-com-interface ( interface quot -- )\r
- over [ slip ] [ com-release ] [ ] cleanup ; inline\r
+ over [ com-release ] curry [ ] cleanup ; inline\r
\r
DESTRUCTOR: com-release\r
: compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ]
- [ [ (( -- alien )) define-declared ] pick slip ]
+ [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
with-compilation-unit ;
: (callback-word) ( function-name interface-name counter -- word )
CONSTANT: DISCL_BACKGROUND HEX: 00000008
CONSTANT: DISCL_NOWINKEY HEX: 00000010
+CONSTANT: DIMOFS_X 0
+CONSTANT: DIMOFS_Y 4
+CONSTANT: DIMOFS_Z 8
+CONSTANT: DIMOFS_BUTTON0 12
+CONSTANT: DIMOFS_BUTTON1 13
+CONSTANT: DIMOFS_BUTTON2 14
+CONSTANT: DIMOFS_BUTTON3 15
+CONSTANT: DIMOFS_BUTTON4 16
+CONSTANT: DIMOFS_BUTTON5 17
+CONSTANT: DIMOFS_BUTTON6 18
+CONSTANT: DIMOFS_BUTTON7 19
+
CONSTANT: DIK_ESCAPE HEX: 01
CONSTANT: DIK_1 HEX: 02
CONSTANT: DIK_2 HEX: 03
FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
! FUNCTION: ChildWindowFromPointEx
! FUNCTION: ClientThreadSetup
-! FUNCTION: ClientToScreen
+FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
! FUNCTION: CliImmSetHotKey
-! FUNCTION: ClipCursor
+FUNCTION: int ClipCursor ( RECT* clipRect ) ;
FUNCTION: BOOL CloseClipboard ( ) ;
! FUNCTION: CloseDesktop
! FUNCTION: CloseWindow
! FUNCTION: SetWindowWord
! FUNCTION: SetWinEventHook
! FUNCTION: ShowCaret
-! FUNCTION: ShowCursor
+FUNCTION: int ShowCursor ( BOOL show ) ;
! FUNCTION: ShowOwnedPopups
! FUNCTION: ShowScrollBar
! FUNCTION: ShowStartGlass
<PRIVATE
: call-under ( quot object -- quot )
- swap dup slip ; inline
+ swap [ call ] keep ; inline
: xml-loop ( quot: ( xml-elem -- ) -- )
parse-text call-under
HOOK: alien>native-string os ( alien -- string )
-HOOK: native-string>alien os ( string -- alien )
-
M: windows alien>native-string utf16n alien>string ;
-M: wince native-string>alien utf16n string>alien ;
+M: unix alien>native-string utf8 alien>string ;
-M: winnt native-string>alien utf8 string>alien ;
+HOOK: native-string>alien os ( string -- alien )
-M: unix alien>native-string utf8 alien>string ;
+M: windows native-string>alien utf16n string>alien ;
M: unix native-string>alien utf8 string>alien ;
: dll-path ( dll -- string )
path>> alien>native-string ;
-: string>symbol ( str -- alien )
- dup string?
- [ native-string>alien ]
- [ [ native-string>alien ] map ] if ;
+HOOK: string>symbol* os ( str/seq -- alien )
+
+M: winnt string>symbol* utf8 string>alien ;
+
+M: wince string>symbol* utf16n string>alien ;
+
+M: unix string>symbol* utf8 string>alien ;
+
+GENERIC: string>symbol ( str -- alien )
+
+M: string string>symbol string>symbol* ;
+
+M: sequence string>symbol [ string>symbol* ] map ;
[
8 getenv utf8 alien>string string>cpu \ cpu set-global
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
- { "direct-entry-def" }
+ "pic-def"
+ "pic-tail-def"
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
{ "(sleep)" "threads.private" (( us -- )) }
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
{ "callstack>array" "kernel" (( callstack -- array )) }
- { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
+ { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
{ "call-clear" "kernel" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
{ "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+ { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
{ "reset-dispatch-stats" "generic.single" (( -- )) }
256 iota [
8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
- ] times >bignum
+ ] times
] map 0 crc32-table copy
: (crc32) ( crc ch -- crc )
- >bignum dupd bitxor
- mask-byte crc32-table nth-unsafe >bignum
+ dupd bitxor
+ mask-byte crc32-table nth-unsafe
swap -8 shift bitxor ; inline
SINGLETON: crc32
": dip [ ] bi* ;"
": 2dip [ ] [ ] tri* ;"
""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
{ $subsection both? }
{ $subsection either? } ;
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection 2dip }
{ $subsection 3dip }
{ $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
+{ $subsection "retainstack-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
{ $subsection continue-with }
"Continuations as control-flow:"
{ $subsection attempt-all }
-{ $subsection retry }
{ $subsection with-return }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
}
} ;
-HELP: retry
-{ $values
- { "quot" quotation } { "n" integer }
-}
-{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
-{ $examples
- "Try to get a 0 as a random number:"
- { $unchecked-example "USING: continuations math prettyprint random ;"
- "[ 5 random 0 = ] 5 retry"
- "t"
- }
-} ;
-
-{ attempt-all retry } related-words
-
HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
[ 1 2 ] [ bar ] unit-test
-[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
] { } make peek swap [ rethrow ] when
] if ; inline
-: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
-
TUPLE: condition error restarts continuation ;
C: <condition> condition ( error restarts cc -- condition )
M: hook-combination dispatch# drop 0 ;
-M: hook-combination inline-cache-quot 2drop f ;
-
M: hook-combination mega-cache-quot
1quotation picker [ lookup-method (execute) ] surround ;
[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
-[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
+[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
\ No newline at end of file
: build-fast-hash ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ compile-engines* >alist >array ] map ;
+ [ compile-engines* >alist { } join ] map ;
M: echelon-dispatch-engine compile-engine
dup n>> 0 = [
[ <engine> compile-engine ] bi
] tri ;
-HOOK: inline-cache-quot combination ( word methods -- quot/f )
+HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
+
+M: single-combination inline-cache-quots 2drop f f ;
: define-inline-cache-quot ( word methods -- )
- [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
+ [ drop ] [ inline-cache-quots ] 2bi
+ [ >>pic-def ] [ >>pic-tail-def ] bi*
+ drop ;
HOOK: mega-cache-quot combination ( methods -- quot/f )
USING: accessors definitions generic generic.single kernel
namespaces words math math.order combinators sequences
generic.single.private quotations kernel.private
-assocs arrays layouts ;
+assocs arrays layouts make ;
IN: generic.standard
TUPLE: standard-combination < single-combination # ;
-: <standard-combination> ( n -- standard-combination )
- dup 0 2 between? [ "Bad dispatch position" throw ] unless
- standard-combination boa ;
+C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
(effective-method) ;
-M: standard-combination inline-cache-quot ( word methods -- )
+: inline-cache-quot ( word methods miss-word -- quot )
+ [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
+
+M: standard-combination inline-cache-quots
#! Direct calls to the generic word (not tail calls or indirect calls)
#! will jump to the inline cache entry point instead of the megamorphic
#! dispatch entry point.
- combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
+ [ \ inline-cache-miss inline-cache-quot ]
+ [ \ inline-cache-miss-tail inline-cache-quot ]
+ 2bi ;
: make-empty-cache ( -- array )
mega-cache-size get f <array> ;
M: standard-combination mega-cache-quot
- combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
+ combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
M: standard-generic definer drop \ GENERIC# f ;
PRIVATE>
M: hashtable >alist
- [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
+ [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
[
[
[ 1 fixnum-shift-fast ] dip
[ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
- ] 2curry each
+ ] 2curry each-integer
] keep { } like ;
M: hashtable clone
}
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
+{ seek-absolute seek-relative seek-end } related-words
HELP: seek-input
{ $values
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
HELP: stream-contents
-{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
+{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
HELP: contents
-{ $values { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
+{ $values { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
{ $subsection bl }
"Seeking on the default output stream:"
{ $subsection seek-output }
+"Seeking descriptors:"
+{ $subsection seek-absolute }
+{ $subsection seek-relative }
+{ $subsection seek-end }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
-continuations destructors assocs ;
+continuations destructors assocs combinators ;
IN: io
SYMBOLS: +byte+ +character+ ;
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
+
SINGLETONS: seek-absolute seek-relative seek-end ;
+
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
: bl ( -- ) " " write ;
-: stream-lines ( stream -- seq )
- [ [ readln dup ] [ ] produce nip ] with-input-stream ;
-
-: lines ( -- seq )
- input-stream get stream-lines ;
-
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
+: stream-element-exemplar ( type -- exemplar )
+ {
+ { +byte+ [ B{ } ] }
+ { +character+ [ "" ] }
+ } case ;
+
+: element-exemplar ( -- exemplar )
+ input-stream get
+ stream-element-type
+ stream-element-exemplar ;
+
PRIVATE>
: each-line ( quot -- )
[ readln ] each-morsel ; inline
-: stream-contents ( stream -- seq )
- [
- [ 65536 read-partial dup ] [ ] produce nip concat f like
- ] with-input-stream ;
+: lines ( -- seq )
+ [ ] accumulator [ each-line ] dip { } like ;
+
+: stream-lines ( stream -- seq )
+ [ lines ] with-input-stream ;
: contents ( -- seq )
- input-stream get stream-contents ;
+ [ 65536 read-partial dup ] [ ] produce nip
+ element-exemplar concat-as ;
+
+: stream-contents ( stream -- seq )
+ [ contents ] with-input-stream ;
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings namespaces ;
+[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
{ $notes "Used to implement " { $link "threads" } "." } ;
-HELP: slip
-{ $values { "quot" quotation } { "x" object } }
-{ $description "Calls a quotation while hiding the top of the stack." } ;
-
-HELP: 2slip
-{ $values { "quot" quotation } { "x" object } { "y" object } }
-{ $description "Calls a quotation while hiding the top two stack elements." } ;
-
-HELP: 3slip
-{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } }
-{ $description "Calls a quotation while hiding the top three stack elements." } ;
-
HELP: keep
{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
[ 2 ] [ f 2 xor ] unit-test
[ f ] [ f f xor ] unit-test
-[ slip ] must-fail
+[ dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 slip ] must-fail
+[ 1 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 slip ] must-fail
+[ 1 2 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 3 slip ] must-fail
-[ ] [ :c ] unit-test
-
-
-[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
+[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
[ [ ] keep ] must-fail
: ?if ( default cond true false -- )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
-! Slippers and dippers.
+! Dippers.
! Not declared inline because the compiler special-cases them
-: slip ( quot x -- x )
- #! 'slip' and 'dip' can be defined in terms of each other
- #! because the JIT special-cases a 'dip' preceeded by
- #! a literal quotation.
- [ call ] dip ;
+: dip ( x quot -- x ) swap [ call ] dip ;
-: 2slip ( quot x y -- x y )
- #! '2slip' and '2dip' can be defined in terms of each other
- #! because the JIT special-cases a '2dip' preceeded by
- #! a literal quotation.
- [ call ] 2dip ;
+: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ;
-: 3slip ( quot x y z -- x y z )
- #! '3slip' and '3dip' can be defined in terms of each other
- #! because the JIT special-cases a '3dip' preceeded by
- #! a literal quotation.
- [ call ] 3dip ;
-
-: dip ( x quot -- x ) swap slip ;
-
-: 2dip ( x y quot -- x y ) -rot 2slip ;
-
-: 3dip ( x y z quot -- x y z ) -roll 3slip ;
+: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ;
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) over [ call ] dip ; inline
: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
{ $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
} ;
+HELP: fp-special?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+HELP: fp-qnan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
+HELP: fp-snan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
HELP: fp-infinity?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
-{ fp-nan? fp-infinity? } related-words
+HELP: fp-nan-payload
+{ $values { "x" real } { "bits" integer } }
+{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
+
+HELP: <fp-nan>
+{ $values { "payload" integer } { "nan" float } }
+{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
+{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
+
+{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
+
+HELP: next-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+
+HELP: prev-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+
+{ next-float prev-float } related-words
HELP: real-part
{ $values { "z" number } { "x" real } }
[ f ] [ 1/0. fp-nan? ] unit-test
[ f ] [ -1/0. fp-nan? ] unit-test
[ t ] [ -0/0. fp-nan? ] unit-test
+[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
+! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
+! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
+[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
[ t ] [ 1/0. fp-infinity? ] unit-test
[ t ] [ -1/0. fp-infinity? ] unit-test
[ f ] [ -0/0. fp-infinity? ] unit-test
+
+[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
+[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+
+[ 0.0 ] [ -0.0 next-float ] unit-test
+[ t ] [ 1.0 dup next-float < ] unit-test
+[ t ] [ -1.0 dup next-float < ] unit-test
+
+[ -0.0 ] [ 0.0 prev-float ] unit-test
+[ t ] [ 1.0 dup prev-float > ] unit-test
+[ t ] [ -1.0 dup prev-float > ] unit-test
UNION: number real complex ;
+: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline
+
+GENERIC: fp-special? ( x -- ? )
GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
+M: object fp-special?
+ drop f ;
M: object fp-nan?
drop f ;
+M: object fp-qnan?
+ drop f ;
+M: object fp-snan?
+ drop f ;
+M: object fp-infinity?
+ drop f ;
+M: object fp-nan-payload
+ drop f ;
+
+M: float fp-special?
+ double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+
+M: float fp-nan-payload
+ double>bits HEX: fffffffffffff bitand ; foldable flushable
M: float fp-nan?
- double>bits -51 shift HEX: fff [ bitand ] keep = ;
+ dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
-GENERIC: fp-infinity? ( x -- ? )
+M: float fp-qnan?
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
-M: object fp-infinity?
- drop f ;
+M: float fp-snan?
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+
+M: float fp-infinity?
+ dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+
+: <fp-nan> ( payload -- nan )
+ HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
-M: float fp-infinity? ( float -- ? )
+: next-float ( m -- n )
double>bits
- dup -52 shift HEX: 7ff [ bitand ] keep = [
- HEX: fffffffffffff bitand 0 =
- ] [
- drop f
- ] if ;
+ dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
+ dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
+ 1 + bits>double ! positive
+ ] if
+ ] if ; foldable flushable
+
+: prev-float ( m -- n )
+ double>bits
+ dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
+ dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
+ 1 - bits>double ! positive non-zero
+ ] if
+ ] if ; foldable flushable
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
normalize-path native-string>alien (save-image) ;
: save-image-and-exit ( path -- )
- normalize-path native-string>alien (save-image) ;
+ normalize-path native-string>alien (save-image-and-exit) ;
: save ( -- ) image save-image ;
M: curry call uncurry call ;
-M: compose call uncompose slip call ;
+M: compose call uncompose [ call ] dip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
{ $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ;
+HELP: concat-as
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." }
+{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ;
+
HELP: join
{ $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } }
{ $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." }
+{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ;
-{ join concat } related-words
+{ join concat concat-as } related-words
HELP: peek
{ $values { "seq" sequence } { "elt" object } }
: sum-lengths ( seq -- n )
0 [ length + ] reduce ;
+: concat-as ( seq exemplar -- newseq )
+ swap [ { } ] [
+ [ sum-lengths over new-resizable ] keep
+ [ over push-all ] each
+ ] if-empty swap like ;
+
: concat ( seq -- newseq )
- [ { } ] [
- [ sum-lengths ] keep
- [ first new-resizable ] keep
- [ [ over push-all ] each ] keep
- first like
- ] if-empty ;
+ [ { } ] [ dup first concat-as ] if-empty ;
<PRIVATE
PRIVATE>
: join ( seq glue -- newseq )
- [
- 2dup joined-length over new-resizable [
- [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
- interleave
- ] keep
- ] keep like ;
+ dup empty? [ concat-as ] [
+ [
+ 2dup joined-length over new-resizable [
+ [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+ interleave
+ ] keep
+ ] keep like
+ ] if ;
: padding ( seq n elt quot -- newseq )
[
[ subwords forget-all ]
[ reset-word ]
[
- f >>direct-entry-def
+ f >>pic-def
+ f >>pic-tail-def
{
"methods"
"combination"
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-unicode? t }
{ deploy-io 3 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-io 1 }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
: >matrix ( q s r t -- z )
4array 2 group ;
-: produce ( z n -- z' )
+: produce ( z y -- z' )
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
: gen-x ( x -- matrix )
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? f }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
read-longlong
read-int32 oid boa ;
-M: bson-binary-custom element-binary-read ( size type -- dbref )
- 2drop
- read-cstring
- read-cstring objref boa ;
-
M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ;
-M: bson-binary-function element-binary-read ( size type -- quot )
+M: bson-binary-custom element-binary-read ( size type -- quot )
drop read bytes>object ;
PRIVATE>
+USE: tools.continuations
+
: stream>assoc ( exemplar -- assoc bytes-read )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
M: real bson-type? ( real -- type ) drop T_Double ;
-M: word bson-type? ( word -- type ) drop T_String ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: string bson-type? ( string -- type ) drop T_String ;
M: oid bson-type? ( word -- type ) drop T_OID ;
M: objref bson-type? ( objref -- type ) drop T_Binary ;
+M: word bson-type? ( word -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
T_Binary_Bytes write-byte
write ;
-M: quotation bson-write ( quotation -- )
- object>bytes [ length write-int32 ] keep
- T_Binary_Function write-byte
- write ;
-
M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: objref bson-write ( objref -- )
- [ binary ] dip
- '[ _
- [ ns>> write-cstring ]
- [ objid>> write-cstring ] bi ] with-byte-writer
- [ length write-int32 ] keep
- T_Binary_Custom write-byte write ;
M: mdbregexp bson-write ( regexp -- )
[ regexp>> write-cstring ]
[ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
write-eoo ] with-length-prefix ;
-M: word bson-write name>> bson-write ;
+: (serialize-code) ( code -- )
+ object>bytes [ length write-int32 ] keep
+ T_Binary_Custom write-byte
+ write ;
+
+M: quotation bson-write ( quotation -- )
+ (serialize-code) ;
+
+M: word bson-write ( word -- )
+ (serialize-code) ;
PRIVATE>
{ deploy-io 3 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
GL_FLOAT 0 0 buffer-offset glNormalPointer
[
nv>> "float" heap-size * buffer-offset
- 3 GL_FLOAT 0 roll glVertexPointer
+ [ 3 GL_FLOAT 0 ] dip glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
: outlining-supported? ( -- ? )
"2.0" {
- "GL_ARB_shading_objects"
+ "GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
} has-gl-version-or-extensions? {
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
- { deploy-compiler? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
: init-hmac ( K -- o i )
64 0 pad-tail
- [ opad seq-bitxor ] keep
- ipad seq-bitxor ;
+ [ opad seq-bitxor ]
+ [ ipad seq-bitxor ] bi ;
PRIVATE>
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.miller-rabin kernel math math.functions namespaces
+USING: math.primes kernel math math.functions namespaces
sequences accessors ;
IN: crypto.rsa
CONSTANT: public-key 65537
: rsa-primes ( numbits -- p q )
- 2/ 2 unique-primes first2 ;
+ 2/ 2 swap unique-primes first2 ;
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: crypto.timing kernel tools.test system math ;
-IN: crypto.timing.tests
-
-[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math threads system calendar ;
-IN: crypto.timing
-
-: with-timing ( quot n -- )
- #! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + milliseconds sleep ; inline
{ deploy-math? t }
{ deploy-name "drills" }
{ deploy-ui? t }
- { deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-c-types? f }
math.rectangles accessors math alien alien.strings
io.encodings.utf16 io.encodings.utf16n continuations
byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors ;
+ui.backend.windows windows.errors struct-arrays
+math.bitwise ;
IN: game-input.dinput
+CONSTANT: MOUSE-BUFFER-SIZE 16
+
SINGLETON: dinput-game-input-backend
dinput-game-input-backend game-input-backend set-global
SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+ ;
+ +device-change-window+ +device-change-handle+
+ +mouse-device+ +mouse-state+ +mouse-buffer+ ;
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
: set-data-format ( device format-symbol -- )
get IDirectInputDevice8W::SetDataFormat ole32-error ;
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+ "DIPROPDWORD" <c-object>
+ "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+ "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+ 0 over set-DIPROPHEADER-dwObj
+ DIPH_DEVICE over set-DIPROPHEADER-dwHow
+ swap over set-DIPROPDWORD-dwData ;
+
+: set-buffer-size ( device size -- )
+ DIPROP_BUFFERSIZE swap <buffer-size-diprop>
+ IDirectInputDevice8W::SetProperty ole32-error ;
+
: configure-keyboard ( keyboard -- )
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-mouse ( mouse -- )
+ [ c_dfDIMouse2 set-data-format ]
+ [ MOUSE-BUFFER-SIZE set-buffer-size ]
+ [ set-coop-level ] tri ;
: configure-controller ( controller -- )
[ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
256 <byte-array> <keys-array> keyboard-state boa
+keyboard-state+ set-global ;
+: find-mouse ( -- )
+ GUID_SysMouse device-for-guid
+ [ configure-mouse ]
+ [ +mouse-device+ set-global ] bi
+ 0 0 0 0 8 f <array> mouse-state boa
+ +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+ +mouse-buffer+ set-global ;
+
: device-info ( device -- DIDEVICEIMAGEINFOW )
"DIDEVICEINSTANCEW" <c-object>
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+keyboard-device+ [ com-release f ] change-global
f +keyboard-state+ set-global ;
+: release-mouse ( -- )
+ +mouse-device+ [ com-release f ] change-global
+ f +mouse-state+ set-global ;
+
M: dinput-game-input-backend (open-game-input)
create-dinput
create-device-change-window
find-keyboard
+ find-mouse
set-up-controllers
add-wm-devicechange ;
M: dinput-game-input-backend (close-game-input)
remove-wm-devicechange
release-controllers
+ release-mouse
release-keyboard
close-device-change-window
delete-dinput ;
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
} 2cleave ;
+: read-device-buffer ( device buffer count -- buffer count' )
+ [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+ [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+
+: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
+ [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+ { DIMOFS_X [ [ + ] curry change-dx ] }
+ { DIMOFS_Y [ [ + ] curry change-dy ] }
+ { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
+ [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
+ } case ;
+
+: fill-mouse-state ( buffer count -- state )
+ [ +mouse-state+ get ] 2dip swap
+ [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
+
: get-device-state ( device byte-array -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ length ] keep
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend read-mouse
+ +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend reset-mouse
+ +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ 2drop ] [ ] with-acquisition
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
IN: game-input
ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
-"The current state of a controller or the keyboard can be read:"
+"The current state of a controller, the keyboard, and the mouse can be read:"
{ $subsection read-controller }
{ $subsection read-keyboard }
+{ $subsection read-mouse }
{ $subsection controller-state }
-{ $subsection keyboard-state } ;
+{ $subsection keyboard-state }
+{ $subsection mouse-state } ;
HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
HELP: game-input-opened?
{ $values { "?" "a boolean" } }
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+HELP: read-mouse
+{ $values { "mouse-state" mouse-state } }
+{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
+
+HELP: reset-mouse
+{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
+
HELP: controller-state
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
{ $list
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+HELP: mouse-state
+{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "dx" } " contains the mouse's X axis movement." }
+ { { $snippet "dy" } " contains the mouse's Y axis movement." }
+ { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
+ { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
+ { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
+}
+"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
+} ;
+
+
{ keyboard-state read-keyboard } related-words
ABOUT: "game-input"
-USING: arrays accessors continuations kernel system
+USING: arrays accessors continuations kernel math system
sequences namespaces init vocabs vocabs.loader combinators ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
+game-input-opened [ 0 ] initialize
+
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
HOOK: (reset-game-input) game-input-backend ( -- )
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
: game-input-opened? ( -- ? )
- game-input-opened get ;
+ game-input-opened get zero? not ;
<PRIVATE
M: f (reset-game-input) ;
: reset-game-input ( -- )
- game-input-opened off
(reset-game-input) ;
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
+ERROR: game-input-not-open ;
+
: open-game-input ( -- )
game-input-opened? [
(open-game-input)
- game-input-opened on
- ] unless ;
+ ] unless
+ game-input-opened [ 1+ ] change-global
+ reset-mouse ;
: close-game-input ( -- )
+ game-input-opened [
+ dup zero? [ game-input-not-open ] when
+ 1-
+ ] change-global
game-input-opened? [
(close-game-input)
reset-game-input
- ] when ;
+ ] unless ;
: with-game-input ( quot -- )
open-game-input [ close-game-input ] [ ] cleanup ; inline
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left ;
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
: find-controller-products ( product-id -- sequence )
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
[ instance-id = ] 2bi* and
] with with find nip ;
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
TUPLE: keyboard-state keys ;
M: keyboard-state clone
call-next-method dup keys>> clone >>keys ;
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+ call-next-method dup buttons>> clone >>buttons ;
{
{ [ os windows? ] [ "game-input.dinput" require ] }
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads
-namespaces assocs vectors arrays combinators
+namespaces assocs vectors arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input ;
+alien.c-types math parser game-input vectors ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
iokit-game-input-backend game-input-backend set-global
: hid-manager-matching ( matching-seq -- alien )
CONSTANT: game-devices-matching-seq
{
+ H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
+ H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
}
CONSTANT: buttons-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
CONSTANT: slider-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: wheel-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
CONSTANT: hat-switch-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
game-devices-matching-seq hid-manager-matching ;
: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty plist> ;
+ <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty plist> ;
+ <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
: set-element-property ( element key value -- )
[ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap set-element-property ;
+ [ dupd element-property ] dip swap
+ [ set-element-property ] [ 2drop ] if* ;
+
+: mouse-device? ( device -- ? )
+ 1 2 IOHIDDeviceConformsTo ;
: controller-device? ( device -- ? )
{
[ 1 4 IOHIDDeviceConformsTo ]
[ 1 5 IOHIDDeviceConformsTo ]
+ [ 1 8 IOHIDDeviceConformsTo ]
} 1|| ;
: element-usage ( element -- {usage-page,usage} )
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
2array ;
-: button? ( {usage-page,usage} -- ? )
- first 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
- first 7 = ; inline
+: button? ( element -- ? )
+ IOHIDElementGetUsagePage 9 = ; inline
+: keyboard-key? ( element -- ? )
+ IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+ IOHIDElementGetUsagePage 1 = ; inline
+
: x-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 30 } = ; inline
+ IOHIDElementGetUsage HEX: 30 = ; inline
: y-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 31 } = ; inline
+ IOHIDElementGetUsage HEX: 31 = ; inline
: z-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 32 } = ; inline
+ IOHIDElementGetUsage HEX: 32 = ; inline
: rx-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 33 } = ; inline
+ IOHIDElementGetUsage HEX: 33 = ; inline
: ry-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 34 } = ; inline
+ IOHIDElementGetUsage HEX: 34 = ; inline
: rz-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 35 } = ; inline
+ IOHIDElementGetUsage HEX: 35 = ; inline
: slider? ( {usage-page,usage} -- ? )
- { 1 HEX: 36 } = ; inline
+ IOHIDElementGetUsage HEX: 36 = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 38 = ; inline
: hat-switch? ( {usage-page,usage} -- ? )
- { 1 HEX: 39 } = ; inline
+ IOHIDElementGetUsage HEX: 39 = ; inline
CONSTANT: pov-values
{
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
: axis-value ( value -- [-1,1] )
kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: mouse-axis-value ( value -- n )
+ IOHIDValueGetIntegerValue ;
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+: record-button ( state hid-value element -- )
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+
: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ] }
[ 3drop ]
} cond ;
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+HINTS: record-controller { controller-state alien } ;
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-: record-keyboard ( value -- )
- dup IOHIDValueGetElement element-usage keyboard-key? [
+: record-keyboard ( keyboard-state value -- )
+ dup IOHIDValueGetElement dup keyboard-key? [
[ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
- +keyboard-state+ get ?set-nth
- ] [ drop ] if ;
+ [ IOHIDElementGetUsage ] bi*
+ rot ?set-nth
+ ] [ 3drop ] if ;
+
+HINTS: record-keyboard { array alien } ;
+
+: record-mouse ( mouse-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+ [ 3drop ]
+ } cond ] }
+ [ 3drop ]
+ } cond ;
+
+HINTS: record-mouse { mouse-state alien } ;
+
+M: iokit-game-input-backend read-mouse
+ +mouse-state+ get ;
+
+M: iokit-game-input-backend reset-mouse
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
: default-calibrate-saturation ( element -- )
[ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
[ button-count f <array> ]
} cleave controller-state boa ;
+: ?add-mouse-buttons ( device -- )
+ button-count +mouse-state+ get buttons>>
+ 2dup length >
+ [ set-length ] [ 2drop ] if ;
+
: device-matched-callback ( -- alien )
[| context result sender device |
- device controller-device? [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] when
+ {
+ { [ device controller-device? ] [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] }
+ { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+ [ ]
+ } cond
] IOHIDDeviceCallback ;
: device-removed-callback ( -- alien )
: device-input-callback ( -- alien )
[| context result sender value |
- sender controller-device?
- [ sender +controller-states+ get at value record-controller ]
- [ value record-keyboard ]
- if
+ {
+ { [ sender controller-device? ] [
+ sender +controller-states+ get at value record-controller
+ ] }
+ { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+ [ +keyboard-state+ get value record-keyboard ]
+ } cond
] IOHIDValueCallback ;
: initialize-variables ( manager -- )
+hid-manager+ set-global
4 <vector> +controller-states+ set-global
+ 0 0 0 0 2 <vector> mouse-state boa
+ +mouse-state+ set-global
256 f <array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
} cleave ;
M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +controller-states+ }
+ { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
[ f swap set-global ] each ;
M: iokit-game-input-backend (close-game-input)
f
] change-global
f +keyboard-state+ set-global
+ f +mouse-state+ set-global
f +controller-states+ set-global
] when ;
-USING: accessors destructors kernel math math.order namespaces
+USING: accessors calendar destructors kernel math math.order namespaces
system threads ;
IN: game-loop
: (run-loop) ( loop -- )
dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )
--- /dev/null
+USING: accessors game-input game-loop kernel math ui.gadgets
+ui.gadgets.worlds ui.gestures ;
+IN: game-worlds
+
+TUPLE: game-world < world
+ game-loop
+ { tick-slice float initial: 0.0 } ;
+
+GENERIC: tick-length ( world -- millis )
+
+M: game-world draw*
+ swap >>tick-slice draw-world ;
+
+M: game-world begin-world
+ dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
+ drop
+ open-game-input ;
+
+M: game-world end-world
+ close-game-input
+ [ [ stop-loop ] when* f ] change-game-loop
+ drop ;
+
+M: game-world focusable-child* drop t ;
+
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
--- /dev/null
+Diego Martinelli
--- /dev/null
+USING: help.markup help.syntax kernel math ;
+IN: hashcash
+
+ARTICLE: "hashcash" "Hashcash"
+"Hashcash is a denial-of-service counter measure tool."
+$nl
+"A hashcash stamp constitutes a proof-of-work which takes a parameterizable amount of work to compute for the sender. The recipient can verify received hashcash stamps efficiently."
+$nl
+"More info on hashcash:"
+$nl
+{ $url "http://www.hashcash.org/" } $nl
+{ $url "http://en.wikipedia.org/wiki/Hashcash" } $nl
+{ $url "http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash" } $nl
+"This library provide basic utilities for hashcash creation and validation."
+$nl
+"Creating stamps:"
+{ $subsection mint }
+{ $subsection mint* }
+"Validation:"
+{ $subsection check-stamp }
+"Hashcash tuple and constructor:"
+{ $subsection hashcash }
+{ $subsection <hashcash> }
+"Utilities:"
+{ $subsection salt } ;
+
+{ mint mint* <hashcash> check-stamp salt } related-words
+
+HELP: mint
+{ $values { "resource" "a string" } { "stamp" "generated stamp" } }
+{ $description "This word generate a valid stamp with default parameters and the specified resource." } ;
+
+HELP: mint*
+{ $values { "tuple" "a tuple" } { "stamp" "generated stamp" } }
+{ $description "As " { $snippet "mint" } " but it takes an hashcash tuple as a parameter." } ;
+
+HELP: check-stamp
+{ $values { "stamp" "a string" } { "?" boolean } }
+{ $description "Check for stamp's validity. Only supports hashcash version 1." } ;
+
+HELP: salt
+{ $values { "length" integer } { "salted" "a string" } }
+{ $description "It generates a random string of " { $snippet "length" } " characters." } ;
+
+HELP: <hashcash>
+{ $values { "tuple" object } }
+{ $description "It fill an hashcash tuple with the default values: 1 as hashcash version, 20 as bits, today's date as date and a random 8 character long salt" } ;
+
+HELP: hashcash
+{ $class-description "An hashcash object. An hashcash have the following slots:"
+ { $table
+ { { $slot "version" } "The version number. Only version 1 is supported." }
+ { { $slot "bits" } "The claimed bit value." }
+ { { $slot "date" } "The date a stamp was minted." }
+ { { $slot "resource" } "The resource for which a stamp is minted." }
+ { { $slot "ext" } "Extensions that a specialized application may want." }
+ { { $slot "salt" } "A random salt." }
+ { { $slot "suffix" } "The computed suffix. This is supposed to be manipulated by the library." }
+ }
+} ;
--- /dev/null
+USING: accessors sequences tools.test hashcash ;
+
+[ t ] [ "foo@bar.com" mint check-stamp ] unit-test
+
+[ t ] [
+ <hashcash>
+ "foo@bar.com" >>resource
+ 16 >>bits
+ mint* check-stamp ] unit-test
+
+[ t ] [
+ "1:20:040927:mertz@gnosis.cx::odVZhQMP:7ca28" check-stamp
+] unit-test
+
+[ 8 ] [ 8 salt length ] unit-test
--- /dev/null
+! Copyright (C) 2009 Diego Martinelli.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays calendar calendar.format
+checksums checksums.openssl classes.tuple
+fry kernel make math math.functions math.parser math.ranges
+present random sequences splitting strings syntax ;
+IN: hashcash
+
+! Hashcash implementation
+! Reference materials listed below:
+!
+! http://hashcash.org
+! http://en.wikipedia.org/wiki/Hashcash
+! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash
+!
+! And the reference implementation (in python):
+! http://www.gnosis.cx/download/gnosis/util/hashcash.py
+
+<PRIVATE
+
+! Return a string with today's date in the form YYMMDD
+: get-date ( -- str )
+ now [ year>> 100 mod pad-00 ]
+ [ month>> pad-00 ]
+ [ day>> pad-00 ] tri 3append ;
+
+! Random salt is formed by ascii characters
+! between 33 and 126
+: available-chars ( -- seq )
+ 33 126 [a,b] [ CHAR: : = not ] filter ;
+
+PRIVATE>
+
+! Generate a 'length' long random salt
+: salt ( length -- salted )
+ available-chars '[ _ random ] "" replicate-as ;
+
+TUPLE: hashcash version bits date resource ext salt suffix ;
+
+: <hashcash> ( -- tuple )
+ hashcash new
+ 1 >>version
+ 20 >>bits
+ get-date >>date
+ 8 salt >>salt ;
+
+M: hashcash string>>
+ tuple-slots [ present ] map ":" join ;
+
+<PRIVATE
+
+: sha1-checksum ( str -- bytes )
+ openssl-sha1 checksum-bytes ; inline
+
+: set-suffix ( tuple guess -- tuple )
+ >hex >>suffix ;
+
+: get-bits ( bytes -- str )
+ [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ;
+
+: checksummed-bits ( tuple -- relevant-bits )
+ dup string>> sha1-checksum
+ swap bits>> 8 / ceiling head get-bits ;
+
+: all-char-zero? ( seq -- ? )
+ [ CHAR: 0 = ] all? ; inline
+
+: valid-guess? ( checksum tuple -- ? )
+ bits>> head all-char-zero? ;
+
+: (mint) ( tuple counter -- tuple )
+ 2dup set-suffix checksummed-bits pick
+ valid-guess? [ drop ] [ 1+ (mint) ] if ;
+
+PRIVATE>
+
+: mint* ( tuple -- stamp )
+ 0 (mint) string>> ;
+
+: mint ( resource -- stamp )
+ <hashcash>
+ swap >>resource
+ mint* ;
+
+! One might wanna add check based on the date,
+! passing a 'good-until' duration param
+: check-stamp ( stamp -- ? )
+ dup ":" split [ sha1-checksum get-bits ] dip
+ second string>number head all-char-zero? ;
+
--- /dev/null
+Hashcash implementation
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-name "Hello world" }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Hello world" }
{ deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-word-props? f }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
USING: tools.deploy.config ;
H{
- { deploy-name "Hello world (console)" }
- { deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
- { deploy-compiler? f }
{ deploy-unicode? f }
+ { deploy-ui? f }
+ { deploy-name "Hello world (console)" }
{ deploy-io 2 }
- { deploy-word-defs? f }
{ deploy-threads? f }
- { "stop-after-last-window?" t }
+ { deploy-reflection 1 }
{ deploy-math? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
}
: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ;
-: find-mp3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files ;
+: find-mp3s ( path -- seq ) ".mp3" find-by-extension ;
ERROR: id3-parse-error path error ;
ui.gadgets.panes ui.render ui.images ;
IN: images.viewer
-TUPLE: image-gadget < gadget image-name ;
+TUPLE: image-gadget < gadget image texture ;
-M: image-gadget pref-dim*
- image-name>> image-dim ;
+M: image-gadget pref-dim* image>> dim>> ;
+
+: image-gadget-texture ( gadget -- texture )
+ dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
- image-name>> draw-image ;
+ [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
+
+! Todo: delete texture on ungraft
+
+GENERIC: <image-gadget> ( object -- gadget )
-: <image-gadget> ( image-name -- gadget )
+M: image <image-gadget>
\ image-gadget new
- swap >>image-name ;
+ swap >>image ;
-: image-window ( path -- gadget )
- [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
+M: string <image-gadget> load-image <image-gadget> ;
-GENERIC: image. ( object -- )
+M: pathname <image-gadget> string>> load-image <image-gadget> ;
-M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image-window ( object -- ) <image-gadget> "Image" open-window ;
-M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image. ( object -- ) <image-gadget> gadget. ;
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-math? t }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
- { deploy-compiler? t }
}
relayout-1 ;
M: key-caps-gadget graft*
+ open-game-input
dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ cancel-alarm ] when* ;
+ alarm>> [ cancel-alarm ] when*
+ close-game-input ;
M: key-caps-gadget handle-gesture
drop [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- )
[
- open-game-input
<key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
] with-ui ;
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
-io.files io.launcher mason.child mason.cleanup mason.common
-mason.help mason.release mason.report mason.email mason.notify
-namespaces prettyprint ;
+io.files io.launcher namespaces prettyprint mason.child mason.cleanup
+mason.common mason.help mason.release mason.report mason.email
+mason.notify ;
IN: mason.build
QUALIFIED: continuations
: begin-build ( -- )
"factor" [ git-id ] with-directory
- [ "git-id" to-file ] [ notify-begin-build ] bi ;
+ [ "git-id" to-file ]
+ [ current-git-id set ]
+ [ notify-begin-build ]
+ tri ;
: build ( -- )
create-build-dir
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system debugger ;
+calendar.format arrays mason.config locals system debugger fry
+continuations strings ;
IN: mason.common
-ERROR: output-process-error output process ;
+SYMBOL: current-git-id
+
+ERROR: output-process-error { output string } { process process } ;
M: output-process-error error.
[ "Process:" print process>> . nl ]
<process>
swap >>command
15 minutes >>timeout
+ +closed+ >>stdin
try-output-process ;
+: retry ( n quot -- )
+ '[ drop @ f ] attempt-all drop ; inline
+
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
scp-remote [ { username "@" host ":" temp } concat ]
scp [ scp-command get ]
ssh [ ssh-command get ] |
- { scp local scp-remote } short-running-process
- { ssh host "-l" username "mv" temp remote } short-running-process
+ 5 [ { scp local scp-remote } short-running-process ] retry
+ 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
] ;
: eval-file ( file -- obj )
IN: mason.email.tests
USING: mason.email mason.common mason.config namespaces tools.test ;
-[ "mason on linux-x86-64: error" ] [
+[ "mason on linux-x86-64: 12345 -- error" ] [
[
"linux" target-os set
"x86.64" target-cpu set
+ "12345" current-git-id set
status-error subject prefix-subject
] with-scope
] unit-test
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors combinators make smtp debugger
-prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
-mason.common mason.platform mason.config ;
+prettyprint sequences io io.streams.string io.encodings.utf8 io.files
+io.sockets mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
send-email ;
: subject ( status -- str )
- {
+ [ current-git-id get 7 short head " -- " ] dip {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
- } case ;
+ } case 3append ;
: email-report ( report status -- )
[ "text/html" ] dip subject email-status ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
io.launcher kernel make mason.config mason.common mason.email
-mason.twitter namespaces sequences prettyprint ;
+mason.twitter namespaces sequences prettyprint fry ;
IN: mason.notify
: status-notify ( input-file args -- )
target-cpu get ,
target-os get ,
] { } make prepend
- <process>
- swap >>command
- swap [ +closed+ ] unless* >>stdin
- try-output-process
+ [ 5 ] 2dip '[
+ <process>
+ _ >>command
+ _ [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] retry
] [ 2drop ] if ;
: notify-begin-build ( git-id -- )
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.directories io.files io.launcher kernel make
-mason.common mason.config mason.platform namespaces prettyprint
-sequences ;
+namespaces prettyprint sequences mason.common mason.config
+mason.platform ;
IN: mason.release.branch
: branch-name ( -- string ) "clean-" platform append ;
] { } make ;
: push-to-clean-branch ( -- )
- push-to-clean-branch-cmd short-running-process ;
+ 5 [ push-to-clean-branch-cmd short-running-process ] retry ;
: upload-clean-image-cmd ( -- args )
[
] { } make ;
: upload-clean-image ( -- )
- upload-clean-image-cmd short-running-process ;
+ 5 [ upload-clean-image-cmd short-running-process ] retry ;
: (update-clean-branch) ( -- )
"factor" [
target-cpu get
host-name
build-dir
- "git-id" eval-file
+ current-git-id get
[XML
<h1>Build report for <->/<-></h1>
<table>
benchmark-error-vocabs-file
benchmark-error-messages-file
error-dump
-
- "Benchmark timings"
+
benchmarks-file eval-file benchmarks-table
] output>array
] with-report ;
[ drop origin>> ] 2tri
v+ v+ ;
+: <identity> ( -- a )
+ { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ;
: <translation> ( origin -- a )
[ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
: <rotation> ( theta -- transform )
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-name "Maze" }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Maze" }
{ deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-name "Merger" }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: modules.rpc-server vocabs ;
-IN: modules.remote-loading mem-service
-
-: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
+++ /dev/null
-required for listeners allowing remote loading of modules
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors assocs continuations effects io
-io.encodings.binary io.servers.connection kernel
-memoize namespaces parser sets sequences serialize
-threads vocabs vocabs.parser words ;
-
-IN: modules.rpc-server
-
-SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
-
-: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
-
-MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- ) [
- <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
- start-server ] in-thread ;
-
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
-
-SYNTAX: service \ do-rpc "executer" set (service) ;
-SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
-
-load-vocab-hook [
- [ dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
-append ] change-global
\ No newline at end of file
+++ /dev/null
-remote procedure call server
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: modules.rpc
-ARTICLE: { "modules" "protocol" } "RPC Protocol"
-{ $list
- "Send vocab as string"
- "Send arglist"
- "Send word as string"
- "Receive result list"
-} ;
\ No newline at end of file
+++ /dev/null
-USING: accessors compiler.units combinators fry generalizations io
-io.encodings.binary io.sockets kernel namespaces
-parser sequences serialize vocabs vocabs.parser words ;
-IN: modules.rpc
-
-DEFER: get-words
-
-: remote-quot ( addrspec vocabspec effect str -- quot )
- '[ _ 5000 <inet> binary
- [
- _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
- ] with-client
- ] ;
-
-: define-remote ( addrspec vocabspec effect str -- ) [
- [ remote-quot ] 2keep create-in -rot define-declared word make-inline
- ] with-compilation-unit ;
-
-: with-in ( vocab quot -- vocab ) over
- [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
-
-: remote-vocab ( addrspec vocabspec -- vocab )
- dup "-remote" append [
- [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
- [ rot first2 swap define-remote ] 2curry each
- ] with-in ;
\ No newline at end of file
+++ /dev/null
-remote procedure call client
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-module pushing in remote-loading listeners
\ No newline at end of file
+++ /dev/null
-USING: assocs modules.rpc-server vocabs
-modules.remote-loading words ;
-IN: modules.uploads service
-
-: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-improved module import syntax
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: modules.rpc-server io.servers.connection ;
-IN: modules.test-server service
-: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
+++ /dev/null
-USING: modules.using ;
-IN: modules.using.tests
-USING: tools.test localhost::modules.test-server ;
-[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
+++ /dev/null
-USING: modules.using modules.rpc-server help.syntax help.markup strings ;
-IN: modules
-
-HELP: service
-{ $syntax "IN: module service" }
-{ $description "Starts a server for requests for remote procedure calls." } ;
-
-ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
-"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
-
-HELP: USING:
-{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
-{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
-{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
+++ /dev/null
-USING: assocs kernel modules.remote-loading modules.rpc
-namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
-strings ;
-IN: modules.using
-
-: >qualified ( vocab prefix -- assoc )
- [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
-
-: >partial-vocab ( words assoc -- assoc )
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
-
-: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
-
-: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
-
-EBNF: modulize
-tokenpart = (!(':').)+ => [[ >string ]]
-s = ':' => [[ drop ignore ]]
-rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
-remote = tokenpart s tokenpart => [[ first2 remote-load ]]
-plain = tokenpart => [[ load-vocab ]]
-module = rpc | remote | plain
-;EBNF
-
-ON-BNF: USING:
-tokenizer = <foreign factor>
-sym = !(";"|"}"|"=>").
-modspec = sym => [[ modulize ]]
-qualified = modspec sym => [[ first2 >qualified ]]
-unqualified = modspec => [[ vocab-words ]]
-words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
-long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
-short = modspec => [[ use+ ignore ]]
-wordSpec = long | short
-using = wordSpec+ ";" => [[ drop ignore ]]
-;ON-BNF
\ No newline at end of file
[ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ;
+
+
PRIVATE>
: MDB_ADDON_SLOTS ( -- slots )
[ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
: set-index-map ( class index-list -- )
- [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence
+ [ dup user-defined-key-index ] dip index-list>map 2array
assoc-combine MDB_INDEX_MAP set-word-prop ; inline
M: tuple-class tuple-collection ( tuple -- mdb-collection )
<update> >upsert update ] assoc-each ; inline
PRIVATE>
-: save-tuple ( tuple -- )
- tuple>storable [ (save-tuples) ] assoc-each ;
+: save-tuple-deep ( tuple -- )
+ tuple>storable [ (save-tuples) ] assoc-each ;
: update-tuple ( tuple -- )
- save-tuple ;
+ [ tuple-collection name>> ]
+ [ id-selector ]
+ [ tuple>assoc ] tri
+ <update> update ;
+
+: save-tuple ( tuple -- )
+ update-tuple ;
: insert-tuple ( tuple -- )
- save-tuple ;
+ [ tuple-collection name>> ]
+ [ tuple>assoc ] bi
+ save ;
: delete-tuple ( tuple -- )
[ tuple-collection name>> ] keep
id-selector delete ;
+: delete-tuples ( seq -- )
+ [ delete-tuple ] each ;
+
: tuple>query ( tuple -- query )
[ tuple-collection name>> ] keep
tuple>selector <query> ;
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
--- /dev/null
+USING: byte-arrays combinators fry images kernel locals math
+math.affine-transforms math.functions math.order
+math.polynomials math.vectors random random.mersenne-twister
+sequences sequences.product hints arrays sequences.private
+combinators.short-circuit math.private ;
+IN: noise
+
+: <perlin-noise-table> ( -- table )
+ 256 iota >byte-array randomize dup append ; inline
+
+: with-seed ( seed quot -- )
+ [ <mersenne-twister> ] dip with-random ; inline
+
+<PRIVATE
+
+: (fade) ( x y z -- x' y' z' )
+ [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
+
+HINTS: (fade) { float float float } ;
+
+: fade ( point -- point' )
+ first3 (fade) 3array ; inline
+
+:: grad ( hash x y z -- gradient )
+ hash 8 bitand zero? [ x ] [ y ] if
+ :> u
+ hash 12 bitand zero?
+ [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if
+ :> v
+
+ hash 1 bitand zero? [ u ] [ u neg ] if
+ hash 2 bitand zero? [ v ] [ v neg ] if + ;
+
+HINTS: grad { fixnum float float float } ;
+
+: unit-cube ( point -- cube )
+ [ floor >fixnum 256 rem ] map ;
+
+:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
+ x table nth-unsafe y fixnum+fast :> a
+ x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
+
+ a table nth-unsafe z fixnum+fast :> aa
+ b table nth-unsafe z fixnum+fast :> ba
+ a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
+ b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
+
+ aa table nth-unsafe
+ ba table nth-unsafe
+ ab table nth-unsafe
+ bb table nth-unsafe
+ aa 1 fixnum+fast table nth-unsafe
+ ba 1 fixnum+fast table nth-unsafe
+ ab 1 fixnum+fast table nth-unsafe
+ bb 1 fixnum+fast table nth-unsafe ; inline
+
+HINTS: hashes { byte-array fixnum fixnum fixnum } ;
+
+: >byte-map ( floats -- bytes )
+ [ 255.0 * >fixnum ] B{ } map-as ;
+
+: >image ( bytes dim -- image )
+ swap [ L f ] dip image boa ;
+
+:: perlin-noise-unsafe ( table point -- value )
+ point unit-cube :> cube
+ point dup vfloor v- :> gradients
+ gradients fade :> faded
+
+ table cube first3 hashes {
+ [ gradients first3 grad ]
+ [ gradients first3 [ 1.0 - ] [ ] [ ] tri* grad ]
+ [ gradients first3 [ ] [ 1.0 - ] [ ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ ] tri* grad ]
+ [ gradients first3 [ ] [ ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
+ [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
+ } spread
+ faded trilerp ;
+
+ERROR: invalid-perlin-noise-table table ;
+
+: validate-table ( table -- table )
+ dup { [ byte-array? ] [ length 512 >= ] } 1&&
+ [ invalid-perlin-noise-table ] unless ;
+
+PRIVATE>
+
+: perlin-noise ( table point -- value )
+ [ validate-table ] dip perlin-noise-unsafe ; inline
+
+: normalize-0-1 ( sequence -- sequence' )
+ [ supremum ] [ infimum [ - ] keep ] [ ] tri
+ [ swap - ] with map [ swap / ] with map ;
+
+: clamp-0-1 ( sequence -- sequence' )
+ [ 0.0 max 1.0 min ] map ;
+
+: perlin-noise-map ( table transform dim -- map )
+ [ validate-table ] 2dip
+ [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ;
+
+: perlin-noise-byte-map ( table transform dim -- map )
+ perlin-noise-map normalize-0-1 >byte-map ;
+
+: perlin-noise-image ( table transform dim -- image )
+ [ perlin-noise-byte-map ] [ >image ] bi ;
+
+: uniform-noise-map ( seed dim -- map )
+ [ product [ 0.0 1.0 uniform-random-float ] replicate ]
+ curry with-seed ;
+
+: uniform-noise-byte-map ( seed dim -- map )
+ uniform-noise-map >byte-map ;
+
+: uniform-noise-image ( seed dim -- image )
+ [ uniform-noise-byte-map ] [ >image ] bi ;
+
+: normal-noise-map ( seed sigma dim -- map )
+ swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
+ with-seed ;
+
+: normal-noise-byte-map ( seed sigma dim -- map )
+ normal-noise-map clamp-0-1 >byte-map ;
+
+: normal-noise-image ( seed sigma dim -- image )
+ [ normal-noise-byte-map ] [ >image ] bi ;
USING: arrays kernel math math.functions math.order math.vectors
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
-ui.gadgets.worlds ui.render accessors combinators ;
+ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
-: FOV ( -- x ) 2.0 sqrt 1+ ; inline
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
IN: poker
HELP: <hand>
-{ $values { "str" string } { "hand" "a new hand" } }
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel math.order poker prettyprint ;"
}
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
+HELP: best-hand
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
+{ $examples
+ { $example "USING: kernel poker prettyprint ;"
+ "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
+} ;
+
HELP: >cards
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." }
{ $examples
{ $example "USING: poker prettyprint ;"
} ;
HELP: >value
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's value." }
{ $examples
{ $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;
+
+HELP: <deck>
+{ $values { "deck" "a new " { $link deck } } }
+{ $description "Creates a standard deck of 52 cards." } ;
+
+HELP: shuffle
+{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
+{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;
-USING: accessors poker poker.private tools.test math.order kernel ;
+USING: accessors kernel math.order poker poker.private tools.test ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
+
+[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test
-! Copyright (c) 2009 Aaron Schaefer.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii binary-search combinators kernel locals math
- math.bitwise math.order poker.arrays sequences splitting ;
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! The contents of this file are licensed under the Simplified BSD License
+! A copy of the license is available at http://factorcode.org/license.txt
+USING: accessors arrays ascii binary-search combinators kernel locals math
+ math.bitwise math.combinatorics math.order poker.arrays random sequences
+ sequences.product splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
CONSTANT: KING 11
CONSTANT: ACE 12
-CONSTANT: STRAIGHT_FLUSH 1
-CONSTANT: FOUR_OF_A_KIND 2
-CONSTANT: FULL_HOUSE 3
-CONSTANT: FLUSH 4
-CONSTANT: STRAIGHT 5
-CONSTANT: THREE_OF_A_KIND 6
-CONSTANT: TWO_PAIR 7
-CONSTANT: ONE_PAIR 8
-CONSTANT: HIGH_CARD 9
+CONSTANT: STRAIGHT_FLUSH 0
+CONSTANT: FOUR_OF_A_KIND 1
+CONSTANT: FULL_HOUSE 2
+CONSTANT: FLUSH 3
+CONSTANT: STRAIGHT 4
+CONSTANT: THREE_OF_A_KIND 5
+CONSTANT: TWO_PAIR 6
+CONSTANT: ONE_PAIR 7
+CONSTANT: HIGH_CARD 8
+
+CONSTANT: SUIT_STR { "C" "D" "H" "S" }
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
-CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
+CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
"Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
: card-rank-prime ( rank -- n )
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
+: parse-cards ( str -- seq )
+ " " split [ >ckf ] map ;
+
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
[ drop "S" ]
} cond ;
-: hand-rank ( hand -- rank )
- value>> {
+: hand-rank ( value -- rank )
+ {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
+: card>string ( card -- str )
+ [ >card-rank ] [ >card-suit ] bi append ;
+
PRIVATE>
TUPLE: hand
{ cards sequence }
- { value integer } ;
+ { value integer initial: 9999 } ;
M: hand <=> [ value>> ] compare ;
M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand )
- " " split [ >ckf ] map
- dup hand-value hand boa ;
+ parse-cards dup hand-value hand boa ;
+
+: best-hand ( str -- hand )
+ parse-cards 5 hand new
+ [ dup hand-value hand boa min ] reduce-combinations ;
: >cards ( hand -- str )
- cards>> [
- [ >card-rank ] [ >card-suit ] bi append
- ] map " " join ;
+ cards>> [ card>string ] map " " join ;
: >value ( hand -- str )
- hand-rank VALUE_STR nth ;
+ value>> hand-rank VALUE_STR nth ;
+
+TUPLE: deck
+ { cards sequence } ;
+
+: <deck> ( -- deck )
+ RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
+
+: shuffle ( deck -- deck )
+ [ randomize ] change-cards ;
+
-5-card poker hand evaluator
+Poker hand evaluator
-! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
+! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences
sets ;
: euler001b ( -- answer )
- 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+ 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
- 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+ 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions sequences project-euler.common ;
+USING: math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5
! --------
: euler005 ( -- answer )
- 20 1 [ 1+ lcm ] reduce ;
+ 20 [1,b] 1 [ lcm ] reduce ;
! [ euler005 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials)
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math project-euler.common sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.018
! http://projecteuler.net/index.php?section=problems&id=18
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
- } 15 iota [ 1+ cut swap ] map nip ;
+ } 15 [1,b] [ cut swap ] map nip ;
PRIVATE>
! Memoized brute force
MEMO: fib ( m -- n )
- dup 1 > [ 1- dup fib swap 1- fib + ] when ;
+ dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ;
<PRIVATE
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences
-project-euler.common ;
+USING: kernel math math.primes math.ranges project-euler.common sequences ;
IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27
<PRIVATE
: source-027 ( -- seq )
- 1000 [ prime? ] filter [ dup [ neg ] map append ] keep
+ 1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions project-euler.common sequences ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30
PRIVATE>
: euler030 ( -- answer )
- 325537 [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1+ ] map 10 digits>integer
+ 9 permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.primes math.ranges
+sequences project-euler.common math.bitwise ;
IN: project-euler.046
! http://projecteuler.net/index.php?section=problems&id=46
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
! --------
: euler048 ( -- answer )
- 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
+ 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
PRIVATE>
: euler055 ( -- answer )
- 10000 [ lychrel? ] count ;
+ 10000 [0,b) [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
! Copyright (c) 2008 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser sequences project-euler.common ;
+USING: kernel math math.functions math.parser math.ranges project-euler.common
+ sequences ;
IN: project-euler.057
! http://projecteuler.net/index.php?section=problems&id=57
! It is possible to show that the square root of two can be expressed
! as an infinite continued fraction.
-! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
+! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! By expanding this for the first four iterations, we get:
-! 1 + 1/2 = 3/2 = 1.5
-! 1 + 1/(2 + 1/2) = 7/5 = 1.4
-! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
-! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
+! 1 + 1/2 = 3/2 = 1.5
+! 1 + 1/(2 + 1/2) = 7/5 = 1.4
+! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
+! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! The next three expansions are 99/70, 239/169, and 577/408, but the
! eighth expansion, 1393/985, is the first example where the number of
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
- 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+ 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
-! [ euler057 ] time
-! 3.375118 seconds
+! [ euler057 ] 100 ave-time
+! 1728 ms ave run time - 80.81 SD (100 trials)
SOLUTION: euler057
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
+USING: hints kernel locals math math.order math.ranges project-euler.common
+ sequences sequences.private ;
IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
+ 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
- m x - iota [| z |
+ m x - [0,b) [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
! Copyright (c) 2007-2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel lists make math math.functions math.matrices
- math.miller-rabin math.order math.parser math.primes.factors
+ math.primes.miller-rabin math.order math.parser math.primes.factors
math.primes.lists math.ranges math.ratios namespaces parser prettyprint
quotations sequences sorting strings unicode.case vocabs vocabs.parser
words ;
-USING: kernel math sequences namespaces
-math.miller-rabin math.functions accessors random ;
+USING: kernel math sequences namespaces math.primes
+math.functions accessors random ;
IN: random.blum-blum-shub
! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.command-writer io.streams.string ;
+IN: redis.command-writer.tests
+
+#! Connection
+[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
+
+[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
+
+[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
+
+#! String values
+[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
+
+[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
+
+[ "GETSET key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" getset ] with-string-writer
+] unit-test
+
+[ "MGET key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } mget ] with-string-writer
+] unit-test
+
+[ "SETNX key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" setnx ] with-string-writer
+] unit-test
+
+[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
+
+[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
+
+[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
+
+[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
+
+[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
+
+[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
+
+[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
+
+#! Key space
+[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
+
+[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
+
+[ "RENAME key newkey\r\n" ] [
+ [ "newkey" "key" rename ] with-string-writer
+] unit-test
+
+[ "RENAMENX key newkey\r\n" ] [
+ [ "newkey" "key" renamenx ] with-string-writer
+] unit-test
+
+[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
+
+[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
+
+#! Lists
+[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
+
+[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
+
+[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
+
+[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
+
+[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
+
+[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
+
+[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
+
+[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
+
+[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
+
+[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
+
+#! Sets
+[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
+
+[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
+
+[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
+ [ "foo" "dstkey" "srckey" smove ] with-string-writer
+] unit-test
+
+[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
+
+[ "SISMEMBER key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" sismember ] with-string-writer
+] unit-test
+
+[ "SINTER key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sinter ] with-string-writer
+] unit-test
+
+[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
+] unit-test
+
+[ "SUNION key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sunion ] with-string-writer
+] unit-test
+
+[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
+] unit-test
+
+[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
+
+#! Multiple db
+[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
+
+[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
+
+[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
+
+[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
+
+#! Sorting
+
+#! Persistence control
+[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
+
+[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
+
+[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
+
+[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
+
+#! Remote server control
+[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
+
+[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.crlf kernel math.parser sequences strings interpolate locals ;
+IN: redis.command-writer
+
+<PRIVATE
+
+GENERIC: write-value-with-length ( value -- )
+
+M: string write-value-with-length
+ [ length number>string write crlf ]
+ [ write ] bi ;
+
+: space ( -- ) CHAR: space write1 ;
+
+: write-key/value ( value key -- )
+ write space
+ write-value-with-length ;
+
+: write-key/integer ( integer key -- )
+ write space
+ number>string write ;
+
+PRIVATE>
+
+#! Connection
+: quit ( -- ) "QUIT" write crlf ;
+: ping ( -- ) "PING" write crlf ;
+: auth ( password -- ) "AUTH " write write crlf ;
+
+#! String values
+: set ( value key -- ) "SET " write write-key/value crlf ;
+: get ( key -- ) "GET " write write crlf ;
+: getset ( value key -- ) "GETSET " write write-key/value crlf ;
+: mget ( keys -- ) "MGET " write " " join write crlf ;
+: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
+: incr ( key -- ) "INCR " write write crlf ;
+: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
+: decr ( key -- ) "DECR " write write crlf ;
+: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
+: exists ( key -- ) "EXISTS " write write crlf ;
+: del ( key -- ) "DEL " write write crlf ;
+: type ( key -- ) "TYPE " write write crlf ;
+
+#! Key space
+: keys ( pattern -- ) "KEYS " write write crlf ;
+: randomkey ( -- ) "RANDOMKEY" write crlf ;
+: rename ( newkey key -- ) "RENAME " write write space write crlf ;
+: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
+: dbsize ( -- ) "DBSIZE" write crlf ;
+: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+
+#! Lists
+: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
+: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
+: llen ( key -- ) "LLEN " write write crlf ;
+: lrange ( start end key -- )
+ "LRANGE " write write [ space number>string write ] bi@ crlf ;
+: ltrim ( start end key -- )
+ "LTRIM " write write [ space number>string write ] bi@ crlf ;
+: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
+: lset ( value index key -- )
+ "LSET " write write-key/integer space write-value-with-length crlf ;
+: lrem ( value amount key -- )
+ "LREM " write write-key/integer space write-value-with-length crlf ;
+: lpop ( key -- ) "LPOP " write write crlf ;
+: rpop ( key -- ) "RPOP " write write crlf ;
+
+#! Sets
+: sadd ( member key -- )
+ "SADD " write write space write-value-with-length crlf ;
+: srem ( member key -- )
+ "SREM " write write space write-value-with-length crlf ;
+: smove ( member newkey key -- )
+ "SMOVE " write write space write space write-value-with-length crlf ;
+: scard ( key -- ) "SCARD " write write crlf ;
+: sismember ( member key -- )
+ "SISMEMBER " write write space write-value-with-length crlf ;
+: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+: sinterstore ( keys destkey -- )
+ "SINTERSTORE " write write space " " join write crlf ;
+: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+: sunionstore ( keys destkey -- )
+ "SUNIONSTORE " write write " " join space write crlf ;
+: smembers ( key -- ) "SMEMBERS " write write crlf ;
+
+#! Multiple db
+: select ( integer -- ) "SELECT " write number>string write crlf ;
+: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
+: flushdb ( -- ) "FLUSHDB" write crlf ;
+: flushall ( -- ) "FLUSHALL" write crlf ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: save ( -- ) "SAVE" write crlf ;
+: bgsave ( -- ) "BGSAVE" write crlf ;
+: lastsave ( -- ) "LASTSAVE" write crlf ;
+: shutdown ( -- ) "SHUTDOWN" write crlf ;
+
+#! Remote server control
+: info ( -- ) "INFO" write crlf ;
+: monitor ( -- ) "MONITOR" write crlf ;
--- /dev/null
+Definitions of messages sent to Redis
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io redis.response-parser redis.command-writer ;
+IN: redis
+
+#! Connection
+: redis-quit ( -- ) quit flush ;
+: redis-ping ( -- response ) ping flush read-response ;
+: redis-auth ( password -- response ) auth flush read-response ;
+
+#! String values
+: redis-set ( value key -- response ) set flush read-response ;
+: redis-get ( key -- response ) get flush read-response ;
+: redis-getset ( value key -- response ) getset flush read-response ;
+: redis-mget ( keys -- response ) mget flush read-response ;
+: redis-setnx ( value key -- response ) setnx flush read-response ;
+: redis-incr ( key -- response ) incr flush read-response ;
+: redis-incrby ( integer key -- response ) incrby flush read-response ;
+: redis-decr ( key -- response ) decr flush read-response ;
+: redis-decrby ( integer key -- response ) decrby flush read-response ;
+: redis-exists ( key -- response ) exists flush read-response ;
+: redis-del ( key -- response ) del flush read-response ;
+: redis-type ( key -- response ) type flush read-response ;
+
+#! Key space
+: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-randomkey ( -- response ) randomkey flush read-response ;
+: redis-rename ( newkey key -- response ) rename flush read-response ;
+: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
+: redis-dbsize ( -- response ) dbsize flush read-response ;
+: redis-expire ( integer key -- response ) expire flush read-response ;
+
+#! Lists
+: redis-rpush ( value key -- response ) rpush flush read-response ;
+: redis-lpush ( value key -- response ) lpush flush read-response ;
+: redis-llen ( key -- response ) llen flush read-response ;
+: redis-lrange ( start end key -- response ) lrange flush read-response ;
+: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
+: redis-lindex ( integer key -- response ) lindex flush read-response ;
+: redis-lset ( value index key -- response ) lset flush read-response ;
+: redis-lrem ( value amount key -- response ) lrem flush read-response ;
+: redis-lpop ( key -- response ) lpop flush read-response ;
+: redis-rpop ( key -- response ) rpop flush read-response ;
+
+#! Sets
+: redis-sadd ( member key -- response ) sadd flush read-response ;
+: redis-srem ( member key -- response ) srem flush read-response ;
+: redis-smove ( member newkey key -- response ) smove flush read-response ;
+: redis-scard ( key -- response ) scard flush read-response ;
+: redis-sismember ( member key -- response ) sismember flush read-response ;
+: redis-sinter ( keys -- response ) sinter flush read-response ;
+: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ;
+: redis-sunion ( keys -- response ) sunion flush read-response ;
+: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ;
+: redis-smembers ( key -- response ) smembers flush read-response ;
+
+#! Multiple db
+: redis-select ( integer -- response ) select flush read-response ;
+: redis-move ( integer key -- response ) move flush read-response ;
+: redis-flushdb ( -- response ) flushdb flush read-response ;
+: redis-flushall ( -- response ) flushall flush read-response ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: redis-save ( -- response ) save flush read-response ;
+: redis-bgsave ( -- response ) bgsave flush read-response ;
+: redis-lastsave ( -- response ) lastsave flush read-response ;
+: redis-shutdown ( -- response ) shutdown flush read-response ;
+
+#! Remote server control
+: redis-info ( -- response ) info flush read-response ;
+: redis-monitor ( -- response ) monitor flush read-response ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.response-parser io.streams.string ;
+IN: redis.response-parser.tests
+
+[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ { "hello" "world!" } ] [
+ "*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader
+] unit-test
+
+[ { "hello" f "world!" } ] [
+ "*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [
+ read-response
+ ] with-string-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators io kernel math math.parser sequences ;
+IN: redis.response-parser
+
+<PRIVATE
+
+: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
+: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+: read-multi-bulk ( n -- seq/f )
+ dup 0 < [ drop f ] [
+ iota [ drop (read-multi-bulk) ] map
+ ] if ;
+
+: handle-response ( string -- string ) ; ! TODO
+: handle-error ( string -- string ) ; ! TODO
+
+PRIVATE>
+
+: read-response ( -- response )
+ readln unclip {
+ { CHAR: : [ string>number ] }
+ { CHAR: + [ handle-response ] }
+ { CHAR: $ [ string>number read-bulk ] }
+ { CHAR: * [ string>number read-multi-bulk ] }
+ { CHAR: - [ handle-error ] }
+ } case ;
--- /dev/null
+Parser for responses sent by the Redis server
--- /dev/null
+Words for communicating with the Redis key-value database
{ 2keep 1 }\r
{ 2nip 2 }\r
{ 2over 4 }\r
- { 2slip 2 }\r
{ 2swap 3 }\r
{ 3curry 2 }\r
{ 3drop 1 }\r
{ 3dup 2 }\r
{ 3keep 3 }\r
- { 3slip 3 }\r
{ 4drop 2 }\r
{ 4dup 3 }\r
{ compose 1/2 }\r
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
- { nslip 5 }\r
{ ntuck 6 }\r
{ nwith 4 }\r
{ over 2 }\r
{ pick 4 }\r
{ roll 4 }\r
{ rot 3 }\r
- { slip 1 }\r
{ spin 3 }\r
{ swap 1 }\r
{ swapd 3 }\r
USING: tools.deploy.config ;
H{
+ { deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-word-defs? f }
- { deploy-word-props? f }
- { deploy-name "Spheres" }
- { deploy-compiler? t }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-io 1 }
- { deploy-threads? t }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Spheres" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel spider ;
+USING: accessors assocs deques dlists kernel ;
IN: spider.unique-deque
TUPLE: todo-url url depth ;
: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
pick deque-empty? [ 3drop ] [
- [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ]
[ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
] if ; inline recursive
{ deploy-word-defs? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
: read-c-string ( n -- str/f )
- read [ zero? ] trim-tail [ f ] when-empty ;
+ read [ zero? ] trim-tail [ f ] when-empty >string ;
: read-tar-header ( -- obj )
\ tar-header new
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-name "Terrain" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+}
--- /dev/null
+USING: accessors arrays byte-arrays combinators fry grouping
+images kernel math math.affine-transforms math.order
+math.vectors noise random sequences ;
+IN: terrain.generation
+
+CONSTANT: terrain-segment-size { 512 512 }
+CONSTANT: terrain-big-noise-scale { 0.002 0.002 }
+CONSTANT: terrain-small-noise-scale { 0.05 0.05 }
+
+TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
+
+: <terrain> ( -- terrain )
+ <perlin-noise-table> <perlin-noise-table>
+ 32 random-bits terrain boa ;
+
+: seed-at ( seed at -- seed' )
+ first2 [ + ] dip [ 32 random-bits + ] curry with-seed ;
+
+: big-noise-segment ( terrain at -- map )
+ [ big-noise-table>> terrain-big-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: small-noise-segment ( terrain at -- map )
+ [ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: tiny-noise-segment ( terrain at -- map )
+ [ tiny-noise-seed>> ] dip seed-at 0.1
+ terrain-segment-size normal-noise-byte-map ;
+
+: padding ( terrain at -- padding )
+ 2drop terrain-segment-size product 255 <repetition> ;
+
+TUPLE: segment image ;
+
+: terrain-segment ( terrain at -- image )
+ {
+ [ big-noise-segment ]
+ [ small-noise-segment ]
+ [ tiny-noise-segment ]
+ [ padding ]
+ } 2cleave
+ 4array flip concat >byte-array
+ [ terrain-segment-size RGBA f ] dip image boa ;
+
+: 4max ( a b c d -- max )
+ max max max ; inline
+
+: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
+ [ [ 2 <groups> ] map 2 <groups> ] dip
+ '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
+
+: group-pixels ( bitmap dim -- scanlines )
+ [ 4 <groups> ] [ first <groups> ] bi* ;
+
+: concat-pixels ( scanlines -- bitmap )
+ [ concat ] map concat ;
+
+: segment-mipmap ( image -- image' )
+ [ clone ] [ bitmap>> ] [ dim>> ] tri
+ group-pixels [ 4max ] mipmap concat-pixels >>bitmap
+ [ 2 v/n ] change-dim ;
--- /dev/null
+USING: multiline ;
+IN: terrain.shaders
+
+STRING: sky-vertex-shader
+
+uniform float sky_theta;
+varying vec3 direction;
+
+void main()
+{
+ vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0);
+ gl_Position = v;
+
+ vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1);
+
+ float s = sin(sky_theta), c = cos(sky_theta);
+ direction = mat3(1, 0, 0, 0, c, s, 0, -s, c)
+ * (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz;
+}
+
+;
+
+STRING: sky-pixel-shader
+
+uniform sampler2D sky;
+uniform float sky_gradient, sky_theta;
+
+const vec4 SKY_COLOR_A = vec4(0.25, 0.0, 0.5, 1.0),
+ SKY_COLOR_B = vec4(0.6, 0.5, 0.75, 1.0);
+
+varying vec3 direction;
+
+void main()
+{
+ float t = texture2D(sky, normalize(direction.xyz).xy * 0.5 + vec2(0.5)).x + sky_gradient;
+ gl_FragColor = mix(SKY_COLOR_A, SKY_COLOR_B, sin(6.28*t));
+}
+
+;
+
+STRING: terrain-vertex-shader
+
+uniform sampler2D heightmap;
+uniform vec4 component_scale;
+
+varying vec2 heightcoords;
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, component_scale);
+}
+
+void main()
+{
+ gl_Position = gl_ModelViewProjectionMatrix
+ * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
+ heightcoords = gl_Vertex.xz;
+}
+
+;
+
+STRING: terrain-pixel-shader
+
+uniform sampler2D heightmap;
+uniform vec4 component_scale;
+
+varying vec2 heightcoords;
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, component_scale);
+}
+
+void main()
+{
+ gl_FragColor = texture2D(heightmap, heightcoords);
+}
+
+;
--- /dev/null
+USING: accessors arrays combinators game-input game-loop
+game-input.scancodes grouping kernel literals locals
+math math.constants math.functions math.matrices math.order
+math.vectors opengl opengl.capabilities opengl.gl
+opengl.shaders opengl.textures opengl.textures.private
+sequences sequences.product specialized-arrays.float
+terrain.generation terrain.shaders ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
+math.affine-transforms noise ;
+IN: terrain
+
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 2.0
+CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
+CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
+CONSTANT: JUMP $[ 1.0 1024.0 / ]
+CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
+CONSTANT: FRICTION 0.95
+CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 }
+CONSTANT: SKY-PERIOD 1200
+CONSTANT: SKY-SPEED 0.0005
+
+CONSTANT: terrain-vertex-size { 512 512 }
+CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
+CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
+
+TUPLE: player
+ location yaw pitch velocity ;
+
+TUPLE: terrain-world < game-world
+ player
+ sky-image sky-texture sky-program
+ terrain terrain-segment terrain-texture terrain-program
+ terrain-vertex-buffer ;
+
+M: terrain-world tick-length
+ drop 1000 30 /i ;
+
+: frustum ( dim -- -x x -y y near far )
+ dup first2 min v/n
+ NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
+ NEAR-PLANE FAR-PLANE ;
+
+: set-modelview-matrix ( gadget -- )
+ GL_DEPTH_BUFFER_BIT glClear
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ player>>
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ [ location>> vneg first3 glTranslatef ] tri ;
+
+: vertex-array-vertex ( x z -- vertex )
+ [ terrain-vertex-distance first * ]
+ [ terrain-vertex-distance second * ] bi*
+ [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( z -- vertices )
+ dup 1 + 2array
+ terrain-vertex-size first 1 + iota
+ 2array [ first2 swap vertex-array-vertex ] product-map
+ concat ;
+
+: vertex-array ( -- vertices )
+ terrain-vertex-size second iota
+ [ vertex-array-row ] map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+ [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: draw-vertex-buffer-row ( i -- )
+ [ GL_TRIANGLE_STRIP ] dip
+ terrain-vertex-row-length * terrain-vertex-row-length
+ glDrawArrays ;
+
+: draw-vertex-buffer ( buffer -- )
+ [ GL_ARRAY_BUFFER ] dip [
+ 3 GL_FLOAT 0 f glVertexPointer
+ terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
+ ] with-gl-buffer ;
+
+: degrees ( deg -- rad )
+ pi 180.0 / * ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+ yaw degrees neg :> y
+ pitch degrees neg :> p
+ y cos :> cosy
+ y sin :> siny
+ p cos :> cosp
+ p sin :> sinp
+
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
+ v swap v.m ;
+
+: forward-vector ( player -- v )
+ yaw>> 0.0
+ { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
+: rightward-vector ( player -- v )
+ yaw>> 0.0
+ { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+
+: walk-forward ( player -- )
+ dup forward-vector [ v+ ] curry change-velocity drop ;
+: walk-backward ( player -- )
+ dup forward-vector [ v- ] curry change-velocity drop ;
+: walk-leftward ( player -- )
+ dup rightward-vector [ v- ] curry change-velocity drop ;
+: walk-rightward ( player -- )
+ dup rightward-vector [ v+ ] curry change-velocity drop ;
+: jump ( player -- )
+ [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ;
+
+: clamp-pitch ( pitch -- pitch' )
+ 90.0 min -90.0 max ;
+
+: rotate-with-mouse ( player mouse -- )
+ [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
+ [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi
+ drop ;
+
+:: handle-input ( world -- )
+ world player>> :> player
+ read-keyboard keys>> :> keys
+ key-w keys nth [ player walk-forward ] when
+ key-s keys nth [ player walk-backward ] when
+ key-a keys nth [ player walk-leftward ] when
+ key-d keys nth [ player walk-rightward ] when
+ key-space keys nth [ player jump ] when
+ key-escape keys nth [ world close-window ] when
+ player read-mouse rotate-with-mouse
+ reset-mouse ;
+
+: apply-friction ( velocity -- velocity' )
+ FRICTION v*n ;
+
+: apply-gravity ( velocity -- velocity' )
+ 1 over [ GRAVITY - ] change-nth ;
+
+: clamp-coords ( coords dim -- coords' )
+ [ { 0 0 } vmax ] dip { 2 2 } v- vmin ;
+
+:: pixel-indices ( coords dim -- indices )
+ coords vfloor [ >integer ] map dim clamp-coords :> floor-coords
+ floor-coords first2 dim first * + :> base-index
+ base-index dim first + :> next-row-index
+
+ base-index
+ base-index 1 +
+ next-row-index
+ next-row-index 1 + 4array ;
+
+:: terrain-height-at ( segment point -- height )
+ segment dim>> :> dim
+ dim point v* :> pixel
+ pixel dup vfloor v- :> pixel-mantissa
+ segment bitmap>> 4 <groups> :> pixels
+ pixel dim pixel-indices :> indices
+
+ indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
+ first4 pixel-mantissa bilerp ;
+
+: collide ( segment location -- location' )
+ [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
+ [ [ 1 ] 2dip [ max ] with change-nth ]
+ [ ] tri ;
+
+: tick-player ( world player -- )
+ [ apply-friction apply-gravity ] change-velocity
+ dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+ drop ;
+
+M: terrain-world tick*
+ [ dup focused?>> [ handle-input ] [ drop ] if ]
+ [ dup player>> tick-player ] bi ;
+
+: set-texture-parameters ( texture -- )
+ GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
+
+: sky-gradient ( world -- t )
+ game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+: sky-theta ( world -- theta )
+ game-loop>> tick-number>> SKY-SPEED * ;
+
+BEFORE: terrain-world begin-world
+ "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
+ require-gl-version-or-extensions
+ GL_DEPTH_TEST glEnable
+ GL_TEXTURE_2D glEnable
+ GL_VERTEX_ARRAY glEnableClientState
+ PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+ <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
+ [ >>sky-image ] keep
+ make-texture [ set-texture-parameters ] keep >>sky-texture
+ <terrain> [ >>terrain ] keep
+ { 0 0 } terrain-segment [ >>terrain-segment ] keep
+ make-texture [ set-texture-parameters ] keep >>terrain-texture
+ sky-vertex-shader sky-pixel-shader <simple-gl-program>
+ >>sky-program
+ terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
+ >>terrain-program
+ vertex-array >vertex-buffer >>terrain-vertex-buffer
+ drop ;
+
+AFTER: terrain-world end-world
+ {
+ [ terrain-vertex-buffer>> delete-gl-buffer ]
+ [ terrain-program>> delete-gl-program ]
+ [ terrain-texture>> delete-texture ]
+ [ sky-program>> delete-gl-program ]
+ [ sky-texture>> delete-texture ]
+ } cleave ;
+
+M: terrain-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ dim>> [ [ 0 0 ] dip first2 glViewport ]
+ [ frustum glFrustum ] bi ;
+
+M: terrain-world draw-world*
+ {
+ [ set-modelview-matrix ]
+ [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+ [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
+ [ GL_DEPTH_TEST glDisable dup sky-program>> [
+ [ nip "sky" glGetUniformLocation 1 glUniform1i ]
+ [ "sky_gradient" glGetUniformLocation swap sky-gradient glUniform1f ]
+ [ "sky_theta" glGetUniformLocation swap sky-theta glUniform1f ] 2tri
+ { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect
+ ] with-gl-program ]
+ [ GL_DEPTH_TEST glEnable dup terrain-program>> [
+ [ "heightmap" glGetUniformLocation 0 glUniform1i ]
+ [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
+ terrain-vertex-buffer>> draw-vertex-buffer
+ ] with-gl-program ]
+ } cleave gl-error ;
+
+M: terrain-world pref-dim* drop { 640 480 } ;
+
+: terrain-window ( -- )
+ [
+ f T{ world-attributes
+ { world-class terrain-world }
+ { title "Terrain" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ { grab-input? t }
+ } open-window
+ ] with-ui ;
+
+MAIN: terrain-window
USING: tools.deploy.config ;
H{
{ deploy-ui? t }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
: random-url ( -- string )
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
+: retry ( quot: ( -- ? ) n -- )
+ swap [ drop ] prepose attempt-all ; inline
+
: insert-short-url ( short-url -- short-url )
'[ _ dup random-url >>short insert-tuple ] 10 retry ;
{ deploy-threads? f }
{ deploy-word-defs? f }
{ deploy-ui? f }
- { deploy-compiler? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
--- /dev/null
+required for listeners allowing remote loading of modules
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors assocs continuations effects io
+io.encodings.binary io.servers.connection kernel
+memoize namespaces parser sets sequences serialize
+threads vocabs vocabs.parser words ;
+
+IN: modules.rpc-server
+
+SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
+
+: do-rpc ( args word -- bytes )
+ [ execute ] curry with-datastack object>bytes ; inline
+
+MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
+
+: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- ) deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- ) [
+ <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+ start-server ] in-thread ;
+
+: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
+
+SYNTAX: service \ do-rpc "executer" set (service) ;
+SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
+
+load-vocab-hook [
+ [ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
+append ] change-global
\ No newline at end of file
--- /dev/null
+remote procedure call server
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.units combinators fry generalizations io
+io.encodings.binary io.sockets kernel namespaces
+parser sequences serialize vocabs vocabs.parser words ;
+IN: modules.rpc
+
+DEFER: get-words
+
+: remote-quot ( addrspec vocabspec effect str -- quot )
+ '[ _ 5000 <inet> binary
+ [
+ _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
+ ] with-client
+ ] ;
+
+: define-remote ( addrspec vocabspec effect str -- ) [
+ [ remote-quot ] 2keep create-in -rot define-declared word make-inline
+ ] with-compilation-unit ;
+
+: with-in ( vocab quot -- vocab ) over
+ [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
+
+: remote-vocab ( addrspec vocabspec -- vocab )
+ dup "-remote" append [
+ [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
+ [ rot first2 swap define-remote ] 2curry each
+ ] with-in ;
\ No newline at end of file
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+module pushing in remote-loading listeners
\ No newline at end of file
--- /dev/null
+USING: assocs modules.rpc-server vocabs
+modules.remote-loading words ;
+IN: modules.uploads service
+
+: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+improved module import syntax
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+USING: modules.rpc-server io.servers.connection ;
+IN: modules.test-server service
+: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
--- /dev/null
+USING: modules.using ;
+IN: modules.using.tests
+USING: tools.test localhost::modules.test-server ;
+[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
--- /dev/null
+USING: modules.using modules.rpc-server help.syntax help.markup strings ;
+IN: modules
+
+HELP: service
+{ $syntax "IN: module service" }
+{ $description "Starts a server for requests for remote procedure calls." } ;
+
+ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
+"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
+
+HELP: USING:
+{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
+{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
+{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
--- /dev/null
+USING: assocs kernel modules.remote-loading modules.rpc
+namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
+strings ;
+IN: modules.using
+
+: >qualified ( vocab prefix -- assoc )
+ [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
+
+: >partial-vocab ( words assoc -- assoc )
+ [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
+
+: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+plain = tokenpart => [[ load-vocab ]]
+module = rpc | remote | plain
+;EBNF
+
+ON-BNF: USING:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>").
+modspec = sym => [[ modulize ]]
+qualified = modspec sym => [[ first2 >qualified ]]
+unqualified = modspec => [[ vocab-words ]]
+words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
+long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
+short = modspec => [[ use+ ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll
SHARED_DLL_EXTENSION=.dll
-LINKER = $(CC) -shared -mno-cygwin -o
+LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
}
/* pop ( alien n ) from datastack, return alien's address plus n */
-static void *alien_pointer(void)
+static void *alien_pointer()
{
fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
gc_root<byte_array> name(dpop());
name.untag_check();
- vm_char *sym = (vm_char *)(name.untagged() + 1);
+ symbol_char *sym = name->data<symbol_char>();
if(library.value() == F)
box_alien(ffi_dlsym(NULL,sym));
}
/* pop an object representing a C pointer */
-VM_C_API char *unbox_alien(void)
+VM_C_API char *unbox_alien()
{
return alien_offset(dpop());
}
PRIMITIVE(dll_validp);
VM_C_API char *alien_offset(cell object);
-VM_C_API char *unbox_alien(void);
+VM_C_API char *unbox_alien();
VM_C_API void box_alien(void *ptr);
VM_C_API void to_value_struct(cell src, void *dest, cell size);
VM_C_API void box_value_struct(void *src, cell size);
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
{
- cell top = (cell)FIRST_STACK_FRAME(stack);
- cell bottom = top + untag_fixnum(stack->length);
-
- iterate_callstack(top,bottom,iterator);
+ iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
}
callstack *allot_callstack(cell size)
will have popped a necessary frame... however this word is only
called by continuation implementation, and user code shouldn't
be calling it at all, so we leave it as it is for now. */
-stack_frame *capture_start(void)
+stack_frame *capture_start()
{
stack_frame *frame = stack_chain->callstack_bottom - 1;
while(frame >= stack_chain->callstack_top
size = 0;
callstack *stack = allot_callstack(size);
- memcpy(FIRST_STACK_FRAME(stack),top,size);
+ memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
callstack *stack = untag_check<callstack>(dpop());
set_callstack(stack_chain->callstack_bottom,
- FIRST_STACK_FRAME(stack),
+ stack->top(),
untag_fixnum(stack->length),
memcpy);
cell frame_type(stack_frame *frame)
{
- return frame_code(frame)->block.type;
+ return frame_code(frame)->type;
}
cell frame_executing(stack_frame *frame)
dpush(tag<array>(frames));
}
-stack_frame *innermost_stack_frame(callstack *callstack)
+stack_frame *innermost_stack_frame(callstack *stack)
{
- stack_frame *top = FIRST_STACK_FRAME(callstack);
- cell bottom = (cell)top + untag_fixnum(callstack->length);
-
- stack_frame *frame = (stack_frame *)bottom - 1;
+ stack_frame *top = stack->top();
+ stack_frame *bottom = stack->bottom();
+ stack_frame *frame = bottom - 1;
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
/* Some primitives implementing a limited form of callstack mutation.
Used by the single stepper. */
-PRIMITIVE(innermost_stack_frame_quot)
+PRIMITIVE(innermost_stack_frame_executing)
{
- dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+ dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
}
PRIMITIVE(innermost_stack_frame_scan)
return sizeof(callstack) + size;
}
-#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
-
typedef void (*CALLSTACK_ITER)(stack_frame *frame);
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
PRIMITIVE(callstack);
PRIMITIVE(set_callstack);
PRIMITIVE(callstack_to_array);
-PRIMITIVE(innermost_stack_frame_quot);
+PRIMITIVE(innermost_stack_frame_executing);
PRIMITIVE(innermost_stack_frame_scan);
PRIMITIVE(set_innermost_stack_frame_quot);
namespace factor
{
+static relocation_type relocation_type_of(relocation_entry r)
+{
+ return (relocation_type)((r & 0xf0000000) >> 28);
+}
+
+static relocation_class relocation_class_of(relocation_entry r)
+{
+ return (relocation_class)((r & 0x0f000000) >> 24);
+}
+
+static cell relocation_offset_of(relocation_entry r)
+{
+ return (r & 0x00ffffff);
+}
+
void flush_icache_for(code_block *block)
{
- flush_icache((cell)block,block->block.size);
+ flush_icache((cell)block,block->size);
+}
+
+static int number_of_parameters(relocation_type type)
+{
+ switch(type)
+ {
+ case RT_PRIMITIVE:
+ case RT_XT:
+ case RT_XT_PIC:
+ case RT_XT_PIC_TAIL:
+ case RT_IMMEDIATE:
+ case RT_HERE:
+ case RT_UNTAGGED:
+ return 1;
+ case RT_DLSYM:
+ return 2;
+ case RT_THIS:
+ case RT_STACK_CHAIN:
+ case RT_MEGAMORPHIC_CACHE_HITS:
+ return 0;
+ default:
+ critical_error("Bad rel type",type);
+ return -1; /* Can't happen */
+ }
+}
+
+void *object_xt(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ return untag<word>(obj)->xt;
+ case QUOTATION_TYPE:
+ return untag<quotation>(obj)->xt;
+ default:
+ critical_error("Expected word or quotation",obj);
+ return NULL;
+ }
+}
+
+static void *xt_pic(word *w, cell tagged_quot)
+{
+ if(tagged_quot == F || max_pic_size == 0)
+ return w->xt;
+ else
+ {
+ quotation *quot = untag<quotation>(tagged_quot);
+ if(quot->compiledp == F)
+ return w->xt;
+ else
+ return quot->xt;
+ }
+}
+
+void *word_xt_pic(word *w)
+{
+ return xt_pic(w,w->pic_def);
+}
+
+void *word_xt_pic_tail(word *w)
+{
+ return xt_pic(w,w->pic_tail_def);
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol()
+{
+ general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *get_rel_symbol(array *literals, cell index)
+{
+ cell symbol = array_nth(literals,index);
+ cell library = array_nth(literals,index + 1);
+
+ dll *d = (library == F ? NULL : untag<dll>(library));
+
+ if(d != NULL && !d->dll)
+ return (void *)undefined_symbol;
+
+ switch(tagged<object>(symbol).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ {
+ symbol_char *name = alien_offset(symbol);
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ else
+ {
+ return (void *)undefined_symbol;
+ }
+ }
+ case ARRAY_TYPE:
+ {
+ cell i;
+ array *names = untag<array>(symbol);
+ for(i = 0; i < array_capacity(names); i++)
+ {
+ symbol_char *name = alien_offset(array_nth(names,i));
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ }
+ return (void *)undefined_symbol;
+ }
+ default:
+ critical_error("Bad symbol specifier",symbol);
+ return (void *)undefined_symbol;
+ }
+}
+
+cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+{
+ array *literals = untag<array>(compiled->literals);
+ cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
+
+#define ARG array_nth(literals,index)
+
+ switch(relocation_type_of(rel))
+ {
+ case RT_PRIMITIVE:
+ return (cell)primitives[untag_fixnum(ARG)];
+ case RT_DLSYM:
+ return (cell)get_rel_symbol(literals,index);
+ case RT_IMMEDIATE:
+ return ARG;
+ case RT_XT:
+ return (cell)object_xt(ARG);
+ case RT_XT_PIC:
+ return (cell)word_xt_pic(untag<word>(ARG));
+ case RT_XT_PIC_TAIL:
+ return (cell)word_xt_pic_tail(untag<word>(ARG));
+ case RT_HERE:
+ return offset + (short)untag_fixnum(ARG);
+ case RT_THIS:
+ return (cell)(compiled + 1);
+ case RT_STACK_CHAIN:
+ return (cell)&stack_chain;
+ case RT_UNTAGGED:
+ return untag_fixnum(ARG);
+ case RT_MEGAMORPHIC_CACHE_HITS:
+ return (cell)&megamorphic_cache_hits;
+ default:
+ critical_error("Bad rel type",rel);
+ return 0; /* Can't happen */
+ }
+
+#undef ARG
}
void iterate_relocations(code_block *compiled, relocation_iterator iter)
for(cell i = 0; i < length; i++)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
-
iter(rel,index,compiled);
-
- switch(REL_TYPE(rel))
- {
- case RT_PRIMITIVE:
- case RT_XT:
- case RT_XT_DIRECT:
- case RT_IMMEDIATE:
- case RT_HERE:
- case RT_UNTAGGED:
- index++;
- break;
- case RT_DLSYM:
- index += 2;
- break;
- case RT_THIS:
- case RT_STACK_CHAIN:
- break;
- default:
- critical_error("Bad rel type",rel);
- return; /* Can't happen */
- }
+ index += number_of_parameters(relocation_type_of(rel));
}
}
}
case RC_ABSOLUTE_PPC_2_2:
store_address_2_2((cell *)offset,absolute_value);
break;
+ case RC_ABSOLUTE_PPC_2:
+ store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0);
+ break;
case RC_RELATIVE_PPC_2:
- store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+ store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_3:
- store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+ store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
- REL_RELATIVE_ARM_3_MASK,2);
+ rel_relative_arm_3_mask,2);
break;
case RC_INDIRECT_ARM:
store_address_masked((cell *)offset,relative_value - sizeof(cell),
- REL_INDIRECT_ARM_MASK,0);
+ rel_indirect_arm_mask,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
- REL_INDIRECT_ARM_MASK,0);
+ rel_indirect_arm_mask,0);
break;
default:
critical_error("Bad rel class",klass);
void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
- if(REL_TYPE(rel) == RT_IMMEDIATE)
+ if(relocation_type_of(rel) == RT_IMMEDIATE)
{
- cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ cell offset = relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+ store_address_in_code_block(relocation_class_of(rel),offset,absolute_value);
}
}
/* Update pointers to literals from compiled code. */
void update_literal_references(code_block *compiled)
{
- if(!compiled->block.needs_fixup)
+ if(!compiled->needs_fixup)
{
iterate_relocations(compiled,update_literal_references_step);
flush_icache_for(compiled);
aging and nursery collections */
void copy_literal_references(code_block *compiled)
{
- if(collecting_gen >= compiled->block.last_scan)
+ if(collecting_gen >= compiled->last_scan)
{
if(collecting_accumulation_gen_p())
- compiled->block.last_scan = collecting_gen;
+ compiled->last_scan = collecting_gen;
else
- compiled->block.last_scan = collecting_gen + 1;
+ compiled->last_scan = collecting_gen + 1;
/* initialize chase pointer */
cell scan = newspace->here;
}
}
-void *object_xt(cell obj)
+/* Compute an address to store at a relocation */
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
{
- switch(tagged<object>(obj).type())
- {
- case WORD_TYPE:
- return untag<word>(obj)->xt;
- case QUOTATION_TYPE:
- return untag<quotation>(obj)->xt;
- default:
- critical_error("Expected word or quotation",obj);
- return NULL;
- }
-}
+#ifdef FACTOR_DEBUG
+ tagged<array>(compiled->literals).untag_check();
+ tagged<byte_array>(compiled->relocation).untag_check();
+#endif
-void *word_direct_xt(word *w)
-{
- cell tagged_quot = w->direct_entry_def;
- if(tagged_quot == F || max_pic_size == 0)
- return w->xt;
- else
- {
- quotation *quot = untag<quotation>(tagged_quot);
- if(quot->compiledp == F)
- return w->xt;
- else
- return quot->xt;
- }
+ store_address_in_code_block(relocation_class_of(rel),
+ relocation_offset_of(rel) + (cell)compiled->xt(),
+ compute_relocation(rel,index,compiled));
}
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
- relocation_type type = REL_TYPE(rel);
- if(type == RT_XT || type == RT_XT_DIRECT)
- {
- cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
- array *literals = untag<array>(compiled->literals);
- cell obj = array_nth(literals,index);
-
- void *xt;
- if(type == RT_XT)
- xt = object_xt(obj);
- else
- xt = word_direct_xt(untag<word>(obj));
-
- store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
- }
+ relocation_type type = relocation_type_of(rel);
+ if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
+ relocate_code_block_step(rel,index,compiled);
}
/* Relocate new code blocks completely; updating references to literals,
or dlsyms. */
void update_word_references(code_block *compiled)
{
- if(compiled->block.needs_fixup)
+ if(compiled->needs_fixup)
relocate_code_block(compiled);
/* update_word_references() is always applied to every block in
the code heap. Since it resets all call sites to point to
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
- else if(compiled->block.type == PIC_TYPE)
- heap_free(&code,&compiled->block);
+ else if(compiled->type == PIC_TYPE)
+ heap_free(&code,compiled);
else
{
iterate_relocations(compiled,update_word_references_step);
{
check_code_address((cell)compiled);
- mark_block(&compiled->block);
+ mark_block(compiled);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
/* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(context *stacks)
{
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
}
}
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol(void)
-{
- general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
-}
-
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(array *literals, cell index)
-{
- cell symbol = array_nth(literals,index);
- cell library = array_nth(literals,index + 1);
-
- dll *d = (library == F ? NULL : untag<dll>(library));
-
- if(d != NULL && !d->dll)
- return (void *)undefined_symbol;
-
- switch(tagged<object>(symbol).type())
- {
- case BYTE_ARRAY_TYPE:
- {
- symbol_char *name = alien_offset(symbol);
- void *sym = ffi_dlsym(d,name);
-
- if(sym)
- return sym;
- else
- {
- printf("%s\n",name);
- return (void *)undefined_symbol;
- }
- }
- case ARRAY_TYPE:
- {
- cell i;
- array *names = untag<array>(symbol);
- for(i = 0; i < array_capacity(names); i++)
- {
- symbol_char *name = alien_offset(array_nth(names,i));
- void *sym = ffi_dlsym(d,name);
-
- if(sym)
- return sym;
- }
- return (void *)undefined_symbol;
- }
- default:
- critical_error("Bad symbol specifier",symbol);
- return (void *)undefined_symbol;
- }
-}
-
-/* Compute an address to store at a relocation */
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
-{
-#ifdef FACTOR_DEBUG
- tagged<array>(compiled->literals).untag_check();
- tagged<byte_array>(compiled->relocation).untag_check();
-#endif
-
- cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
- array *literals = untag<array>(compiled->literals);
- fixnum absolute_value;
-
- switch(REL_TYPE(rel))
- {
- case RT_PRIMITIVE:
- absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
- break;
- case RT_DLSYM:
- absolute_value = (cell)get_rel_symbol(literals,index);
- break;
- case RT_IMMEDIATE:
- absolute_value = array_nth(literals,index);
- break;
- case RT_XT:
- absolute_value = (cell)object_xt(array_nth(literals,index));
- break;
- case RT_XT_DIRECT:
- absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
- break;
- case RT_HERE:
- absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
- break;
- case RT_THIS:
- absolute_value = (cell)(compiled + 1);
- break;
- case RT_STACK_CHAIN:
- absolute_value = (cell)&stack_chain;
- break;
- case RT_UNTAGGED:
- absolute_value = untag_fixnum(array_nth(literals,index));
- break;
- default:
- critical_error("Bad rel type",rel);
- return; /* Can't happen */
- }
-
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
-}
-
/* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled)
{
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = false;
+ compiled->last_scan = data->nursery();
+ compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
code_block *compiled = allot_code_block(code_length);
/* compiled header */
- compiled->block.type = type;
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = true;
+ compiled->type = type;
+ compiled->last_scan = data->nursery();
+ compiled->needs_fixup = true;
compiled->relocation = relocation.value();
/* slight space optimization */
/* next time we do a minor GC, we have to scan the code heap for
literals */
- last_code_heap_scan = NURSERY;
+ last_code_heap_scan = data->nursery();
return compiled;
}
RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
- /* a word's general entry point XT */
+ /* a word or quotation's general entry point */
RT_XT,
- /* a word's direct entry point XT */
- RT_XT_DIRECT,
+ /* a word's PIC entry point */
+ RT_XT_PIC,
+ /* a word's tail-call PIC entry point */
+ RT_XT_PIC_TAIL,
/* current offset */
RT_HERE,
/* current code block */
RT_STACK_CHAIN,
/* untagged fixnum literal */
RT_UNTAGGED,
+ /* address of megamorphic_cache_hits var */
+ RT_MEGAMORPHIC_CACHE_HITS,
};
enum relocation_class {
RC_ABSOLUTE,
/* relative address in a 32-bit location */
RC_RELATIVE,
- /* relative address in a PowerPC LIS/ORI sequence */
+ /* absolute address in a PowerPC LIS/ORI sequence */
RC_ABSOLUTE_PPC_2_2,
+ /* absolute address in a PowerPC LWZ instruction */
+ RC_ABSOLUTE_PPC_2,
/* relative address in a PowerPC LWZ/STW/BC instruction */
RC_RELATIVE_PPC_2,
/* relative address in a PowerPC B/BL instruction */
RC_INDIRECT_ARM_PC
};
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+static const cell rel_absolute_ppc_2_mask = 0xffff;
+static const cell rel_relative_ppc_2_mask = 0xfffc;
+static const cell rel_relative_ppc_3_mask = 0x3fffffc;
+static const cell rel_indirect_arm_mask = 0xfff;
+static const cell rel_relative_arm_3_mask = 0xffffff;
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(code_block *compiled);
void relocate_code_block(code_block *relocating);
-inline static bool stack_traces_p(void)
+inline static bool stack_traces_p()
{
return userenv[STACK_TRACES_ENV] != F;
}
static void add_to_free_list(heap *heap, free_heap_block *block)
{
- if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ if(block->size < free_list_count * block_size_increment)
{
- int index = block->block.size / BLOCK_SIZE_INCREMENT;
+ int index = block->size / block_size_increment;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
clear_free_list(heap);
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
heap_block *scan = first_block(heap);
free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
branch is only taken after loading a new image, not after code GC */
if((cell)(end + 1) <= heap->seg->end)
{
- end->block.status = B_FREE;
- end->block.size = heap->seg->end - (cell)end;
+ end->status = B_FREE;
+ end->size = heap->seg->end - (cell)end;
/* add final free block */
add_to_free_list(heap,end);
static void assert_free_block(free_heap_block *block)
{
- if(block->block.status != B_FREE)
+ if(block->status != B_FREE)
critical_error("Invalid block in free list",(cell)block);
}
{
cell attempt = size;
- while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ while(attempt < free_list_count * block_size_increment)
{
- int index = attempt / BLOCK_SIZE_INCREMENT;
+ int index = attempt / block_size_increment;
free_heap_block *block = heap->free.small_blocks[index];
if(block)
{
while(block)
{
assert_free_block(block);
- if(block->block.size >= size)
+ if(block->size >= size)
{
if(prev)
prev->next_free = block->next_free;
static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
{
- if(block->block.size != size )
+ if(block->size != size )
{
/* split the block in two */
free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->block.status = B_FREE;
- split->block.size = block->block.size - size;
+ split->status = B_FREE;
+ split->size = block->size - size;
split->next_free = block->next_free;
- block->block.size = size;
+ block->size = size;
add_to_free_list(heap,split);
}
/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap_allot(heap *heap, cell size)
{
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(heap,size);
if(block)
{
block = split_free_block(heap,block,size);
- block->block.status = B_ALLOCATED;
- return &block->block;
+ block->status = B_ALLOCATED;
+ return block;
}
else
return NULL;
}
/* Compute where each block is going to go, after compaction */
-cell compute_heap_forwarding(heap *heap)
+cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
- cell address = (cell)first_block(heap);
+ char *address = (char *)first_block(heap);
while(scan)
{
if(scan->status == B_ALLOCATED)
{
- scan->forwarding = (heap_block *)address;
+ forwarding[scan] = address;
address += scan->size;
}
else if(scan->status == B_MARKED)
scan = next_block(heap,scan);
}
- return address - heap->seg->start;
+ return (cell)address - heap->seg->start;
}
-void compact_heap(heap *heap)
+void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
{
heap_block *scan = first_block(heap);
{
heap_block *next = next_block(heap,scan);
- if(scan->status == B_ALLOCATED && scan != scan->forwarding)
- memcpy(scan->forwarding,scan,scan->size);
+ if(scan->status == B_ALLOCATED)
+ memmove(forwarding[scan],scan,scan->size);
scan = next;
}
}
namespace factor
{
-#define FREE_LIST_COUNT 16
-#define BLOCK_SIZE_INCREMENT 32
+static const cell free_list_count = 16;
+static const cell block_size_increment = 32;
struct heap_free_list {
- free_heap_block *small_blocks[FREE_LIST_COUNT];
+ free_heap_block *small_blocks[free_list_count];
free_heap_block *large_blocks;
};
void free_unmarked(heap *heap, heap_iterator iter);
void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free);
cell heap_size(heap *h);
-cell compute_heap_forwarding(heap *h);
-void compact_heap(heap *h);
+cell compute_heap_forwarding(heap *h, unordered_map<heap_block *,char *> &forwarding);
+void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
inline static heap_block *next_block(heap *h, heap_block *block)
{
word->code = def->code;
- if(word->direct_entry_def != F)
- jit_compile(word->direct_entry_def,relocate);
+ if(word->pic_def != F) jit_compile(word->pic_def,relocate);
+ if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate);
}
/* Apply a function to every code block */
/* Copy literals referenced from all code blocks to newspace. Only for
aging and nursery collections */
-void copy_code_heap_roots(void)
+void copy_code_heap_roots()
{
iterate_code_heap(copy_literal_references);
}
/* Update pointers to words referenced from all code blocks. Only after
defining a new word. */
-void update_code_heap_words(void)
+void update_code_heap_words()
{
iterate_code_heap(update_word_references);
}
dpush(tag_fixnum(max_free / 1024));
}
+static unordered_map<heap_block *,char *> forwarding;
+
code_block *forward_xt(code_block *compiled)
{
- return (code_block *)compiled->block.forwarding;
+ return (code_block *)forwarding[compiled];
}
void forward_frame_xt(stack_frame *frame)
FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
}
-void forward_object_xts(void)
+void forward_object_xts()
{
begin_scan();
}
/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts(void)
+void fixup_object_xts()
{
begin_scan();
since it makes several passes over the code and data heaps, but we only ever
do this before saving a deployed image and exiting, so performaance is not
critical here */
-void compact_code_heap(void)
+void compact_code_heap()
{
/* Free all unreachable code blocks */
gc();
/* Figure out where the code heap blocks are going to end up */
- cell size = compute_heap_forwarding(&code);
+ cell size = compute_heap_forwarding(&code, forwarding);
/* Update word and quotation code pointers */
forward_object_xts();
/* Actually perform the compaction */
- compact_heap(&code);
+ compact_heap(&code,forwarding);
/* Update word and quotation XTs */
fixup_object_xts();
void iterate_code_heap(code_heap_iterator iter);
-void copy_code_heap_roots(void);
+void copy_code_heap_roots();
PRIMITIVE(modify_code_heap);
PRIMITIVE(code_room);
-void compact_code_heap(void);
+void compact_code_heap();
inline static void check_code_pointer(cell ptr)
{
cell ds_size, rs_size;
context *unused_contexts;
-void reset_datastack(void)
+void reset_datastack()
{
ds = ds_bot - sizeof(cell);
}
-void reset_retainstack(void)
+void reset_retainstack()
{
rs = rs_bot - sizeof(cell);
}
-#define RESERVED (64 * sizeof(cell))
+static const cell stack_reserved = (64 * sizeof(cell));
-void fix_stacks(void)
+void fix_stacks()
{
- if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
- if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+ if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
+ if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
}
/* called before entry into foreign C code. Note that ds and rs might
be stored in registers, so callbacks must save and restore the correct values */
-void save_stacks(void)
+void save_stacks()
{
if(stack_chain)
{
}
}
-context *alloc_context(void)
+context *alloc_context()
{
context *new_context;
}
/* called on entry into a compiled callback */
-void nest_stacks(void)
+void nest_stacks()
{
context *new_context = alloc_context();
}
/* called when leaving a compiled callback */
-void unnest_stacks(void)
+void unnest_stacks()
{
ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save;
DEFPUSHPOP(d,ds)
DEFPUSHPOP(r,rs)
-void reset_datastack(void);
-void reset_retainstack(void);
-void fix_stacks(void);
+void reset_datastack();
+void reset_retainstack();
+void fix_stacks();
void init_stacks(cell ds_size, cell rs_size);
PRIMITIVE(datastack);
PRIMITIVE(set_retainstack);
PRIMITIVE(check_datastack);
-VM_C_API void save_stacks(void);
-VM_C_API void nest_stacks(void);
-VM_C_API void unnest_stacks(void);
+VM_C_API void save_stacks();
+VM_C_API void nest_stacks();
+VM_C_API void unnest_stacks();
}
in the public domain. */
#include "asm.h"
-#define DS_REG r29
+#define DS_REG r13
DEF(void,primitive_fixnum_add,(void)):
lwz r3,0(DS_REG)
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
- lwz r11,14(r3) /* load quotation-xt slot */ XX \
+ lwz r11,16(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
DEF(void,c_to_factor,(CELL quot)):
PROLOGUE
- SAVE_INT(r13,0) /* save GPRs */
- SAVE_INT(r14,1)
- SAVE_INT(r15,2)
- SAVE_INT(r16,3)
- SAVE_INT(r17,4)
- SAVE_INT(r18,5)
- SAVE_INT(r19,6)
- SAVE_INT(r20,7)
- SAVE_INT(r21,8)
- SAVE_INT(r22,9)
- SAVE_INT(r23,10)
- SAVE_INT(r24,11)
- SAVE_INT(r25,12)
- SAVE_INT(r26,13)
- SAVE_INT(r27,14)
- SAVE_INT(r28,15)
+ SAVE_INT(r15,0) /* save GPRs */
+ SAVE_INT(r16,1)
+ SAVE_INT(r17,2)
+ SAVE_INT(r18,3)
+ SAVE_INT(r19,4)
+ SAVE_INT(r20,5)
+ SAVE_INT(r21,6)
+ SAVE_INT(r22,7)
+ SAVE_INT(r23,8)
+ SAVE_INT(r24,9)
+ SAVE_INT(r25,10)
+ SAVE_INT(r26,11)
+ SAVE_INT(r27,12)
+ SAVE_INT(r28,13)
+ SAVE_INT(r29,14)
+ SAVE_INT(r30,15)
SAVE_INT(r31,16)
SAVE_FP(f14,20) /* save FPRs */
RESTORE_FP(f14,20) /* save FPRs */
RESTORE_INT(r31,16) /* restore GPRs */
- RESTORE_INT(r28,15)
- RESTORE_INT(r27,14)
- RESTORE_INT(r26,13)
- RESTORE_INT(r25,12)
- RESTORE_INT(r24,11)
- RESTORE_INT(r23,10)
- RESTORE_INT(r22,9)
- RESTORE_INT(r21,8)
- RESTORE_INT(r20,7)
- RESTORE_INT(r19,6)
- RESTORE_INT(r18,5)
- RESTORE_INT(r17,4)
- RESTORE_INT(r16,3)
- RESTORE_INT(r15,2)
- RESTORE_INT(r14,1)
- RESTORE_INT(r13,0)
+ RESTORE_INT(r30,15)
+ RESTORE_INT(r29,14)
+ RESTORE_INT(r28,13)
+ RESTORE_INT(r27,12)
+ RESTORE_INT(r26,11)
+ RESTORE_INT(r25,10)
+ RESTORE_INT(r24,9)
+ RESTORE_INT(r23,8)
+ RESTORE_INT(r22,7)
+ RESTORE_INT(r21,6)
+ RESTORE_INT(r20,5)
+ RESTORE_INT(r19,4)
+ RESTORE_INT(r18,3)
+ RESTORE_INT(r17,2)
+ RESTORE_INT(r16,1)
+ RESTORE_INT(r15,0)
EPILOGUE
blr
sync /* finish up */
isync
blr
+
+DEF(void,primitive_inline_cache_miss,(void)):
+ mflr r6
+DEF(void,primitive_inline_cache_miss_tail,(void)):
+ PROLOGUE
+ mr r3,r6
+ bl MANGLE(inline_cache_miss)
+ EPILOGUE
+ mtctr r3
+ bctr
{
#define FACTOR_CPU_STRING "ppc"
-#define VM_ASM_API
+#define VM_ASM_API VM_C_API
-register cell ds asm("r29");
-register cell rs asm("r30");
+register cell ds asm("r13");
+register cell rs asm("r14");
-void c_to_factor(cell quot);
-void undefined(cell word);
-void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
-void throw_impl(cell quot, stack_frame *rewind);
-void lazy_jit_compile(cell quot);
-void flush_icache(cell start, cell len);
+/* In the instruction sequence:
+
+ LOAD32 r3,...
+ B blah
+
+ the offset from the immediate operand to LOAD32 to the instruction after
+ the branch is two instructions. */
+static const fixnum xt_tail_pic_offset = 4 * 2;
+
+inline static void check_call_site(cell return_address)
+{
+#ifdef FACTOR_DEBUG
+ cell insn = *(cell *)return_address;
+ /* Check that absolute bit is 0 */
+ assert((insn & 0x2) == 0x0);
+ /* Check that instruction is branch */
+ assert((insn >> 26) == 0x12);
+#endif
+}
+
+static const cell b_mask = 0x3fffffc;
+
+inline static void *get_call_target(cell return_address)
+{
+ return_address -= sizeof(cell);
+ check_call_site(return_address);
+
+ cell insn = *(cell *)return_address;
+ cell unsigned_addr = (insn & b_mask);
+ fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
+ return (void *)(signed_addr + return_address);
+}
+
+inline static void set_call_target(cell return_address, void *target)
+{
+ return_address -= sizeof(cell);
+ check_call_site(return_address);
+
+ cell insn = *(cell *)return_address;
+
+ fixnum relative_address = ((cell)target - return_address);
+ insn = ((insn & ~b_mask) | (relative_address & b_mask));
+ *(cell *)return_address = insn;
+
+ /* Flush the cache line containing the call we just patched */
+ __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
+}
+
+inline static bool tail_call_site_p(cell return_address)
+{
+ return_address -= sizeof(cell);
+ cell insn = *(cell *)return_address;
+ return (insn & 0x1) == 0;
+}
+
+/* Defined in assembly */
+VM_ASM_API void c_to_factor(cell quot);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
+VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void flush_icache(cell start, cell len);
+
+VM_ASM_API void set_callstack(stack_frame *to,
+ stack_frame *from,
+ cell length,
+ void *(*memcpy)(void*,const void*, size_t));
}
#include "asm.h"
-/* Note that primitive word definitions are compiled with
-__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
-and the callstack top is passed in EDX */
-
#define ARG0 %eax
#define ARG1 %edx
#define STACK_REG %esp
pop %ebx
#define QUOT_XT_OFFSET 16
-#define WORD_XT_OFFSET 30
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
mov %edx,%eax
ret
-DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
- mov (%esp),%eax
+DEF(void,primitive_inline_cache_miss,(void)):
+ mov (%esp),%ebx
+DEF(void,primitive_inline_cache_miss_tail,(void)):
sub $8,%esp
- push %eax
+ push %ebx
call MANGLE(inline_cache_miss)
add $12,%esp
jmp *%eax
register cell ds asm("esi");
register cell rs asm("edi");
-#define VM_ASM_API extern "C" __attribute__ ((regparm (2)))
+#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
}
#endif
#define QUOT_XT_OFFSET 36
-#define WORD_XT_OFFSET 66
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
-DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
- mov (%rsp),ARG0
+DEF(void,primitive_inline_cache_miss,(void)):
+ mov (%rsp),%rbx
+DEF(void,primitive_inline_cache_miss_tail,(void)):
sub $STACK_PADDING,%rsp
+ mov %rbx,ARG0
call MANGLE(inline_cache_miss)
add $STACK_PADDING,%rsp
jmp *%rax
register cell ds asm("r14");
register cell rs asm("r15");
-#define VM_ASM_API extern "C"
+#define VM_ASM_API VM_C_API
}
inline static void flush_icache(cell start, cell len) {}
+/* In the instruction sequence:
+
+ MOV EBX,...
+ JMP blah
+
+ the offset from the immediate operand to MOV to the instruction after
+ the jump is a cell for the immediate operand, 4 bytes for the JMP
+ destination, and one byte for the JMP opcode. */
+static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1;
+
+static const unsigned char call_opcode = 0xe8;
+static const unsigned char jmp_opcode = 0xe9;
+
+inline static unsigned char call_site_opcode(cell return_address)
+{
+ return *(unsigned char *)(return_address - 5);
+}
+
inline static void check_call_site(cell return_address)
{
- /* An x86 CALL instruction looks like so:
- |e8|..|..|..|..|
- where the ... are a PC-relative jump address.
- The return_address points to right after the
- instruction. */
#ifdef FACTOR_DEBUG
- assert(*(unsigned char *)(return_address - 5) == 0xe8);
+ unsigned char opcode = call_site_opcode(return_address);
+ assert(opcode == call_opcode || opcode == jmp_opcode);
#endif
}
*(int *)(return_address - 4) = ((cell)target - return_address);
}
+inline static bool tail_call_site_p(cell return_address)
+{
+ return call_site_opcode(return_address) == jmp_opcode;
+}
+
/* Defined in assembly */
VM_ASM_API void c_to_factor(cell quot);
VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);
bool performing_compaction;
cell collecting_gen;
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
+/* if true, we collecting aging space for the second time, so if it is still
+full, we go on to collect tenured */
bool collecting_aging_again;
/* in case a generation fills up in the middle of a gc, we jump back
up to try collecting the next generation. */
jmp_buf gc_jmp;
-gc_stats stats[MAX_GEN_COUNT];
+gc_stats stats[max_gen_count];
u64 cards_scanned;
u64 decks_scanned;
u64 card_scan_time;
bool growing_data_heap;
data_heap *old_data_heap;
-void init_data_gc(void)
+void init_data_gc()
{
performing_gc = false;
- last_code_heap_scan = NURSERY;
+ last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
{
if(in_zone(newspace,untagged))
return false;
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
return true;
- else if(HAVE_AGING_P && collecting_gen == AGING)
- return !in_zone(&data->generations[TENURED],untagged);
- else if(collecting_gen == NURSERY)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
+ return !in_zone(&data->generations[data->tenured()],untagged);
+ else if(collecting_gen == data->nursery())
return in_zone(&nursery,untagged);
else
{
/* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */
- if(collecting_gen == NURSERY)
+ if(collecting_gen == data->nursery())
{
- mask = CARD_POINTS_TO_NURSERY;
+ mask = card_points_to_nursery;
/* after the collection, no old->nursery pointers remain
anywhere, but old->aging pointers might remain in tenured
space */
- if(gen == TENURED)
- unmask = CARD_POINTS_TO_NURSERY;
+ if(gen == data->tenured())
+ unmask = card_points_to_nursery;
/* after the collection, all cards in aging space can be
cleared */
- else if(HAVE_AGING_P && gen == AGING)
- unmask = CARD_MARK_MASK;
+ else if(data->have_aging_p() && gen == data->aging())
+ unmask = card_mark_mask;
else
{
critical_error("bug in copy_gen_cards",gen);
/* if we are collecting aging space into tenured space, we care about
all old->nursery and old->aging pointers. no old->aging pointers can
remain */
- else if(HAVE_AGING_P && collecting_gen == AGING)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
{
if(collecting_aging_again)
{
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_MARK_MASK;
+ mask = card_points_to_aging;
+ unmask = card_mark_mask;
}
/* after we collect aging space into the aging semispace, no
old->nursery pointers remain but tenured space might still have
pointers to aging space. */
else
{
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_POINTS_TO_NURSERY;
+ mask = card_points_to_aging;
+ unmask = card_points_to_nursery;
}
}
else
/* Scan cards in all generations older than the one being collected, copying
old->new references */
-static void copy_cards(void)
+static void copy_cards()
{
u64 start = current_micros();
copy_handle((cell*)ptr);
}
-static void copy_registered_locals(void)
+static void copy_registered_locals()
{
cell scan = gc_locals_region->start;
copy_handle(*(cell **)scan);
}
-static void copy_registered_bignums(void)
+static void copy_registered_bignums()
{
cell scan = gc_bignums_region->start;
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
-static void copy_roots(void)
+static void copy_roots()
{
copy_handle(&T);
copy_handle(&bignum_zero);
{
obj++;
- cell tenured_start = data->generations[TENURED].start;
- cell tenured_end = data->generations[TENURED].end;
+ cell tenured_start = data->generations[data->tenured()].start;
+ cell tenured_end = data->generations[data->tenured()].end;
cell newspace_start = newspace->start;
cell newspace_end = newspace->end;
void copy_reachable_objects(cell scan, cell *end)
{
- if(collecting_gen == NURSERY)
+ if(collecting_gen == data->nursery())
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
}
- else if(HAVE_AGING_P && collecting_gen == AGING)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
{
while(scan < *end)
scan = copy_next_from_aging(scan);
}
- else if(collecting_gen == TENURED)
+ else if(collecting_gen == data->tenured())
{
while(scan < *end)
scan = copy_next_from_tenured(scan);
{
if(growing_data_heap)
{
- if(collecting_gen != TENURED)
+ if(collecting_gen != data->tenured())
critical_error("Invalid parameters to begin_gc",0);
old_data_heap = data;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data->generations[TENURED];
+ newspace = &data->generations[data->tenured()];
}
else if(collecting_accumulation_gen_p())
{
if(collecting_accumulation_gen_p())
{
/* all younger generations except are now empty.
- if collecting_gen == NURSERY here, we only have 1 generation;
+ if collecting_gen == data->nursery() here, we only have 1 generation;
old-school Cheney collector */
- if(collecting_gen != NURSERY)
- reset_generations(NURSERY,collecting_gen - 1);
+ if(collecting_gen != data->nursery())
+ reset_generations(data->nursery(),collecting_gen - 1);
}
- else if(collecting_gen == NURSERY)
+ else if(collecting_gen == data->nursery())
{
nursery.here = nursery.start;
}
{
/* all generations up to and including the one
collected are now empty */
- reset_generations(NURSERY,collecting_gen);
+ reset_generations(data->nursery(),collecting_gen);
}
collecting_aging_again = false;
{
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
unmark_marked(&code);
}
- /* we try collecting AGING space twice before going on to
- collect TENURED */
- else if(HAVE_AGING_P
- && collecting_gen == AGING
+ /* we try collecting aging space twice before going on to
+ collect tenured */
+ else if(data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
{
collecting_aging_again = true;
{
code_heap_scans++;
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
else
copy_code_heap_roots();
performing_gc = false;
}
-void gc(void)
+void gc()
{
- garbage_collection(TENURED,false,0);
+ garbage_collection(data->tenured(),false,0);
}
PRIMITIVE(gc)
cell i;
u64 total_gc_time = 0;
- for(i = 0; i < MAX_GEN_COUNT; i++)
+ for(i = 0; i < max_gen_count; i++)
{
gc_stats *s = &stats[i];
result.add(allot_cell(s->collections));
dpush(result.elements.value());
}
-void clear_gc_stats(void)
+void clear_gc_stats()
{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
+ for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
cards_scanned = 0;
compile_all_words();
}
-VM_C_API void minor_gc(void)
+VM_C_API void minor_gc()
{
- garbage_collection(NURSERY,false,0);
+ garbage_collection(data->nursery(),false,0);
}
}
extern cell last_code_heap_scan;
-void init_data_gc(void);
+void init_data_gc();
-void gc(void);
+void gc();
-inline static bool collecting_accumulation_gen_p(void)
+inline static bool collecting_accumulation_gen_p()
{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
- || collecting_gen == TENURED);
+ || collecting_gen == data->tenured());
}
void copy_handle(cell *handle);
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
+static const cell allot_buffer_zone = 1024;
inline static object *allot_zone(zone *z, cell a)
{
object *obj;
- if(nursery.size - ALLOT_BUFFER_ZONE > size)
+ if(nursery.size - allot_buffer_zone > size)
{
/* If there is insufficient room, collect the nursery */
- if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
- garbage_collection(NURSERY,false,0);
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
cell h = nursery.here;
nursery.here = h + align8(size);
tenured space */
else
{
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
/* If tenured space does not have enough room, collect */
if(tenured->here + size > tenured->end)
{
gc();
- tenured = &data->generations[TENURED];
+ tenured = &data->generations[data->tenured()];
}
/* If it still won't fit, grow the heap */
if(tenured->here + size > tenured->end)
{
- garbage_collection(TENURED,true,size);
- tenured = &data->generations[TENURED];
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
}
obj = allot_zone(tenured,size);
PRIMITIVE(gc);
PRIMITIVE(gc_stats);
-void clear_gc_stats(void);
+void clear_gc_stats();
PRIMITIVE(clear_gc_stats);
PRIMITIVE(become);
#endif
}
-VM_C_API void minor_gc(void);
+VM_C_API void minor_gc();
}
return z->end;
}
-void init_card_decks(void)
+void init_card_decks()
{
- cell start = align(data->seg->start,DECK_SIZE);
- allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
- cards_offset = (cell)data->cards - (start >> CARD_BITS);
- decks_offset = (cell)data->decks - (start >> DECK_BITS);
+ cell start = align(data->seg->start,deck_size);
+ allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
+ cards_offset = (cell)data->cards - (start >> card_bits);
+ decks_offset = (cell)data->decks - (start >> deck_bits);
}
data_heap *alloc_data_heap(cell gens,
cell aging_size,
cell tenured_size)
{
- young_size = align(young_size,DECK_SIZE);
- aging_size = align(aging_size,DECK_SIZE);
- tenured_size = align(tenured_size,DECK_SIZE);
+ young_size = align(young_size,deck_size);
+ aging_size = align(aging_size,deck_size);
+ tenured_size = align(tenured_size,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
data->young_size = young_size;
return NULL; /* can't happen */
}
- total_size += DECK_SIZE;
+ total_size += deck_size;
data->seg = alloc_segment(total_size);
data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
- cell cards_size = total_size >> CARD_BITS;
+ cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size);
data->allot_markers_end = data->allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size);
data->cards_end = data->cards + cards_size;
- cell decks_size = total_size >> DECK_BITS;
+ cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size);
data->decks_end = data->decks + decks_size;
- cell alloter = align(data->seg->start,DECK_SIZE);
+ cell alloter = align(data->seg->start,deck_size);
- alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
+ alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
if(data->gen_count == 3)
{
- alloter = init_zone(&data->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+ alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
+ alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
}
if(data->gen_count >= 2)
{
- alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+ alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
+ alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
}
- if(data->seg->end - alloter > DECK_SIZE)
+ if(data->seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter);
return data;
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+ memset(first_card,invalid_allot_marker,last_card - first_card);
}
void reset_generation(cell i)
{
- zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+ zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
z->here = z->start;
if(secure_gc)
void set_data_heap(data_heap *data_)
{
data = data_;
- nursery = data->generations[NURSERY];
+ nursery = data->generations[data->nursery()];
init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
+ clear_cards(data->nursery(),data->tenured());
+ clear_decks(data->nursery(),data->tenured());
+ clear_allot_markers(data->nursery(),data->tenured());
}
void init_data_heap(cell gens,
return callstack_size(untag_fixnum(((callstack *)pointer)->length));
default:
critical_error("Invalid header",(cell)pointer);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
return sizeof(wrapper);
default:
critical_error("Invalid header",(cell)pointer);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
{
- zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+ zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
a.add(tag_fixnum((z->end - z->here) >> 10));
a.add(tag_fixnum((z->size) >> 10));
}
cell heap_scan_ptr;
/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan(void)
+void begin_scan()
{
- heap_scan_ptr = data->generations[TENURED].start;
+ heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
begin_scan();
}
-cell next_object(void)
+cell next_object()
{
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
- if(heap_scan_ptr >= data->generations[TENURED].here)
+ if(heap_scan_ptr >= data->generations[data->tenured()].here)
return F;
object *obj = (object *)heap_scan_ptr;
gc_off = false;
}
-cell find_all_words(void)
+cell find_all_words()
{
growable_array words;
cell *decks;
cell *decks_end;
+
+ /* the 0th generation is where new objects are allocated. */
+ cell nursery() { return 0; }
+
+ /* where objects hang around */
+ cell aging() { return gen_count - 2; }
+
+ /* the oldest generation */
+ cell tenured() { return gen_count - 1; }
+
+ bool have_aging_p() { return gen_count > 2; }
};
extern data_heap *data;
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* where objects hang around */
-#define AGING (data->gen_count-2)
-#define HAVE_AGING_P (data->gen_count>2)
-/* the oldest generation */
-#define TENURED (data->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
+static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
{
cell init_zone(zone *z, cell size, cell base);
-void init_card_decks(void);
+void init_card_decks();
data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
cell binary_payload_start(object *pointer);
cell object_size(cell tagged);
-void begin_scan(void);
-cell next_object(void);
+void begin_scan();
+cell next_object();
PRIMITIVE(data_room);
PRIMITIVE(size);
/* GC is off during heap walking */
extern bool gc_off;
-cell find_all_words(void);
+cell find_all_words();
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
}
}
-void print_datastack(void)
+void print_datastack()
{
print_string("==== DATA STACK:\n");
print_objects((cell *)ds_bot,(cell *)ds);
}
-void print_retainstack(void)
+void print_retainstack()
{
print_string("==== RETAIN STACK:\n");
print_objects((cell *)rs_bot,(cell *)rs);
print_string("\n");
}
-void print_callstack(void)
+void print_callstack()
{
print_string("==== CALL STACK:\n");
cell bottom = (cell)stack_chain->callstack_bottom;
print_string(", here="); print_cell(z->here - z->start); nl();
}
-void dump_generations(void)
+void dump_generations()
{
cell i;
}
/* Dump all code blocks for debugging */
-void dump_code_heap(void)
+void dump_code_heap()
{
cell reloc_size = 0, literal_size = 0;
print_cell(literal_size); print_string(" bytes of literal data\n");
}
-void factorbug(void)
+void factorbug()
{
if(fep_disabled)
{
void print_obj(cell obj);
void print_nested_obj(cell obj, fixnum nesting);
-void dump_generations(void);
-void factorbug(void);
+void dump_generations();
+void factorbug();
void dump_zone(zone *z);
PRIMITIVE(die);
static cell search_lookup_alist(cell table, cell klass)
{
- array *
pairs = untag<array>(table);
- fixnum index = array_capacity(pairs) - 1;
+ array *
elements = untag<array>(table);
+ fixnum index = array_capacity(elements) - 2;
while(index >= 0)
{
- array *pair = untag<array>(array_nth(pairs,index));
- if(array_nth(pair,0) == klass)
- return array_nth(pair,1);
+ if(array_nth(elements,index) == klass)
+ return array_nth(elements,index + 1);
else
- index--;
+ index -= 2;
}
return F;
break;
default:
critical_error("Bad methods array",methods);
- return -1;
+ return 0;
}
}
}
namespace factor
{
+extern cell megamorphic_cache_hits;
+extern cell megamorphic_cache_misses;
+
cell lookup_method(cell object, cell methods);
PRIMITIVE(lookup_method);
cell signal_fault_addr;
stack_frame *signal_callstack_top;
-void out_of_memory(void)
+void out_of_memory()
{
print_string("Out of memory\n\n");
dump_generations();
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
-void not_implemented_error(void)
+void not_implemented_error()
{
general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
}
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error(void)
+void divide_by_zero_error()
{
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
not_implemented_error();
}
-void memory_signal_handler_impl(void)
+void memory_signal_handler_impl()
{
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void misc_signal_handler_impl(void)
+void misc_signal_handler_impl()
{
signal_error(signal_number,signal_callstack_top);
}
ERROR_MEMORY,
};
-void out_of_memory(void);
+void out_of_memory();
void fatal_error(const char* msg, cell tagged);
void critical_error(const char* msg, cell tagged);
void throw_error(cell error, stack_frame *native_stack);
void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
-void divide_by_zero_error(void);
+void divide_by_zero_error();
void memory_protection_error(cell addr, stack_frame *native_stack);
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
-void not_implemented_error(void);
+void not_implemented_error();
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
extern cell signal_fault_addr;
extern stack_frame *signal_callstack_top;
-void memory_signal_handler_impl(void);
-void misc_signal_handler_impl(void);
+void memory_signal_handler_impl();
+void misc_signal_handler_impl();
}
}
/* Do some initialization that we do once only */
-static void do_stage1_init(void)
+static void do_stage1_init()
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING);
userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING);
- userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell));
+ userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
free(result);
}
-VM_C_API void factor_yield(void)
+VM_C_API void factor_yield()
{
- void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
VM_C_API char *factor_eval_string(char *string);
VM_C_API void factor_eval_free(char *result);
-VM_C_API void factor_yield(void);
+VM_C_API void factor_yield();
VM_C_API void factor_sleep(long ms);
}
{
return x + 2 * y;
}
+
+short ffi_test_48(struct bool_field_test x)
+{
+ return x.parents;
+}
+#include <stdbool.h>
+
#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define F_STDCALL __attribute__((stdcall))
#else
F_EXPORT _Complex double ffi_test_46(int x);
F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
+
+struct bool_field_test {
+ char *name;
+ bool on;
+ short parents;
+};
+
+F_EXPORT short ffi_test_48(struct bool_field_test x);
clear_gc_stats();
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
return false;
}
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
- h.magic = IMAGE_MAGIC;
- h.version = IMAGE_VERSION;
+ h.magic = image_magic;
+ h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
- cell i;
- for(i = 0; i < USER_ENV; i++)
- {
- if(i < FIRST_SAVE_ENV)
- h.userenv[i] = F;
- else
- h.userenv[i] = userenv[i];
- }
+ for(cell i = 0; i < USER_ENV; i++)
+ h.userenv[i] = (save_env_p(i) ? userenv[i] : F);
bool ok = true;
path.untag_check();
/* strip out userenv data which is set on startup anyway */
- cell i;
- for(i = 0; i < FIRST_SAVE_ENV; i++)
- userenv[i] = F;
-
- for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
- userenv[i] = F;
+ for(cell i = 0; i < USER_ENV; i++)
+ {
+ if(!save_env_p(i)) userenv[i] = F;
+ }
/* do a full GC + code heap compaction */
performing_compaction = true;
if(immediate_p(*cell))
return;
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
*cell += (tenured->start - data_relocation_base);
}
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
for(relocating = tenured->start;
relocating < tenured->here;
if(fread(&h,sizeof(image_header),1,file) != 1)
fatal_error("Cannot read image header",0);
- if(h.magic != IMAGE_MAGIC)
+ if(h.magic != image_magic)
fatal_error("Bad image: magic number check failed",h.magic);
- if(h.version != IMAGE_VERSION)
+ if(h.version != image_version)
fatal_error("Bad image: version number check failed",h.version);
load_data_heap(file,&h,p);
namespace factor
{
-#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 4
+static const cell image_magic = 0x0f0e0d0c;
+static const cell image_version = 4;
struct image_header {
cell magic;
{
/* Find the call target. */
void *old_xt = get_call_target(return_address);
+ check_code_pointer((cell)old_xt);
+
code_block *old_block = (code_block *)old_xt - 1;
- cell old_type = old_block->block.type;
+ cell old_type = old_block->type;
#ifdef FACTOR_DEBUG
/* The call target was either another PIC,
#endif
if(old_type == PIC_TYPE)
- heap_free(&code,&old_block->block);
+ heap_free(&code,old_block);
}
/* Figure out what kind of type check the PIC needs based on the methods
if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
critical_error("Oops",0);
- return -1;
+ return 0;
}
static void update_pic_count(cell type)
inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
void emit_check(cell klass);
- void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_);
+ void compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p);
};
void inline_cache_jit::emit_check(cell klass)
/* index: 0 = top of stack, 1 = item underneath, etc
cache_entries: array of class/method pairs */
-void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_)
+void inline_cache_jit::compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p)
{
gc_root<word> generic_word(generic_word_);
gc_root<array> methods(methods_);
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_jump(userenv[PIC_MISS_WORD]);
+ word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
static code_block *compile_inline_cache(fixnum index,
- cell generic_word_,
- cell methods_,
- cell cache_entries_)
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p)
{
gc_root<word> generic_word(generic_word_);
gc_root<array> methods(methods_);
gc_root<array> cache_entries(cache_entries_);
inline_cache_jit jit(generic_word.value());
- jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value());
+ jit.compile_inline_cache(index,
+ generic_word.value(),
+ methods.value(),
+ cache_entries.value(),
+ tail_call_p);
code_block *code = jit.to_code_block();
relocate_code_block(code);
return code;
xt = compile_inline_cache(index,
generic_word.value(),
methods.value(),
- new_cache_entries.value()) + 1;
+ new_cache_entries.value(),
+ tail_call_site_p(return_address))->xt();
}
/* Install the new stub. */
set_call_target(return_address,xt);
#ifdef PIC_DEBUG
- printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt);
+ printf("Updated %s call site 0x%lx with 0x%lx\n",
+ tail_call_site_p(return_address) ? "tail" : "non-tail",
+ return_address,
+ (cell)xt);
#endif
return xt;
PRIMITIVE(reset_inline_cache_stats);
PRIMITIVE(inline_cache_stats);
PRIMITIVE(inline_cache_miss);
+PRIMITIVE(inline_cache_miss_tail);
-extern "C" void *inline_cache_miss(cell return_address);
+VM_C_API void *inline_cache_miss(cell return_address);
}
with many more capabilities so these words are not usually used in
normal operation. */
-void init_c_io(void)
+void init_c_io()
{
userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
-void io_error(void)
+void io_error()
{
#ifndef WINCE
if(errno == EINTR)
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */
-VM_C_API int err_no(void)
+VM_C_API int err_no()
{
return errno;
}
-VM_C_API void clear_err_no(void)
+VM_C_API void clear_err_no()
{
errno = 0;
}
namespace factor
{
-void init_c_io(void);
-void io_error(void);
+void init_c_io();
+void io_error();
PRIMITIVE(fopen);
PRIMITIVE(fgetc);
PRIMITIVE(existsp);
PRIMITIVE(read_dir);
-VM_C_API int err_no(void);
-VM_C_API void clear_err_no(void);
+VM_C_API int err_no();
+VM_C_API void clear_err_no();
}
if(stack_traces_p()) literal(owner.value());
}
-relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p)
+void jit::emit_relocation(cell code_template_)
{
- array *quadruple = untag<array>(code_template);
- cell rel_class = array_nth(quadruple,1);
- cell rel_type = array_nth(quadruple,2);
- cell offset = array_nth(quadruple,3);
-
- if(rel_class == F)
- {
- *rel_p = false;
- return 0;
- }
- else
+ gc_root<array> code_template(code_template_);
+ cell capacity = array_capacity(code_template.untagged());
+ for(cell i = 1; i < capacity; i += 3)
{
- *rel_p = true;
- return (untag_fixnum(rel_type) << 28)
+ cell rel_class = array_nth(code_template.untagged(),i);
+ cell rel_type = array_nth(code_template.untagged(),i + 1);
+ cell offset = array_nth(code_template.untagged(),i + 2);
+
+ relocation_entry new_entry
+ = (untag_fixnum(rel_type) << 28)
| (untag_fixnum(rel_class) << 24)
| ((code.count + untag_fixnum(offset)));
+ relocation.append_bytes(&new_entry,sizeof(relocation_entry));
}
}
{
gc_root<array> code_template(code_template_);
- bool rel_p;
- relocation_entry rel = rel_to_emit(code_template.value(),&rel_p);
- if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry));
+ emit_relocation(code_template.value());
gc_root<byte_array> insns(array_nth(code_template.untagged(),0));
jit(cell jit_type, cell owner);
void compute_position(cell offset);
- relocation_entry rel_to_emit(cell code_template, bool *rel_p);
+ void emit_relocation(cell code_template);
void emit(cell code_template);
void literal(cell literal) { literals.add(literal); }
}
void word_jump(cell word) {
- emit_with(userenv[JIT_WORD_JUMP],word);
+ literal(tag_fixnum(xt_tail_pic_offset));
+ literal(word);
+ emit(userenv[JIT_WORD_JUMP]);
}
void word_call(cell word) {
emit_with(userenv[JIT_WORD_CALL],word);
}
+ void word_special(cell word) {
+ emit_with(userenv[JIT_WORD_SPECIAL],word);
+ }
+
void emit_subprimitive(cell word_) {
gc_root<word> word(word_);
gc_root<array> code_template(word->subprimitive);
- if(array_nth(code_template.untagged(),1) != F) literal(T);
+ if(array_capacity(code_template.untagged()) > 1) literal(T);
emit(code_template.value());
}
return (a + (b-1)) & ~(b-1);
}
-#define align8(a) align(a,8)
-#define align_page(a) align(a,getpagesize())
+inline static cell align8(cell a)
+{
+ return align(a,8);
+}
#define WORD_SIZE (signed)(sizeof(cell)*8)
struct header {
cell value;
+ /* Default ctor to make gcc 3.x happy */
+ header() { abort(); }
+
header(cell value_) : value(value_ << TAG_BITS) {}
void check_header() {
unsigned char status; /* free or allocated? */
unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */
unsigned char last_scan; /* the youngest generation in which this block's literals may live */
- char needs_fixup; /* is this a new block that needs full fixup? */
+ unsigned char needs_fixup; /* is this a new block that needs full fixup? */
/* In bytes, includes this header */
cell size;
-
- /* Used during compaction */
- heap_block *forwarding;
};
-struct free_heap_block
+struct free_heap_block : public heap_block
{
- heap_block block;
-
- /* Filled in on image load */
free_heap_block *next_free;
};
-struct code_block
+struct code_block : public heap_block
{
- heap_block block;
cell literals; /* # bytes */
cell relocation; /* tagged pointer to byte-array or f */
/* TAGGED property assoc for library code */
cell props;
/* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
- cell direct_entry_def;
+ cell pic_def;
+ /* TAGGED alternative entry point for direct tail calls. Used for inline caching */
+ cell pic_tail_def;
/* TAGGED call count for profiling */
cell counter;
/* TAGGED machine code for sub-primitive */
void *dll;
};
-struct callstack : public object {
- static const cell type_number = CALLSTACK_TYPE;
- /* tagged */
- cell length;
-};
-
struct stack_frame
{
void *xt;
cell size;
};
+struct callstack : public object {
+ static const cell type_number = CALLSTACK_TYPE;
+ /* tagged */
+ cell length;
+
+ stack_frame *top() { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+};
+
struct tuple : public object {
static const cell type_number = TUPLE_TYPE;
/* tagged layout */
}
/* Initialize the Mach exception handler thread. */
-void mach_initialize (void)
+void mach_initialize ()
{
mach_port_t self;
exception_mask_t mask;
namespace factor
{
-void mach_initialize (void);
+void mach_initialize ();
}
#include <assert.h>
#endif
+/* C headers */
#include <fcntl.h>
#include <limits.h>
#include <math.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
+#include <unistd.h>
#include <sys/param.h>
+/* C++ headers */
+#if __GNUC__ == 4
+ #include <tr1/unordered_map>
+ #define unordered_map std::tr1::unordered_map
+#elif __GNUC__ == 3
+ #include <boost/unordered_map.hpp>
+ #define unordered_map boost::unordered_map
+#else
+ #error Factor requires GCC 3.x or later
+#endif
+
+/* Factor headers */
#include "layouts.hpp"
#include "platform.hpp"
#include "primitives.hpp"
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
fixnum result = x / y;
- if(result == -FIXNUM_MIN)
- drepl(allot_integer(-FIXNUM_MIN));
+ if(result == -fixnum_min)
+ drepl(allot_integer(-fixnum_min));
else
drepl(tag_fixnum(result));
}
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
- if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
{
- ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+ ((cell *)ds)[-1] = allot_integer(-fixnum_min);
((cell *)ds)[0] = tag_fixnum(0);
}
else
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+static inline fixnum sign_mask(fixnum x)
+{
+ return x >> (WORD_SIZE - 1);
+}
+
+static inline fixnum branchless_max(fixnum x, fixnum y)
+{
+ return (x - ((x - y) & sign_mask(x - y)));
+}
+
+static inline fixnum branchless_abs(fixnum x)
+{
+ return (x ^ sign_mask(x)) - sign_mask(x);
+}
PRIMITIVE(fixnum_shift)
{
return;
else if(y < 0)
{
- y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ y = branchless_max(y,-WORD_SIZE + 1);
drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if(!(BRANCHLESS_ABS(x) & mask))
+ if(!(branchless_abs(x) & mask))
{
drepl(tag_fixnum(x << y));
return;
drepl(tag<bignum>(result));
}
-cell unbox_array_size(void)
+cell unbox_array_size()
{
switch(tagged<object>(dpeek()).type())
{
case FIXNUM_TYPE:
{
fixnum n = untag_fixnum(dpeek());
- if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+ if(n >= 0 && n < (fixnum)array_size_max)
{
dpop();
return n;
case BIGNUM_TYPE:
{
bignum * zero = untag<bignum>(bignum_zero);
- bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum * max = cell_to_bignum(array_size_max);
bignum * n = untag<bignum>(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
}
}
- general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);
return 0; /* can't happen */
}
return bignum_to_fixnum(untag<bignum>(tagged));
default:
type_error(FIXNUM_TYPE,tagged);
- return -1; /* can't happen */
+ return 0; /* can't happen */
}
}
VM_C_API void box_signed_8(s64 n)
{
- if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
return bignum_to_long_long(untag<bignum>(obj));
default:
type_error(BIGNUM_TYPE,obj);
- return -1;
+ return 0;
}
}
VM_C_API void box_unsigned_8(u64 n)
{
- if(n > FIXNUM_MAX)
+ if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
return bignum_to_ulong_long(untag<bignum>(obj));
default:
type_error(BIGNUM_TYPE,obj);
- return -1;
+ return 0;
}
}
extern cell bignum_pos_one;
extern cell bignum_neg_one;
-#define cell_MAX (cell)(-1)
-#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
-#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
+static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
+static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
+static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
inline static cell allot_integer(fixnum x)
{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
else
return tag_fixnum(x);
inline static cell allot_cell(cell x)
{
- if(x > (cell)FIXNUM_MAX)
+ if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
else
return tag_fixnum(x);
}
-cell unbox_array_size(void);
+cell unbox_array_size();
inline static double untag_float(cell tagged)
{
{
/* From SBCL */
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
char path[PATH_MAX + 1];
#include <osreldate.h>
#include <sys/sysctl.h>
-extern "C" int getosreldate(void);
+extern "C" int getosreldate();
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
c_to_factor(quot);
}
-void init_signals(void)
+void init_signals()
{
unix_init_signals();
}
-void early_init(void) { }
+void early_init() { }
#define SUFFIX ".image"
#define SUFFIX_LEN 6
-const char *default_image_path(void)
+const char *default_image_path()
{
const char *path = vm_executable_path();
#define NULL_DLL NULL
void c_to_factor_toplevel(cell quot);
-void init_signals(void);
-void early_init(void);
-const char *vm_executable_path(void);
-const char *default_image_path(void);
+void init_signals();
+void early_init();
+const char *vm_executable_path();
+const char *default_image_path();
}
{
/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
char *path = (char *)safe_malloc(PATH_MAX + 1);
#ifdef SYS_inotify_init
-int inotify_init(void)
+int inotify_init()
{
return syscall(SYS_inotify_init);
}
#else
-int inotify_init(void)
+int inotify_init()
{
not_implemented_error();
return -1;
namespace factor
{
-int inotify_init(void);
+int inotify_init();
int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd);
#define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib"
-void init_signals(void);
-void early_init(void);
+void init_signals();
+void early_init();
-const char *vm_executable_path(void);
-const char *default_image_path(void);
+const char *vm_executable_path();
+const char *default_image_path();
inline static void *ucontext_stack_pointer(void *uap)
{
extern "C" int main();
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
static Dl_info info = {0};
if (!info.dli_fname)
namespace factor
{
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
return NULL;
}
namespace factor
{
-const char *vm_executable_path(void)
+const char *vm_executable_path()
{
return NULL;
}
static void *null_dll;
-s64 current_micros(void)
+s64 current_micros()
{
struct timeval t;
gettimeofday(&t,NULL);
usleep(usec);
}
-void init_ffi(void)
+void init_ffi()
{
/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
fatal_error("sigaction failed", 0);
}
-void unix_init_signals(void)
+void unix_init_signals()
{
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
return NULL;
}
-void open_console(void)
+void open_console()
{
int filedes[2];
start_thread(stdin_loop);
}
-VM_C_API void wait_for_stdin(void)
+VM_C_API void wait_for_stdin()
{
if(write(control_write,"X",1) != 1)
{
void start_thread(void *(*start_routine)(void *));
-void init_ffi(void);
+void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
-void unix_init_signals(void);
+void unix_init_signals();
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-s64 current_micros(void);
+s64 current_micros();
void sleep_micros(cell usec);
-void open_console(void);
+void open_console();
}
namespace factor
{
-s64 current_micros(void)
+s64 current_micros()
{
SYSTEMTIME st;
FILETIME ft;
c_to_factor(quot);
}
-void open_console(void) { }
+void open_console() { }
}
#define snprintf _snprintf
#define snwprintf _snwprintf
-s64 current_micros(void);
+s64 current_micros();
void c_to_factor_toplevel(cell quot);
-void open_console(void);
+void open_console();
}
namespace factor
{
-s64 current_micros(void)
+s64 current_micros()
{
FILETIME t;
GetSystemTimeAsFileTime(&t);
- EPOCH_OFFSET) / 10;
}
-long exception_handler(PEXCEPTION_POINTERS pe)
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
if(in_code_heap_p(c->EIP))
- signal_callstack_top = (void *)c->ESP;
+ signal_callstack_top = (stack_frame *)c->ESP;
else
signal_callstack_top = NULL;
void c_to_factor_toplevel(cell quot)
{
- if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
+ if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
fatal_error("AddVectoredExceptionHandler failed", 0);
c_to_factor(quot);
- RemoveVectoredExceptionHandler((void*)exception_handler);
+ RemoveVectoredExceptionHandler((void *)exception_handler);
}
-void open_console(void)
+void open_console()
{
}
#define UNICODE
#endif
-#include <shellapi.h>
#include <windows.h>
+#include <shellapi.h>
namespace factor
{
#define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll"
+#define FACTOR_STDCALL __attribute__((stdcall))
+
void c_to_factor_toplevel(cell quot);
-long exception_handler(PEXCEPTION_POINTERS pe);
-void open_console(void);
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
+void open_console();
}
HMODULE hFactorDll;
-void init_ffi(void)
+void init_ffi()
{
hFactorDll = GetModuleHandle(FACTOR_DLL);
if(!hFactorDll)
void ffi_dlopen(dll *dll)
{
- dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
+ dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
}
void *ffi_dlsym(dll *dll, symbol_char *symbol)
{
- return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+ return (void *)GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
void ffi_dlclose(dll *dll)
}
/* You must free() this yourself. */
-const vm_char *default_image_path(void)
+const vm_char *default_image_path()
{
vm_char full_path[MAX_UNICODE_PATH];
vm_char *ptr;
}
/* You must free() this yourself. */
-const vm_char *vm_executable_path(void)
+const vm_char *vm_executable_path()
{
vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
PRIMITIVE(existsp)
{
- vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1);
+ vm_char *path = untag_check<byte_array>(dpop())->data<vm_char>();
box_boolean(windows_stat(path));
}
getpagesize(), PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (cell)mem);
- segment *block = safe_malloc(sizeof(segment));
+ segment *block = (segment *)safe_malloc(sizeof(segment));
block->start = (cell)mem + getpagesize();
block->size = size;
free(block);
}
-long getpagesize(void)
+long getpagesize()
{
static long g_pagesize = 0;
if (! g_pagesize)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
-void init_ffi(void);
+void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
void ffi_dlclose(dll *dll);
void sleep_micros(u64 msec);
-inline static void init_signals(void) {}
-inline static void early_init(void) {}
-const vm_char *vm_executable_path(void);
-const vm_char *default_image_path(void);
-long getpagesize (void);
+inline static void init_signals() {}
+inline static void early_init() {}
+const vm_char *vm_executable_path();
+const vm_char *default_image_path();
+long getpagesize ();
-s64 current_micros(void);
+s64 current_micros();
}
primitive_sleep,
primitive_tuple_boa,
primitive_callstack_to_array,
- primitive_innermost_stack_frame_quot,
+ primitive_innermost_stack_frame_executing,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_load_locals,
primitive_check_datastack,
primitive_inline_cache_miss,
+ primitive_inline_cache_miss_tail,
primitive_mega_cache_miss,
primitive_lookup_method,
primitive_reset_dispatch_stats,
bool profiling_p;
-void init_profiler(void)
+void init_profiler()
{
profiling_p = false;
}
{
extern bool profiling_p;
-void init_profiler(void);
+void init_profiler();
code_block *compile_profiling_stub(cell word);
PRIMITIVE(profiling);
{
if(stack_frame) emit(userenv[JIT_EPILOG]);
tail_call = true;
- word_jump(obj.value());
+ /* Inline cache misses are special-cased.
+ The calling convention for tail
+ calls stores the address of the next
+ instruction in a register. However,
+ PIC miss stubs themselves tail-call
+ the inline cache miss primitive, and
+ we don't want to clobber the saved
+ address. */
+ if(obj.value() == userenv[PIC_MISS_WORD]
+ || obj.value() == userenv[PIC_MISS_TAIL_WORD])
+ {
+ word_special(obj.value());
+ }
+ else
+ {
+ word_jump(obj.value());
+ }
}
else
word_call(obj.value());
/* Primitive calls */
if(primitive_call_p(i))
{
- emit(userenv[JIT_SAVE_STACK]);
emit_with(userenv[JIT_PRIMITIVE],obj.value());
i++;
jit_compile(array_nth(elements.untagged(),i + 1),relocate);
}
- emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i));
- emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1));
+ literal(array_nth(elements.untagged(),i));
+ literal(array_nth(elements.untagged(),i + 1));
+ emit(userenv[JIT_IF]);
i += 2;
void set_quot_xt(quotation *quot, code_block *code)
{
- if(code->block.type != QUOTATION_TYPE)
+ if(code->type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(cell)code);
quot->code = code;
drepl(allot_cell((cell)quot->xt));
}
-void compile_all_words(void)
+void compile_all_words()
{
gc_root<array> words(find_all_words());
PRIMITIVE(jit_compile);
-void compile_all_words(void);
+void compile_all_words();
PRIMITIVE(array_to_quotation);
PRIMITIVE(quotation_xt);
BREAK_ENV = 5, /* quotation called by throw primitive */
ERROR_ENV, /* a marker consed onto kernel errors */
- cell_SIZE_ENV = 7, /* sizeof(cell) */
+ CELL_SIZE_ENV = 7, /* sizeof(cell) */
CPU_ENV, /* CPU architecture */
OS_ENV, /* operating system name */
JIT_PRIMITIVE,
JIT_WORD_JUMP,
JIT_WORD_CALL,
+ JIT_WORD_SPECIAL,
JIT_IF_WORD,
- JIT_IF_1,
- JIT_IF_2,
- JIT_EPILOG = 33,
+ JIT_IF,
+ JIT_EPILOG,
JIT_RETURN,
JIT_PROFILING,
JIT_PUSH_IMMEDIATE,
- JIT_SAVE_STACK = 38,
JIT_DIP_WORD,
JIT_DIP,
JIT_2DIP_WORD,
JIT_EXECUTE_CALL,
/* Polymorphic inline cache generation in inline_cache.c */
- PIC_LOAD = 48,
+ PIC_LOAD = 47,
PIC_TAG,
PIC_HI_TAG,
PIC_TUPLE,
PIC_CHECK,
PIC_HIT,
PIC_MISS_WORD,
+ PIC_MISS_TAIL_WORD,
/* Megamorphic cache generation in dispatch.c */
MEGA_LOOKUP = 57,
#define FIRST_SAVE_ENV BOOT_ENV
#define LAST_SAVE_ENV STAGE2_ENV
+inline static bool save_env_p(cell i)
+{
+ return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_ENV;
+}
+
/* Canonical T object. It's just a word */
extern cell T;
cell end;
};
+inline static cell align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
}
#define DEFPUSHPOP(prefix,ptr) \
inline static cell prefix##peek() { return *(cell *)ptr; } \
inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
- inline static cell prefix##pop(void) \
+ inline static cell prefix##pop() \
{ \
cell value = prefix##peek(); \
ptr -= sizeof(cell); \
/* We don't use printf directly, because format directives are not portable.
Instead we define the common cases here. */
-void nl(void)
+void nl()
{
fputs("\n",stdout);
}
printf(FIXNUM_FORMAT,x);
}
-cell read_cell_hex(void)
+cell read_cell_hex()
{
cell cell;
if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
void *safe_malloc(size_t size);
vm_char *safe_strdup(const vm_char *str);
-void nl(void);
+void nl();
void print_string(const char *str);
void print_cell(cell x);
void print_cell_hex(cell x);
void print_cell_hex_pad(cell x);
void print_fixnum(fixnum x);
-cell read_cell_hex(void);
+cell read_cell_hex();
}
new_word->def = userenv[UNDEFINED_ENV];
new_word->props = F;
new_word->counter = tag_fixnum(0);
- new_word->direct_entry_def = F;
+ new_word->pic_def = F;
+ new_word->pic_tail_def = F;
new_word->subprimitive = F;
new_word->profiling = NULL;
new_word->code = NULL;
word *w = untag_check<word>(dpop());
code_block *code = (profiling_p ? w->profiling : w->code);
dpush(allot_cell((cell)code->xt()));
- dpush(allot_cell((cell)code + code->block.size));
+ dpush(allot_cell((cell)code + code->size));
}
/* Allocates memory */
inline bool word_optimized_p(word *word)
{
- return word->code->block.type == WORD_TYPE;
+ return word->code->type == WORD_TYPE;
}
PRIMITIVE(optimized_p);
cell cards_offset;
cell decks_offset;
-cell allot_markers_offset;
+
+namespace factor
+{
+ cell allot_markers_offset;
+}
the offset of the first object is set by the allocator. */
+VM_C_API factor::cell cards_offset;
+VM_C_API factor::cell decks_offset;
+
namespace factor
{
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+/* if card_points_to_nursery is set, card_points_to_aging must also be set. */
+static const cell card_points_to_nursery = 0x80;
+static const cell card_points_to_aging = 0x40;
+static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging);
typedef u8 card;
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-VM_C_API cell cards_offset;
+static const cell card_bits = 8;
+static const cell card_size = (1<<card_bits);
+static const cell addr_card_mask = (card_size-1);
inline static card *addr_to_card(cell a)
{
- return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
inline static cell card_to_addr(card *c)
{
- return ((cell)c - cards_offset) << CARD_BITS;
+ return ((cell)c - cards_offset) << card_bits;
}
inline static cell card_offset(card *c)
typedef u8 card_deck;
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
-
-VM_C_API cell decks_offset;
+static const cell deck_bits = (card_bits + 10);
+static const cell deck_size = (1<<deck_bits);
+static const cell addr_deck_mask = (deck_size-1);
inline static card_deck *addr_to_deck(cell a)
{
- return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
inline static cell deck_to_addr(card_deck *c)
{
- return ((cell)c - decks_offset) << DECK_BITS;
+ return ((cell)c - decks_offset) << deck_bits;
}
inline static card *deck_to_card(card_deck *d)
{
- return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
-#define INVALID_ALLOT_MARKER 0xff
+static const cell invalid_allot_marker = 0xff;
-VM_C_API cell allot_markers_offset;
+extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a)
{
- return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
inline static void write_barrier(object *obj)
{
- *addr_to_card((cell)obj) = CARD_MARK_MASK;
- *addr_to_deck((cell)obj) = CARD_MARK_MASK;
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
inline static void allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = ((cell)address & ADDR_CARD_MASK);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
}
}
projects / factor.git / commitdiff