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

Merge git://factorcode.org/git/factor

release
Doug Coleman 2007-10-24 01:21:59 -05:00
parent ac002af5fa 850c145a09
commit 8493de2d67
152 changed files with 2411 additions and 1041 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/compiler/compiler.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system math.functions
inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ;

2
core/alien/structs/structs.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
alien.c-types math.functions math.vectors cpu.architecture ;
alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )

3
core/arrays/arrays-tests.factor Normal file → Executable file
View File

@ -1,6 +1,5 @@
USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math math.functions
vectors.private ;
tools.test vectors layouts system math vectors.private ;
IN: temporary
[ -2 { "a" "b" "c" } nth ] unit-test-fails

82
core/bootstrap/compiler/compiler.factor Normal file → Executable file
View File

@ -5,48 +5,46 @@ hashtables.private sequences.private math tuples.private
growable namespaces.private alien.remote-control assocs
words generator command-line vocabs io prettyprint libc ;
"bootstrap.math" vocab [
"cpu." cpu append require
"cpu." cpu append require
global [ { "compiler" } add-use ] bind
global [ { "compiler" } add-use ] bind
"-no-stack-traces" cli-args member? [
f compiled-stack-traces set-global
] when
! Compile a set of words ahead of our general
! compile-all. This set of words was determined
! semi-empirically using the profiler. It improves
! bootstrap time significantly, because frequenly
! called words which are also quick to compile
! are replaced by compiled definitions as soon as
! possible.
{
roll -roll declare not
tuple-class-eq? array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth
wrap probe
delegate
underlying
find-pair-next namestack*
bitand bitor bitxor bitnot
+ 1+ 1- 2/ < <= > >= shift min
new nth push pop peek hashcode* = get set
. lines
malloc free memcpy
} [ compile ] each
[ recompile ] parse-hook set-global
"-no-stack-traces" cli-args member? [
f compiled-stack-traces set-global
] when
! Compile a set of words ahead of our general
! compile-all. This set of words was determined
! semi-empirically using the profiler. It improves
! bootstrap time significantly, because frequenly
! called words which are also quick to compile
! are replaced by compiled definitions as soon as
! possible.
{
roll -roll declare not
tuple-class-eq? array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth
wrap probe
delegate
underlying
find-pair-next namestack*
bitand bitor bitxor bitnot
+ 1+ 1- 2/ < <= > >= shift min
new nth push pop peek hashcode* = get set
. lines
malloc free memcpy
} [ compile ] each
[ recompile ] parse-hook set-global

4
core/bootstrap/image/image.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
splitting growable math.functions classes tuples words.private
splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
combinators.private combinators ;
@ -160,7 +160,7 @@ GENERIC: ' ( obj -- ptr )
{ } unfold ;
: emit-bignum ( n -- )
[ 0 < 1 0 ? ] keep abs bignum>seq
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
swap emit emit-seq ;

1
core/bootstrap/stage1.factor Normal file → Executable file
View File

@ -23,6 +23,7 @@ vocabs.loader system ;
\ boot ,
"math.integers" require
"math.floats" require
"memory" require
"io.streams.c" require
"vocabs.loader" require

17
core/bootstrap/stage2.factor Normal file → Executable file
View File

@ -19,11 +19,14 @@ IN: bootstrap.stage2
parse-command-line
"Cross-referencing..." print flush
H{ } clone changed-words set-global
H{ } clone crossref set-global
xref-words
xref-sources
all-words [ dup ] H{ } map>assoc changed-words set-global
"-no-crossref" cli-args member? [
"Cross-referencing..." print flush
H{ } clone crossref set-global
xref-words
xref-sources
] unless
! Set dll paths
wince? [ "windows.ce" require ] when
@ -34,12 +37,10 @@ IN: bootstrap.stage2
] [
"listener" require
"none" require
"listener" use+
] if
[
! Compile everything if compiler is loaded
all-words [ changed-word ] each
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] 2apply
seq-diff

1
core/bootstrap/syntax.factor Normal file → Executable file
View File

@ -20,7 +20,6 @@ f swap set-vocab-source-loaded?
"B{"
"C:"
"CHAR:"
"C{"
"DEFER:"
"F{"
"FORGET:"

4
core/compiler/test/curry.factor Normal file → Executable file
View File

@ -7,8 +7,8 @@ IN: temporary
[ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test
[ 1/3 ] [ 5 2 [ [ - ] 2curry 1 swap call / ] compile-1 ] unit-test
[ 1/3 ] [ 5 2 [ [ - ] 2curry >r 1 r> call / ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test
[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test

4
core/compiler/test/ifte.factor Normal file → Executable file
View File

@ -33,12 +33,12 @@ math.private combinators ;
: dead-code-rec
t [
C{ 3 2 }
3.2
] [
dead-code-rec
] if ;
[ C{ 3 2 } ] [ dead-code-rec ] unit-test
[ 3.2 ] [ dead-code-rec ] unit-test
: one-rec [ f one-rec ] [ "hi" ] if ;

23
core/compiler/test/intrinsics.factor Normal file → Executable file
View File

@ -1,11 +1,10 @@
IN: temporary
USING: arrays compiler kernel kernel.private math
math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays
strings.private system random math.vectors layouts
vectors.private sbufs.private strings.private slots.private
alien alien.c-types alien.syntax namespaces libc math.constants
math.functions ;
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien alien.c-types
alien.syntax namespaces libc ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-1 ] unit-test
@ -327,9 +326,13 @@ cell 8 = [
[ 500 <byte-array> length ] compile-1
] unit-test
[ C{ 1 2 } ] [ 1 2 [ <complex> ] compile-1 ] unit-test
[ 1 2 ] [
1 2 [ <complex> ] compile-1 dup real swap imaginary
] unit-test
[ 1/2 ] [ 1 2 [ <ratio> ] compile-1 ] unit-test
[ 1 2 ] [
1 2 [ <ratio> ] compile-1 dup numerator swap denominator
] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-1 ] unit-test
@ -412,8 +415,8 @@ cell 8 = [
[ t ] [ pi <double> [ { byte-array } declare *double ] compile-1 pi = ] unit-test
! Silly
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - abs 0.001 < ] unit-test
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test
[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test

16
core/compiler/test/optimizer.factor Normal file → Executable file
View File

@ -208,10 +208,6 @@ M: slice foozul ;
[ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test
[ 5 ] [ 5 [ 1 / ] compile-1 ] unit-test
[ 1/5 ] [ 5 [ 1 swap / ] compile-1 ] unit-test
[ -5 ] [ 5 [ -1 / ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
@ -246,8 +242,6 @@ M: slice foozul ;
[ t ] [ 5 [ dup number= ] compile-1 ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
[ 3 ] [ 10/3 [ { ratio } declare 1 /i ] compile-1 ] unit-test
GENERIC: detect-number ( obj -- obj )
M: number detect-number ;
@ -275,7 +269,11 @@ USE: sorting.private
] unit-test
! Regression
[ 1 2 { real imaginary } ] [
C{ 1 2 }
[ { real imaginary } [ get-slots ] keep ] compile-1
TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-1
] unit-test

4
core/compiler/test/stack-trace.factor Normal file → Executable file
View File

@ -27,8 +27,8 @@ words splitting ;
[ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
] unit-test
[ f t ] [
[ { C{ 1 2 } } bleh ] catch drop
[ t f ] [
[ { "hi" } bleh ] catch drop
\ + stack-trace-contains?
\ > stack-trace-contains?
] unit-test

39
core/compiler/test/templates.factor Normal file → Executable file
View File

@ -1,9 +1,9 @@
! Black box testing of templating optimization
USING: arrays compiler kernel kernel.private math
hashtables.private math.private math.ratios.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private combinators.private byte-arrays alien layouts ;
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
combinators.private byte-arrays alien layouts ;
IN: temporary
! Oops!
@ -37,41 +37,14 @@ unit-test
: foo ;
[ 4 4 ]
[ 1/2 [ tag [ foo ] keep ] compile-1 ]
[ 5 5 ]
[ 1.2 [ tag [ foo ] keep ] compile-1 ]
unit-test
[ 1 2 2 ]
[ 1/2 [ dup 1 slot swap 2 slot [ foo ] keep ] compile-1 ]
[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-1 ]
unit-test
[ 41 5 4 ] [
5/4 4/5 [
dup ratio? [
over ratio? [
2dup 2>fraction >r * swap r> * swap
+ -rot denominator swap denominator
] [
2drop f f f
] if
] [
2drop f f f
] if
] compile-1
] unit-test
: jxyz
over bignum? [
dup ratio? [
[ >fraction ] 2apply swapd
>r 2array swap r> 2array swap
] when
] when ;
\ jxyz compile
[ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test
[ 3 ]
[
global [ 3 \ foo set ] bind

2
core/cpu/arm5/intrinsics/intrinsics.factor → core/cpu/arm/4/4.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations
byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private
strings.private ;
IN: cpu.arm5.intrinsics
IN: cpu.arm4
: (%char-slot)
"out" operand string-offset MOV

0
core/cpu/arm5/authors.txt → core/cpu/arm/4/authors.txt
View File

1
core/cpu/arm/4/summary.txt Normal file
View File

@ -0,0 +1 @@
Additional compiler intrinsics for ARM4

69
core/cpu/arm/allot/allot.factor Normal file → Executable file
View File

@ -1,49 +1,46 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.architecture cpu.arm.assembler
cpu.arm.architecture namespaces math math.functions sequences
cpu.arm.architecture namespaces math sequences
generator generator.registers generator.fixup system layouts
alien ;
IN: cpu.arm.allot
: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
: object@ "allot-tmp" operand swap cells <+> ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
#! nursery in allot-tmp.
#! nursery in R11
8 align ! align the size
R12 load-zone-ptr ! nusery -> r12
"allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp
"allot-tmp" operand dup pick ADD ! increment allot-tmp
"allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here
"allot-tmp" operand dup rot SUB ! old value
R11 R12 cell <+> LDR ! nursery.here -> r11
R11 R11 pick ADD ! increment r11
R11 R12 cell <+> STR ! r11 -> nursery.here
R11 R11 rot SUB ! old value
R12 swap type-number tag-header MOV ! compute header
R12 0 object@ STR ! store header
R12 R11 0 <+> STR ! store header
;
: %tag-allot ( tag -- )
"allot-tmp" operand dup rot tag-number ORR
"allot-tmp" get fresh-object ;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand R11 r> tag-number ORR ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
bignum over 3 + cells %allot
R12 swap 1+ v>operand MOV ! compute the length
R12 1 object@ STR ! store the length
R12 R11 cell <+> STR ! store the length
;
: %allot-bignum-signed-1 ( reg -- )
: %allot-bignum-signed-1 ( dst src -- )
#! on entry, reg is a 30-bit quantity sign-extended to
#! 32-bits.
#! exits with tagged ptr to bignum in allot-tmp.
#! exits with tagged ptr to bignum in reg.
[
"end" define-label
! is it zero?
dup v>operand 0 CMP
0 >bignum "allot-tmp" operand EQ load-indirect
0 >bignum pick EQ load-literal
"end" get EQ B
! ! it is non-zero
1 %allot-bignum
@ -56,29 +53,27 @@ IN: cpu.arm.allot
! positive sign
R12 0 GE MOV
! store sign
R12 2 object@ STR
R12 R11 2 cells <+> STR
! store the number
v>operand 3 object@ STR
v>operand R11 3 cells <+> STR
! tag the bignum, store it in reg
bignum %tag-allot
bignum %store-tagged
"end" resolve-label
] with-scope ;
: %allot-alien ( ptr -- )
#! Tagged pointer to alien is in allot-tmp on exit.
[
"temp" set
"end" define-label
"temp" operand 0 CMP
"allot-tmp" operand f v>operand EQ MOV
"end" get EQ B
alien 4 cells %allot
"temp" operand 2 object@ STR
"temp" operand f v>operand MOV
"temp" operand 1 object@ STR
"temp" operand 0 MOV
"temp" operand 3 object@ STR
! Store tagged ptr in reg
object %tag-allot
"end" resolve-label
] with-scope ;
M: arm-backend %box-alien ( dst src -- )
"end" define-label
dup v>operand 0 CMP
over v>operand f v>operand EQ MOV
"end" get EQ B
alien 4 cells %allot
! Store offset
v>operand R11 3 cells <+> STR
R12 f v>operand MOV
! Store expired slot
R12 R11 1 cells <+> STR
! Store underlying-alien slot
R12 R11 2 cells <+> STR
! Store tagged ptr in reg
object %store-tagged
"end" resolve-label ;

169
core/cpu/arm/architecture/architecture.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays cpu.arm.assembler compiler
kernel kernel.private math math.functions namespaces words
kernel kernel.private math namespaces words
words.private generator.registers generator.fixup generator
cpu.architecture system layouts ;
IN: cpu.arm.architecture
@ -9,8 +9,8 @@ IN: cpu.arm.architecture
TUPLE: arm-backend ;
! ARM register assignments:
! R0, R1, R2, R3 integer vregs
! R12 temporary
! R0-R4, R7-R10 integer vregs
! R11, R12 temporary
! R5 data stack
! R6 retain stack
! R7 primitives
@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ;
M: int-regs return-reg drop R0 ;
M: int-regs param-regs drop { R0 R1 R2 R3 } ;
M: int-regs vregs drop { R0 R1 R2 R3 } ;
M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ;
! No FPU support yet
M: float-regs param-regs drop { } ;
@ -44,15 +44,27 @@ M: immediate load-literal
v>operand load-indirect
] if ;
M: arm-backend stack-frame ( n -- i ) 4 + 8 align ;
: lr-save ( n -- i ) cell - ;
: next-save ( n -- i ) 2 cells - ;
: xt-save ( n -- i ) 3 cells - ;
: factor-area-size 5 cells ;
M: arm-backend stack-frame ( n -- i )
factor-area-size + 8 align ;
M: arm-backend %save-xt ( -- )
R12 PC 8 SUB ;
M: arm-backend %prologue ( n -- )
LR SP 4 <-> STR
SP SP rot stack-frame SUB ;
SP SP pick SUB
R11 over MOV
R11 SP pick next-save <+> STR
R12 SP pick xt-save <+> STR
LR SP rot lr-save <+> STR ;
M: arm-backend %epilogue ( n -- )
SP SP rot stack-frame ADD
LR SP 4 <-> LDR ;
LR SP pick lr-save <+> LDR
SP SP rot ADD ;
: compile-dlsym ( symbol dll reg -- )
[
@ -83,26 +95,29 @@ M: arm-backend %profiler-prologue ( word -- )
R0 R12 profile-count-offset <+> STR
"end" resolve-label ;
: primitive-addr ( word dst -- )
#! Load a word address into dst.
R7 rot word-primitive cells <+> LDR ;
M: arm-backend %call-label ( label -- ) BL ;
M: arm-backend %call ( label -- )
#! Far C call for primitives, near C call for compiled defs.
dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ;
M: arm-backend %jump-label ( label -- ) B ;
M: arm-backend %jump-label ( label -- )
#! For tail calls. IP not saved on C stack.
#! WARNING: don't clobber LR here!
dup primitive? [ PC primitive-addr ] [ B ] if ;
: %prepare-primitive ( word -- )
#! Save stack pointer to stack_chain->callstack_top, load XT
R1 SP MOV
T{ temp-reg } load-literal
R12 R12 word-xt-offset <+> LDR ;
M: arm-backend %call-primitive ( word -- )
%prepare-primitive R12 BLX ;
M: arm-backend %jump-primitive ( word -- )
%prepare-primitive R12 BX ;
M: arm-backend %jump-t ( label -- )
"flag" operand object tag-number CMP NE B ;
"flag" operand f v>operand CMP NE B ;
: (%dispatch) ( word-table# reg -- )
#! Load jump table target address into reg.
"n" operand PC "n" operand 1 <LSR> ADD
"n" operand 0 <+> LDR
"scratch" operand PC "n" operand 1 <LSR> ADD
"scratch" operand 0 <+> LDR
rc-indirect-arm rel-dispatch ;
M: arm-backend %call-dispatch ( word-table# -- )
@ -112,7 +127,6 @@ M: arm-backend %call-dispatch ( word-table# -- )
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "n" } }
} with-template ;
M: arm-backend %jump-dispatch ( word-table# -- )
@ -121,21 +135,16 @@ M: arm-backend %jump-dispatch ( word-table# -- )
PC (%dispatch)
] H{
{ +input+ { { f "n" } } }
{ +clobber+ { "n" } }
{ +scratch+ { { f "scratch" } } }
} with-template ;
M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
M: arm-backend %unwind drop %return ;
: (%peek/replace)
>r drop >r v>operand r> loc>operand r> execute ;
M: arm-backend %peek >r v>operand r> loc>operand LDR ;
M: int-regs (%peek) \ LDR (%peek/replace) ;
M: int-regs (%replace) \ STR (%peek/replace) ;
M: arm-backend %move-int>int ( dst src -- )
[ v>operand ] 2apply MOV ;
M: arm-backend %replace >r v>operand r> loc>operand STR ;
: (%inc) ( n reg -- )
dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
@ -215,11 +224,13 @@ M: arm-backend %box-small-struct ( size -- )
R2 swap MOV
"box_small_struct" f %alien-invoke ;
: temp@ stack-frame* factor-area-size - swap - ;
: struct-return@ ( size n -- n )
[
stack-frame* +
] [
stack-frame* swap - cell -
stack-frame* factor-area-size - swap -
] ?if ;
M: arm-backend %prepare-box-struct ( size -- )
@ -239,6 +250,15 @@ M: arm-backend %box-large-struct ( n size -- )
M: arm-backend struct-small-enough? ( size -- ? )
wince? [ drop f ] [ 4 <= ] if ;
M: arm-backend %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f R12 %alien-global
SP R12 0 <+> STR
ds-reg R12 8 <+> STR
rs-reg R12 12 <+> STR ;
M: arm-backend %alien-invoke ( symbol dll -- )
! Load target address
R12 PC 4 <+> LDR
@ -249,15 +269,13 @@ M: arm-backend %alien-invoke ( symbol dll -- )
! The target address
0 , rc-absolute rel-dlsym ;
: temp@ SP stack-frame* 2 cells - <+> ;
M: arm-backend %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
R0 temp@ STR ;
R0 SP cell temp@ <+> STR ;
M: arm-backend %alien-indirect ( -- )
IP temp@ LDR
IP BLX ;
R12 SP cell temp@ <+> LDR
R12 BLX ;
M: arm-backend %alien-callback ( quot -- )
R0 load-indirect
@ -266,11 +284,11 @@ M: arm-backend %alien-callback ( quot -- )
M: arm-backend %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
R0 temp@ STR
R0 SP cell temp@ <+> STR
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place former top of data stack in R0
R0 temp@ LDR
R0 SP cell temp@ <+> LDR
! Unbox R0
unbox-return ;
@ -291,37 +309,50 @@ M: long-long-type c-type-stack-align? drop wince? not ;
M: arm-backend fp-shadows-int? ( -- ? ) f ;
! Alien intrinsics
: add-alien-offset "offset" operand tag-bits get <ASR> ADD ;
M: arm-backend %unbox-byte-array ( dst src -- )
[ v>operand ] 2apply byte-array-offset ADD ;
: (%unbox-alien) <+> roll call ; inline
M: arm-backend %unbox-alien ( dst src -- )
[ v>operand ] 2apply alien-offset <+> LDR ;
M: arm-backend %unbox-byte-array ( quot src -- )
"address" operand "alien" operand add-alien-offset
"address" operand alien-offset (%unbox-alien) ;
M: arm-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: arm-backend %unbox-alien ( quot src -- )
"address" operand "alien" operand alien-offset <+> LDR
"address" operand dup add-alien-offset
"address" operand 0 (%unbox-alien) ;
M: arm-backend %unbox-f ( quot src -- )
"offset" operand dup %untag-fixnum
"offset" operand 0 (%unbox-alien) ;
M: arm-backend %complex-alien-accessor ( quot src -- )
"is-f" define-label
"is-alien" define-label
M: arm-backend %unbox-any-c-ptr ( dst src -- )
#! We need three registers here. R11 and R12 are reserved
#! temporary registers. The third one is R14, which we have
#! to save/restore.
"end" define-label
"alien" operand f v>operand CMP
"is-f" get EQ B
"address" operand "alien" operand header-offset neg <-> LDR
"address" operand alien type-number tag-header CMP
"is-alien" get EQ B
[ %unbox-byte-array ] 2keep
"end" get B
"is-alien" resolve-label
[ %unbox-alien ] 2keep
"end" get B
"is-f" resolve-label
%unbox-f
"end" resolve-label ;
"start" define-label
! Save R14.
R14 SP 4 <-> STR
! Address is computed in R11
R11 0 MOV
! Load object into R12
R12 swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
R12 f v>operand CMP
! If so, done
"end" get EQ B
! Is the object an alien?
R14 R12 header-offset <+/-> LDR
R14 alien type-number tag-header CMP
! Add byte array address to address being computed
R11 R11 R12 NE ADD
! Add an offset to start of byte array's data area
R11 R11 byte-array-offset NE ADD
"end" get NE B
! If alien, load the offset
R14 R12 alien-offset <+/-> LDR
! Add it to address being computed
R11 R11 R14 ADD
! Now recurse on the underlying alien
R12 R12 underlying-alien-offset <+/-> LDR
"start" get B
"end" resolve-label
! Done, store address in destination register
v>operand R11 MOV
! Restore R14.
R14 SP 4 <-> LDR ;

50
core/cpu/arm/arm.factor Normal file → Executable file
View File

@ -1,7 +1,9 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math namespaces
cpu.architecture cpu.arm.architecture cpu.arm.intrinsics
generator generator.registers continuations compiler io
vocabs.loader ;
cpu.architecture cpu.arm.architecture cpu.arm.assembler
cpu.arm.intrinsics generator generator.registers continuations
compiler io vocabs.loader sequences ;
! EABI passes floats in integer registers.
[ alien-float ]
@ -24,27 +26,29 @@ vocabs.loader ;
T{ arm-backend } compiler-backend set-global
: (detect-arm5) ;
\ (detect-arm5) [
! The LDRH word is defined in the module we conditionally
! load below...
! R0 PC 0 <+> LDRH
HEX: e1df00b0 ,
] H{
{ +scratch+ { { 0 "scratch" } } }
} define-intrinsic
: detect-arm5 (detect-arm5) ;
: arm5? ( -- ? ) [ detect-arm5 ] catch not ;
! We don't auto-detect since that would require us to support
! illegal instruction traps. This works on Linux but not on
! Windows CE.
"arm-variant" get [
\ detect-arm5 compile
"Detecting ARM architecture variant..." print
arm5? "arm5" "arm3" ? "arm-variant" set
] unless
"ARM variant: " write "arm-variant" get print
] [
"==========" print
"You should specify the -arm-variant=<variant> switch." print
"<variant> can be one of arm3, arm4, arm4t, or arm5." print
"Assuming arm3." print
"==========" print
"arm3" "arm-variant" set-global
] if
"ARM architecture variant: " write "arm-variant" get print
"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
"cpu.arm.4" require
] when
"arm-variant" "arm5" = [ "cpu.arm5" require ] when
"arm-variant" get { "arm4t" "arm5" } member? [
t have-BX? set-global
] when
"arm-variant" get "arm5" = [
t have-BLX? set-global
] when

76
core/cpu/arm/assembler/assembler.factor Normal file → Executable file
View File

@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words
namespaces math math.bitfields ;
IN: cpu.arm.assembler
SYMBOL: arm-variant
: define-registers ( seq -- )
dup length [ "register" set-word-prop ] 2each ;
@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
: STR 0 0 addr2 ;
: STRB 1 0 addr2 ;
HOOK: BX arm-variant ( operand -- )
HOOK: BLX arm-variant ( operand -- )
! We might have to simulate these instructions since older ARM
! chips don't have them.
M: f BX PC swap MOV ;
SYMBOL: have-BX?
SYMBOL: have-BLX?
M: f BLX LR PC MOV BX ;
GENERIC# (BX) 1 ( Rm l -- )
M: register (BX) ( Rm l -- )
{
{ 1 24 }
{ 1 21 }
{ BIN: 1111 16 }
{ BIN: 1111 12 }
{ BIN: 1111 8 }
5
{ 1 4 }
{ register 0 }
} insn ;
M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
! More load and store instructions
GENERIC: addressing-mode-3 ( addressing-mode -- n )
: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
M: addressing addressing-mode-3
[ addressing-p ] keep
[ addressing-u ] keep
[ addressing-w ] keep
delegate addressing-mode-3
{ 0 21 23 24 } bitfield ;
M: integer addressing-mode-3
b>n/n {
! { 1 24 }
{ 1 22 }
{ 1 7 }
{ 1 4 }
0
8
} bitfield ;
M: object addressing-mode-3
shifter-op {
! { 1 24 }
{ 1 7 }
{ 1 4 }
0
} bitfield ;
: addr3 ( Rn Rd addressing-mode h l s -- )
{
6
20
5
{ addressing-mode-3 0 }
{ register 16 }
{ register 12 }
} insn ;
: LDRH 1 1 0 addr3 ;
: LDRSB 0 1 1 addr3 ;
: LDRSH 1 1 1 addr3 ;
: STRH 1 0 0 addr3 ;
! Load and store multiple instructions

117
core/cpu/arm/bootstrap.factor Normal file → Executable file
View File

@ -1,4 +1,119 @@
USING: bootstrap.image.private kernel namespaces system ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.arm.assembler math layouts words vocabs ;
IN: bootstrap.arm
! We generate ARM3 code
f have-BX? set
4 \ cell set
big-endian off
4 jit-code-format set
: ds-reg R5 ;
: word-reg R0 ;
: quot-reg R0 ;
: scan-reg R2 ;
: temp-reg R3 ;
: xt-reg R12 ;
: stack-frame 16 bootstrap-cells ;
: next-save stack-frame 2 bootstrap-cells - ;
: xt-save stack-frame 3 bootstrap-cells - ;
: array-save stack-frame 4 bootstrap-cells - ;
: scan-save stack-frame 5 bootstrap-cells - ;
[
temp-reg quot-reg quot-array@ <+> LDR ! load array
scan-reg temp-reg scan@ ADD ! initialize scan pointer
] { } make jit-setup set
[
LR SP 4 <-> STR ! save return address
SP SP stack-frame SUB
xt-reg SP xt-save <+> STR ! save XT
xt-reg stack-frame MOV
xt-reg SP next-save <+> STR ! save frame size
temp-reg SP array-save <+> STR ! save array
] { } make jit-prolog set
[
temp-reg scan-reg 4 <!+> LDR ! load literal and advance
temp-reg ds-reg 4 <!+> STR ! push literal
] { } make jit-push-literal set
[
temp-reg scan-reg 4 <!+> LDR ! load wrapper and advance
temp-reg dup wrapper@ <+> LDR ! load wrapped object
temp-reg ds-reg 4 <!+> STR ! push wrapped object
] { } make jit-push-wrapper set
[
R1 SP 4 SUB ! pass stack pointer to primitive
] { } make jit-word-primitive-jump set
[
R1 SP 4 SUB ! pass stack pointer to primitive
] { } make jit-word-primitive-call set
: load-word-xt ( -- )
word-reg scan-reg 4 <!+> LDR ! load word and advance
xt-reg word-reg word-xt@ <+> LDR ;
: jit-call
scan-reg SP scan-save <+> STR ! save scan pointer
LR PC MOV ! save return address
xt-reg BX ! call
scan-reg SP scan-save <+> LDR ! restore scan pointer
;
: jit-jump
xt-reg BX ;
[ load-word-xt jit-call ] { } make jit-word-call set
[ load-word-xt jit-jump ] { } make jit-word-jump set
: load-quot-xt
xt-reg quot-reg quot-xt@ <+> LDR ;
: load-branch
temp-reg ds-reg 4 <-!> LDR ! pop boolean
temp-reg \ f tag-number CMP ! compare it with f
quot-reg scan-reg MOV ! point quot-reg at false branch
quot-reg dup 4 EQ ADD ! point quot-reg at true branch
quot-reg dup 4 <+> LDR ! load the branch
scan-reg dup 12 ADD ! advance scan pointer
load-quot-xt
;
[
load-branch jit-jump
] { } make jit-if-jump set
[
load-branch jit-call
] { } make jit-if-call set
[
temp-reg ds-reg 4 <-!> LDR ! pop index
temp-reg dup 1 <LSR> MOV ! turn it into an array offset
scan-reg dup 4 <+> LDR ! load array
temp-reg dup scan-reg ADD ! compute quotation location
quot-reg temp-reg array-start <+> LDR ! load quotation
load-quot-xt
jit-jump
] { } make jit-dispatch set
[
SP SP stack-frame ADD ! pop stack frame
LR SP 4 <-> LDR ! load return address
] { } make jit-epilog set
[ LR BX ] { } make jit-return set
"bootstrap.arm" forget-vocab

260
core/cpu/arm/intrinsics/intrinsics.factor Normal file → Executable file
View File

@ -2,40 +2,58 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.architecture cpu.arm.assembler
cpu.arm.architecture cpu.arm.allot kernel kernel.private math
math.functions math.private namespaces sequences words
math.private namespaces sequences words
quotations byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private sbufs
sbufs.private vectors vectors.private system tuples.private
layouts strings.private slots.private ;
IN: cpu.arm.intrinsics
: %slot-literal-known-tag
"val" operand
"obj" operand
"n" get cells
"obj" get operand-tag - <+/-> ;
: %slot-literal-any-tag
"scratch" operand "obj" operand %untag
"val" operand "scratch" operand "n" get cells <+> ;
: %slot-any
"scratch" operand "obj" operand %untag
"n" operand dup 1 <LSR> MOV
"val" operand "scratch" operand "n" operand <+> ;
\ slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag LDR ] H{
{ +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number is literal
{
[
"out" operand "obj" operand %untag
"out" operand dup "n" get cells <+> LDR
] H{
[ %slot-literal-any-tag LDR ] H{
{ +input+ { { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +scratch+ { { f "scratch" } { f "val" } } }
{ +output+ { "val" } }
}
}
! Slot number in a register
{
[
"out" operand "obj" operand %untag
"out" operand dup "n" operand 1 <LSR> <+> LDR
] H{
[ %slot-any LDR ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +scratch+ { { f "val" } { f "scratch" } } }
{ +output+ { "val" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics
: generate-write-barrier ( -- )
"val" operand-immediate? "obj" get fresh-object? or [
: %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [
"cards_offset" f R12 %alien-global
"scratch" operand R12 "scratch" operand card-bits <LSR> ADD
"val" operand "scratch" operand 0 LDRB
@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics
] unless ;
\ set-slot {
! Slot number is literal and tag is known
{
[ %slot-literal-known-tag STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" } }
}
}
! Slot number is literal
{
[
"scratch" operand "obj" operand %untag
"val" operand "scratch" operand "n" get cells <+> STR
generate-write-barrier
] H{
[ %slot-literal-any-tag STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" } }
@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics
}
! Slot number is in a register
{
[
"scratch" operand "obj" operand %untag
"n" operand "scratch" operand "n" operand 1 <LSR> ADD
"val" operand "n" operand 0 STR
generate-write-barrier
] H{
[ %slot-any STR %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" "n" } }
@ -135,19 +152,19 @@ IN: cpu.arm.intrinsics
: overflow-check ( insn -- )
[
"end" define-label
[ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep
[ "out" operand "x" operand "y" operand roll S execute ] keep
"end" get VC B
{ "x" "y" } %untag-fixnums
"x" operand "x" operand "y" operand roll execute
"x" get %allot-bignum-signed-1
"out" get "x" get %allot-bignum-signed-1
"end" resolve-label
] with-scope ; inline
: overflow-template ( word insn -- )
[ overflow-check ] curry H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic ;
@ -156,12 +173,12 @@ IN: cpu.arm.intrinsics
\ fixnum>bignum [
"x" operand dup %untag-fixnum
"x" get %allot-bignum-signed-1
"out" get "x" get %allot-bignum-signed-1
] H{
{ +input+ { { f "x" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +scratch+ { { f "out" } } }
{ +clobber+ { "x" } }
{ +output+ { "allot-tmp" } }
{ +output+ { "out" } }
} define-intrinsic
\ bignum>fixnum [
@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics
} define-intrinsic
\ type [
! Get the tag
"out" operand "obj" operand tag-mask get AND
! Compare with object tag number (3).
"out" operand object tag-number CMP
! Tag the tag if it is not equal to 3
"out" operand dup NE %tag-fixnum
! Load the object header if tag is equal to 3
"out" operand "obj" operand object tag-number <-> EQ LDR
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ class-hash [
"end" define-label
! Get the tag
"y" operand "obj" operand tag-mask get AND
"out" operand "obj" operand tag-mask get AND
! Compare with tuple tag number (2).
"out" operand tuple tag-number CMP
"out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
"out" operand dup class-hash-offset <+/-> EQ LDR
"end" get EQ B
! Compare with object tag number (3).
"y" operand object tag-number CMP
! Tag the tag if it is not equal to 3
"x" operand "y" operand NE %tag-fixnum
! Jump to end if it is not equal to 3
"end" get NE B
! Is the pointer itself equal to 3? Then its F_TYPE (9).
"obj" operand object tag-number CMP
! Load F_TYPE (9) if it is equal
"x" operand f type v>operand EQ MOV
! Load the object header if it is not equal
"x" operand "obj" operand object tag-number <-> NE LDR
! Turn the header into a fixnum
"x" operand dup NE %untag
"out" operand object tag-number CMP
"out" operand "obj" operand object tag-number <-> EQ LDR
! Tag the tag
"out" operand dup NE %tag-fixnum
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: userenv ( reg -- )
@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
: %set-slot "allot-tmp" operand swap cells <+> STR ;
: %set-slot R11 swap cells <+> STR ;
: %store-length
R12 "n" operand MOV
@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics
! Zero out the rest of the tuple
R12 f v>operand MOV
"n" get 1- [ 1+ R12 %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "class" } { [ inline-array? ] "n" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <array> [
@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics
%store-length
! Store initial element
"n" get [ "initial" operand %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { [ inline-array? ] "n" } { f "initial" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <byte-array> [
@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics
! Store initial element
R12 0 MOV
"n" get cell align cell /i [ R12 %fill-array ] each
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { [ inline-array? ] "n" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <ratio> [
ratio 3 cells %allot
"numerator" operand 1 %set-slot
"denominator" operand 2 %set-slot
ratio %tag-allot
"out" get ratio %store-tagged
] H{
{ +input+ { { f "numerator" } { f "denominator" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <complex> [
@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics
"real" operand 1 %set-slot
"imaginary" operand 2 %set-slot
! Store tagged ptr in reg
complex %tag-allot
"out" get complex %store-tagged
] H{
{ +input+ { { f "real" } { f "imaginary" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells %allot
"obj" operand 1 %set-slot
! Store tagged ptr in reg
wrapper %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ (hashtable) [
@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics
R12 2 %set-slot
R12 3 %set-slot
! Store tagged ptr in reg
object %tag-allot
"out" get object %store-tagged
] H{
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ string>sbuf [
sbuf 3 cells %allot
"length" operand 1 %set-slot
"string" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "string" } { f "length" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ array>vector [
vector 3 cells %allot
"length" operand 1 %set-slot
"array" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "array" } { f "length" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ curry [
\ curry 3 cells %allot
"obj" operand 1 %set-slot
"quot" operand 2 %set-slot
object %tag-allot
"out" get object %store-tagged
] H{
{ +input+ { { f "obj" } { f "quot" } } }
{ +scratch+ { { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand dup %untag-fixnum
"offset" operand dup "alien" operand ADD
"value" operand "offset" operand 0 <+> roll call ; inline
: alien-integer-get-template
H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } } }
{ +output+ { "output" } }
{ +scratch+ { { f "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
: %alien-get ( quot -- )
"output" get "address" set
"output" operand "alien" operand-class %alien-accessor ;
: %alien-integer-get ( quot -- )
%alien-get
"output" operand dup %tag-fixnum ; inline
: %alien-integer-set ( quot -- )
"value" operand dup %untag-fixnum
"value" operand "alien" operand-class %alien-accessor ; inline
%alien-accessor
"value" operand dup %tag-fixnum ; inline
: alien-integer-set-template
H{
{ +input+ {
{ f "value" fixnum }
{ f "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "address" } } }
{ +clobber+ { "value" "offset" } }
} ;
: %alien-integer-set ( quot -- )
"offset" get "value" get = [
"value" operand dup %untag-fixnum
] unless
%alien-accessor ; inline
: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
[ %alien-integer-set ] curry
alien-integer-set-template
@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics
\ set-alien-unsigned-1 [ STRB ]
define-alien-integer-intrinsics
\ alien-cell [
[ LDR ] %alien-get
"output" get %allot-alien
] H{
{ +input+ {
{ f "alien" simple-c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "output" } { f "allot-tmp" } } }
{ +output+ { "allot-tmp" } }
{ +clobber+ { "offset" } }
} define-intrinsic
: alien-cell-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
{ +output+ { "value" } }
{ +clobber+ { "offset" } }
} ;
\ alien-cell
[ [ LDR ] %alien-accessor ]
alien-cell-template define-intrinsic
: set-alien-cell-template
H{
{ +input+ {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
} ;
\ set-alien-cell
[ [ STR ] %alien-accessor ]
set-alien-cell-template define-intrinsic

4
core/cpu/arm5/arm5.factor
View File

@ -1,4 +0,0 @@
USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics
namespaces ;
T{ arm5-variant } arm-variant set-global

74
core/cpu/arm5/assembler/assembler.factor
View File

@ -1,74 +0,0 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator generator.fixup kernel sequences words
namespaces math math.bitfields cpu.arm.assembler ;
IN: cpu.arm5.assembler
TUPLE: arm5-variant ;
GENERIC# (BX) 1 ( Rm l -- )
M: register (BX) ( Rm l -- )
{
{ 1 24 }
{ 1 21 }
{ BIN: 1111 16 }
{ BIN: 1111 12 }
{ BIN: 1111 8 }
5
{ 1 4 }
{ register 0 }
} insn ;
M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
M: arm5-variant BX 0 (BX) ;
M: arm5-variant BLX 1 (BX) ;
! More load and store instructions
GENERIC: addressing-mode-3 ( addressing-mode -- n )
: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
M: addressing addressing-mode-3
[ addressing-p ] keep
[ addressing-u ] keep
[ addressing-w ] keep
delegate addressing-mode-3
{ 0 21 23 24 } bitfield ;
M: integer addressing-mode-3
b>n/n {
! { 1 24 }
{ 1 22 }
{ 1 7 }
{ 1 4 }
0
8
} bitfield ;
M: object addressing-mode-3
shifter-op {
! { 1 24 }
{ 1 7 }
{ 1 4 }
0
} bitfield ;
: addr3 ( Rn Rd addressing-mode h l s -- )
{
6
20
5
{ addressing-mode-3 0 }
{ register 16 }
{ register 12 }
} insn ;
: LDRH 1 1 0 addr3 ;
: LDRSB 0 1 1 addr3 ;
: LDRSH 1 1 1 addr3 ;
: STRH 1 0 0 addr3 ;

1
core/cpu/arm5/summary.txt
View File

@ -1 +0,0 @@
Additional compiler intrinsics for ARM5

2
core/cpu/ppc/allot/allot.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
generator generator.registers generator.fixup system layouts
math.functions cpu.architecture alien ;
cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )

14
core/cpu/ppc/architecture/architecture.factor Normal file → Executable file
View File

@ -3,7 +3,7 @@
USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words
assocs generator generator.registers generator.fixup system
layouts math.functions classes words.private alien combinators ;
layouts classes words.private alien combinators ;
IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
@ -15,10 +15,8 @@ TUPLE: ppc-backend ;
! r14: data stack
! r15: retain stack
! For stack frame layout, see vm/cpu-ppc.h.
: ds-reg 14 ;
: rs-reg 15 ;
: ds-reg 14 ; inline
: rs-reg 15 ; inline
: reserved-area-size
os {
@ -59,13 +57,11 @@ M: int-regs vregs
} ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ "linux" { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ;
: %prepare-primitive ( word -- )
! Save stack pointer to stack_chain->callstack_top, load XT
#! Save stack pointer to stack_chain->callstack_top, load XT
4 1 MR 11 %load-xt ;
: (%call) 11 MTLR BLRL ;
@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- )
%prepare-primitive (%jump) ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand \ f tag-number CMPI BNE ;
0 "flag" operand f v>operand CMPI BNE ;
: dispatch-template ( word-table# quot -- )
[

2
core/cpu/ppc/assembler/assembler.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: cpu.ppc.assembler
USING: generator.fixup generic kernel math memory namespaces
words math.bitfields math.functions io.binary ;
words math.bitfields io.binary ;
! See the Motorola or IBM documentation for details. The opcode
! names are standard, and the operand order is the same as in

15
core/cpu/ppc/bootstrap.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.ppc.assembler math math.functions layouts words vocabs ;
cpu.ppc.assembler math layouts words vocabs ;
IN: bootstrap.ppc
4 \ cell set
@ -62,6 +62,7 @@ big-endian on
] { } make jit-word-primitive-call set
: load-xt ( -- )
word-reg scan-reg 4 LWZU ! load word and advance
xt-reg word-reg word-xt@ LWZ ;
: jit-call
@ -74,17 +75,9 @@ big-endian on
: jit-jump
xt-reg MTCTR BCTR ;
[
word-reg scan-reg 4 LWZU ! load word and advance
load-xt
jit-call
] { } make jit-word-call set
[ load-xt jit-call ] { } make jit-word-call set
[
word-reg scan-reg 4 LWZ ! load word
load-xt ! jump to word XT
jit-jump
] { } make jit-word-jump set
[ load-xt jit-jump ] { } make jit-word-jump set
: load-branch
temp-reg ds-reg 0 LWZ ! load boolean

10
core/cpu/ppc/intrinsics/intrinsics.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
kernel.private math math.private namespaces sequences words
generic quotations byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.functions math.floats.private
sbufs vectors system layouts math.floats.private
classes tuples tuples.private sbufs.private vectors.private
strings.private slots.private combinators bit-arrays
float-arrays ;
@ -374,14 +374,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
! \ fsqrt [
! "y" operand "x" operand FSQRT
! ] H{
! { +input+ { { float "x" } } }
! { +scratch+ { { float "y" } } }
! { +output+ { "y" } }
! } define-intrinsic
\ tag [
"out" operand "in" operand tag-mask get ANDI
"out" operand dup %tag-fixnum

2
core/cpu/x86/32/32.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system
math.functions alien.compiler combinators command-line
alien.compiler combinators command-line
compiler io vocabs.loader ;
IN: cpu.x86.32

6
core/cpu/x86/64/64.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
alien alien.compiler alien.structs slots splitting math.functions ;
alien alien.compiler alien.structs slots splitting ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
@ -13,8 +13,8 @@ PREDICATE: x86-backend amd64-backend
M: amd64-backend ds-reg R14 ;
M: amd64-backend rs-reg R15 ;
M: amd64-backend stack-reg RSP ;
M: x86-backend xt-reg RCX ;
M: x86-backend stack-save-reg RSI ;
M: amd64-backend xt-reg RCX ;
M: amd64-backend stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ;

4
core/cpu/x86/allot/allot.factor Normal file → Executable file
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.architecture cpu.x86.assembler
cpu.x86.architecture kernel.private namespaces math
math.functions sequences generic arrays generator
generator.fixup generator.registers system layouts alien ;
sequences generic arrays generator generator.fixup
generator.registers system layouts alien ;
IN: cpu.x86.allot
: allot-reg

4
core/cpu/x86/architecture/architecture.factor Normal file → Executable file
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
math.functions memory namespaces sequences words generator
generator.registers generator.fixup system layouts combinators ;
memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators ;
IN: cpu.x86.architecture
TUPLE: x86-backend cell ;

2
core/cpu/x86/intrinsics/intrinsics.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.allot
cpu.x86.architecture cpu.architecture kernel kernel.private math
math.functions math.private namespaces quotations sequences
math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system

1
core/generator/generator.factor Normal file → Executable file
View File

@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ;
: underlying-alien-offset cell object tag-number - ;
: tuple-class-offset 2 cells tuple tag-number - ;
: class-hash-offset cell object tag-number - ;
: word-xt-offset 8 cells object tag-number - ;

4
core/generic/generic-tests.factor Normal file → Executable file
View File

@ -34,7 +34,7 @@ M: f bool>str drop "false" ;
[ f ] [ f bool>str str>bool ] unit-test
! Testing unions
UNION: funnies quotation ratio complex ;
UNION: funnies quotation float complex ;
GENERIC: funny ( x -- y )
M: funnies funny drop 2 ;
@ -48,7 +48,7 @@ PREDICATE: funnies very-funny number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;
[ 1/4 ] [ 1/2 gooey ] unit-test
[ 0.25 ] [ 0.5 gooey ] unit-test
DEFER: complement-test
FORGET: complement-test

2
core/generic/generic.factor Normal file → Executable file
View File

@ -21,7 +21,7 @@ M: object perform-combination
#! method combination, and a method on the generic, and the
#! method combination is forgotten first, then forgetting
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry ;
nip [ "Invalid method combination" throw ] curry [ ] like ;
: make-generic ( word -- )
dup

2
core/growable/growable-tests.factor Normal file → Executable file
View File

@ -22,5 +22,5 @@ unit-test-fails
[ ] [
10 V{ } [ set-length ] keep
1/2 swap set-length
0.5 swap set-length
] unit-test

6
core/hashtables/hashtables-tests.factor Normal file → Executable file
View File

@ -34,11 +34,11 @@ unit-test
16 <hashtable> "testhash" set
t C{ 2 3 } "testhash" get set-at
t { 2 3 } "testhash" get set-at
f 100000000000000000000000000 "testhash" get set-at
{ } { [ { } ] } "testhash" get set-at
[ t ] [ C{ 2 3 } "testhash" get at ] unit-test
[ t ] [ { 2 3 } "testhash" get at ] unit-test
[ f ] [ 100000000000000000000000000 "testhash" get at* drop ] unit-test
[ { } ] [ { [ { } ] } clone "testhash" get at* drop ] unit-test
@ -122,7 +122,7 @@ H{ } "x" set
100 [ drop "x" get clear-assoc ] each
! Crash discovered by erg
[ t ] [ 3/4 <hashtable> dup clone = ] unit-test
[ t ] [ 0.75 <hashtable> dup clone = ] unit-test
! Another crash discovered by erg
[ ] [

2
core/inference/backend/backend.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: inference.backend
USING: inference.dataflow arrays generic io io.streams.string
kernel math math.vectors namespaces parser prettyprint sequences
kernel math namespaces parser prettyprint sequences
strings vectors words quotations effects classes continuations
debugger assocs combinators ;

3
core/inference/class/class.factor Normal file → Executable file
View File

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
math.vectors effects classes inference.dataflow
inference.backend ;
effects classes inference.dataflow inference.backend ;
IN: inference.class
! Class inference

4
core/inference/inference-tests.factor Normal file → Executable file
View File

@ -230,8 +230,8 @@ DEFER: do-crap*
! Error reporting is wrong
MATH: xyz
M: fixnum xyz 2array ;
M: ratio xyz
[ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
M: float xyz
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test

5
core/io/files/files.factor
View File

@ -29,9 +29,8 @@ M: object root-directory? ( path -- ? ) "/" = ;
"/\\" member? ;
: path+ ( str1 str2 -- str )
>r [ path-separator? ] rtrim r>
[ path-separator? ] ltrim
>r "/" r> 3append ;
>r [ path-separator? ] right-trim "/" r>
[ path-separator? ] left-trim 3append ;
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;

2
core/io/utf16/utf16.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting math.functions ;
io.encodings combinators splitting ;
IN: io.utf16
SYMBOL: double

65
core/math/complex/complex-tests.factor
View File

@ -1,65 +0,0 @@
USING: kernel math math.constants math.functions tools.test ;
IN: temporary
[ 1 C{ 0 1 } rect> ] unit-test-fails
[ C{ 0 1 } 1 rect> ] unit-test-fails
[ f ] [ C{ 5 12.5 } 5 = ] unit-test
[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
[ C{ 2 5 } ] [ 2 5 rect> ] unit-test
[ 2 5 ] [ C{ 2 5 } >rect ] unit-test
[ C{ 1/2 1 } ] [ 1/2 i + ] unit-test
[ C{ 1/2 1 } ] [ i 1/2 + ] unit-test
[ t ] [ C{ 11 64 } C{ 11 64 } = ] unit-test
[ C{ 2 1 } ] [ 2 i + ] unit-test
[ C{ 2 1 } ] [ i 2 + ] unit-test
[ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 } + ] unit-test
[ 5 ] [ C{ 2 2 } C{ 3 -2 } + ] unit-test
[ C{ 1.0 1 } ] [ 1.0 i + ] unit-test
[ C{ 1/2 -1 } ] [ 1/2 i - ] unit-test
[ C{ -1/2 1 } ] [ i 1/2 - ] unit-test
[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * - ] unit-test
[ C{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + - ] unit-test
[ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 } - ] unit-test
[ 4 ] [ C{ 5 10/3 } C{ 1 10/3 } - ] unit-test
[ C{ 1.0 -1 } ] [ 1.0 i - ] unit-test
[ C{ 0 1 } ] [ i 1 * ] unit-test
[ C{ 0 1 } ] [ 1 i * ] unit-test
[ C{ 0 1.0 } ] [ 1.0 i * ] unit-test
[ -1 ] [ i i * ] unit-test
[ C{ 0 1 } ] [ 1 i * ] unit-test
[ C{ 0 1 } ] [ i 1 * ] unit-test
[ C{ 0 1/2 } ] [ 1/2 i * ] unit-test
[ C{ 0 1/2 } ] [ i 1/2 * ] unit-test
[ 2 ] [ C{ 1 1 } C{ 1 -1 } * ] unit-test
[ 1 ] [ i -i * ] unit-test
[ -1 ] [ i -i / ] unit-test
[ C{ 0 1 } ] [ 1 -i / ] unit-test
[ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 } = ] unit-test
[ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test
[ 5 ] [ C{ 3 4 } abs ] unit-test
[ 5 ] [ -5.0 abs ] unit-test
! Make sure arguments are sane
[ 0 ] [ 0 arg ] unit-test
[ 0 ] [ 1 arg ] unit-test
[ t ] [ -1 arg 3.14 3.15 between? ] unit-test
[ t ] [ i arg 1.57 1.58 between? ] unit-test
[ t ] [ -i arg -1.58 -1.57 between? ] unit-test
[ 1 0 ] [ 1 >polar ] unit-test
[ 1 ] [ -1 >polar drop ] unit-test
[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
! I broke something
[ ] [ C{ 1 4 } tanh drop ] unit-test
[ ] [ C{ 1 4 } tan drop ] unit-test
[ ] [ C{ 1 4 } coth drop ] unit-test
[ ] [ C{ 1 4 } cot drop ] unit-test

20
core/math/floats/floats-tests.factor Normal file → Executable file
View File

@ -25,9 +25,6 @@ IN: temporary
[ 2.1 ] [ -2.1 neg ] unit-test
[ 1 ] [ 0.5 1/2 + ] unit-test
[ 1 ] [ 1/2 0.5 + ] unit-test
[ 3 ] [ 3.1415 >fixnum ] unit-test
[ 3 ] [ 3.1415 >bignum ] unit-test
@ -48,23 +45,6 @@ unit-test
[ 2.0 ] [ 1.0 1+ ] unit-test
[ 0.0 ] [ 1.0 1- ] unit-test
[ 4.0 ] [ 4.5 truncate ] unit-test
[ 4.0 ] [ 4.5 floor ] unit-test
[ 5.0 ] [ 4.5 ceiling ] unit-test
[ -4.0 ] [ -4.5 truncate ] unit-test
[ -5.0 ] [ -4.5 floor ] unit-test
[ -4.0 ] [ -4.5 ceiling ] unit-test
[ -4.0 ] [ -4.0 truncate ] unit-test
[ -4.0 ] [ -4.0 floor ] unit-test
[ -4.0 ] [ -4.0 ceiling ] unit-test
[ -5.0 ] [ -4.5 round ] unit-test
[ -4.0 ] [ -4.4 round ] unit-test
[ 5.0 ] [ 4.5 round ] unit-test
[ 4.0 ] [ 4.4 round ] unit-test
! [ t ] [ -0.0 -0.0 = ] unit-test
! [ f ] [ 0.0 -0.0 = ] unit-test

11
core/math/floats/floats.factor Normal file → Executable file
View File

@ -1,17 +1,11 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.private math.libm ;
USING: kernel math math.private ;
IN: math.floats.private
M: fixnum >float fixnum>float ;
M: bignum >float bignum>float ;
M: real abs dup 0 < [ neg ] when ;
M: real absq sq ;
M: real hashcode* nip >fixnum ;
M: real <=> - ;
M: float zero? dup 0.0 float= swap -0.0 float= or ;
M: float >fixnum float>fixnum ;
@ -29,6 +23,3 @@ M: float - float- ;
M: float * float* ;
M: float / float/f ;
M: float mod float-mod ;
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;

7
core/math/integers/integers-docs.factor Normal file → Executable file
View File

@ -1,5 +1,4 @@
USING: help.markup help.syntax math math.private math.functions
math.ratios.private ;
USING: help.markup help.syntax math math.private ;
IN: math.integers
ARTICLE: "integers" "Integers"
@ -45,10 +44,6 @@ HELP: odd?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if an integer is odd." } ;
HELP: fraction>
{ $values { "a" integer } { "b" "a positive integer" } { "a/b" rational } }
{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ;
! Unsafe primitives
HELP: fixnum+ ( x y -- z )
{ $values { "x" fixnum } { "y" fixnum } { "z" integer } }

18
core/math/integers/integers-tests.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: kernel math namespaces prettyprint math.functions
USING: kernel math namespaces prettyprint
math.private continuations tools.test sequences ;
IN: temporary
@ -57,15 +57,6 @@ IN: temporary
[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1 ] [ 10 0 ^ ] unit-test
[ 1/8 ] [ 1/2 3 ^ ] unit-test
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ 7 ] [ 255 log2 ] unit-test
[ 8 ] [ 256 log2 ] unit-test
[ 8 ] [ 257 log2 ] unit-test
@ -100,11 +91,6 @@ unit-test
[ f ] [ BIN: -1101 >bignum 3 bit? ] unit-test
[ t ] [ BIN: -1101 >bignum 4 bit? ] unit-test
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test
[ -1 ] [ -3/2 ceiling ] unit-test
[ 2 ] [ 0 next-power-of-2 ] unit-test
[ 2 ] [ 1 next-power-of-2 ] unit-test
[ 2 ] [ 2 next-power-of-2 ] unit-test
@ -112,10 +98,8 @@ unit-test
[ 16 ] [ 13 next-power-of-2 ] unit-test
[ 16 ] [ 16 next-power-of-2 ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test

3
core/math/integers/integers.factor Normal file → Executable file
View File

@ -4,9 +4,6 @@ USING: kernel kernel.private sequences
sequences.private math math.private combinators ;
IN: math.integers.private
M: integer hashcode* nip >fixnum ;
M: integer <=> - ;
M: integer numerator ;
M: integer denominator drop 1 ;

23
core/math/intervals/intervals-tests.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random ;
prettyprint tools.test random vocabs ;
IN: temporary
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
@ -39,11 +39,11 @@ IN: temporary
] unit-test
[ t ] [
1 2 [a,b] -1/2 1/2 [a,b] interval* -1 1 [a,b] =
1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] =
] unit-test
[ t ] [
1 2 [a,b] -1/2 1/2 (a,b] interval* -1 1 (a,b] =
1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] =
] unit-test
[ t ] [
@ -77,7 +77,7 @@ IN: temporary
] unit-test
[ t ] [
1/2 0 1 (a,b) interval-contains?
0.5 0 1 (a,b) interval-contains?
] unit-test
[ f ] [
@ -88,9 +88,11 @@ IN: temporary
[ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test
[ t ] [
-1 1 (a,b) 1/2 1 (a,b) interval/ -2 2 (a,b) =
] unit-test
"math.ratios.private" vocab [
[ t ] [
-1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) =
] unit-test
] when
[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test
@ -125,12 +127,15 @@ IN: temporary
{ + interval+ }
{ - interval- }
{ * interval* }
{ / interval/ }
{ /i interval/i }
{ shift interval-shift }
{ min interval-min }
{ max interval-max }
} random ;
}
"math.ratios.private" vocab [
{ / interval/ } add
] when
random ;
: interval-test
random-interval random-interval random-op

33
core/math/math-docs.factor Normal file → Executable file
View File

@ -243,26 +243,6 @@ HELP: 1-
{ $code "1-" "1 -" }
} ;
HELP: truncate
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: floor
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: ceiling
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: round
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the whole number closest to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: sq
{ $values { "x" number } { "y" number } }
{ $description "Multiplies a number by itself." } ;
@ -351,22 +331,9 @@ HELP: imaginary ( z -- y )
{ $values { "z" number } { "y" real } }
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
HELP: (rect>)
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components." }
{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
HELP: number
{ $class-description "The class of numbers." } ;
HELP: rect>
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components." } ;
HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;

49
core/math/math.factor Normal file → Executable file
View File

@ -8,6 +8,7 @@ GENERIC: >bignum ( x -- y ) foldable
GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable
M: object number= 2drop f ;
MATH: < ( x y -- ? ) foldable
@ -48,8 +49,6 @@ GENERIC: zero? ( x -- ? ) foldable
M: object zero? drop f ;
GENERIC: sqrt ( x -- y ) foldable
: 1+ ( x -- y ) 1 + ; foldable
: 1- ( x -- y ) 1 - ; foldable
: 2/ ( x -- y ) -1 shift ; foldable
@ -66,15 +65,8 @@ GENERIC: sqrt ( x -- y ) foldable
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: truncate ( x -- y ) dup 1 mod - ; inline
: round ( x -- y ) dup sgn 2 / + truncate ; inline
: floor ( x -- y )
dup 1 mod dup zero?
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
: [-] ( x y -- z ) - 0 max ; inline
@ -84,9 +76,6 @@ GENERIC: sqrt ( x -- y ) foldable
: odd? ( n -- ? ) 1 bitand 1 number= ;
: >fraction ( a/b -- a b )
dup numerator swap denominator ; inline
UNION: integer fixnum bignum ;
UNION: rational integer ratio ;
@ -95,6 +84,19 @@ UNION: real rational float ;
UNION: number real complex ;
M: number equal? number= ;
M: real hashcode* nip >fixnum ;
M: real <=> - ;
! real and sequence overlap. we disambiguate:
M: integer equal? number= ;
M: integer hashcode* nip >fixnum ;
M: integer <=> - ;
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
@ -104,25 +106,6 @@ M: float fp-nan?
double>bits -51 shift BIN: 111111111111 [ bitand ] keep
number= ;
<PRIVATE
: (rect>) ( x y -- z )
dup zero? [ drop ] [ <complex> ] if ; inline
PRIVATE>
: rect> ( x y -- z )
over real? over real? and [
(rect>)
] [
"Complex number must have real components" throw
] if ; inline
: >rect ( z -- x y ) dup real swap imaginary ; inline
: >float-rect ( z -- x y )
>rect swap >float swap >float ; inline
: (next-power-of-2) ( i n -- n )
2dup >= [
drop
@ -132,6 +115,8 @@ PRIVATE>
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
<PRIVATE
: iterate-prep 0 -rot ; inline

20
core/math/parser/parser-tests.factor Normal file → Executable file
View File

@ -77,22 +77,6 @@ unit-test
[ "-101.0e-2" string>number number>string ]
unit-test
[ 5 ]
[ "10/2" string>number ]
unit-test
[ -5 ]
[ "-10/2" string>number ]
unit-test
[ -5 ]
[ "10/-2" string>number ]
unit-test
[ 5 ]
[ "-10/-2" string>number ]
unit-test
[ 5.0 ]
[ "10.0/2" string>number ]
unit-test
@ -105,10 +89,6 @@ unit-test
[ "e/2" string>number ]
unit-test
[ "33/100" ]
[ "66/200" string>number number>string ]
unit-test
[ f ] [ "12" bin> ] unit-test
[ f ] [ "fdsf" bin> ] unit-test
[ 3 ] [ "11" bin> ] unit-test

18
core/optimizer/known-words/known-words.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.buffers io.streams.string layouts splitting math.intervals
math.floats.private math.vectors tuples tuples.private classes
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays combinators.private ;
@ -92,7 +92,7 @@ float-arrays combinators.private ;
] each
! Specializers
{ 1+ 1- sq neg recip sgn truncate } [
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop
] each
@ -102,20 +102,6 @@ float-arrays combinators.private ;
{ number number } "specializer" set-word-prop
] each
{ vneg norm-sq norm normalize } [
{ { float-array array } } "specializer" set-word-prop
] each
\ n*v { * { float-array array } } "specializer" set-word-prop
\ v*n { { float-array array } * } "specializer" set-word-prop
\ n/v { * { float-array array } } "specializer" set-word-prop
\ v/n { { float-array array } * } "specializer" set-word-prop
{ v+ v- v* v/ vmax vmin v. } [
{ { float-array array } { float-array array } }
"specializer" set-word-prop
] each
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each

16
core/optimizer/math/math.factor Normal file → Executable file
View File

@ -5,7 +5,7 @@ USING: alien arrays generic hashtables kernel assocs math
math.private kernel.private sequences words parser
inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
math.libm combinators splitting layouts math.parser classes
combinators splitting layouts math.parser classes
generic.math optimizer.pattern-match optimizer.backend
optimizer.def-use generic.standard ;
@ -439,17 +439,3 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
! This will go away when we have cross-word type inference
{
facos fasin fatan
fcos fexp fcosh flog fpow
fsin fsinh fsqrt
} [
[ drop { float } f ]
"output-classes" set-word-prop
] each
\ fatan2
[ drop { float float } f ]
"output-classes" set-word-prop

0
core/parser/parser-docs.factor Normal file → Executable file
View File

2
core/prettyprint/backend/backend.factor Normal file → Executable file
View File

@ -138,7 +138,6 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ;
GENERIC: pprint-delims ( obj -- start end )
M: complex pprint-delims drop \ C{ \ } ;
M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
@ -155,7 +154,6 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ;
M: complex >pprint-sequence >rect 2array ;
M: hashtable >pprint-sequence >alist ;
M: tuple >pprint-sequence tuple>array ;
M: wrapper >pprint-sequence wrapped 1array ;

1
core/prettyprint/prettyprint-tests.factor Normal file → Executable file
View File

@ -7,7 +7,6 @@ IN: temporary
[ "4" ] [ 4 unparse ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test
[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
[ "+" ] [ \ + unparse ] unit-test

18
core/sequences/sequences-docs.factor Normal file → Executable file
View File

@ -943,3 +943,21 @@ HELP: unclip
HELP: unclip-slice
{ $values { "seq" sequence } { "rest" slice } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
HELP: sum
{ $values { "seq" "a sequence of numbers" } { "n" "a number" } }
{ $description "Outputs the sum of all elements of " { $snippet "seq" } ". Outputs zero given an empty sequence." } ;
HELP: product
{ $values { "seq" "a sequence of numbers" } { "n" "a number" } }
{ $description "Outputs the product of all elements of " { $snippet "seq" } ". Outputs one given an empty sequence." } ;
HELP: infimum
{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
{ $description "Outputs the least element of " { $snippet "seq" } "." }
{ $errors "Throws an error if the sequence is empty." } ;
HELP: supremum
{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
{ $errors "Throws an error if the sequence is empty." } ;

20
core/sequences/sequences-tests.factor Normal file → Executable file
View File

@ -43,9 +43,9 @@ IN: temporary
[ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test
[ f ] [ [ "Hello" { } 4/3 ] [ string? ] all? ] unit-test
[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test
[ t ] [ [ ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 1/2 ] [ ] all? ] unit-test
[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
[ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
@ -68,8 +68,8 @@ unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
[ t ] [ [ ] all-equal? ] unit-test
[ t ] [ [ 1/2 ] all-equal? ] unit-test
[ t ] [ [ 1.0 10/10 1 ] all-equal? ] unit-test
[ t ] [ [ 1234 ] all-equal? ] unit-test
[ t ] [ [ 1.0 1 1 ] all-equal? ] unit-test
[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
[ [ 2 3 4 ] ] [ [ 1 2 3 ] 1 [ + ] curry map ] unit-test
@ -190,7 +190,7 @@ unit-test
"cache-test" get
] unit-test
[ 1 ] [ 1/2 { 1 2 3 } nth ] unit-test
[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
@ -236,9 +236,11 @@ unit-test
[ -1./0. 0 delete-nth ] unit-test-fails
[ "" ] [ "" [ blank? ] trim ] unit-test
[ "" ] [ "" [ blank? ] ltrim ] unit-test
[ "" ] [ "" [ blank? ] rtrim ] unit-test
[ "" ] [ "" [ blank? ] left-trim ] unit-test
[ "" ] [ "" [ blank? ] right-trim ] unit-test
[ "" ] [ " " [ blank? ] left-trim ] unit-test
[ "" ] [ " " [ blank? ] right-trim ] unit-test
[ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test
[ "asdf " ] [ " asdf " [ blank? ] ltrim ] unit-test
[ " asdf" ] [ " asdf " [ blank? ] rtrim ] unit-test
[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test

32
core/sequences/sequences.factor Normal file → Executable file
View File

@ -414,6 +414,13 @@ PRIVATE>
: interleave ( seq between quot -- )
[ (interleave) ] 2curry iterate-seq 2each ; inline
: unfold ( obj pred quot exemplar -- seq )
[
10 swap new-resizable [
[ push ] curry compose [ drop ] while
] keep
] keep like ; inline
: index ( obj seq -- n )
[ = ] curry* find drop ;
@ -645,20 +652,19 @@ PRIVATE>
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
: ltrim ( seq quot -- newseq )
over >r [ not ] compose find drop
r> swap [ tail ] when* ; inline
: left-trim ( seq quot -- newseq )
over >r [ not ] compose find drop r> swap
[ tail ] [ dup length tail ] if* ; inline
: rtrim ( seq quot -- newseq )
over >r [ not ] compose find-last drop
r> swap [ 1+ head ] when* ; inline
: right-trim ( seq quot -- newseq )
over >r [ not ] compose find-last drop r> swap
[ 1+ head ] [ 0 head ] if* ; inline
: trim ( seq quot -- newseq )
[ ltrim ] keep rtrim ; inline
[ left-trim ] keep right-trim ; inline
: unfold ( obj pred quot exemplar -- seq )
[
10 swap new-resizable [
[ push ] curry compose [ drop ] while
] keep
] keep like ; inline
: sum ( seq -- n ) 0 [ + ] reduce ;
: product ( seq -- n ) 1 [ * ] reduce ;
: infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ;

3
core/syntax/syntax.factor Normal file → Executable file
View File

@ -77,7 +77,6 @@ IN: bootstrap.syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"C{" [ \ } [ first2 rect> ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
@ -165,5 +164,3 @@ IN: bootstrap.syntax
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"bootstrap.syntax" forget-vocab

1
core/threads/threads-tests.factor Normal file → Executable file
View File

@ -8,6 +8,5 @@ IN: temporary
[ ] [ [ "Errors, errors" throw ] in-thread ] unit-test
yield
[ ] [ 1/2 sleep ] unit-test
[ ] [ 0.3 sleep ] unit-test
[ "hey" sleep ] unit-test-fails

2
core/vectors/vectors-tests.factor Normal file → Executable file
View File

@ -10,7 +10,7 @@ IN: temporary
[ -3 V{ } nth ] unit-test-fails
[ 3 V{ } nth ] unit-test-fails
[ 3 C{ 1 2 } nth ] unit-test-fails
[ 3 54.3 nth ] unit-test-fails
[ "hey" [ 1 2 ] set-length ] unit-test-fails
[ "hey" V{ 1 2 } set-length ] unit-test-fails

0
core/vectors/vectors.factor Normal file → Executable file
View File

2
extra/benchmark/raytracer/raytracer.factor
View File

@ -2,7 +2,7 @@
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: float-arrays compiler generic io io.files kernel math
math.vectors math.parser namespaces sequences
math.functions math.vectors math.parser namespaces sequences
sequences.private words ;
IN: benchmark.raytracer

4
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -1,7 +1,7 @@
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: float-arrays kernel math math.vectors sequences
sequences.private prettyprint words tools.time hints ;
USING: float-arrays kernel math math.functions math.vectors
sequences sequences.private prettyprint words tools.time hints ;
IN: benchmark.spectral-norm
: fast-truncate >fixnum >float ; inline

1
extra/boids/ui/ui.factor
View File

@ -1,6 +1,7 @@
USING: kernel namespaces
math
math.functions
math.vectors
math.parser
hashtables sequences threads

2
extra/calendar/calendar.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math
math.vectors math.parser
math.vectors math.functions math.parser
namespaces sequences strings tuples system ;
IN: calendar

7
extra/color-picker/color-picker.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser models sequences ui ui.gadgets
ui.gadgets.controls ui.gadgets.frames ui.gadgets.labels
ui.gadgets.packs ui.gadgets.sliders ui.render ;
USING: kernel math math.functions math.parser models sequences
ui ui.gadgets ui.gadgets.controls ui.gadgets.frames
ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
;
IN: color-picker
! Simple example demonstrating the use of models.

3
extra/colors/hsv/hsv.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators arrays sequences math combinators.lib ;
USING: kernel combinators arrays sequences math math.functions
combinators.lib ;
IN: colors.hsv

2
extra/crypto/sha1/sha1.factor
View File

@ -127,7 +127,7 @@ SYMBOL: K
: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
: string>sha1-interleave ( string -- )
[ zero? ] ltrim
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
seq>2seq [ string>sha1 ] 2apply
swap 2seq>seq ;

2
extra/factory/commands/commands.factor
View File

@ -1,5 +1,5 @@
USING: kernel combinators sequences math math.vectors mortar slot-accessors
USING: kernel combinators sequences math math.functions math.vectors mortar slot-accessors
x x.widgets.wm.root x.widgets.wm.frame combinators.lib ;
IN: factory.commands

2
extra/html/html.factor Normal file → Executable file
View File

@ -37,7 +37,7 @@ TUPLE: html-sub-stream style stream ;
: object-link-tag ( style quot -- )
presented pick at [
browser-link-href [
<a =href a> call </a>
<a =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline

2
extra/io/windows/nt/backend/backend.factor
View File

@ -32,7 +32,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make
] }
} cond [ "/\\." member? ] rtrim ;
} cond [ "/\\." member? ] right-trim ;
SYMBOL: io-hash

2
extra/io/windows/windows.factor
View File

@ -17,7 +17,7 @@ M: windows-io (socket-destructor) ( obj -- )
destructor-obj closesocket drop ;
M: windows-io root-directory? ( path -- ? )
[ path-separator? ] rtrim
[ path-separator? ] right-trim
dup length 2 = [
dup first Letter?
swap second CHAR: : = and

2
extra/irc/irc.factor
View File

@ -72,7 +72,7 @@ TUPLE: part-command channel text ;
SYMBOL: irc-client
: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
: trim-: ( seq -- seq ) [ CHAR: : = ] ltrim ;
: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
: parse-name ( string -- string )
trim-: "!" split first ;
: irc-split ( string -- seq )

0
core/math/complex/authors.txt → extra/math/complex/authors.txt
View File

0
core/math/complex/complex-docs.factor → extra/math/complex/complex-docs.factor
View File

68
extra/math/complex/complex-tests.factor Executable file
View File

@ -0,0 +1,68 @@
USING: kernel math math.constants math.functions tools.test
prettyprint ;
IN: temporary
[ 1 C{ 0 1 } rect> ] unit-test-fails
[ C{ 0 1 } 1 rect> ] unit-test-fails
[ f ] [ C{ 5 12.5 } 5 = ] unit-test
[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
[ C{ 2 5 } ] [ 2 5 rect> ] unit-test
[ 2 5 ] [ C{ 2 5 } >rect ] unit-test
[ C{ 1/2 1 } ] [ 1/2 C{ 0 1 } + ] unit-test
[ C{ 1/2 1 } ] [ C{ 0 1 } 1/2 + ] unit-test
[ t ] [ C{ 11 64 } C{ 11 64 } = ] unit-test
[ C{ 2 1 } ] [ 2 C{ 0 1 } + ] unit-test
[ C{ 2 1 } ] [ C{ 0 1 } 2 + ] unit-test
[ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 } + ] unit-test
[ 5 ] [ C{ 2 2 } C{ 3 -2 } + ] unit-test
[ C{ 1.0 1 } ] [ 1.0 C{ 0 1 } + ] unit-test
[ C{ 1/2 -1 } ] [ 1/2 C{ 0 1 } - ] unit-test
[ C{ -1/2 1 } ] [ C{ 0 1 } 1/2 - ] unit-test
[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i* + 1 4 / i* - ] unit-test
[ C{ -1/3 -1/4 } ] [ 1 4 / i* 1 3 / 1 2 / i* + - ] unit-test
[ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 } - ] unit-test
[ 4 ] [ C{ 5 10/3 } C{ 1 10/3 } - ] unit-test
[ C{ 1.0 -1 } ] [ 1.0 C{ 0 1 } - ] unit-test
[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test
[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test
[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test
[ -1 ] [ C{ 0 1 } C{ 0 1 } * ] unit-test
[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test
[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test
[ C{ 0 1/2 } ] [ 1/2 C{ 0 1 } * ] unit-test
[ C{ 0 1/2 } ] [ C{ 0 1 } 1/2 * ] unit-test
[ 2 ] [ C{ 1 1 } C{ 1 -1 } * ] unit-test
[ 1 ] [ C{ 0 1 } C{ 0 -1 } * ] unit-test
[ -1 ] [ C{ 0 1 } C{ 0 -1 } / ] unit-test
[ C{ 0 1 } ] [ 1 C{ 0 -1 } / ] unit-test
[ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 } = ] unit-test
[ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test
[ 5 ] [ C{ 3 4 } abs ] unit-test
[ 5 ] [ -5.0 abs ] unit-test
! Make sure arguments are sane
[ 0 ] [ 0 arg ] unit-test
[ 0 ] [ 1 arg ] unit-test
[ t ] [ -1 arg 3.14 3.15 between? ] unit-test
[ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test
[ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test
[ 1 0 ] [ 1 >polar ] unit-test
[ 1 ] [ -1 >polar drop ] unit-test
[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
! I broke something
[ ] [ C{ 1 4 } tanh drop ] unit-test
[ ] [ C{ 1 4 } tan drop ] unit-test
[ ] [ C{ 1 4 } coth drop ] unit-test
[ ] [ C{ 1 4 } cot drop ] unit-test
[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test

13
core/math/complex/complex.factor → extra/math/complex/complex.factor Normal file → Executable file
View File

@ -2,13 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
IN: math.complex.private
USING: kernel kernel.private math math.private
math.libm math.functions ;
math.libm math.functions prettyprint.backend arrays
math.functions.private sequences parser ;
M: real real ;
M: real imaginary drop 0 ;
M: number equal? number= ;
M: complex absq >rect [ sq ] 2apply + ;
: 2>rect ( x y -- xr yr xi yi )
@ -34,3 +33,11 @@ M: complex abs absq >float fsqrt ;
M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ;
IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
M: complex pprint-delims drop \ C{ \ } ;
M: complex >pprint-sequence >rect 2array ;

0
core/math/complex/summary.txt → extra/math/complex/summary.txt
View File

0
core/math/constants/authors.txt → extra/math/constants/authors.txt
View File

8
core/math/constants/constants-docs.factor → extra/math/constants/constants-docs.factor Normal file → Executable file
View File

@ -3,8 +3,6 @@ IN: math.constants
ARTICLE: "math-constants" "Constants"
"Standard mathematical constants:"
{ $subsection i }
{ $subsection -i }
{ $subsection e }
{ $subsection pi }
"Various limits:"
@ -14,12 +12,6 @@ ARTICLE: "math-constants" "Constants"
ABOUT: "math-constants"
HELP: i
{ $values { "i" "the imaginary unit" } } ;
HELP: -i
{ $values { "-i" "the negated imaginary unit" } } ;
HELP: e
{ $values { "e" "base of natural logarithm" } } ;

2
core/math/constants/constants.factor → extra/math/constants/constants.factor Normal file → Executable file
View File

@ -2,8 +2,6 @@
! See http://factorcode.org/license.txt for BSD license.
IN: math.constants
: i ( -- i ) C{ 0 1 } ; inline
: -i ( -- -i ) C{ 0 -1 } ; inline
: e ( -- e ) 2.7182818284590452354 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

0
core/math/constants/summary.txt → extra/math/constants/summary.txt
View File

2
extra/math/fft/fft.factor
View File

@ -9,7 +9,7 @@ IN: math.fft
: odd ( seq -- seq ) 2 group 1 <column> ;
DEFER: fft
: two ( seq -- seq ) fft 2 v/n dup append ;
: omega ( n -- n ) recip -2 pi i * * * exp ;
: omega ( n -- n ) recip -2 pi i* * * exp ;
: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;

0
core/math/functions/authors.txt → extra/math/functions/authors.txt
View File

36
core/math/functions/functions-docs.factor → extra/math/functions/functions-docs.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel math
sequences quotations ;
sequences quotations math.functions.private ;
IN: math.functions
ARTICLE: "integer-functions" "Integer functions"
@ -94,6 +94,19 @@ ARTICLE: "math-functions" "Mathematical functions"
ABOUT: "math-functions"
HELP: (rect>)
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components." }
{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
HELP: rect>
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components." } ;
HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
@ -281,3 +294,24 @@ HELP: ~
{ { $snippet "epsilon" } " is negative: relative distance test." }
}
} ;
HELP: truncate
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: floor
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: ceiling
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: round
{ $values { "x" real } { "y" "a whole real number" } }
{ $description "Outputs the whole number closest to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;

35
core/math/functions/functions-tests.factor → extra/math/functions/functions-tests.factor Normal file → Executable file
View File

@ -17,8 +17,8 @@ IN: temporary
[ 4.0 ] [ 2 2 ^ ] unit-test
[ 0.25 ] [ 2 -2 ^ ] unit-test
[ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
[ t ] [ e pi i * ^ real -1.0 = ] unit-test
[ t ] [ e pi i * ^ imaginary -0.00001 0.00001 between? ] unit-test
[ t ] [ e pi i* ^ real -1.0 = ] unit-test
[ t ] [ e pi i* ^ imaginary -0.00001 0.00001 between? ] unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
@ -74,3 +74,34 @@ IN: temporary
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
[ 2 10 mod-inv ] unit-test-fails
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1 ] [ 10 0 ^ ] unit-test
[ 1/8 ] [ 1/2 3 ^ ] unit-test
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test
[ -1 ] [ -3/2 ceiling ] unit-test
[ 4.0 ] [ 4.5 truncate ] unit-test
[ 4.0 ] [ 4.5 floor ] unit-test
[ 5.0 ] [ 4.5 ceiling ] unit-test
[ -4.0 ] [ -4.5 truncate ] unit-test
[ -5.0 ] [ -4.5 floor ] unit-test
[ -4.0 ] [ -4.5 ceiling ] unit-test
[ -4.0 ] [ -4.0 truncate ] unit-test
[ -4.0 ] [ -4.0 floor ] unit-test
[ -4.0 ] [ -4.0 ceiling ] unit-test
[ -5.0 ] [ -4.5 round ] unit-test
[ -4.0 ] [ -4.4 round ] unit-test
[ 5.0 ] [ 4.5 round ] unit-test
[ 4.0 ] [ 4.4 round ] unit-test

49
core/math/functions/functions.factor → extra/math/functions/functions.factor Normal file → Executable file
View File

@ -1,8 +1,28 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.libm combinators ;
USING: math kernel math.constants math.private
math.libm combinators ;
IN: math.functions
<PRIVATE
: (rect>) ( x y -- z )
dup zero? [ drop ] [ <complex> ] if ; inline
PRIVATE>
: rect> ( x y -- z )
over real? over real? and [
(rect>)
] [
"Complex number must have real components" throw
] if ; inline
GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot -- )
over 0 number= pick -1 number= or [
2drop
@ -62,8 +82,12 @@ M: integer (^)
GENERIC: abs ( x -- y ) foldable
M: real abs dup 0 < [ neg ] when ;
GENERIC: absq ( x -- y ) foldable
M: real absq sq ;
: ~abs ( x y epsilon -- ? )
>r - abs r> < ;
@ -81,10 +105,13 @@ GENERIC: absq ( x -- y ) foldable
: power-of-2? ( n -- ? )
dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
: >rect ( z -- x y ) dup real swap imaginary ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline
: >float-rect ( z -- x y )
>rect swap >float swap >float ; inline
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
: >polar ( z -- abs arg )
@ -160,18 +187,32 @@ M: number (^)
: [-1,1]? ( x -- ? )
dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: i* ( x -- y ) >rect neg swap rect> ;
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
dup [-1,1]? [ >float fasin ] [ i * asinh -i * ] if ; inline
dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
inline
: atan ( x -- y )
dup [-1,1]? [ >float fatan ] [ i * atanh i * ] if ; inline
dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline
: asec ( x -- y ) recip acos ; inline
: acosec ( x -- y ) recip asin ; inline
: acot ( x -- y ) recip atan ; inline
: truncate ( x -- y ) dup 1 mod - ; inline
: round ( x -- y ) dup sgn 2 / + truncate ; inline
: floor ( x -- y )
dup 1 mod dup zero?
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable

0
core/math/functions/summary.txt → extra/math/functions/summary.txt
View File

0
core/math/libm/authors.txt → extra/math/libm/authors.txt
View File

0
core/math/libm/libm-docs.factor → extra/math/libm/libm-docs.factor
View File

0
core/math/libm/libm.factor → extra/math/libm/libm.factor
View File

0
core/math/libm/summary.txt → extra/math/libm/summary.txt
View File

0
core/math/libm/tags.txt → extra/math/libm/tags.txt
View File

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