Merge branch 'master' of /Users/slava/factor/
commit
75f03e9a18
19
README.txt
19
README.txt
|
@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
|
|||
|
||||
* Compiling the Factor VM
|
||||
|
||||
The Factor runtime is written in GNU C++, and is built with GNU make and
|
||||
gcc.
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org>.
|
||||
|
||||
Factor requires gcc 3.4 or later.
|
||||
|
||||
On x86, Factor /will not/ build using gcc 3.3 or earlier.
|
||||
|
||||
If you are using gcc 4.3, you might get an unusable Factor binary unless
|
||||
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
|
||||
arguments for make.
|
||||
The Factor VM is written in C++ and uses GNU extensions. When compiling
|
||||
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
|
||||
uses std::tr1::unordered_map which is shipped as part of GCC.
|
||||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
Once you have compiled the Factor runtime, you must bootstrap the Factor
|
||||
Once you have compiled the Factor VM, you must bootstrap the Factor
|
||||
system using the image that corresponds to your CPU architecture.
|
||||
|
||||
Boot images can be obtained from <http://factorcode.org/images/latest/>.
|
||||
|
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
|
|||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
|
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
|
|||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
vm/ - sources for the Factor VM, written in C++
|
||||
vm/ - Factor VM
|
||||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||
io.encodings.utf8 io.encodings.utf16n ;
|
||||
io.encodings.utf8 ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
@ -95,5 +95,4 @@ M: string-type c-type-setter
|
|||
|
||||
{ "char*" utf8 } "char*" typedef
|
||||
"char*" "uchar*" typedef
|
||||
{ "char*" utf16n } "wchar_t*" typedef
|
||||
|
||||
|
|
|
@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
|
|||
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
|
||||
(( value -- c-ptr )) define-inline ;
|
||||
|
||||
: c-bool> ( int -- ? )
|
||||
0 = not ; inline
|
||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||
|
||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||
|
||||
: define-primitive-type ( type name -- )
|
||||
[ typedef ]
|
||||
|
@ -409,10 +410,10 @@ CONSTANT: primitive-types
|
|||
"uchar" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
[ alien-unsigned-4 zero? not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
[ alien-unsigned-1 c-bool> ] >>getter
|
||||
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" define-primitive-type
|
||||
|
|
|
@ -5,7 +5,7 @@ IN: alien.libraries
|
|||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
||||
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
|
||||
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
||||
|
||||
SYMBOL: libraries
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ IN: base64.tests
|
|||
|
||||
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
|
||||
] unit-test
|
||||
[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
|
||||
|
|
|
@ -41,7 +41,7 @@ nl
|
|||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
roll -roll declare not
|
||||
not
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
|
|
|
@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs
|
|||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry ;
|
||||
fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
|
|||
|
||||
M: integer (eql?) = ;
|
||||
|
||||
M: float (eql?)
|
||||
over float? [ fp-bitwise= ] [ 2drop f ] if ;
|
||||
|
||||
M: sequence (eql?)
|
||||
over sequence? [
|
||||
2dup [ length ] bi@ =
|
||||
|
@ -93,24 +96,19 @@ CONSTANT: -1-offset 9
|
|||
|
||||
SYMBOL: sub-primitives
|
||||
|
||||
SYMBOL: jit-define-rc
|
||||
SYMBOL: jit-define-rt
|
||||
SYMBOL: jit-define-offset
|
||||
SYMBOL: jit-relocations
|
||||
|
||||
: compute-offset ( -- offset )
|
||||
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
: compute-offset ( rc -- offset )
|
||||
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
|
||||
: jit-rel ( rc rt -- )
|
||||
jit-define-rt set
|
||||
jit-define-rc set
|
||||
compute-offset jit-define-offset set ;
|
||||
over compute-offset 3array jit-relocations get push-all ;
|
||||
|
||||
: make-jit ( quot -- quad )
|
||||
: make-jit ( quot -- jit-data )
|
||||
[
|
||||
V{ } clone jit-relocations set
|
||||
call( -- )
|
||||
jit-define-rc get
|
||||
jit-define-rt get
|
||||
jit-define-offset get 3array
|
||||
jit-relocations get >array
|
||||
] B{ } make prefix ;
|
||||
|
||||
: jit-define ( quot name -- )
|
||||
|
@ -128,98 +126,59 @@ SYMBOL: big-endian
|
|||
! Bootstrap architecture name
|
||||
SYMBOL: architecture
|
||||
|
||||
! Bootstrap global namesapce
|
||||
SYMBOL: bootstrap-global
|
||||
RESET
|
||||
|
||||
! Boot quotation, set in stage1.factor
|
||||
SYMBOL: bootstrap-boot-quot
|
||||
USERENV: bootstrap-boot-quot 20
|
||||
|
||||
! Bootstrap global namesapce
|
||||
USERENV: bootstrap-global 21
|
||||
|
||||
! JIT parameters
|
||||
SYMBOL: jit-prolog
|
||||
SYMBOL: jit-primitive-word
|
||||
SYMBOL: jit-primitive
|
||||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dip-word
|
||||
SYMBOL: jit-dip
|
||||
SYMBOL: jit-2dip-word
|
||||
SYMBOL: jit-2dip
|
||||
SYMBOL: jit-3dip-word
|
||||
SYMBOL: jit-3dip
|
||||
SYMBOL: jit-execute-word
|
||||
SYMBOL: jit-execute-jump
|
||||
SYMBOL: jit-execute-call
|
||||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
SYMBOL: jit-profiling
|
||||
SYMBOL: jit-save-stack
|
||||
USERENV: jit-prolog 23
|
||||
USERENV: jit-primitive-word 24
|
||||
USERENV: jit-primitive 25
|
||||
USERENV: jit-word-jump 26
|
||||
USERENV: jit-word-call 27
|
||||
USERENV: jit-word-special 28
|
||||
USERENV: jit-if-word 29
|
||||
USERENV: jit-if 30
|
||||
USERENV: jit-epilog 31
|
||||
USERENV: jit-return 32
|
||||
USERENV: jit-profiling 33
|
||||
USERENV: jit-push-immediate 34
|
||||
USERENV: jit-dip-word 35
|
||||
USERENV: jit-dip 36
|
||||
USERENV: jit-2dip-word 37
|
||||
USERENV: jit-2dip 38
|
||||
USERENV: jit-3dip-word 39
|
||||
USERENV: jit-3dip 40
|
||||
USERENV: jit-execute-word 41
|
||||
USERENV: jit-execute-jump 42
|
||||
USERENV: jit-execute-call 43
|
||||
|
||||
! PIC stubs
|
||||
SYMBOL: pic-load
|
||||
SYMBOL: pic-tag
|
||||
SYMBOL: pic-hi-tag
|
||||
SYMBOL: pic-tuple
|
||||
SYMBOL: pic-hi-tag-tuple
|
||||
SYMBOL: pic-check-tag
|
||||
SYMBOL: pic-check
|
||||
SYMBOL: pic-hit
|
||||
SYMBOL: pic-miss-word
|
||||
USERENV: pic-load 47
|
||||
USERENV: pic-tag 48
|
||||
USERENV: pic-hi-tag 49
|
||||
USERENV: pic-tuple 50
|
||||
USERENV: pic-hi-tag-tuple 51
|
||||
USERENV: pic-check-tag 52
|
||||
USERENV: pic-check 53
|
||||
USERENV: pic-hit 54
|
||||
USERENV: pic-miss-word 55
|
||||
USERENV: pic-miss-tail-word 56
|
||||
|
||||
! Megamorphic dispatch
|
||||
SYMBOL: mega-lookup
|
||||
SYMBOL: mega-lookup-word
|
||||
SYMBOL: mega-miss-word
|
||||
USERENV: mega-lookup 57
|
||||
USERENV: mega-lookup-word 58
|
||||
USERENV: mega-miss-word 59
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenvs ( -- assoc )
|
||||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-primitive-word 24 }
|
||||
{ jit-primitive 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-save-stack 38 }
|
||||
{ jit-dip-word 39 }
|
||||
{ jit-dip 40 }
|
||||
{ jit-2dip-word 41 }
|
||||
{ jit-2dip 42 }
|
||||
{ jit-3dip-word 43 }
|
||||
{ jit-3dip 44 }
|
||||
{ jit-execute-word 45 }
|
||||
{ jit-execute-jump 46 }
|
||||
{ jit-execute-call 47 }
|
||||
{ pic-load 48 }
|
||||
{ pic-tag 49 }
|
||||
{ pic-hi-tag 50 }
|
||||
{ pic-tuple 51 }
|
||||
{ pic-hi-tag-tuple 52 }
|
||||
{ pic-check-tag 53 }
|
||||
{ pic-check 54 }
|
||||
{ pic-hit 55 }
|
||||
{ pic-miss-word 56 }
|
||||
{ mega-lookup 57 }
|
||||
{ mega-lookup-word 58 }
|
||||
{ mega-miss-word 59 }
|
||||
{ undefined-quot 60 }
|
||||
} ; inline
|
||||
USERENV: undefined-quot 60
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
userenvs at header-size + ;
|
||||
userenvs get at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
|
@ -351,7 +310,8 @@ M: f '
|
|||
[ vocabulary>> , ]
|
||||
[ def>> , ]
|
||||
[ props>> , ]
|
||||
[ direct-entry-def>> , ] ! direct-entry-def
|
||||
[ pic-def>> , ]
|
||||
[ pic-tail-def>> , ]
|
||||
[ drop 0 , ] ! count
|
||||
[ word-sub-primitive , ]
|
||||
[ drop 0 , ] ! xt
|
||||
|
@ -488,7 +448,6 @@ M: quotation '
|
|||
array>> '
|
||||
quotation [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
f ' emit ! cache-counter
|
||||
0 emit ! xt
|
||||
|
@ -510,11 +469,7 @@ M: quotation '
|
|||
class<=-cache class-not-cache classes-intersect-cache
|
||||
class-and-cache class-or-cache next-method-quot-cache
|
||||
} [ H{ } clone ] H{ } map>assoc assoc-union
|
||||
bootstrap-global set
|
||||
bootstrap-global emit-userenv ;
|
||||
|
||||
: emit-boot-quot ( -- )
|
||||
bootstrap-boot-quot emit-userenv ;
|
||||
bootstrap-global set ;
|
||||
|
||||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
|
@ -524,46 +479,13 @@ M: quotation '
|
|||
\ 3dip jit-3dip-word set
|
||||
\ (execute) jit-execute-word set
|
||||
\ inline-cache-miss \ pic-miss-word set
|
||||
\ inline-cache-miss-tail \ pic-miss-tail-word set
|
||||
\ mega-cache-lookup \ mega-lookup-word set
|
||||
\ mega-cache-miss \ mega-miss-word set
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-prolog
|
||||
jit-primitive-word
|
||||
jit-primitive
|
||||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-execute-word
|
||||
jit-execute-jump
|
||||
jit-execute-call
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
jit-save-stack
|
||||
pic-load
|
||||
pic-tag
|
||||
pic-hi-tag
|
||||
pic-tuple
|
||||
pic-hi-tag-tuple
|
||||
pic-check-tag
|
||||
pic-check
|
||||
pic-hit
|
||||
pic-miss-word
|
||||
mega-lookup
|
||||
mega-lookup-word
|
||||
mega-miss-word
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
[ undefined ] undefined-quot set ;
|
||||
|
||||
: emit-userenvs ( -- )
|
||||
userenvs get keys [ emit-userenv ] each ;
|
||||
|
||||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
@ -580,8 +502,8 @@ M: quotation '
|
|||
emit-jit-data
|
||||
"Serializing global namespace..." print flush
|
||||
emit-global
|
||||
"Serializing boot quotation..." print flush
|
||||
emit-boot-quot
|
||||
"Serializing user environment..." print flush
|
||||
emit-userenvs
|
||||
"Performing word fixups..." print flush
|
||||
fixup-words
|
||||
"Performing header fixups..." print flush
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel namespaces assocs words.symbol ;
|
||||
IN: bootstrap.image.syntax
|
||||
|
||||
SYMBOL: userenvs
|
||||
|
||||
SYNTAX: RESET H{ } clone userenvs set-global ;
|
||||
|
||||
SYNTAX: USERENV:
|
||||
CREATE-WORD scan-word
|
||||
[ swap userenvs get set-at ]
|
||||
[ drop define-symbol ]
|
||||
2bi ;
|
|
@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
|
|||
|
||||
SYMBOL: bootstrap-time
|
||||
|
||||
: strip-encodings ( -- )
|
||||
os unix? [
|
||||
[
|
||||
P" resource:core/io/encodings/utf16/utf16.factor"
|
||||
P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
|
||||
"io.encodings.utf16"
|
||||
"io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
|
||||
] with-compilation-unit
|
||||
] when ;
|
||||
|
||||
: default-image-name ( -- string )
|
||||
vm file-name os windows? [ "." split1-last drop ] when
|
||||
".image" append resource-path ;
|
||||
|
@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
|
|||
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
strip-encodings
|
||||
|
||||
(command-line) parse-command-line
|
||||
|
||||
! Set dll paths
|
||||
|
|
|
@ -9,6 +9,9 @@ SYMBOL: bytes-read
|
|||
: calculate-pad-length ( length -- length' )
|
||||
[ 56 < 55 119 ? ] keep - ;
|
||||
|
||||
: calculate-pad-length-long ( length -- length' )
|
||||
[ 120 < 119 247 ? ] keep - ;
|
||||
|
||||
: pad-last-block ( str big-endian? length -- str )
|
||||
[
|
||||
[ % ] 2dip HEX: 80 ,
|
||||
|
|
|
@ -1,7 +1,42 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
|
||||
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
|
||||
USING: arrays kernel math namespaces sequences tools.test
|
||||
checksums.sha2 checksums ;
|
||||
IN: checksums.sha2.tests
|
||||
|
||||
: test-checksum ( text identifier -- checksum )
|
||||
checksum-bytes hex-string ;
|
||||
|
||||
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
|
||||
[
|
||||
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
||||
sha-224 test-checksum
|
||||
] unit-test
|
||||
|
||||
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
|
||||
[ "" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
|
||||
[ "abc" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
|
||||
[ "message digest" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
|
||||
[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
|
||||
[
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
|
||||
sha-256 test-checksum
|
||||
] unit-test
|
||||
|
||||
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
|
||||
[
|
||||
"12345678901234567890123456789012345678901234567890123456789012345678901234567890"
|
||||
sha-256 test-checksum
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
|
||||
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
|
||||
|
|
|
@ -2,12 +2,27 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings ;
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
|
||||
<PRIVATE
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
TUPLE: sha2-long < sha2-state ;
|
||||
|
||||
TUPLE: sha-224-state < sha2-short ;
|
||||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
|
@ -18,13 +33,43 @@ CONSTANT: f 5
|
|||
CONSTANT: g 6
|
||||
CONSTANT: h 7
|
||||
|
||||
: initial-H-256 ( -- seq )
|
||||
CONSTANT: initial-H-224
|
||||
{
|
||||
HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
|
||||
HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-256
|
||||
{
|
||||
HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
|
||||
HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
|
||||
} ;
|
||||
}
|
||||
|
||||
: K-256 ( -- seq )
|
||||
CONSTANT: initial-H-384
|
||||
{
|
||||
HEX: cbbb9d5dc1059ed8
|
||||
HEX: 629a292a367cd507
|
||||
HEX: 9159015a3070dd17
|
||||
HEX: 152fecd8f70e5939
|
||||
HEX: 67332667ffc00b31
|
||||
HEX: 8eb44a8768581511
|
||||
HEX: db0c2e0d64f98fa7
|
||||
HEX: 47b5481dbefa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-512
|
||||
{
|
||||
HEX: 6a09e667f3bcc908
|
||||
HEX: bb67ae8584caa73b
|
||||
HEX: 3c6ef372fe94f82b
|
||||
HEX: a54ff53a5f1d36f1
|
||||
HEX: 510e527fade682d1
|
||||
HEX: 9b05688c2b3e6c1f
|
||||
HEX: 1f83d9abfb41bd6b
|
||||
HEX: 5be0cd19137e2179
|
||||
}
|
||||
|
||||
CONSTANT: K-256
|
||||
{
|
||||
HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
|
||||
HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
|
||||
|
@ -42,62 +87,163 @@ CONSTANT: h 7
|
|||
HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
|
||||
HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
|
||||
HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
|
||||
} ;
|
||||
}
|
||||
|
||||
CONSTANT: K-384
|
||||
{
|
||||
|
||||
HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
|
||||
HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
|
||||
HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
|
||||
HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
|
||||
HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
|
||||
HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
|
||||
HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
|
||||
HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
|
||||
HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
|
||||
HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
|
||||
HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
|
||||
HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
|
||||
HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
|
||||
HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
|
||||
HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
|
||||
HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
|
||||
HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
|
||||
HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
|
||||
HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
|
||||
HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
|
||||
}
|
||||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[ -7 bitroll-32 ] keep
|
||||
[ -18 bitroll-32 ] keep
|
||||
-3 shift bitxor bitxor ; inline
|
||||
[
|
||||
[ -7 bitroll-32 ]
|
||||
[ -18 bitroll-32 ]
|
||||
[ -3 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: s1-256 ( x -- x' )
|
||||
[ -17 bitroll-32 ] keep
|
||||
[ -19 bitroll-32 ] keep
|
||||
-10 shift bitxor bitxor ; inline
|
||||
|
||||
: process-M-256 ( seq n -- )
|
||||
[ 16 - swap nth ] 2keep
|
||||
[ 15 - swap nth s0-256 ] 2keep
|
||||
[ 7 - swap nth ] 2keep
|
||||
[ 2 - swap nth s1-256 ] 2keep
|
||||
[ + + w+ ] 2dip swap set-nth ; inline
|
||||
|
||||
: prepare-message-schedule ( seq -- w-seq )
|
||||
word-size get group [ be> ] map block-size get 0 pad-tail
|
||||
dup 16 64 dup <slice> [
|
||||
process-M-256
|
||||
] with each ;
|
||||
|
||||
: ch ( x y z -- x' )
|
||||
[ bitxor bitand ] keep bitxor ;
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
|
||||
[
|
||||
[ -17 bitroll-32 ]
|
||||
[ -19 bitroll-32 ]
|
||||
[ -10 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S0-256 ( x -- x' )
|
||||
[ -2 bitroll-32 ] keep
|
||||
[ -13 bitroll-32 ] keep
|
||||
-22 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -2 bitroll-32 ]
|
||||
[ -13 bitroll-32 ]
|
||||
[ -22 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S1-256 ( x -- x' )
|
||||
[ -6 bitroll-32 ] keep
|
||||
[ -11 bitroll-32 ] keep
|
||||
-25 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -6 bitroll-32 ]
|
||||
[ -11 bitroll-32 ]
|
||||
[ -25 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
|
||||
: s0-512 ( x -- x' )
|
||||
[
|
||||
[ -1 bitroll-64 ]
|
||||
[ -8 bitroll-64 ]
|
||||
[ -7 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T1 ( W n -- T1 )
|
||||
[ swap nth ] keep
|
||||
K get nth +
|
||||
e vars get slice3 ch +
|
||||
e vars get nth S1-256 +
|
||||
h vars get nth w+ ;
|
||||
: s1-512 ( x -- x' )
|
||||
[
|
||||
[ -19 bitroll-64 ]
|
||||
[ -61 bitroll-64 ]
|
||||
[ -6 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T2 ( -- T2 )
|
||||
a vars get nth S0-256
|
||||
a vars get slice3 maj w+ ;
|
||||
: S0-512 ( x -- x' )
|
||||
[
|
||||
[ -28 bitroll-64 ]
|
||||
[ -34 bitroll-64 ]
|
||||
[ -39 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: update-vars ( T1 T2 -- )
|
||||
vars get
|
||||
: S1-512 ( x -- x' )
|
||||
[
|
||||
[ -14 bitroll-64 ]
|
||||
[ -18 bitroll-64 ]
|
||||
[ -41 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: process-M-256 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-256 ]
|
||||
[ [ 7 - ] dip nth ]
|
||||
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
|
||||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: process-M-512 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-512 ]
|
||||
[ [ 7 - ] dip nth ]
|
||||
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
|
||||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: ch ( x y z -- x' )
|
||||
[ bitxor bitand ] keep bitxor ; inline
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c )
|
||||
[ dup 3 + ] dip <slice> first3 ; inline
|
||||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 128 mod calculate-pad-length-long 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-256 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-256 ( H -- T2 )
|
||||
[ a swap nth S0-256 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
:: T1-512 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-512 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-512 ( H -- T2 )
|
||||
[ a swap nth S0-512 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
: update-H ( T1 T2 H -- )
|
||||
h g pick exchange
|
||||
g f pick exchange
|
||||
f e pick exchange
|
||||
|
@ -105,42 +251,56 @@ CONSTANT: h 7
|
|||
d c pick exchange
|
||||
c b pick exchange
|
||||
b a pick exchange
|
||||
[ w+ a ] dip set-nth ;
|
||||
[ w+ a ] dip set-nth ; inline
|
||||
|
||||
: process-chunk ( M -- )
|
||||
H get clone vars set
|
||||
prepare-message-schedule block-size get [
|
||||
T1 T2 update-vars
|
||||
] with each vars get H get [ w+ ] 2map H set ;
|
||||
: prepare-message-schedule ( seq sha2 -- w-seq )
|
||||
[ word-size>> <sliced-groups> [ be> ] map ]
|
||||
[
|
||||
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
|
||||
'[ _ process-M-256 ] each
|
||||
] bi ; inline
|
||||
|
||||
: seq>byte-array ( n seq -- string )
|
||||
[ swap [ >be % ] curry each ] B{ } make ;
|
||||
:: process-chunk ( M block-size cloned-H sha2 -- )
|
||||
block-size [
|
||||
M cloned-H sha2 T1-256
|
||||
cloned-H T2-256
|
||||
cloned-H update-H
|
||||
] each
|
||||
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
|
||||
|
||||
: preprocess-plaintext ( string big-endian? -- padded-string )
|
||||
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
|
||||
[ >sbuf ] dip over [
|
||||
HEX: 80 ,
|
||||
dup length HEX: 3f bitand
|
||||
calculate-pad-length 0 <string> %
|
||||
length 3 shift 8 rot [ >be ] [ >le ] if %
|
||||
] "" make over push-all ;
|
||||
: sha2-steps ( sliced-groups state -- )
|
||||
'[
|
||||
_
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
|
||||
] each ;
|
||||
|
||||
: byte-array>sha2 ( byte-array -- string )
|
||||
t preprocess-plaintext
|
||||
block-size get group [ process-chunk ] each
|
||||
4 H get seq>byte-array ;
|
||||
: byte-array>sha2 ( bytes state -- )
|
||||
[ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
|
||||
[ sha2-steps ] bi ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-256 checksum
|
||||
M: sha-224 checksum-bytes
|
||||
drop <sha-224-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 7 head 4 seq>byte-array ] bi ;
|
||||
|
||||
M: sha-256 checksum-bytes
|
||||
drop [
|
||||
K-256 K set
|
||||
initial-H-256 H set
|
||||
4 word-size set
|
||||
64 block-size set
|
||||
byte-array>sha2
|
||||
] with-scope ;
|
||||
drop <sha-256-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 4 seq>byte-array ] bi ;
|
||||
|
|
|
@ -43,6 +43,11 @@ HELP: push-growing-circular
|
|||
{ "elt" object } { "circular" circular } }
|
||||
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
|
||||
|
||||
HELP: rotate-circular
|
||||
{ $values
|
||||
{ "circular" circular } }
|
||||
{ $description "Advances the start index of a circular object by one." } ;
|
||||
|
||||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
|
@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
|
|||
{ $subsection <growing-circular> }
|
||||
"Changing the start index:"
|
||||
{ $subsection change-circular-start }
|
||||
{ $subsection rotate-circular }
|
||||
"Pushing new elements:"
|
||||
{ $subsection push-circular }
|
||||
{ $subsection push-growing-circular } ;
|
||||
|
|
|
@ -12,6 +12,7 @@ circular strings ;
|
|||
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
|
||||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
|
|
@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
|
|||
#! change start to (start + n) mod length
|
||||
circular-wrap (>>start) ;
|
||||
|
||||
: rotate-circular ( circular -- )
|
||||
[ start>> 1 + ] keep circular-wrap (>>start) ;
|
||||
|
||||
: push-circular ( elt circular -- )
|
||||
[ set-first ] [ 1 swap change-circular-start ] bi ;
|
||||
|
||||
|
|
|
@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
|
|||
NSApplicationDelegateReplyFailure ;
|
||||
|
||||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool -> new slip -> release ; inline
|
||||
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
|
||||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler io kernel cocoa.runtime cocoa.subclassing
|
||||
cocoa.messages cocoa.types sequences words vocabs parser
|
||||
|
@ -27,22 +27,16 @@ SYMBOL: frameworks
|
|||
|
||||
frameworks [ V{ } clone ] initialize
|
||||
|
||||
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
|
||||
[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
|
||||
|
||||
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
|
||||
|
||||
SYNTAX: IMPORT: scan [ ] import-objc-class ;
|
||||
|
||||
"Compiling Objective C bridge..." print
|
||||
"Importing Cocoa classes..." print
|
||||
|
||||
"cocoa.classes" create-vocab drop
|
||||
|
||||
{
|
||||
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
|
||||
} [ words ] map concat compile
|
||||
|
||||
"Importing Cocoa classes..." print
|
||||
|
||||
[
|
||||
{
|
||||
"NSApplication"
|
||||
|
|
|
@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
|
|||
[ dup lookup-method ] dip
|
||||
[ make-prepare-send ] 2keep
|
||||
super-message-senders message-senders ? get at
|
||||
'[ _ call _ execute ] ;
|
||||
1quotation append ;
|
||||
|
||||
: send ( receiver args... selector -- return... ) f (send) ; inline
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
USING: strings arrays hashtables assocs sequences fry macros
|
||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||
combinators alien.c-types words core-foundation
|
||||
combinators alien.c-types words core-foundation quotations
|
||||
core-foundation.data core-foundation.utilities ;
|
||||
IN: cocoa.plists
|
||||
|
||||
|
@ -41,10 +41,16 @@ DEFER: plist>
|
|||
*void* [ -> release "read-plist failed" throw ] when* ;
|
||||
|
||||
MACRO: objc-class-case ( alist -- quot )
|
||||
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
|
||||
[
|
||||
dup callable?
|
||||
[ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
|
||||
unless
|
||||
] map '[ _ cond ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: invalid-plist-object object ;
|
||||
|
||||
: plist> ( plist -- value )
|
||||
{
|
||||
{ NSString [ (plist-NSString>) ] }
|
||||
|
@ -53,6 +59,7 @@ PRIVATE>
|
|||
{ NSArray [ (plist-NSArray>) ] }
|
||||
{ NSDictionary [ (plist-NSDictionary>) ] }
|
||||
{ NSObject [ ] }
|
||||
[ invalid-plist-object ]
|
||||
} objc-class-case ;
|
||||
|
||||
: read-plist ( path -- assoc )
|
||||
|
|
|
@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot )
|
|||
[ dup infer out>> ] dip
|
||||
'[ @ _ _ nsequence ] ;
|
||||
|
||||
: output>array ( quot -- newquot )
|
||||
{ } output>sequence ; inline
|
||||
MACRO: output>array ( quot -- newquot )
|
||||
'[ _ { } output>sequence ] ;
|
||||
|
||||
MACRO: input<sequence ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
|
@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
|
|||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
: sum-outputs ( quot -- n )
|
||||
[ + ] reduce-outputs ; inline
|
||||
MACRO: sum-outputs ( quot -- n )
|
||||
'[ _ [ + ] reduce-outputs ] ;
|
||||
|
||||
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
||||
[ dup infer out>> ] 2dip
|
||||
|
@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
|||
MACRO: append-outputs-as ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
|
||||
|
||||
: append-outputs ( quot -- seq )
|
||||
{ } append-outputs-as ; inline
|
||||
MACRO: append-outputs ( quot -- seq )
|
||||
'[ _ { } append-outputs-as ] ;
|
||||
|
|
|
@ -88,7 +88,7 @@ M: ##call generate-insn
|
|||
word>> dup sub-primitive>>
|
||||
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
|
@ -444,8 +444,7 @@ TUPLE: callback-context ;
|
|||
|
||||
: do-callback ( quot token -- )
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
[ 2 setenv call ] keep
|
||||
wait-to-return ; inline
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
|
|
|
@ -56,8 +56,11 @@ SYMBOL: literal-table
|
|||
: rel-word ( word class -- )
|
||||
[ add-literal ] dip rt-xt rel-fixup ;
|
||||
|
||||
: rel-word-direct ( word class -- )
|
||||
[ add-literal ] dip rt-xt-direct rel-fixup ;
|
||||
: rel-word-pic ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic rel-fixup ;
|
||||
|
||||
: rel-word-pic-tail ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||
|
|
|
@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
|||
} cond ;
|
||||
|
||||
: optimize? ( word -- ? )
|
||||
{
|
||||
[ predicate-engine-word? ]
|
||||
[ contains-breakpoints? ]
|
||||
[ single-generic? ]
|
||||
} 1|| not ;
|
||||
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
|
||||
|
||||
: contains-breakpoints? ( -- ? )
|
||||
dependencies get keys [ "break?" word-prop ] any? ;
|
||||
|
||||
: frontend ( word -- nodes )
|
||||
#! If the word contains breakpoints, don't optimize it, since
|
||||
#! the walker does not support this.
|
||||
dup optimize?
|
||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ]
|
||||
[ dup def>> deoptimize-with ]
|
||||
if ;
|
||||
dup optimize? [
|
||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
|
||||
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
|
||||
] [ dup def>> deoptimize-with ] if ;
|
||||
|
||||
: compile-dependency ( word -- )
|
||||
#! If a word calls an unoptimized word, try to compile the callee.
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays ;
|
||||
alien arrays literals sequences ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
@ -14,42 +14,42 @@ CONSTANT: deck-bits 18
|
|||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation 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? ;
|
||||
|
|
|
@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
|
|||
C{ 1.0 2.0 }
|
||||
C{ 1.5 1.0 } ffi_test_47
|
||||
] unit-test
|
||||
|
||||
! Reported by jedahu
|
||||
C-STRUCT: bool-field-test
|
||||
{ "char*" "name" }
|
||||
{ "bool" "on" }
|
||||
{ "short" "parents" } ;
|
||||
|
||||
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
||||
|
||||
[ 123 ] [
|
||||
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
|
||||
ffi_test_48
|
||||
] unit-test
|
|
@ -33,7 +33,7 @@ IN: compiler.tests.curry
|
|||
] unit-test
|
||||
|
||||
: foobar ( quot: ( -- ) -- )
|
||||
dup slip swap [ foobar ] [ drop ] if ; inline recursive
|
||||
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
|
||||
|
||||
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
|
||||
|
||||
|
|
|
@ -389,4 +389,26 @@ DEFER: loop-bbb
|
|||
|
||||
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
|
||||
! Modular arithmetic bug
|
||||
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
|
||||
|
||||
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
|
||||
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
|
||||
|
||||
! Optimizer needs to ignore invalid generics
|
||||
GENERIC# bad-dispatch-position-test* 3 ( -- )
|
||||
|
||||
M: object bad-dispatch-position-test* ;
|
||||
|
||||
: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
|
||||
|
||||
[ 1 2 3 4 bad-dispatch-position-test ] must-fail
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ bad-dispatch-position-test forget
|
||||
\ bad-dispatch-position-test* forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
|
@ -65,5 +65,3 @@ PRIVATE>
|
|||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
|
||||
] with-variable ;
|
||||
|
||||
: contains-breakpoints? ( word -- ? )
|
||||
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||
|
|
|
@ -302,7 +302,7 @@ C: <ro-box> ro-box
|
|||
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
|
||||
|
||||
: impeach-node ( quot: ( node -- ) -- )
|
||||
dup slip impeach-node ; inline recursive
|
||||
[ call ] keep impeach-node ; inline recursive
|
||||
|
||||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
|
|
@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
>fixnum 256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
|
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.def-use
|
||||
|
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
|||
: optimize->fixnum ( #call -- nodes )
|
||||
dup redundant->fixnum? [ drop f ] when ;
|
||||
|
||||
: optimize->integer ( #call -- nodes )
|
||||
dup out-d>> first actually-used-by dup length 1 = [
|
||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
||||
[ drop { } ] when
|
||||
] [ drop ] if ;
|
||||
|
||||
MEMO: fixnum-coercion ( flags -- nodes )
|
||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||
|
||||
|
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
|
|
@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
|
|||
|
||||
: inlining-standard-method ( #call word -- class/f method/f )
|
||||
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
|
||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||
[ swap nth value-info class>> dup ] dip
|
||||
specific-method
|
||||
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
|
||||
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
||||
[ swap nth value-info class>> dup ] dip
|
||||
specific-method
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: inline-standard-method ( #call word -- ? )
|
||||
|
@ -157,11 +159,7 @@ DEFER: (flat-length)
|
|||
] sum-outputs ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
{
|
||||
{ [ dup contains-breakpoints? ] [ 2drop f ] }
|
||||
{ [ dup "inline" word-prop ] [ 2drop t ] }
|
||||
[ inlining-rank 5 >= ]
|
||||
} cond ;
|
||||
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
||||
SYMBOL: history
|
||||
|
||||
|
|
|
@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
comparison-ops
|
||||
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
! generic-comparison-ops [
|
||||
! dup specific-comparison define-comparison-constraints
|
||||
! ] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
[ [ interval>> ] bi@ ] dip interval-comparison {
|
||||
|
@ -217,6 +213,8 @@ generic-comparison-ops [
|
|||
{ >float float }
|
||||
{ fixnum>float float }
|
||||
{ bignum>float float }
|
||||
|
||||
{ >integer integer }
|
||||
} [
|
||||
'[
|
||||
_
|
||||
|
@ -228,19 +226,26 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
rem
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
|
@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
! Mutable tuples with circularity should not cause problems
|
||||
TUPLE: circle me ;
|
||||
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
|
||||
! Joe found an oversight
|
||||
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
|
|
@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
|
|||
|
||||
! A more complicated example
|
||||
: impeach-node ( quot: ( node -- ) -- )
|
||||
dup slip impeach-node ; inline recursive
|
||||
[ call ] keep impeach-node ; inline recursive
|
||||
|
||||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
|
|
@ -105,6 +105,19 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
|
|||
|
||||
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
|
||||
|
||||
FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
|
||||
|
||||
FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
|
||||
FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
|
||||
|
||||
FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ;
|
||||
|
||||
FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
|
||||
|
||||
FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
|
||||
|
||||
FUNCTION: uint GetCurrentButtonState ( ) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bitmap-flags ( -- flags )
|
||||
|
|
|
@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
|
|||
TYPEDEF: uint CGBitmapInfo
|
||||
|
||||
TYPEDEF: int CGLError
|
||||
TYPEDEF: int CGError
|
||||
TYPEDEF: uint CGDirectDisplayID
|
||||
TYPEDEF: int boolean_t
|
||||
TYPEDEF: void* CGLContextObj
|
||||
TYPEDEF: int CGLContextParameter
|
||||
TYPEDEF: int CGLContextParameter
|
||||
|
|
|
@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
|
|||
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
HOOK: %call cpu ( word -- )
|
||||
HOOK: %jump cpu ( word -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
|
|
|
@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
|
|||
make vocabs sequences ;
|
||||
|
||||
: test-assembler ( expected quot -- )
|
||||
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
|
||||
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
|
||||
|
||||
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
|
||||
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
|
||||
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
|
||||
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
|
||||
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
|
||||
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
|
||||
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
|
||||
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
|
||||
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
|
||||
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
|
||||
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
|
||||
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
|
||||
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
|
||||
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
|
||||
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
|
||||
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
|
||||
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
|
||||
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
|
||||
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
|
||||
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
|
||||
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
|
||||
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
|
||||
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
|
||||
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
|
||||
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
|
||||
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
|
||||
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
|
||||
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
|
||||
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
|
||||
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
|
||||
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
|
||||
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
|
||||
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
|
||||
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
|
||||
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
|
||||
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
|
||||
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
|
||||
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
|
||||
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
|
||||
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
|
||||
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
|
||||
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
|
||||
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
|
||||
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
|
||||
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
|
||||
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
|
||||
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
|
||||
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
|
||||
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
|
||||
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
|
||||
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 B ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 BL ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 41810004 } [ 1 BGT ] test-assembler
|
||||
{ HEX: 40810004 } [ 1 BLE ] test-assembler
|
||||
{ HEX: 40800004 } [ 1 BGE ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 40820004 } [ 1 BNE ] test-assembler
|
||||
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
|
||||
{ HEX: 41830004 } [ 1 BO ] test-assembler
|
||||
{ HEX: 40830004 } [ 1 BNO ] test-assembler
|
||||
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
|
||||
{ HEX: 4e800020 } [ BLR ] test-assembler
|
||||
{ HEX: 4e800021 } [ BLRL ] test-assembler
|
||||
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
|
||||
{ HEX: 4e800420 } [ BCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
|
||||
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
|
||||
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
|
||||
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
|
||||
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
|
||||
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
|
||||
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
|
||||
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
|
||||
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
|
||||
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
|
||||
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
|
||||
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
|
||||
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
|
||||
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
|
||||
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
|
||||
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
|
||||
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
|
||||
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
|
||||
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
|
||||
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
|
||||
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
|
||||
B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
|
||||
B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
|
||||
B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
|
||||
B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
|
||||
B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
|
||||
B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
|
||||
B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
|
||||
B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
|
||||
B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
|
||||
B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
|
||||
B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
|
||||
B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
|
||||
B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
|
||||
B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
|
||||
B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
|
||||
B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
|
||||
B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
|
||||
B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
|
||||
B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
|
||||
B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
|
||||
B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
|
||||
B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
|
||||
B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
|
||||
B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
|
||||
B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
|
||||
B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
|
||||
B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
|
||||
B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
|
||||
B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
|
||||
B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup kernel namespaces words
|
||||
io.binary math math.order cpu.ppc.assembler.backend ;
|
||||
USING: kernel namespaces words io.binary math math.order
|
||||
cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup cpu.architecture
|
||||
compiler.constants kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer ;
|
||||
USING: kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer fry ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
|
||||
|
||||
: a-insn ( d a b c xo rc opcode -- )
|
||||
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
|
||||
|
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
|
|||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
SYNTAX: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ;
|
||||
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
|
||||
|
||||
SYNTAX: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ;
|
||||
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
|
||||
|
|
|
@ -9,8 +9,8 @@ IN: bootstrap.ppc
|
|||
4 \ cell set
|
||||
big-endian on
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
@ -21,46 +21,48 @@ CONSTANT: rs-reg 30
|
|||
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
11 6 profile-count-offset LWZ
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
11 3 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 6 profile-count-offset STW
|
||||
11 6 word-code-offset LWZ
|
||||
11 3 profile-count-offset STW
|
||||
11 3 word-code-offset LWZ
|
||||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
BCTR
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||
0 MFLR
|
||||
1 1 stack-frame SUBI
|
||||
6 1 xt-save STW
|
||||
stack-frame 6 LI
|
||||
6 1 next-save STW
|
||||
3 1 xt-save STW
|
||||
stack-frame 3 LI
|
||||
3 1 next-save STW
|
||||
0 1 lr-save stack-frame + STW
|
||||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
6 ds-reg 4 STWU
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
3 ds-reg 4 STWU
|
||||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
7 6 0 LWZ
|
||||
1 7 0 STW
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
6 MTCTR
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
4 3 0 LWZ
|
||||
1 4 0 STW
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
3 MTCTR
|
||||
BCTR
|
||||
] jit-primitive jit-define
|
||||
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
|
||||
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
@ -68,11 +70,8 @@ CONSTANT: rs-reg 30
|
|||
0 3 \ f tag-number CMPI
|
||||
2 BEQ
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
4 ds-reg 0 LWZ
|
||||
|
@ -138,6 +137,16 @@ CONSTANT: rs-reg 30
|
|||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
: prepare-(execute) ( -- operand )
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 ;
|
||||
|
||||
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
|
||||
|
||||
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
|
||||
|
||||
[
|
||||
0 1 lr-save stack-frame + LWZ
|
||||
1 1 stack-frame ADDI
|
||||
|
@ -146,7 +155,99 @@ CONSTANT: rs-reg 30
|
|||
|
||||
[ BLR ] jit-return jit-define
|
||||
|
||||
! Sub-primitives
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! Don't touch r6 here; it's used to pass the tail call site
|
||||
! address for tail PICs
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI ;
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 object tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 object tag-number neg LWZ
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 tuple tag-number neg bootstrap-cell + LWZ
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
0 4 BIN: 110 tag-fixnum CMPI
|
||||
5 BLT
|
||||
! Untag r3
|
||||
3 3 0 0 31 tag-bits get - RLWINM
|
||||
! Set r4 to 0 for objects, and bootstrap-cell for tuples
|
||||
4 4 1 tag-fixnum ANDI
|
||||
4 4 1 SRAWI
|
||||
! Load header cell or tuple layout cell
|
||||
4 4 3 LWZX
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 0 5 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
! key = class
|
||||
5 4 MR
|
||||
! key &= cache.length - 1
|
||||
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
|
||||
! cache += array-start-offset
|
||||
3 3 array-start-offset ADDI
|
||||
! cache += key
|
||||
3 3 5 ADD
|
||||
! if(get(cache) == class)
|
||||
6 3 0 LWZ
|
||||
6 0 4 CMP
|
||||
10 BNE
|
||||
! megamorphic_cache_hits++
|
||||
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
|
||||
5 4 0 LWZ
|
||||
5 5 1 ADDI
|
||||
5 4 0 STW
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
3 3 4 LWZ
|
||||
3 3 word-xt-offset LWZ
|
||||
3 MTCTR
|
||||
BCTR
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
||||
! Quotations and words
|
||||
[
|
||||
|
@ -157,14 +258,6 @@ CONSTANT: rs-reg 30
|
|||
BCTR
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR
|
||||
] \ (execute) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
|
@ -1,33 +1,39 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
alien alien.accessors alien.c-types literals cpu.architecture
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.units ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
! r2-r27: integer vregs
|
||||
! r28: integer scratch
|
||||
! r29: data stack
|
||||
! r30: retain stack
|
||||
! r2-r12: integer vregs
|
||||
! r15-r29
|
||||
! r30: integer scratch
|
||||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
! f30: float scratch
|
||||
|
||||
! Add some methods to the assembler that are useful to us
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
<<
|
||||
\ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop
|
||||
>>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
||||
{ double-float-regs $[ 0 29 [a,b] ] }
|
||||
} ;
|
||||
|
||||
CONSTANT: scratch-reg 28
|
||||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
|
|||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
|
@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
|
|||
factor-area-size +
|
||||
4 cells align ;
|
||||
|
||||
M: ppc %call ( label -- ) BL ;
|
||||
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
|
||||
|
||||
M: ppc %jump ( word -- )
|
||||
0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
|
||||
0 B rc-relative-ppc-3 rel-word-pic-tail ;
|
||||
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
|
@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
|
|||
BCTR ;
|
||||
|
||||
M: ppc %dispatch-label ( word -- )
|
||||
0 , rc-absolute-cell rel-word ;
|
||||
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- reg offset )
|
||||
temp slot obj ADD
|
||||
|
@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
|
|||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
13 3 MR ;
|
||||
15 3 MR ;
|
||||
|
||||
M: ppc %alien-indirect ( -- )
|
||||
13 MTLR BLRL ;
|
||||
15 MTLR BLRL ;
|
||||
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
@ -702,3 +713,14 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
|
||||
[
|
||||
<c-type>
|
||||
[ alien-unsigned-4 c-bool> ] >>getter
|
||||
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" define-primitive-type
|
||||
] with-compilation-unit
|
||||
|
|
|
@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
|
|||
M: x86.32 param-reg-1 EAX ;
|
||||
M: x86.32 param-reg-2 EDX ;
|
||||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants ;
|
||||
|
@ -26,10 +26,8 @@ IN: bootstrap.x86
|
|||
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
(JMP) drop rc-relative rt-primitive jit-rel
|
||||
! call the primitive
|
||||
0 JMP rc-relative rt-primitive jit-rel
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
|
|
|
@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
|
|||
M: x86.64 param-reg-2 int-regs param-regs second ;
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
|
||||
|
@ -25,9 +25,6 @@ IN: bootstrap.x86
|
|||
temp0 temp0 [] MOV
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
! load XT
|
||||
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||
! go
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cpu.architecture compiler.constants
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
|
@ -296,36 +295,23 @@ M: operand (MOV-I)
|
|||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: integer JMP HEX: e9 , 4, ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word-direct ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: integer CALL HEX: e8 , 4, ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
|
||||
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
|
||||
M: integer JUMPcc (JUMPcc) drop ;
|
||||
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
|
||||
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
|
|
|
@ -42,13 +42,18 @@ big-endian off
|
|||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
temp3 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
0 JMP rc-relative rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[
|
||||
f CALL rc-relative rt-xt-direct jit-rel
|
||||
0 CALL rc-relative rt-xt-pic jit-rel
|
||||
] jit-word-call jit-define
|
||||
|
||||
[
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-word-special jit-define
|
||||
|
||||
[
|
||||
! load boolean
|
||||
temp0 ds-reg [] MOV
|
||||
|
@ -57,13 +62,10 @@ big-endian off
|
|||
! compare boolean with f
|
||||
temp0 \ f tag-number CMP
|
||||
! jump to true branch if not equal
|
||||
f JNE rc-relative rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
! jump to false branch if equal
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
rs-reg bootstrap-cell ADD
|
||||
|
@ -115,19 +117,19 @@ big-endian off
|
|||
|
||||
[
|
||||
jit->r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-r>
|
||||
] jit-dip jit-define
|
||||
|
||||
[
|
||||
jit-2>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-2r>
|
||||
] jit-2dip jit-define
|
||||
|
||||
[
|
||||
jit-3>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
|
@ -152,8 +154,7 @@ big-endian off
|
|||
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! temp0 contains the object being dispatched on
|
||||
! temp1 contains its class
|
||||
! The PIC and megamorphic code stubs are not permitted to touch temp3.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
|
@ -197,7 +198,7 @@ big-endian off
|
|||
[
|
||||
! Untag temp0
|
||||
temp0 tag-mask get bitnot AND
|
||||
! Set temp1 to 0 for objects, and 8 for tuples
|
||||
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
|
||||
temp1 1 tag-fixnum AND
|
||||
bootstrap-cell 4 = [ temp1 1 SHR ] when
|
||||
! Load header cell or tuple layout cell
|
||||
|
@ -214,7 +215,7 @@ big-endian off
|
|||
temp1 temp2 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
|
@ -232,12 +233,13 @@ big-endian off
|
|||
temp0 temp2 ADD
|
||||
! if(get(cache) == class)
|
||||
temp0 [] temp1 CMP
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
[
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
] [ ] make
|
||||
[ length JNE ] [ % ] bi
|
||||
bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
|
|
|
@ -11,6 +11,10 @@ IN: cpu.x86
|
|||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
! Add some methods to the assembler to be more useful to the backend
|
||||
M: label JMP 0 JMP rc-relative label-fixup ;
|
||||
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
HOOK: param-reg-1 cpu ( -- reg )
|
||||
HOOK: param-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: pic-tail-reg cpu ( -- reg )
|
||||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
|
|||
reserved-area-size +
|
||||
align-stack ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
||||
|
||||
: xt-tail-pic-offset ( -- n )
|
||||
#! See the comment in vm/cpu-x86.hpp
|
||||
cell 4 + 1 + ; inline
|
||||
|
||||
M: x86 %jump ( word -- )
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
|
||||
0 JMP rc-relative rel-word-pic-tail ;
|
||||
|
||||
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
|
||||
|
||||
M: x86 %return ( -- ) 0 RET ;
|
||||
|
||||
: code-alignment ( align -- n )
|
||||
|
|
|
@ -15,6 +15,7 @@ $nl
|
|||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-filter }
|
||||
{ $subsection dlist-any? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
|
@ -40,6 +41,11 @@ HELP: dlist-find
|
|||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-filter
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
|
||||
{ $side-effects { "dlist" } } ;
|
||||
|
||||
HELP: dlist-any?
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
|
|
|
@ -79,3 +79,8 @@ IN: dlists.tests
|
|||
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
|
||||
|
||||
[ V{ } ] [ <dlist> dlist>seq ] unit-test
|
||||
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
|
|
|
@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-next drop
|
||||
next>>
|
||||
f over set-prev-when
|
||||
] change-front drop
|
||||
] keep
|
||||
|
@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-prev drop
|
||||
prev>>
|
||||
f over set-next-when
|
||||
] change-back drop
|
||||
] keep
|
||||
|
@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
|
|||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
: dlist-filter ( dlist quot -- dlist )
|
||||
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
|
||||
|
||||
M: dlist clone
|
||||
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
|
||||
|
||||
|
|
|
@ -57,7 +57,6 @@ $nl
|
|||
"Here are some built-in combinators rewritten in terms of fried quotations:"
|
||||
{ $table
|
||||
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
|
||||
{ { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
|
||||
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
|
||||
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
|
||||
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
|
||||
|
|
|
@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals
|
|||
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
|
||||
|
@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
: 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 ;
|
||||
|
||||
|
@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
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
|
||||
|
@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ;
|
|||
+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 ;
|
||||
|
@ -263,6 +298,22 @@ CONSTANT: pov-values
|
|||
[ 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
|
||||
|
@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard
|
|||
+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 ;
|
|
@ -3,7 +3,7 @@ sequences strings math ;
|
|||
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 }
|
||||
|
@ -18,17 +18,19 @@ ARTICLE: "game-input" "Game controller 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" } }
|
||||
|
@ -86,6 +88,14 @@ HELP: read-keyboard
|
|||
{ $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
|
||||
|
@ -121,6 +131,19 @@ HELP: keyboard-state
|
|||
{ $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"
|
|
@ -0,0 +1,8 @@
|
|||
IN: game-input.tests
|
||||
USING: ui game-input tools.test kernel system threads calendar ;
|
||||
|
||||
os windows? os macosx? or [
|
||||
[ ] [ open-game-input ] unit-test
|
||||
[ ] [ 1 seconds sleep ] unit-test
|
||||
[ ] [ close-game-input ] unit-test
|
||||
] when
|
|
@ -1,38 +1,61 @@
|
|||
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
|
||||
|
@ -48,12 +71,6 @@ SYMBOLS:
|
|||
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 )
|
||||
|
@ -63,15 +80,15 @@ HOOK: instance-id game-input-backend ( controller -- id )
|
|||
[ 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 ] }
|
|
@ -1,13 +1,15 @@
|
|||
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 )
|
||||
|
@ -23,9 +25,12 @@ iokit-game-input-backend game-input-backend set-global
|
|||
|
||||
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
|
||||
|
@ -46,6 +51,8 @@ CONSTANT: rz-axis-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 } }
|
||||
|
||||
|
@ -82,44 +89,54 @@ CONSTANT: hat-switch-matching-hash
|
|||
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
|
||||
{
|
||||
|
@ -132,34 +149,70 @@ 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 ]
|
||||
|
@ -194,12 +247,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
[ 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 )
|
||||
|
@ -209,15 +271,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
|
||||
: 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)
|
||||
|
@ -234,7 +301,7 @@ 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)
|
||||
|
@ -249,6 +316,7 @@ 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 ;
|
||||
|
|
@ -161,22 +161,6 @@ HELP: ndip
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link slip } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
{ { $link 2slip } { $snippet "2 nslip" } }
|
||||
{ { $link 3slip } { $snippet "3 nslip" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nkeep
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link keep } " that can work "
|
||||
|
@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
|||
|
||||
ARTICLE: "combinator-generalizations" "Generalized combinators"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
{ $subsection ncleave }
|
||||
|
|
|
@ -26,8 +26,6 @@ IN: generalizations.tests
|
|||
[ [ 1 ] 5 ndip ] must-infer
|
||||
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
|
|
|
@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
|
|||
MACRO: ndip ( quot n -- )
|
||||
[ '[ _ dip ] ] times ;
|
||||
|
||||
MACRO: nslip ( n -- )
|
||||
'[ [ call ] _ ndip ] ;
|
||||
|
||||
MACRO: nkeep ( quot n -- )
|
||||
tuck '[ _ ndup _ _ ndip ] ;
|
||||
|
||||
|
|
|
@ -87,7 +87,7 @@ PRIVATE>
|
|||
|
||||
: help-lint-all ( -- ) "" help-lint ;
|
||||
|
||||
: :lint-failures ( -- ) lint-failures get errors. ;
|
||||
: :lint-failures ( -- ) lint-failures get values errors. ;
|
||||
|
||||
: unlinked-words ( words -- seq )
|
||||
all-word-help [ article-parent not ] filter ;
|
||||
|
|
|
@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
|
|||
io.binary io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||
math.bitwise math.order math.parser pack prettyprint sequences
|
||||
strings math.vectors specialized-arrays.float ;
|
||||
strings math.vectors specialized-arrays.float locals ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
|
|||
software date-time photoshop exif-ifd sub-ifd inter-color-profile
|
||||
xmp iptc fill-order document-name page-number page-name
|
||||
x-position y-position host-computer copyright artist
|
||||
min-sample-value max-sample-value make model cell-width cell-length
|
||||
min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
|
||||
gray-response-unit gray-response-curve color-map threshholding
|
||||
image-description free-offsets free-byte-counts tile-width tile-length
|
||||
matteing data-type image-depth tile-depth
|
||||
|
@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
|
|||
|
||||
ERROR: no-tag class ;
|
||||
|
||||
: find-tag ( idf class -- tag )
|
||||
swap processed-tags>> ?at [ no-tag ] unless ;
|
||||
: find-tag* ( ifd class -- tag/class ? )
|
||||
swap processed-tags>> ?at ;
|
||||
|
||||
: tag? ( idf class -- tag )
|
||||
: find-tag ( ifd class -- tag )
|
||||
find-tag* [ no-tag ] unless ;
|
||||
|
||||
: tag? ( ifd class -- tag )
|
||||
swap processed-tags>> key? ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
|
@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 266 [ fill-order ] }
|
||||
{ 269 [ ascii decode document-name ] }
|
||||
{ 270 [ ascii decode image-description ] }
|
||||
{ 271 [ ascii decode make ] }
|
||||
{ 272 [ ascii decode model ] }
|
||||
{ 271 [ ascii decode tiff-make ] }
|
||||
{ 272 [ ascii decode tiff-model ] }
|
||||
{ 273 [ strip-offsets ] }
|
||||
{ 274 [ orientation ] }
|
||||
{ 277 [ samples-per-pixel ] }
|
||||
|
@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
{ 281 [ max-sample-value ] }
|
||||
{ 282 [ first x-resolution ] }
|
||||
{ 283 [ first y-resolution ] }
|
||||
{ 284 [ planar-configuration ] }
|
||||
{ 284 [ lookup-planar-configuration planar-configuration ] }
|
||||
{ 285 [ page-name ] }
|
||||
{ 286 [ x-position ] }
|
||||
{ 287 [ y-position ] }
|
||||
|
@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
|
|||
[ samples-per-pixel find-tag ] tri
|
||||
[ * ] keep
|
||||
'[
|
||||
_ group [ _ group [ rest ] [ first ] bi
|
||||
[ v+ ] accumulate swap suffix concat ] map
|
||||
_ group
|
||||
[ _ group unclip [ v+ ] accumulate swap suffix concat ] map
|
||||
concat >byte-array
|
||||
] change-bitmap ;
|
||||
|
||||
|
@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
|
|||
] with-tiff-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
|
||||
dup ifds>> [
|
||||
read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop
|
||||
] each ;
|
||||
: process-chunky-ifd ( ifd -- )
|
||||
read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop ;
|
||||
|
||||
: process-planar-ifd ( ifd -- )
|
||||
"planar ifd not supported" throw ;
|
||||
|
||||
: dispatch-planar-configuration ( ifd planar-configuration -- )
|
||||
{
|
||||
{ planar-configuration-chunky [ process-chunky-ifd ] }
|
||||
{ planar-configuration-planar [ process-planar-ifd ] }
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- )
|
||||
dup planar-configuration find-tag* [
|
||||
dispatch-planar-configuration
|
||||
] [
|
||||
drop "no planar configuration" throw
|
||||
] if ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- )
|
||||
ifds>> [ process-ifd ] each ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
[ load-tiff-ifds ] [
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
] with-file-reader
|
||||
] bi ;
|
||||
[ load-tiff-ifds dup ] keep
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
! tiff files can store several images -- we just take the first for now
|
||||
M: tiff-image load-image* ( path tiff-image -- image )
|
||||
|
|
|
@ -173,10 +173,11 @@ M: stdin refill
|
|||
size-read-fd <fd> init-fd <input-port> >>size
|
||||
data-read-fd <fd> >>data ;
|
||||
|
||||
M: unix (init-stdio)
|
||||
M: unix init-stdio
|
||||
<stdin> <input-port>
|
||||
1 <fd> <output-port>
|
||||
2 <fd> <output-port> t ;
|
||||
2 <fd> <output-port>
|
||||
set-stdio ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
|
|
@ -1,9 +1,9 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.ports io.timeouts
|
||||
io.backend.windows io.files.windows io.files.windows.nt io.files
|
||||
io.pathnames io.buffers io.streams.c libc kernel math namespaces
|
||||
sequences threads windows windows.errors windows.kernel32
|
||||
strings splitting ascii system accessors locals ;
|
||||
USING: alien alien.c-types arrays assocs combinators continuations
|
||||
destructors io io.backend io.ports io.timeouts io.backend.windows
|
||||
io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
|
||||
io.streams.c io.streams.null libc kernel math namespaces sequences
|
||||
threads windows windows.errors windows.kernel32 strings splitting
|
||||
ascii system accessors locals ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.backend.windows.nt
|
||||
|
||||
|
@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
|
|||
|
||||
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
|
||||
|
||||
M: winnt (init-stdio)
|
||||
console-app? [ init-c-stdio t ] [ f f f f ] if ;
|
||||
M: winnt init-stdio
|
||||
console-app?
|
||||
[ init-c-stdio ]
|
||||
[ null-reader null-writer null-writer set-stdio ] if ;
|
||||
|
||||
winnt set-io-backend
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
IN: io.backend.windows.privileges.tests
|
||||
USING: io.backend.windows.privileges tools.test ;
|
||||
|
||||
[ [ ] with-privileges ] must-infer
|
|
@ -1,12 +1,13 @@
|
|||
USING: io.backend kernel continuations sequences
|
||||
system vocabs.loader combinators ;
|
||||
system vocabs.loader combinators fry ;
|
||||
IN: io.backend.windows.privileges
|
||||
|
||||
HOOK: set-privilege io-backend ( name ? -- ) inline
|
||||
HOOK: set-privilege io-backend ( name ? -- )
|
||||
|
||||
: with-privileges ( seq quot -- )
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
|
||||
[ '[ _ [ t set-privilege ] each @ ] ]
|
||||
[ drop '[ _ [ f set-privilege ] each ] ]
|
||||
2bi [ ] cleanup ; inline
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }
|
||||
|
|
|
@ -20,7 +20,7 @@ DEFER: copy-tree-into
|
|||
{
|
||||
{ +symbolic-link+ [ copy-link ] }
|
||||
{ +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] }
|
||||
[ drop copy-file ]
|
||||
[ drop copy-file-and-info ]
|
||||
} case ;
|
||||
|
||||
: copy-tree-into ( from to -- )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations ;
|
||||
USING: help.markup help.syntax kernel quotations sequences ;
|
||||
IN: io.directories.search
|
||||
|
||||
HELP: each-file
|
||||
|
@ -57,6 +57,32 @@ HELP: find-all-in-directories
|
|||
}
|
||||
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
|
||||
|
||||
HELP: find-by-extension
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "extension" "a file extension" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: io.directories.search ;"
|
||||
"\"/\" \".mp3\" find-by-extension"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: find-by-extensions
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: io.directories.search ;"
|
||||
"\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
|
||||
|
||||
ARTICLE: "io.directories.search" "Searching directories"
|
||||
|
@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories"
|
|||
{ $subsection recursive-directory-files }
|
||||
{ $subsection recursive-directory-entries }
|
||||
{ $subsection each-file }
|
||||
"Finding files:"
|
||||
"Finding files by name:"
|
||||
{ $subsection find-file }
|
||||
{ $subsection find-all-files }
|
||||
{ $subsection find-in-directories }
|
||||
{ $subsection find-all-in-directories } ;
|
||||
{ $subsection find-all-in-directories }
|
||||
"Finding files by extension:"
|
||||
{ $subsection find-by-extension }
|
||||
{ $subsection find-by-extensions } ;
|
||||
|
||||
ABOUT: "io.directories.search"
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays continuations deques dlists fry
|
||||
io.directories io.files io.files.info io.pathnames kernel
|
||||
sequences system vocabs.loader locals math namespaces
|
||||
sorting assocs calendar threads io math.parser ;
|
||||
sorting assocs calendar threads io math.parser unicode.case ;
|
||||
IN: io.directories.search
|
||||
|
||||
: qualified-directory-entries ( path -- seq )
|
||||
|
@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
|
|||
] { } map>assoc
|
||||
] with-qualified-directory-entries sort-values ;
|
||||
|
||||
: find-by-extensions ( path extensions -- seq )
|
||||
[ >lower ] map
|
||||
'[ >lower _ [ tail? ] with any? ] find-all-files ;
|
||||
|
||||
: find-by-extension ( path extension -- seq )
|
||||
1array find-by-extensions ;
|
||||
|
||||
os windows? [ "io.directories.search.windows" require ] when
|
||||
|
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types io.directories.unix kernel system unix ;
|
||||
IN: io.directories.unix.linux
|
||||
|
||||
M: unix find-next-file ( DIR* -- byte-array )
|
||||
"dirent" <c-object>
|
||||
f <void*>
|
||||
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
|
||||
*void* [ drop f ] unless ;
|
|
@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
|
|||
continuations destructors fry io io.backend io.backend.unix
|
||||
io.directories io.encodings.binary io.encodings.utf8 io.files
|
||||
io.pathnames io.files.types kernel math.bitwise sequences system
|
||||
unix unix.stat ;
|
||||
unix unix.stat vocabs.loader ;
|
||||
IN: io.directories.unix
|
||||
|
||||
: touch-mode ( -- n )
|
||||
|
@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
|
|||
[ opendir dup [ (io-error) ] unless ] dip
|
||||
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
|
||||
|
||||
: find-next-file ( DIR* -- byte-array )
|
||||
HOOK: find-next-file os ( DIR* -- byte-array )
|
||||
|
||||
M: unix find-next-file ( DIR* -- byte-array )
|
||||
"dirent" <c-object>
|
||||
f <void*>
|
||||
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
|
||||
|
@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
|
|||
} case ;
|
||||
|
||||
M: unix >directory-entry ( byte-array -- directory-entry )
|
||||
[ dirent-d_name utf8 alien>string ]
|
||||
[ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
|
||||
{
|
||||
[ dirent-d_name utf8 alien>string ]
|
||||
[ dirent-d_type dirent-type>file-type ]
|
||||
} cleave directory-entry boa ;
|
||||
|
||||
M: unix (directory-entries) ( path -- seq )
|
||||
[
|
||||
|
@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
|
|||
[ >directory-entry ]
|
||||
produce nip
|
||||
] with-unix-directory ;
|
||||
|
||||
os linux? [ "io.directories.unix.linux" require ] when
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel system sequences combinators
|
||||
vocabs.loader io.files.types ;
|
||||
vocabs.loader io.files.types io.directories math ;
|
||||
IN: io.files.info
|
||||
|
||||
! File info
|
||||
|
@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
|
|||
|
||||
: directory? ( file-info -- ? ) type>> +directory+ = ;
|
||||
|
||||
: sparse-file? ( file-info -- ? )
|
||||
[ size-on-disk>> ] [ size>> ] bi < ;
|
||||
|
||||
! File systems
|
||||
HOOK: file-systems os ( -- array )
|
||||
|
||||
|
@ -26,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info )
|
|||
{ [ os unix? ] [ "io.files.info.unix." os name>> append ] }
|
||||
{ [ os windows? ] [ "io.files.info.windows" ] }
|
||||
} cond require
|
||||
|
||||
HOOK: copy-file-and-info os ( from to -- )
|
||||
|
||||
M: object copy-file-and-info copy-file ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors kernel system math math.bitwise strings arrays
|
||||
sequences combinators combinators.short-circuit alien.c-types
|
||||
vocabs.loader calendar calendar.unix io.files.info
|
||||
io.files.types io.backend unix unix.stat unix.time unix.users
|
||||
io.files.types io.backend io.directories unix unix.stat unix.time unix.users
|
||||
unix.groups ;
|
||||
IN: io.files.info.unix
|
||||
|
||||
|
@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001
|
|||
: file-permissions ( path -- n )
|
||||
normalize-path file-info permissions>> ;
|
||||
|
||||
M: unix copy-file-and-info ( from to -- )
|
||||
[ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: make-timeval-array ( array -- byte-array )
|
||||
|
|
|
@ -35,6 +35,9 @@ SYMBOL: unique-retries
|
|||
: random-name ( -- string )
|
||||
unique-length get [ random-ch ] "" replicate-as ;
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- )
|
||||
swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
: (make-unique-file) ( path prefix suffix -- path )
|
||||
'[
|
||||
_ _ _ random-name glue append-path
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system kernel namespaces strings hashtables sequences
|
||||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors environment
|
||||
io io.encodings.ascii io.backend io.timeouts io.pipes
|
||||
io.pipes.private io.encodings io.streams.duplex io.ports
|
||||
debugger prettyprint summary calendar ;
|
||||
USING: system kernel namespaces strings hashtables sequences assocs
|
||||
combinators vocabs.loader init threads continuations math accessors
|
||||
concurrency.flags destructors environment io io.encodings.ascii
|
||||
io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
|
||||
summary calendar ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
@ -254,6 +254,21 @@ M: object run-pipeline-element
|
|||
swap [ with-stream ] dip
|
||||
wait-for-success ; inline
|
||||
|
||||
ERROR: output-process-error { output string } { process process } ;
|
||||
|
||||
M: output-process-error error.
|
||||
[ "Process:" print process>> . nl ]
|
||||
[ "Output:" print output>> print ]
|
||||
bi ;
|
||||
|
||||
: try-output-process ( command -- )
|
||||
>process
|
||||
+stdout+ >>stderr
|
||||
+closed+ >>stdin
|
||||
utf8 <process-reader*>
|
||||
[ stream-contents ] [ dup wait-for-process ] bi*
|
||||
0 = [ 2drop ] [ output-process-error ] if ;
|
||||
|
||||
: notify-exit ( process status -- )
|
||||
>>status
|
||||
[ processes get delete-at* drop [ resume ] each ] keep
|
||||
|
|
|
@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
|
|||
try-process
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ "" ] [
|
||||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
|
|
|
@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
+stdout+ >>stderr
|
||||
ascii [ input-stream get contents ] with-process-reader
|
||||
ascii [ contents ] with-process-reader
|
||||
] unit-test
|
||||
|
||||
: launcher-test-path ( -- str )
|
||||
|
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "stderr.factor" 3array >>command
|
||||
"err2.txt" temp-file >>stderr
|
||||
ascii <process-reader> lines first
|
||||
ascii <process-reader> stream-lines first
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
|
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
+replace-environment+ >>environment-mode
|
||||
os-envs >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"A" swap at
|
||||
|
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "USERPROFILE" "XXX" } } >>environment
|
||||
+prepend-environment+ >>environment-mode
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"USERPROFILE" swap at "XXX" =
|
||||
|
|
|
@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
|
|||
tools.test ;
|
||||
IN: io.streams.string.tests
|
||||
|
||||
[ "" ] [ "" [ contents ] with-string-reader ] unit-test
|
||||
|
||||
[ "line 1" CHAR: l ]
|
||||
[
|
||||
"line 1\nline 2\nline 3" <string-reader>
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue