various clean ups, fix linearization of #label
Slava Pestov
parent
9707d90970
commit
05a9338bc7
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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= [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 + ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
IN: scratchpad
|
||||
USING: kernel memory sequences test ;
|
||||
|
||||
[ 0 ] [ f size ] unit-test
|
||||
[ t ] [ [ \ = \ = ] [ = ] every? ] unit-test
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue