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 "infer-effect" set-word-prop
dup f "base-case" set-word-prop dup f "base-case" set-word-prop
dup f "no-effect" 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 decompile
] ifte ; ] ifte ;

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

@ -1,8 +1,24 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler generic hashtables USING: alien assembler command-line compiler errors generic
kernel lists memory namespaces parser sequences io unparser hashtables io kernel lists memory namespaces parser sequences
words ; 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 -- ) : pull-in ( ? list -- )
swap [ swap [

3
library/compiler/linearizer.factor
View File

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

45
library/generic/tuple.factor
View File

@ -24,11 +24,14 @@ BUILTIN: tuple 18 tuple? ;
: class ( object -- class ) : class ( object -- class )
dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline
: class-tuple ( object -- class )
dup tuple? [ 2 slot ] [ drop f ] ifte ; inline
: tuple-predicate ( word -- ) : tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top #! Make a foo? word for testing the tuple class at the top
#! of the stack. #! of the stack.
dup predicate-word dup predicate-word
[ \ class , over literalize , \ eq? , ] make-list [ \ class-tuple , over literalize , \ eq? , ] make-list
define-predicate ; define-predicate ;
: forget-tuple ( class -- ) : forget-tuple ( class -- )
@ -72,34 +75,31 @@ BUILTIN: tuple 18 tuple? ;
dup r> tuple-slots dup r> tuple-slots
default-constructor ; 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 ) : 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 #! Turn an association list that maps values to quotations
#! into a quotation that executes a quotation depending on #! into a quotation that executes a quotation depending on
#! the value on the stack. #! the value on the stack.
[ [
[ [
unswons unswons
\ dup , unswons literalize , \ eq? , \ drop swons , \ dup , unswons "predicate" word-prop % ,
alist>quot , \ ifte , alist>quot , \ ifte ,
] make-list ] make-list
] when* ; ] when* ;
: (hash>quot) ( default hash -- quot ) : tuple-methods ( generic -- hash )
[ #! A hashtable of methods on tuples.
\ dup , \ hashcode , dup bucket-count , \ rem , "methods" word-prop [ car metaclass tuple = ] hash-subset ;
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 ;
: default-tuple-method ( generic -- quot ) : default-tuple-method ( generic -- quot )
#! If the generic does not define a specific method for a #! If the generic does not define a specific method for a
@ -115,16 +115,11 @@ BUILTIN: tuple 18 tuple? ;
] ifte ] ifte
] 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 ) : tuple-dispatch-quot ( generic -- quot )
#! Generate a quotation that performs tuple class dispatch #! Generate a quotation that performs tuple class dispatch
#! for methods defined on the given generic. #! for methods defined on the given generic.
dup default-tuple-method \ drop swons dup dup tuple-methods hash>alist class-predicates
over tuple-methods hash>quot >r default-tuple-method r> alist>quot ;
>r "picker" word-prop [ class ] r> append3 ;
: add-tuple-dispatch ( word vtable -- ) : add-tuple-dispatch ( word vtable -- )
>r tuple-dispatch-quot tuple r> set-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 ; { [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
: partial-eval? ( #call -- ? ) : partial-eval? ( #call -- ? )
dup node-param "stateless" word-prop [ dup node-param "foldable" word-prop [
dup node-in-d [ dup node-in-d [
dup literal? dup literal?
[ 2drop t ] [ swap node-literals hash* ] ifte [ 2drop t ] [ swap node-literals hash* ] ifte
@ -56,3 +56,10 @@ M: #call optimize-node* ( node -- node/t )
{ [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ t ] [ drop t ] } { [ t ] [ drop t ] }
} cond ; } 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 recursive-state [ cdr ] change ; inline
: inline-block ( word -- node-block ) : inline-block ( word -- node-block )
gensym over word-def cons gensym over word-def cons [
[ #entry node, word-def infer-quot ] with-block ; #entry node, word-def infer-quot #return node,
] with-block ;
: inline-compound ( word -- ) : inline-compound ( word -- )
#! Infer the stack effect of a compound word in the current #! 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 } ; BUILTIN: wrapper 14 wrapper? { 1 "wrapped" f } ;
M: wrapper = ( obj wrapper -- ? ) 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 ! defined in parse-syntax.factor
DEFER: not DEFER: not

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

@ -9,16 +9,16 @@ USING: kernel math math-internals ;
! Inverse hyperbolic functions: ! Inverse hyperbolic functions:
! acosh asech asinh acosech atanh acoth ! acosh asech asinh acosech atanh acoth
: acosh dup sq 1 - sqrt + log ; stateless : acosh dup sq 1 - sqrt + log ; inline
: asech recip acosh ; stateless : asech recip acosh ; inline
: asinh dup sq 1 + sqrt + log ; stateless : asinh dup sq 1 + sqrt + log ; inline
: acosech recip asinh ; stateless : acosech recip asinh ; inline
: atanh dup 1 + swap 1 - neg / log 2 / ; stateless : atanh dup 1 + swap 1 - neg / log 2 / ; inline
: acoth recip atanh ; stateless : acoth recip atanh ; inline
: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; stateless : <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] ifte ; inline
: asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; stateless : asin dup <=1 [ fasin ] [ i * asinh -i * ] ifte ; inline
: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] ifte ; stateless : acos dup <=1 [ facos ] [ asin pi 2 / swap - ] ifte ; inline
: atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; stateless : atan dup <=1 [ fatan ] [ i * atanh i * ] ifte ; inline
: asec recip acos ; stateless : asec recip acos ; inline
: acosec recip asin ; stateless : acosec recip asin ; inline
: acot recip atan ; stateless : 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 ) : (rect>) ( xr xi -- x )
#! Does not perform a check that the arguments are reals. #! Does not perform a check that the arguments are reals.
#! Do not use in your own code. #! Do not use in your own code.
dup 0 number= [ drop ] [ <complex> ] ifte ; dup 0 number= [ drop ] [ <complex> ] ifte ; inline
IN: math IN: math
@ -24,39 +24,38 @@ M: number = ( n n -- ? ) number= ;
(rect>) (rect>)
] [ ] [
"Complex number must have real components" throw drop "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* ) : conjugate ( z -- z* ) >rect neg rect> ; inline
>rect neg rect> ;
: arg ( z -- arg ) : arg ( z -- arg )
#! Compute the complex argument. #! Compute the complex argument.
>rect swap fatan2 ; >rect swap fatan2 ; inline
: >polar ( z -- abs arg ) : >polar ( z -- abs arg )
dup abs swap >rect swap fatan2 ; dup abs swap >rect swap fatan2 ; inline
: cis ( theta -- cis ) : cis ( theta -- cis )
dup fcos swap fsin rect> ; dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z ) : polar> ( abs arg -- z )
cis * ; cis * ; inline
: absq >rect swap sq swap sq + ; : absq >rect swap sq swap sq + ; inline
IN: math-internals IN: math-internals
: 2>rect ( x y -- xr yr xi yi ) : 2>rect ( x y -- xr yr xi yi )
[ swap real swap real ] 2keep [ swap real swap real ] 2keep
swap imaginary swap imaginary ; swap imaginary swap imaginary ; inline
M: complex number= ( x y -- ? ) M: complex number= ( x y -- ? )
2>rect number= [ number= ] [ 2drop f ] ifte ; 2>rect number= [ number= ] [ 2drop f ] ifte ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * 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> * ; : *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>) ;
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 ) : complex/ ( x y -- r i m )
#! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi #! 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 / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f 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 : e 2.7182818284590452354 ; inline
: pi 3.14159265358979323846 ; inline : pi 3.14159265358979323846 ; inline
: deg>rad pi * 180 / ; : deg>rad pi * 180 / ; inline
: rad>deg 180 * pi / ; : rad>deg 180 * pi / ; inline

6
library/math/integer.factor
View File

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

54
library/math/math.factor
View File

@ -4,34 +4,34 @@ IN: math
USING: errors generic kernel math-internals ; USING: errors generic kernel math-internals ;
! Math operations ! Math operations
G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ; G: number= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
M: object number= 2drop f ; M: object number= 2drop f ;
G: < ( x y -- ? ) [ ] [ arithmetic-type ] ; G: < ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ; G: <= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: > ( x y -- ? ) [ ] [ arithmetic-type ] ; G: > ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ; G: >= ( x y -- ? ) [ ] [ arithmetic-type ] ; foldable
G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ; G: + ( x y -- x+y ) [ ] [ arithmetic-type ] ; foldable
G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ; G: - ( x y -- x-y ) [ ] [ arithmetic-type ] ; foldable
G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ; G: * ( x y -- x*y ) [ ] [ arithmetic-type ] ; foldable
G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ; G: / ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ; G: /i ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ; G: /f ( x y -- x/y ) [ ] [ arithmetic-type ] ; foldable
G: mod ( x y -- x%y ) [ ] [ arithmetic-type ] ; 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: bitand ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ; G: bitor ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ; G: bitxor ( x y -- z ) [ ] [ arithmetic-type ] ; foldable
G: shift ( x n -- y ) [ ] [ arithmetic-type ] ; G: shift ( x n -- y ) [ ] [ arithmetic-type ] ; foldable
GENERIC: bitnot ( n -- n ) GENERIC: bitnot ( n -- n ) foldable
GENERIC: truncate ( n -- n ) GENERIC: truncate ( n -- n ) foldable
GENERIC: floor ( n -- n ) GENERIC: floor ( n -- n ) foldable
GENERIC: ceiling ( n -- n ) GENERIC: ceiling ( n -- n ) foldable
: max ( x y -- z ) [ > ] 2keep ? ; inline : max ( x y -- z ) [ > ] 2keep ? ; inline
: min ( x y -- z ) [ < ] 2keep ? ; inline : min ( x y -- z ) [ < ] 2keep ? ; inline
@ -39,7 +39,7 @@ GENERIC: ceiling ( n -- n )
: between? ( x min max -- ? ) : between? ( x min max -- ? )
#! Push if min <= x <= max. Handles case where min > max #! Push if min <= x <= max. Handles case where min > max
#! by swapping them. #! by swapping them.
2dup > [ swap ] when >r dupd max r> min = ; 2dup > [ swap ] when >r dupd max r> min = ; foldable
: sq dup * ; inline : sq dup * ; inline
@ -48,16 +48,16 @@ GENERIC: ceiling ( n -- n )
: rem ( x y -- x%y ) : rem ( x y -- x%y )
#! Like modulus, but always gives a positive result. #! 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 ) : sgn ( n -- -1/0/1 )
#! Push the sign of a real number. #! 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| ) GENERIC: abs ( z -- |z| )
: align ( offset width -- offset ) : align ( offset width -- offset )
2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; 2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ; inline
: (repeat) ( i n quot -- ) : (repeat) ( i n quot -- )
pick pick >= pick pick >=
@ -77,7 +77,7 @@ GENERIC: abs ( z -- |z| )
dup dup neg bitand = dup dup neg bitand =
] [ ] [
drop f drop f
] ifte ; ] ifte ; foldable
: log2 ( n -- b ) : log2 ( n -- b )
#! Log base two for integers. #! Log base two for integers.
@ -85,4 +85,4 @@ GENERIC: abs ( z -- |z| )
"Input must be positive" throw "Input must be positive" throw
] [ ] [
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte 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: ! Power-related functions:
! exp log sqrt pow ^mod ! exp log sqrt pow ^mod
: exp >rect swap fexp swap polar> ; : exp >rect swap fexp swap polar> ; inline
: log >polar swap flog swap rect> ; : log >polar swap flog swap rect> ; inline
: sqrt ( z -- sqrt ) : sqrt ( z -- sqrt )
>polar dup pi = [ >polar dup pi = [
@ -16,13 +16,13 @@ USING: errors kernel math math-internals ;
swap fsqrt swap 2 / polar> swap fsqrt swap 2 / polar>
] ifte ; ] ifte ;
GENERIC: ^ ( z w -- z^w ) GENERIC: ^ ( z w -- z^w ) foldable
: ^mag ( w abs arg -- magnitude ) : ^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 ) : ^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 ) M: number ^ ( z w -- z^w )
swap >polar 3dup ^theta >r ^mag r> polar> ; swap >polar 3dup ^theta >r ^mag r> polar> ;
@ -38,18 +38,19 @@ M: number ^ ( z w -- z^w )
: (integer^) ( z w -- z^w ) : (integer^) ( z w -- z^w )
1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ; 1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ;
inline
M: integer ^ ( z w -- z^w ) M: integer ^ ( z w -- z^w )
over 0 number= over 0 number= and [ over 0 number= over 0 number= and [
"0^0 is not defined" throw "0^0 is not defined" throw
] [ ] [
dup 0 < [ neg ^ recip ] [ (integer^) ] ifte dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
] ifte ; ] ifte ; foldable
: (^mod) ( n z w -- z^w ) : (^mod) ( n z w -- z^w )
1 swap [ 1 swap [
1 number= [ dupd * pick mod ] when >r sq over mod r> 1 number= [ dupd * pick mod ] when >r sq over mod r>
] each-bit 2nip ; ] each-bit 2nip ; inline
: ^mod ( z w n -- z^w ) : ^mod ( z w n -- z^w )
#! Compute z^w mod n. #! Compute z^w mod n.
@ -57,4 +58,4 @@ M: integer ^ ( z w -- z^w )
[ >r neg r> ^mod ] keep mod-inv [ >r neg r> ^mod ] keep mod-inv
] [ ] [
-rot (^mod) -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) 2drop (random-int) 2dup swap mod (random-int-0)
] [ ] [
2nip 2nip
] ifte ; ] ifte ; inline
: random-int-0 ( max -- n ) : random-int-0 ( max -- n )
1 + dup power-of-2? [ 1 + dup power-of-2? [
(random-int) * -31 shift (random-int) * -31 shift
] [ ] [
(random-int) 2dup swap mod (random-int-0) (random-int) 2dup swap mod (random-int-0)
] ifte ; ] ifte ; inline
: random-int ( min max -- n ) dupd swap - random-int-0 + ; : 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 ; M: integer denominator drop 1 ;
: >fraction ( a/b -- a b ) : >fraction ( a/b -- a b )
dup numerator swap denominator ; dup numerator swap denominator ; inline
IN: math-internals IN: math-internals
: 2>fraction ( a/b c/d -- a c b d ) : 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 -- ? ) M: ratio number= ( a/b c/d -- ? )
2>fraction number= [ number= ] [ 2drop f ] ifte ; 2>fraction number= [ number= ] [ 2drop f ] ifte ;
: scale ( a/b c/d -- a*d b*c ) : 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 ) : ratio+d ( a/b c/d -- b*d )
denominator swap denominator * ; inline denominator swap denominator * ; inline

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

@ -12,32 +12,32 @@ USING: kernel math math-internals ;
: cos ( z -- cos ) : cos ( z -- cos )
>rect 2dup >rect 2dup
fcosh swap fcos * -rot 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 ) : cosh ( z -- cosh )
>rect 2dup >rect 2dup
fcos swap fcosh * -rot fcos swap fcosh * -rot
fsin swap fsinh * rect> ; fsin swap fsinh * rect> ; inline
: sech cosh recip ; : sech cosh recip ; inline
: sin ( z -- sin ) : sin ( z -- sin )
>rect 2dup >rect 2dup
fcosh swap fsin * -rot fcosh swap fsin * -rot
fsinh swap fcos * rect> ; fsinh swap fcos * rect> ; inline
: cosec sin recip ; : cosec sin recip ; inline
: sinh ( z -- sinh ) : sinh ( z -- sinh )
>rect 2dup >rect 2dup
fcos swap fsinh * -rot 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 / ; : tan dup sin swap cos / ; inline
: tanh dup sinh swap cosh / ; : tanh dup sinh swap cosh / ; inline
: cot dup cos swap sin / ; : cot dup cos swap sin / ; inline
: coth dup cosh swap sinh / ; : 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. #! Mark the last word to be inlined.
word t "inline" set-word-prop ; parsing word t "inline" set-word-prop ; parsing
: stateless ( -- ) : flushable ( -- )
#! Mark the last word to be evaluated at compile time if #! Declare that a word may be removed if the value it
#! all inputs are literals. #! computes is unused.
word t "stateless" set-word-prop ; parsing 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 : ... ;. ! The variable "in-definition" is set inside a : ... ;.
! ( and #! then add "stack-effect" and "documentation" ! ( and #! then add "stack-effect" and "documentation"

13
library/syntax/see.factor
View File

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

9
library/test/combinators.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: alien strings ; USING: alien errors strings ;
USE: kernel USE: kernel
USE: math USE: math
USE: test USE: test
@ -57,3 +57,10 @@ unit-test
{ [ t ] [ drop "neither" ] } { [ t ] [ drop "neither" ] }
} cond } cond
] unit-test ] 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 IN: temporary
USING: memory ;
USE: errors USE: errors
USE: kernel USE: kernel
USE: namespaces USE: namespaces
@ -27,3 +28,14 @@ USE: io
! This should not raise an error ! This should not raise an error
[ 1 2 3 ] [ 1 2 3 f throw ] unit-test [ 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: strings
USE: sequences USE: sequences
[ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
[ "fdsfs" [ > ] sort ] unit-test-fails [ "fdsfs" [ > ] sort ] unit-test-fails
[ [ ] ] [ [ ] [ > ] sort ] unit-test [ [ ] ] [ [ ] [ > ] sort ] unit-test
[ [ "2 + 2" ] ] [ [ "2 + 2" ] [ lexi> ] 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 [ [ 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 IN: temporary
USING: kernel lists sequences test ; 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 ] ] [ [ 3 ] last ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] last ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] last ] unit-test
[ [[ 3 4 ]] ] [ [[ 1 [[ 2 [[ 3 4 ]] ]] ]] 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 [ t ] [ [ 1 2 ] list? ] unit-test
[ f ] [ [[ 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 [ 2 3 ] unique ] unit-test
[ [ 1 2 3 ] ] [ 1 [ 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 [ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test
[ [ ] ] [ 0 >list ] unit-test [ [ ] ] [ 0 >list ] unit-test
[ [ 0 1 2 3 ] ] [ 4 >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 4 } { 2 5 } { 3 6 } } ]
[ { { 1 2 3 } { 4 5 6 } } flip ] unit-test [ { { 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: sequences
USE: lists USE: lists
[ ] [ 10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times ] unit-test
[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
[ "abc" ] [ "ab" "c" append ] 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/complex" "math/irrational" "math/integer"
"math/matrices" "math/matrices"
"httpd/url-encoding" "httpd/html" "httpd/httpd" "httpd/url-encoding" "httpd/html" "httpd/httpd"
"httpd/http-client" "httpd/http-client" "sbuf" "threads" "parsing-word"
"crashes" "sbuf" "threads" "parsing-word" "inference" "interpreter" "alien"
"inference" "interpreter"
"alien"
"gadgets/line-editor" "gadgets/rectangles" "gadgets/line-editor" "gadgets/rectangles"
"gadgets/gradients" "memory" "gadgets/gradients" "memory"
"redefine" "annotate" "sequences" "binary" "inspector" "redefine" "annotate" "sequences" "binary" "inspector"
"kernel"
] run-tests ; ] run-tests ;
: benchmarks : benchmarks

6
library/test/vectors.factor
View File

@ -1,6 +1,8 @@
IN: temporary IN: temporary
USING: kernel kernel-internals lists math namespaces random USING: errors kernel kernel-internals lists math namespaces
sequences strings test vectors ; 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
[ 3 ] [ { t f t } length ] unit-test [ 3 ] [ { t f t } length ] unit-test