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

various clean ups, fix linearization of #label

cvs
Slava Pestov 2005-08-12 22:02:03 +00:00
parent 9707d90970
commit 05a9338bc7
28 changed files with 238 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
library/alien/compiler.factor
View File

@ -159,5 +159,8 @@ M: compound (uncrossref)
dup f "infer-effect" set-word-prop
dup f "base-case" set-word-prop
dup f "no-effect" set-word-prop
dup f "inline" set-word-prop
dup f "foldable" set-word-prop
dup f "flushable" set-word-prop
decompile
] ifte ;

22
library/bootstrap/boot-stage2.factor
View File

@ -1,8 +1,24 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler generic hashtables
kernel lists memory namespaces parser sequences io unparser
words ;
USING: alien assembler command-line compiler errors generic
hashtables io kernel lists memory namespaces parser sequences
unparser words ;
: restarts. ( menu -- )
"Restarts:" print
dup length [ unparse print ". " write first print ] 2each
"> " write flush
;
: try-resource ( path -- )
"Loading " write dup print
[
run-resource
] [
[
"Error loading resource. Restarts:" print
] when*
] catch ;
: pull-in ( ? list -- )
swap [

3
library/compiler/linearizer.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler-frontend
USING: compiler-backend errors generic lists inference kernel
kernel-internals math namespaces prettyprint sequences
math namespaces prettyprint sequences
strings words ;
GENERIC: linearize-node* ( node -- )
@ -26,7 +26,6 @@ M: #label linearize-node* ( node -- )
<label> dup %return-to , >r
dup node-param %label ,
node-children first linearize-node
f %return ,
r> %label , ;
M: #call linearize-node* ( node -- )

45
library/generic/tuple.factor
View File

@ -24,11 +24,14 @@ BUILTIN: tuple 18 tuple? ;
: class ( object -- class )
dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline
: class-tuple ( object -- class )
dup tuple? [ 2 slot ] [ drop f ] ifte ; inline
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word
[ \ class , over literalize , \ eq? , ] make-list
[ \ class-tuple , over literalize , \ eq? , ] make-list
define-predicate ;
: forget-tuple ( class -- )
@ -72,34 +75,31 @@ BUILTIN: tuple 18 tuple? ;
dup r> tuple-slots
default-constructor ;
: class-predicates ( generic classes -- predicates )
>r "picker" word-prop r> [
uncons >r "predicate" word-prop append r> cons
] map-with ;
: alist>quot ( default alist -- quot )
reverse-slice [
unswons [ % , , \ ifte , ] make-list
] each ;
: (tuple-dispatch-quot) ( default alist -- quot )
#! Turn an association list that maps values to quotations
#! into a quotation that executes a quotation depending on
#! the value on the stack.
[
[
unswons
\ dup , unswons literalize , \ eq? , \ drop swons ,
\ dup , unswons "predicate" word-prop % ,
alist>quot , \ ifte ,
] make-list
] when* ;
: (hash>quot) ( default hash -- quot )
[
\ dup , \ hashcode , dup bucket-count , \ rem ,
buckets>vector [ alist>quot ] map-with ,
\ dispatch ,
] make-list ;
: hash>quot ( default hash -- quot )
#! Turn a hash table that maps values to quotations into a
#! quotation that executes a quotation depending on the
#! value on the stack.
( dup hash-size 4 <= ) t [
hash>alist alist>quot
] [
(hash>quot)
] ifte ;
: tuple-methods ( generic -- hash )
#! A hashtable of methods on tuples.
"methods" word-prop [ car metaclass tuple = ] hash-subset ;
: default-tuple-method ( generic -- quot )
#! If the generic does not define a specific method for a
@ -115,16 +115,11 @@ BUILTIN: tuple 18 tuple? ;
] ifte
] ifte ;
: tuple-methods ( generic -- hash )
#! A hashtable of methods on tuples.
"methods" word-prop [ car metaclass tuple = ] hash-subset ;
: tuple-dispatch-quot ( generic -- quot )
#! Generate a quotation that performs tuple class dispatch
#! for methods defined on the given generic.
dup default-tuple-method \ drop swons
over tuple-methods hash>quot
>r "picker" word-prop [ class ] r> append3 ;
dup dup tuple-methods hash>alist class-predicates
>r default-tuple-method r> alist>quot ;
: add-tuple-dispatch ( word vtable -- )
>r tuple-dispatch-quot tuple r> set-vtable ;

9
library/inference/call-optimizers.factor
View File

@ -15,7 +15,7 @@ USING: errors hashtables kernel sequences vectors words ;
{ [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
: partial-eval? ( #call -- ? )
dup node-param "stateless" word-prop [
dup node-param "foldable" word-prop [
dup node-in-d [
dup literal?
[ 2drop t ] [ swap node-literals hash* ] ifte
@ -56,3 +56,10 @@ M: #call optimize-node* ( node -- node/t )
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ t ] [ drop t ] }
} cond ;
SYMBOL: @
: values-match? ( spec values -- ? )
#! spec is a sequence of literals, or the symbol @ which is
#! a wildcard.
[ dup literal? [ drop @ ] unless = ] 2map conjunction ;

5
library/inference/words.factor
View File

@ -36,8 +36,9 @@ hashtables parser prettyprint ;
recursive-state [ cdr ] change ; inline
: inline-block ( word -- node-block )
gensym over word-def cons
[ #entry node, word-def infer-quot ] with-block ;
gensym over word-def cons [
#entry node, word-def infer-quot #return node,
] with-block ;
: inline-compound ( word -- )
#! Infer the stack effect of a compound word in the current

3
library/kernel.factor
View File

@ -50,7 +50,8 @@ DEFER: wrapper?
BUILTIN: wrapper 14 wrapper? { 1 "wrapped" f } ;
M: wrapper = ( obj wrapper -- ? )
over wrapper? [ swap wrapped = ] [ 2drop f ] ifte ;
over wrapper?
[ swap wrapped swap wrapped = ] [ 2drop f ] ifte ;
! defined in parse-syntax.factor
DEFER: not

26
library/math/arc-trig-hyp.factor
View File

@ -9,16 +9,16 @@ USING: kernel math math-internals ;
! Inverse hyperbolic functions:
! acosh asech asinh acosech atanh acoth
: acosh dup sq 1 - sqrt + log ; stateless
: asech recip acosh ; stateless
: asinh dup sq 1 + sqrt + log ; stateless
: acosech recip asinh ; stateless
: atanh dup 1 + swap 1 - neg / log 2 / ; stateless
: acoth recip atanh ; stateless
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; stateless
: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; stateless
: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] ifte ; stateless
: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; stateless
: asec recip acos ; stateless
: acosec recip asin ; stateless
: acot recip atan ; stateless
: acosh dup sq 1 - sqrt + log ; inline
: asech recip acosh ; inline
: asinh dup sq 1 + sqrt + log ; inline
: acosech recip asinh ; inline
: atanh dup 1 + swap 1 - neg / log 2 / ; inline
: acoth recip atanh ; inline
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; inline
: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; inline
: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] ifte ; inline
: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; inline
: asec recip acos ; inline
: acosec recip asin ; inline
: acot recip atan ; inline

27
library/math/complex.factor
View File

@ -6,7 +6,7 @@ USING: errors generic kernel kernel-internals math ;
: (rect>) ( xr xi -- x )
#! Does not perform a check that the arguments are reals.
#! Do not use in your own code.
dup 0 number= [ drop ] [ <complex> ] ifte ;
dup 0 number= [ drop ] [ <complex> ] ifte ; inline
IN: math
@ -24,39 +24,38 @@ M: number = ( n n -- ? ) number= ;
(rect>)
] [
"Complex number must have real components" throw drop
] ifte ;
] ifte ; inline
: >rect ( x -- xr xi ) dup real swap imaginary ;
: >rect ( x -- xr xi ) dup real swap imaginary ; inline
: conjugate ( z -- z* )
>rect neg rect> ;
: conjugate ( z -- z* ) >rect neg rect> ; inline
: arg ( z -- arg )
#! Compute the complex argument.
>rect swap fatan2 ;
>rect swap fatan2 ; inline
: >polar ( z -- abs arg )
dup abs swap >rect swap fatan2 ;
dup abs swap >rect swap fatan2 ; inline
: cis ( theta -- cis )
dup fcos swap fsin rect> ;
dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z )
cis * ;
cis * ; inline
: absq >rect swap sq swap sq + ;
: absq >rect swap sq swap sq + ; inline
IN: math-internals
: 2>rect ( x y -- xr yr xi yi )
[ swap real swap real ] 2keep
swap imaginary swap imaginary ;
swap imaginary swap imaginary ; inline
M: complex number= ( x y -- ? )
2>rect number= [ number= ] [ 2drop f ] ifte ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ;
: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline
M: complex + 2>rect + >r + r> (rect>) ;
M: complex - 2>rect - >r - r> (rect>) ;
@ -64,7 +63,7 @@ M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ;
: complex/ ( x y -- r i m )
#! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
dup absq >r 2dup *re + -rot *im - r> ;
dup absq >r 2dup *re + -rot *im - r> ; inline
M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ;

4
library/math/constants.factor
View File

@ -10,5 +10,5 @@ USE: kernel
: e 2.7182818284590452354 ; inline
: pi 3.14159265358979323846 ; inline
: deg>rad pi * 180 / ;
: rad>deg 180 * pi / ;
: deg>rad pi * 180 / ; inline
: rad>deg 180 * pi / ; inline

6
library/math/integer.factor
View File

@ -14,7 +14,7 @@ UNION: integer fixnum bignum ;
drop nip
] [
tuck /mod >r pick * swap >r swapd - r> r> (gcd)
] ifte ;
] ifte ; inline
: gcd ( x y -- a d )
#! Compute the greatest common divisor d and multiplier a
@ -37,10 +37,10 @@ IN: math-internals
drop
] [
(fraction>)
] ifte ;
] ifte ; inline
: division-by-zero ( x y -- )
"Division by zero" throw drop ;
"Division by zero" throw drop ; inline
M: integer / ( x y -- x/y )
dup 0 number= [

54
library/math/math.factor
View File

@ -4,34 +4,34 @@ IN: math
USING: errors generic kernel math-internals ;
! Math operations
G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ;
G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
M: object number= 2drop f ;
G: < ( x y -- ? ) [ ] [ arithmetic-type ] ;
G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ;
G: > ( x y -- ? ) [ ] [ arithmetic-type ] ;
G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ;
G: < ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: > ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ;
G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ;
G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ;
G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ;
G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ;
G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ;
G: mod ( x y -- x%y ) [ ] [ arithmetic-type ] ;
G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ; foldable
G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ; foldable
G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ; foldable
G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: mod ( x y -- x%y ) [ ] [ arithmetic-type ] ; foldable
G: /mod ( x y -- x/y x%y ) [ ] [ arithmetic-type ] ;
G: /mod ( x y -- x/y x%y ) [ ] [ arithmetic-type ] ; foldable
G: bitand ( x y -- z ) [ ] [ arithmetic-type ] ;
G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ;
G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ;
G: shift ( x n -- y ) [ ] [ arithmetic-type ] ;
G: bitand ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: shift ( x n -- y ) [ ] [ arithmetic-type ] ; foldable
GENERIC: bitnot ( n -- n )
GENERIC: bitnot ( n -- n ) foldable
GENERIC: truncate ( n -- n )
GENERIC: floor ( n -- n )
GENERIC: ceiling ( n -- n )
GENERIC: truncate ( n -- n ) foldable
GENERIC: floor ( n -- n ) foldable
GENERIC: ceiling ( n -- n ) foldable
: max ( x y -- z ) [ > ] 2keep ? ; inline
: min ( x y -- z ) [ < ] 2keep ? ; inline
@ -39,7 +39,7 @@ GENERIC: ceiling ( n -- n )
: between? ( x min max -- ? )
#! Push if min <= x <= max. Handles case where min > max
#! by swapping them.
2dup > [ swap ] when >r dupd max r> min = ;
2dup > [ swap ] when >r dupd max r> min = ; foldable
: sq dup * ; inline
@ -48,16 +48,16 @@ GENERIC: ceiling ( n -- n )
: rem ( x y -- x%y )
#! Like modulus, but always gives a positive result.
[ mod ] keep over 0 < [ + ] [ drop ] ifte ;
[ mod ] keep over 0 < [ + ] [ drop ] ifte ; inline
: sgn ( n -- -1/0/1 )
#! Push the sign of a real number.
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ; inline
GENERIC: abs ( z -- |z| )
: align ( offset width -- offset )
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; inline
: (repeat) ( i n quot -- )
pick pick >=
@ -77,7 +77,7 @@ GENERIC: abs ( z -- |z| )
dup dup neg bitand =
] [
drop f
] ifte ;
] ifte ; foldable
: log2 ( n -- b )
#! Log base two for integers.
@ -85,4 +85,4 @@ GENERIC: abs ( z -- |z| )
"Input must be positive" throw
] [
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
] ifte ;
] ifte ; foldable

17
library/math/pow.factor
View File

@ -6,8 +6,8 @@ USING: errors kernel math math-internals ;
! Power-related functions:
! exp log sqrt pow ^mod
: exp >rect swap fexp swap polar> ;
: log >polar swap flog swap rect> ;
: exp >rect swap fexp swap polar> ; inline
: log >polar swap flog swap rect> ; inline
: sqrt ( z -- sqrt )
>polar dup pi = [
@ -16,13 +16,13 @@ USING: errors kernel math math-internals ;
swap fsqrt swap 2 / polar>
] ifte ;
GENERIC: ^ ( z w -- z^w )
GENERIC: ^ ( z w -- z^w ) foldable
: ^mag ( w abs arg -- magnitude )
>r >r >rect swap r> swap fpow r> rot * fexp / ;
>r >r >rect swap r> swap fpow r> rot * fexp / ; inline
: ^theta ( w abs arg -- theta )
>r >r >rect r> flog * swap r> * + ;
>r >r >rect r> flog * swap r> * + ; inline
M: number ^ ( z w -- z^w )
swap >polar 3dup ^theta >r ^mag r> polar> ;
@ -38,18 +38,19 @@ M: number ^ ( z w -- z^w )
: (integer^) ( z w -- z^w )
1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ;
inline
M: integer ^ ( z w -- z^w )
over 0 number= over 0 number= and [
"0^0 is not defined" throw
] [
dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
] ifte ;
] ifte ; foldable
: (^mod) ( n z w -- z^w )
1 swap [
1 number= [ dupd * pick mod ] when >r sq over mod r>
] each-bit 2nip ;
] each-bit 2nip ; inline
: ^mod ( z w n -- z^w )
#! Compute z^w mod n.
@ -57,4 +58,4 @@ M: integer ^ ( z w -- z^w )
[ >r neg r> ^mod ] keep mod-inv
] [
-rot (^mod)
] ifte ;
] ifte ; foldable

4
library/math/random.factor
View File

@ -7,13 +7,13 @@ IN: math USING: kernel ;
2drop (random-int) 2dup swap mod (random-int-0)
] [
2nip
] ifte ;
] ifte ; inline
: random-int-0 ( max -- n )
1 + dup power-of-2? [
(random-int) * -31 shift
] [
(random-int) 2dup swap mod (random-int-0)
] ifte ;
] ifte ; inline
: random-int ( min max -- n ) dupd swap - random-int-0 + ;

6
library/math/ratio.factor
View File

@ -11,18 +11,18 @@ M: integer numerator ;
M: integer denominator drop 1 ;
: >fraction ( a/b -- a b )
dup numerator swap denominator ;
dup numerator swap denominator ; inline
IN: math-internals
: 2>fraction ( a/b c/d -- a c b d )
>r >fraction r> >fraction swapd ;
>r >fraction r> >fraction swapd ; inline
M: ratio number= ( a/b c/d -- ? )
2>fraction number= [ number= ] [ 2drop f ] ifte ;
: scale ( a/b c/d -- a*d b*c )
2>fraction >r * swap r> * swap ;
2>fraction >r * swap r> * swap ; inline
: ratio+d ( a/b c/d -- b*d )
denominator swap denominator * ; inline

24
library/math/trig-hyp.factor
View File

@ -12,32 +12,32 @@ USING: kernel math math-internals ;
: cos ( z -- cos )
>rect 2dup
fcosh swap fcos * -rot
fsinh swap fsin neg * rect> ;
fsinh swap fsin neg * rect> ; inline
: sec cos recip ;
: sec cos recip ; inline
: cosh ( z -- cosh )
>rect 2dup
fcos swap fcosh * -rot
fsin swap fsinh * rect> ;
fsin swap fsinh * rect> ; inline
: sech cosh recip ;
: sech cosh recip ; inline
: sin ( z -- sin )
>rect 2dup
fcosh swap fsin * -rot
fsinh swap fcos * rect> ;
fsinh swap fcos * rect> ; inline
: cosec sin recip ;
: cosec sin recip ; inline
: sinh ( z -- sinh )
>rect 2dup
fcos swap fsinh * -rot
fsin swap fcosh * rect> ;
fsin swap fcosh * rect> ; inline
: cosech sinh recip ;
: cosech sinh recip ; inline
: tan dup sin swap cos / ;
: tanh dup sinh swap cosh / ;
: cot dup cos swap sin / ;
: coth dup cosh swap sinh / ;
: tan dup sin swap cos / ; inline
: tanh dup sinh swap cosh / ; inline
: cot dup cos swap sin / ; inline
: coth dup cosh swap sinh / ; inline

16
library/syntax/parse-syntax.factor
View File

@ -17,10 +17,18 @@ words ;
#! Mark the last word to be inlined.
word t "inline" set-word-prop ; parsing
: stateless ( -- )
#! Mark the last word to be evaluated at compile time if
#! all inputs are literals.
word t "stateless" set-word-prop ; parsing
: flushable ( -- )
#! Declare that a word may be removed if the value it
#! computes is unused.
word t "flushable" set-word-prop ; parsing
: foldable ( -- )
#! Declare a word as safe for compile-time evaluation.
#! Foldable implies flushable, since we can first fold to
#! a constant then flush the constant.
word
dup t "foldable" set-word-prop
t "flushable" set-word-prop ; parsing
! The variable "in-definition" is set inside a : ... ;.
! ( and #! then add "stack-effect" and "documentation"

13
library/syntax/see.factor
View File

@ -15,9 +15,12 @@ streams strings styles unparser words ;
] ifte ;
: prettyprint-plist ( word -- )
dup
\ parsing prettyprint-prop
\ inline prettyprint-prop ;
[
POSTPONE: parsing
POSTPONE: inline
POSTPONE: foldable
POSTPONE: flushable
] [ prettyprint-prop ] each-with ;
: comment. ( comment -- )
[ [[ font-style italic ]] ] format ;
@ -78,7 +81,9 @@ M: generic (see) ( word -- )
over "dispatcher" word-prop prettyprint* bl
] with-scope
drop
\ ; unparse. terpri
\ ; unparse.
dup prettyprint-plist
terpri
dup methods [ method. ] each-with ;
M: word (see) drop ;

9
library/test/combinators.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: alien strings ;
USING: alien errors strings ;
USE: kernel
USE: math
USE: test
@ -57,3 +57,10 @@ unit-test
{ [ t ] [ drop "neither" ] }
} cond
] unit-test
[ ] [
[
[ drop ] [ drop ] catch
[ drop ] [ drop ] catch
] keep-datastack
] unit-test

33
library/test/crashes.factor
View File

@ -1,33 +0,0 @@
IN: temporary
! Various things that broke CFactor at various times.
USING: errors kernel lists math memory namespaces parser
prettyprint sequences strings test vectors words ;
[ ] [
"20 <sbuf> \"foo\" set" eval
"full-gc" eval
] unit-test
[ ] [
[
[ drop ] [ drop ] catch
[ drop ] [ drop ] catch
] keep-datastack
] unit-test
[ ] [ 10 [ [ -1000000 <vector> ] [ drop ] catch ] times ] unit-test
[ ] [ 10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times ] unit-test
! See how well callstack overflow is handled
: callstack-overflow callstack-overflow f ;
[ callstack-overflow ] unit-test-fails
! Weird PowerPC bug.
[ ] [
[ "4" throw ] [ drop ] catch
full-gc
full-gc
] unit-test
[ 0 ] [ f size ] unit-test

12
library/test/errors.factor
View File

@ -1,4 +1,5 @@
IN: temporary
USING: memory ;
USE: errors
USE: kernel
USE: namespaces
@ -27,3 +28,14 @@ USE: io
! This should not raise an error
[ 1 2 3 ] [ 1 2 3 f throw ] unit-test
! See how well callstack overflow is handled
: callstack-overflow callstack-overflow f ;
[ callstack-overflow ] unit-test-fails
! Weird PowerPC bug.
[ ] [
[ "4" throw ] [ drop ] catch
full-gc
full-gc
] unit-test

5
library/test/kernel.factor Normal file
View File

@ -0,0 +1,5 @@
IN: scratchpad
USING: kernel memory sequences test ;
[ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] [ = ] every? ] unit-test

10
library/test/lists/combinators.factor
View File

@ -7,17 +7,7 @@ USE: test
USE: strings
USE: sequences
[ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
[ "fdsfs" [ > ] sort ] unit-test-fails
[ [ ] ] [ [ ] [ > ] sort ] unit-test
[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ lexi> ] sort ] unit-test
[ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ > ] sort ] unit-test
[ f ] [ [ { } { } "Hello" ] [ = ] every? ] unit-test
[ f ] [ [ { 2 } { } { } ] [ = ] every? ] unit-test
[ t ] [ [ ] [ = ] every? ] unit-test
[ t ] [ [ 1/2 ] [ = ] every? ] unit-test
[ t ] [ [ 1.0 10/10 1 ] [ = ] every? ] unit-test
[ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test

33
library/test/lists/lists.factor
View File

@ -1,15 +1,6 @@
IN: temporary
USING: kernel lists sequences test ;
[ 1 ] [ 0 [ 1 2 ] nth ] unit-test
[ 2 ] [ 1 [ 1 2 ] nth ] unit-test
[ [ ] ] [ [ ] [ ] append ] unit-test
[ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test
[ [ 2 ] ] [ [ ] [ 2 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test
[ [ 3 ] ] [ [ 3 ] last ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] last ] unit-test
[ [[ 3 4 ]] ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] last ] unit-test
@ -26,33 +17,9 @@ USING: kernel lists sequences test ;
[ t ] [ [ 1 2 ] list? ] unit-test
[ f ] [ [[ 1 2 ]] list? ] unit-test
[ [ ] ] [ 1 [ ] remove ] unit-test
[ [ ] ] [ 1 [ 1 ] remove ] unit-test
[ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] remove ] unit-test
[ [ ] ] [ [ ] reverse ] unit-test
[ [ 1 ] ] [ [ 1 ] reverse ] unit-test
[ [ 3 2 1 ] ] [ [ 1 2 3 ] reverse ] unit-test
[ [ 1 2 3 ] ] [ 1 [ 2 3 ] unique ] unit-test
[ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test
[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
[ [ ] ] [ 0 >list ] unit-test
[ [ 0 1 2 3 ] ] [ 4 >list ] unit-test
[ f ] [ 0 f head ] unit-test
[ f ] [ 0 [ 1 ] head ] unit-test
[ [ 1 2 3 ] ] [ 3 [ 1 2 3 4 ] head ] unit-test
[ f ] [ 3 [ 1 2 3 ] tail ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] seq-diff ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
[ f ] [ [ ] [ 1 2 3 ] sequence= ] unit-test

43
library/test/sequences.factor
View File

@ -69,3 +69,46 @@ unit-test
[ { { 1 4 } { 2 5 } { 3 6 } } ]
[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test
[ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
[ f ] [ [ { } { } "Hello" ] [ = ] every? ] unit-test
[ f ] [ [ { 2 } { } { } ] [ = ] every? ] unit-test
[ t ] [ [ ] [ = ] every? ] unit-test
[ t ] [ [ 1/2 ] [ = ] every? ] unit-test
[ t ] [ [ 1.0 10/10 1 ] [ = ] every? ] unit-test
[ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test
[ 1 ] [ 0 [ 1 2 ] nth ] unit-test
[ 2 ] [ 1 [ 1 2 ] nth ] unit-test
[ [ ] ] [ [ ] [ ] append ] unit-test
[ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test
[ [ 2 ] ] [ [ ] [ 2 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test
[ [ ] ] [ 1 [ ] remove ] unit-test
[ [ ] ] [ 1 [ 1 ] remove ] unit-test
[ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] remove ] unit-test
[ [ ] ] [ [ ] reverse ] unit-test
[ [ 1 ] ] [ [ 1 ] reverse ] unit-test
[ [ 3 2 1 ] ] [ [ 1 2 3 ] reverse ] unit-test
[ f ] [ 0 f head ] unit-test
[ f ] [ 0 [ 1 ] head ] unit-test
[ [ 1 2 3 ] ] [ 3 [ 1 2 3 4 ] head ] unit-test
[ f ] [ 3 [ 1 2 3 ] tail ] unit-test
[ [ 3 ] ] [ 2 [ 1 2 3 ] tail ] unit-test
[ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] seq-diff ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
[ f ] [ [ ] [ 1 2 3 ] sequence= ] unit-test

2
library/test/strings.factor
View File

@ -9,6 +9,8 @@ USE: test
USE: sequences
USE: lists
[ ] [ 10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times ] unit-test
[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
[ "abc" ] [ "ab" "c" append ] unit-test

7
library/test/test.factor
View File

@ -85,13 +85,12 @@ SYMBOL: failures
"math/complex" "math/irrational" "math/integer"
"math/matrices"
"httpd/url-encoding" "httpd/html" "httpd/httpd"
"httpd/http-client"
"crashes" "sbuf" "threads" "parsing-word"
"inference" "interpreter"
"alien"
"httpd/http-client" "sbuf" "threads" "parsing-word"
"inference" "interpreter" "alien"
"gadgets/line-editor" "gadgets/rectangles"
"gadgets/gradients" "memory"
"redefine" "annotate" "sequences" "binary" "inspector"
"kernel"
] run-tests ;
: benchmarks

6
library/test/vectors.factor
View File

@ -1,6 +1,8 @@
IN: temporary
USING: kernel kernel-internals lists math namespaces random
sequences strings test vectors ;
USING: errors kernel kernel-internals lists math namespaces
random sequences strings test vectors ;
[ ] [ 10 [ [ -1000000 <vector> ] [ drop ] catch ] times ] unit-test
[ 3 ] [ [ t f t ] length ] unit-test
[ 3 ] [ { t f t } length ] unit-test