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

redid = hashcode and math words using new object system

cvs
Slava Pestov 2004-12-19 04:18:32 +00:00
parent 50e40afde9
commit cad99c8888
25 changed files with 571 additions and 703 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
TODO.FACTOR.txt
View File

@ -24,15 +24,11 @@
+ oop:
- union metaclass
- add defined methods to a word prop
- M: sort method list, build vtable, redefine generic
- 2generic
- move generic, 2generic from kernel vocabulary
- generic = hashcode and math ops
- no vtable word-prop
- make see work with generics
- doc comments of generics
- GENERIC: don't install empty vtable if already defined
+ ffi:

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

@ -38,6 +38,7 @@ USE: stdio
"/library/generic/object.factor"
"/library/generic/builtin.factor"
"/library/generic/predicate.factor"
"/library/generic/union.factor"
"/library/generic/traits.factor"
"/version.factor"
@ -47,11 +48,13 @@ USE: stdio
"/library/logic.factor"
"/library/cons.factor"
"/library/assoc.factor"
"/library/math/generic.factor"
"/library/words.factor"
"/library/math/arithmetic.factor"
"/library/math/math-combinators.factor"
"/library/math/math.factor"
"/library/math/integer.factor"
"/library/math/ratio.factor"
"/library/math/float.factor"
"/library/math/complex.factor"
"/library/words.factor"
"/library/math/math-combinators.factor"
"/library/lists.factor"
"/library/vectors.factor"
"/library/strings.factor"

11
library/bootstrap/boot.factor
View File

@ -43,11 +43,13 @@ USE: hashtables
"/library/logic.factor" run-resource
"/library/cons.factor" run-resource
"/library/assoc.factor" run-resource
"/library/math/generic.factor" run-resource
"/library/words.factor" run-resource
"/library/math/arithmetic.factor" run-resource
"/library/math/math-combinators.factor" run-resource
"/library/math/math.factor" run-resource
"/library/math/integer.factor" run-resource
"/library/math/ratio.factor" run-resource
"/library/math/float.factor" run-resource
"/library/math/complex.factor" run-resource
"/library/words.factor" run-resource
"/library/math/math-combinators.factor" run-resource
"/library/lists.factor" run-resource
"/library/vectors.factor" run-resource
"/library/strings.factor" run-resource
@ -76,6 +78,7 @@ vocabularies get [
"/library/generic/object.factor" run-resource
"/library/generic/builtin.factor" run-resource
"/library/generic/predicate.factor" run-resource
"/library/generic/union.factor" run-resource
"/library/generic/traits.factor" run-resource
! init.factor leaves a boot quotation on the stack

9
library/bootstrap/image.factor
View File

@ -190,13 +190,6 @@ M: f ' ( obj -- ptr )
( Words )
: make-plist ( word -- plist )
[
dup word-name "name" swons ,
dup word-vocabulary "vocabulary" swons ,
parsing? [ t "parsing" swons , ] when
] make-list ;
: word, ( word -- )
[
word-tag >header ,
@ -204,7 +197,7 @@ M: f ' ( obj -- ptr )
0 ,
dup word-primitive ,
dup word-parameter ' ,
dup make-plist ' ,
dup word-plist ' ,
0 ,
0 ,
] make-list

12
library/generic/builtin.factor
View File

@ -39,15 +39,17 @@ USE: vectors
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
: builtin-method ( type generic definition -- )
-rot "vtable" word-property add-method ;
builtin [ builtin-method ] "define-method" set-word-property
builtin [
"builtin-type" word-property unit
] "builtin-supertypes" set-word-property
builtin [
( vtable definition class -- )
rot set-vtable
] "add-method" set-word-property
builtin 50 "priority" set-word-property
: builtin-predicate ( type# symbol -- word )
predicate-word [
swap [ swap type eq? ] cons define-compound

81
library/generic/generic.factor
View File

@ -35,6 +35,8 @@ USE: parser
USE: strings
USE: words
USE: vectors
USE: math
USE: math-internals
! A simple single-dispatch generic word system.
@ -53,7 +55,10 @@ USE: vectors
! The class of an object with traits is determined by the object
! identity of the traits method map.
! - metaclass: a metaclass is a symbol with a handful of word
! properties: "define-method" "builtin-types"
! properties: "define-method" "builtin-types" "priority"
! Metaclasses have priority -- this induces an order in which
! methods are added to the vtable.
: undefined-method
"No applicable method." throw ;
@ -65,33 +70,81 @@ USE: vectors
#! A list of builtin supertypes of the class.
dup metaclass "builtin-supertypes" word-property call ;
: add-method ( definition type vtable -- )
: set-vtable ( definition class vtable -- )
>r "builtin-type" word-property r> set-vector-nth ;
: define-generic ( word vtable -- )
2dup "vtable" set-word-property
[ generic ] cons define-compound ;
: <empty-vtable> ( -- vtable )
num-types [ drop [ undefined-method ] ] vector-project ;
: <vtable> ( default -- vtable )
num-types [ drop dup ] vector-project nip ;
: class-ord ( class -- n ) metaclass "priority" word-property ;
: class< ( cls1 cls2 -- ? )
swap car class-ord swap car class-ord < ;
: sort-methods ( methods -- alist )
hash>alist [ class< ] sort ;
: add-method ( vtable definition class -- )
#! Add the method entry to the vtable. Unlike define-method,
#! this is called at vtable build time, and in the sorted
#! order.
dup metaclass "add-method" word-property
[ [ undefined-method ] ] unless* call ;
: <vtable> ( methods -- vtable )
<empty-vtable> swap sort-methods [
dupd unswons add-method
] each ;
DEFER: add-traits-dispatch
: define-generic ( word vtable -- )
over "combination" word-property cons define-compound ;
: (define-method) ( definition class generic -- )
[ "methods" word-property [ set-hash ] keep <vtable> ] keep
swap define-generic ;
! Defining generic words
: (GENERIC) ( combination -- )
#! Takes a combination parameter. A combination is a
#! quotation that takes some objects and a vtable from the
#! stack, and calls the appropriate row of the vtable.
CREATE 2dup "combination" word-property = [
2drop
] [
[ swap "combination" set-word-property ] keep
dup <namespace> "methods" set-word-property
<empty-vtable> [ add-traits-dispatch ] 2keep
define-generic
] ifte ;
: single-combination ( obj vtable -- )
>r dup type r> dispatch ; inline
: GENERIC:
#! GENERIC: bar creates a generic word bar that calls the
#! bar method on the traits object, with the traits object
#! on the stack.
CREATE [ undefined-method ] <vtable>
2dup add-traits-dispatch
define-generic ; parsing
#! GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:.
[ single-combination ] (GENERIC) ; parsing
: arithmetic-combination ( n n vtable -- )
#! Note that the numbers remain on the stack, possibly after
#! being coerced to a maximal type.
>r arithmetic-type r> dispatch ; inline
: 2GENERIC:
#! 2GENERIC: bar creates a generic word bar. Add methods to
#! the generic word using M:. 2GENERIC words dispatch on
#! arithmetic types and should not be used for non-numerical
#! types.
[ arithmetic-combination ] (GENERIC) ; parsing
: define-method ( class -- quotation )
#! In a vain attempt at something resembling a "meta object
#! protocol", we call the "define-method" word property with
#! stack ( class generic definition -- ).
metaclass "define-method" word-property
[ [ undefined-method ] ] unless* ;
[ [ -rot (define-method) ] ] unless* ;
: M: ( -- class generic [ ] )
#! M: foo bar begins a definition of the bar generic word

17
library/generic/object.factor
View File

@ -35,19 +35,22 @@ USE: parser
USE: strings
USE: words
USE: vectors
USE: math
! Catch-all metaclass for providing a default method.
SYMBOL: object
: define-object ( generic definition -- )
<vtable> define-generic drop ;
object object "metaclass" set-word-property
object [
define-object
] "define-method" set-word-property
object [
drop num-types count
] "builtin-supertypes" set-word-property
object [
( vtable definition class -- )
drop over vector-length [
pick pick -rot set-vector-nth
] times* 2drop
] "add-method" set-word-property
object 100 "priority" set-word-property

35
library/generic/predicate.factor
View File

@ -39,31 +39,32 @@ USE: vectors
! Predicate metaclass for generalized predicate dispatch.
SYMBOL: predicate
: predicate-dispatch ( class definition existing -- dispatch )
: predicate-dispatch ( existing definition class -- dispatch )
[
\ dup ,
rot "predicate" word-property ,
swap , , \ ifte ,
\ dup , "predicate" word-property , , , \ ifte ,
] make-list ;
: (predicate-method) ( class generic definition type# -- )
rot "vtable" word-property
[ vector-nth predicate-dispatch ] 2keep
set-vector-nth ;
: predicate-method ( class generic definition -- )
pick builtin-supertypes [
>r 3dup r> (predicate-method)
] each 3drop ;
predicate [
predicate-method
] "define-method" set-word-property
: (predicate-method) ( vtable definition class type# -- )
>r rot r> swap [
vector-nth
( vtable definition class existing )
-rot predicate-dispatch
] 2keep set-vector-nth ;
predicate [
"superclass" word-property builtin-supertypes
] "builtin-supertypes" set-word-property
predicate [
( vtable definition class -- )
dup builtin-supertypes [
( vtable definition class type# )
>r 3dup r> (predicate-method)
] each 3drop
] "add-method" set-word-property
predicate 25 "priority" set-word-property
: define-predicate ( class predicate definition -- )
rot "superclass" word-property "predicate" word-property
[ \ dup , , , [ drop f ] , \ ifte , ] make-list

13
library/generic/traits.factor
View File

@ -46,15 +46,18 @@ SYMBOL: traits
#! definitions.
"traits-map" word-property ;
: traits-method ( class generic definition -- )
swap rot traits-map set-hash ;
traits [ traits-method ] "define-method" set-word-property
traits [
( class generic quotation )
swap rot traits-map set-hash
] "define-method" set-word-property
traits [
\ vector "builtin-type" word-property unique,
] "builtin-supertypes" set-word-property
traits 10 "priority" set-word-property
! Hashtable slot holding an optional delegate. Any undefined
! methods are called on the delegate. The object can also
! manually pass any methods on to the delegate.
@ -100,7 +103,7 @@ SYMBOL: delegate
: add-traits-dispatch ( word vtable -- )
>r unit [ car swap traits-dispatch call ] cons \ vector r>
add-method ;
set-vtable ;
: constructor-word ( word -- word )
word-name "<" swap ">" cat3 "in" get create ;

78
library/generic/union.factor Normal file
View File

@ -0,0 +1,78 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: generic
USE: errors
USE: hashtables
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
! Union metaclass for dispatch on multiple classes.
SYMBOL: union
union [
[ ] swap "members" word-property [
builtin-supertypes append
] each
] "builtin-supertypes" set-word-property
union [
( vtable definition class -- )
"members" word-property [ >r 2dup r> add-method ] each 2drop
] "add-method" set-word-property
union 30 "priority" set-word-property
: union-predicate ( definition -- list )
[
[
\ dup ,
unswons "predicate" word-property ,
[ drop t ] ,
union-predicate ,
\ ifte ,
] make-list
] [
[ drop f ]
] ifte* ;
: define-union ( class predicate definition -- )
[ union-predicate define-compound ] keep
"members" set-word-property ;
: UNION: ( -- class predicate definition )
#! Followed by a class name, then a list of union members.
CREATE
dup union "metaclass" set-word-property
dup predicate-word
[ dupd "predicate" set-word-property ] keep
[ define-union ] [ ] ; parsing

79
library/kernel.factor
View File

@ -1,4 +1,4 @@
! :folding=none:collapseFolds=1:
! :folding=indent:collapseFolds=1:
! $Id$
!
@ -25,24 +25,8 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: syntax
USE: generic
BUILTIN: f 6 FORGET: f?
BUILTIN: t 7 FORGET: t?
IN: vectors
DEFER: vector=
DEFER: vector-hashcode
IN: lists
DEFER: cons=
DEFER: cons-hashcode
IN: math
DEFER: >rect
DEFER: bitxor
IN: kernel
USE: generic
USE: lists
USE: math
USE: math-internals
@ -59,64 +43,17 @@ USE: vectors
#! Returns one of "unix" or "win32".
11 getenv ;
! The 'fake vtable' used here speeds things up a lot.
! It is quite clumsy, however. A higher-level CLOS-style
! 'generic words' system will be built later.
: dispatch ( n vtable -- )
vector-nth call ;
: generic ( obj vtable -- )
>r dup type r> dispatch ; inline
: 2generic ( n n vtable -- )
>r arithmetic-type r> dispatch ; inline
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.
{
[ ] ! 0
[ word-hashcode ] ! 1
[ cons-hashcode ] ! 2
[ drop 0 ] ! 3
[ >fixnum ] ! 4
[ >rect >fixnum swap >fixnum bitxor ] ! 5
[ drop 0 ] ! 6
[ drop 0 ] ! 7
[ drop 0 ] ! 8
[ >fixnum ] ! 9
[ >fixnum ] ! 10
[ vector-hashcode ] ! 11
[ str-hashcode ] ! 12
[ sbuf-hashcode ] ! 13
[ drop 0 ] ! 14
[ drop 0 ] ! 15
[ drop 0 ] ! 16
} generic ;
GENERIC: hashcode
M: object hashcode drop 0 ;
IN: math DEFER: number= ( defined later... )
IN: kernel
: = ( obj obj -- ? )
#! Push t if a is isomorphic to b.
{
[ number= ] ! 0
[ eq? ] ! 1
[ cons= ] ! 2
[ eq? ] ! 3
[ number= ] ! 4
[ number= ] ! 5
[ eq? ] ! 6
[ eq? ] ! 7
[ eq? ] ! 8
[ number= ] ! 9
[ number= ] ! 10
[ vector= ] ! 11
[ str= ] ! 12
[ sbuf= ] ! 13
[ eq? ] ! 14
[ eq? ] ! 15
[ eq? ] ! 16
} generic ;
GENERIC: =
M: object = eq? ;
: set-boot ( quot -- )
#! Set the boot quotation.
@ -125,3 +62,7 @@ IN: kernel
: num-types ( -- n )
#! One more than the maximum value from type primitive.
17 ;
IN: syntax
BUILTIN: f 6 FORGET: f?
BUILTIN: t 7 FORGET: t?

13
library/lists.factor
View File

@ -26,9 +26,9 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: lists
USE: generic
USE: kernel
USE: math
USE: vectors
: 2list ( a b -- [ a b ] )
unit cons ;
@ -152,7 +152,7 @@ DEFER: tree-contains?
#! partial order with stack effect ( o1 o2 -- ? ).
swap [ pick >r maximize r> swap ] (top) nip ; inline
: cons= ( obj cons -- ? )
M: cons = ( obj cons -- ? )
2dup eq? [
2drop t
] [
@ -163,22 +163,21 @@ DEFER: tree-contains?
] ifte
] ifte ;
: (cons-hashcode) ( cons count -- hash )
: cons-hashcode ( cons count -- hash )
dup 0 = [
2drop 0
] [
over cons? [
pred >r uncons r> tuck
(cons-hashcode) >r
(cons-hashcode) r>
cons-hashcode >r
cons-hashcode r>
bitxor
] [
drop hashcode
] ifte
] ifte ;
: cons-hashcode ( cons -- hash )
4 (cons-hashcode) ;
M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
: project ( n quot -- list )
#! Execute the quotation n times, passing the loop counter

78
library/math/complex.factor Normal file
View File

@ -0,0 +1,78 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
USE: generic
USE: kernel
USE: math
: >rect ( x -- xr xi ) dup real swap imaginary ;
IN: math-internals
: 2>rect ( x y -- xr yr xi yi )
[ swap real swap real ] 2keep
swap imaginary swap imaginary ;
M: complex number= ( x y -- ? )
2>rect number= [ number= ] [ 2drop f ] ifte ;
: *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> ;
M: complex * ( x y -- x*y ) 2dup *re - -rot *im + rect> ;
: abs^2 ( x -- y ) >rect sq swap sq + ; inline
: complex/ ( x y -- r i m )
#! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
dup abs^2 >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> ;
M: complex abs ( z -- |z| ) >rect mag2 ;
: conjugate ( z -- z* )
>rect neg rect> ;
: arg ( z -- arg )
#! Compute the complex argument.
>rect swap fatan2 ;
: >polar ( z -- abs arg )
>rect 2dup swap fatan2 >r mag2 r> ;
: cis ( theta -- cis )
dup fcos swap fsin rect> ;
: polar> ( abs arg -- z )
cis * ;
M: complex hashcode ( n -- n )
>rect >fixnum swap >fixnum bitxor ;

43
library/math/float.factor Normal file
View File

@ -0,0 +1,43 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math-internals
USE: generic
USE: kernel
USE: math
M: float number= float= ;
M: float < float< ;
M: float <= float<= ;
M: float > float> ;
M: float >= float>= ;
M: float + float+ ;
M: float - float- ;
M: float * float* ;
M: float / float/f ;
M: float /f float/f ;

492
library/math/generic.factor
View File

@ -1,492 +0,0 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
USE: errors
USE: generic
USE: kernel
USE: vectors
USE: words
BUILTIN: fixnum 0
BUILTIN: ratio 4
BUILTIN: complex 5
BUILTIN: bignum 9
BUILTIN: float 10
DEFER: number=
DEFER: mod
DEFER: abs
DEFER: <
DEFER: <=
DEFER: >
DEFER: >=
DEFER: neg
DEFER: /i
DEFER: *
DEFER: +
DEFER: -
DEFER: /
DEFER: /f
DEFER: sq
: (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
: gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ;
: >rect ( x -- x:re x: im ) dup real swap imaginary ;
: 2>rect ( x y -- x:re y:re x:im y:im )
[ swap real swap real ] 2keep
swap imaginary swap imaginary ;
: 2>fraction ( a/b c/d -- a c b d )
[ swap numerator swap numerator ] 2keep
swap denominator swap denominator ;
IN: math-internals
: reduce ( x y -- x' y' )
dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
: ratio ( x y -- x/y ) reduce fraction> ;
: ratio= ( a/b c/d -- ? )
2>fraction number= [ number= ] [ 2drop f ] ifte ;
: ratio-scale ( a/b c/d -- a*d b*c )
2>fraction >r * swap r> * swap ;
: ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ;
: ratio+ ( x y -- x+y ) 2dup ratio-scale + -rot ratio+d ratio ;
: ratio- ( x y -- x-y ) 2dup ratio-scale - -rot ratio+d ratio ;
: ratio* ( x y -- x*y ) 2>fraction * >r * r> ratio ;
: ratio/ ( x y -- x/y ) ratio-scale ratio ;
: ratio/f ( x y -- x/y ) ratio-scale /f ;
: ratio< ( x y -- ? ) ratio-scale < ;
: ratio<= ( x y -- ? ) ratio-scale <= ;
: ratio> ( x y -- ? ) ratio-scale > ;
: ratio>= ( x y -- ? ) ratio-scale >= ;
: complex= ( x y -- ? )
2>rect number= [ number= ] [ 2drop f ] ifte ;
: complex+ ( x y -- x+y ) 2>rect + >r + r> rect> ;
: complex- ( x y -- x-y ) 2>rect - >r - r> rect> ;
: complex*re ( x y -- x:re * y:re x:im * r:im )
2>rect * >r * r> ;
: complex*im ( x y -- x:im * y:re x:re * y:im )
2>rect >r * swap r> * ;
: complex* ( x y -- x*y )
2dup complex*re - -rot complex*im + rect> ;
: abs^2 ( x -- y ) >rect sq swap sq + ;
: (complex/) ( x y -- r i m )
#! r = x:re * y:re + x:im * y:im
#! i = x:im * y:re - x:re * y:im
#! m = y:re * y:re + y:im * y:im
dup abs^2 >r 2dup complex*re + -rot complex*im - r> ;
: complex/ ( x y -- x/y )
(complex/) tuck / >r / r> rect> ;
: complex/f ( x y -- x/y )
(complex/) tuck /f >r /f r> rect> ;
IN: math
USE: math-internals
: number= ( x y -- ? )
{
[ fixnum= ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
[ ratio= ]
[ complex= ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
[ bignum= ]
[ float= ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
[ 2drop f ]
} 2generic ;
: + ( x y -- x+y )
{
[ fixnum+ ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio+ ]
[ complex+ ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum+ ]
[ float+ ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: - ( x y -- x-y )
{
[ fixnum- ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio- ]
[ complex- ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum- ]
[ float- ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: * ( x y -- x*y )
{
[ fixnum* ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio* ]
[ complex* ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum* ]
[ float* ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: / ( x y -- x/y )
{
[ ratio ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio/ ]
[ complex/ ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio ]
[ float/f ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: /i ( x y -- x/y )
{
[ fixnum/i ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum/i ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: /f ( x y -- x/y )
{
[ fixnum/f ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio/f ]
[ complex/f ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum/f ]
[ float/f ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: mod ( x y -- x%y )
{
[ fixnum-mod ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-mod ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: /mod ( x y -- x/y x%y )
{
[ fixnum/mod ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum/mod ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: bitand ( x y -- x&y )
{
[ fixnum-bitand ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-bitand ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: bitor ( x y -- x|y )
{
[ fixnum-bitor ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-bitor ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: bitxor ( x y -- x^y )
{
[ fixnum-bitxor ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-bitxor ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: bitnot ( x -- ~x )
{
[ fixnum-bitnot ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-bitnot ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} generic ;
: shift ( x n -- x<<n )
{
[ fixnum-shift ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum-shift ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: < ( x y -- ? )
{
[ fixnum< ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio< ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum< ]
[ float< ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: <= ( x y -- ? )
{
[ fixnum<= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio<= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum<= ]
[ float<= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: > ( x y -- ? )
{
[ fixnum> ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio> ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum> ]
[ float> ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;
: >= ( x y -- ? )
{
[ fixnum>= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ ratio>= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ bignum>= ]
[ float>= ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
[ undefined-method ]
} 2generic ;

84
library/math/integer.factor Normal file
View File

@ -0,0 +1,84 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math-internals
USE: generic
USE: kernel
USE: math
: reduce ( x y -- x' y' )
dup 0 < [ swap neg swap neg ] when
2dup gcd tuck /i >r /i r> ; inline
: integer/ ( x y -- x/y )
reduce fraction> ; inline
M: fixnum number= fixnum= ;
M: fixnum < fixnum< ;
M: fixnum <= fixnum<= ;
M: fixnum > fixnum> ;
M: fixnum >= fixnum>= ;
M: fixnum + fixnum+ ;
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum / integer/ ;
M: fixnum /i fixnum/i ;
M: fixnum /f fixnum/f ;
M: fixnum mod fixnum-mod ;
M: fixnum /mod fixnum/mod ;
M: fixnum bitand fixnum-bitand ;
M: fixnum bitor fixnum-bitor ;
M: fixnum bitxor fixnum-bitxor ;
M: fixnum shift fixnum-shift ;
M: fixnum bitnot fixnum-bitnot ;
M: bignum number= bignum= ;
M: bignum < bignum< ;
M: bignum <= bignum<= ;
M: bignum > bignum> ;
M: bignum >= bignum>= ;
M: bignum + bignum+ ;
M: bignum - bignum- ;
M: bignum * bignum* ;
M: bignum / integer/ ;
M: bignum /i bignum/i ;
M: bignum /f bignum/f ;
M: bignum mod bignum-mod ;
M: bignum /mod bignum/mod ;
M: bignum bitand bignum-bitand ;
M: bignum bitor bignum-bitor ;
M: bignum bitxor bignum-bitxor ;
M: bignum shift bignum-shift ;
M: bignum bitnot bignum-bitnot ;

3
library/math/math-combinators.factor
View File

@ -51,6 +51,9 @@ USE: kernel
#! than it produces.
0 swap (times) ; inline
: fac ( n -- n! )
1 swap [ succ * ] times* ;
: 2times-succ ( #{ a b } #{ c d } -- z )
#! Lexicographically add #{ 0 1 } to a complex number.
#! If d + 1 == b, return #{ c+1 0 }. Otherwise, #{ c d+1 }.

99
library/math/math.factor
View File

@ -2,7 +2,7 @@
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
! Copyright (C) 2003, 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@ -26,37 +26,92 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
USE: generic
USE: kernel
USE: math
USE: math-internals
: fac ( n -- n! )
! This is the naive implementation, for benchmarking purposes.
1 swap [ succ * ] times* ;
! Math operations
2GENERIC: number= ( x y -- ? )
2GENERIC: < ( x y -- ? )
2GENERIC: <= ( x y -- ? )
2GENERIC: > ( x y -- ? )
2GENERIC: >= ( x y -- ? )
2GENERIC: + ( x y -- x+y )
2GENERIC: - ( x y -- x-y )
2GENERIC: * ( x y -- x*y )
2GENERIC: / ( x y -- x/y )
2GENERIC: /i ( x y -- x/y )
2GENERIC: /f ( x y -- x/y )
2GENERIC: mod ( x y -- x%y )
2GENERIC: /mod ( x y -- x/y x%y )
2GENERIC: bitand ( x y -- z )
2GENERIC: bitor ( x y -- z )
2GENERIC: bitxor ( x y -- z )
2GENERIC: shift ( x n -- y )
GENERIC: bitnot ( n -- n )
! Math types
BUILTIN: fixnum 0
BUILTIN: bignum 9
UNION: integer fixnum bignum ;
BUILTIN: ratio 4
UNION: rational integer ratio ;
BUILTIN: float 10
UNION: real rational float ;
BUILTIN: complex 5
UNION: number real complex ;
M: real hashcode ( n -- n ) >fixnum ;
M: number = ( n n -- ? ) number= ;
: max ( x y -- z )
2dup > [ drop ] [ nip ] ifte ;
: min ( x y -- z )
2dup < [ drop ] [ nip ] ifte ;
: 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 = ;
: sq dup * ; inline
: pred 1 - ; inline
: succ 1 + ; inline
: neg 0 swap - ; inline
: recip 1 swap / ; inline
: rem ( x y -- x%y )
#! Like modulus, but always gives a positive result.
[ mod ] keep over 0 < [ + ] [ drop ] ifte ;
: sgn ( n -- -1/0/1 )
#! Push the sign of a real number.
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
: mag2 ( x y -- mag )
#! Returns the magnitude of the vector (x,y).
swap sq swap sq + fsqrt ;
: abs ( z -- abs )
#! Compute the complex absolute value.
dup complex? [ >rect mag2 ] [ dup 0 < [ neg ] when ] ifte ;
GENERIC: abs ( z -- |z| )
M: real abs dup 0 < [ neg ] when ;
: conjugate ( z -- z* )
>rect neg rect> ;
: (gcd) ( x y -- z )
dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
: arg ( z -- arg )
#! Compute the complex argument.
>rect swap fatan2 ; inline
: >polar ( z -- abs arg )
>rect 2dup swap fatan2 >r mag2 r> ;
: cis ( theta -- cis )
dup fcos swap fsin rect> ;
: polar> ( abs arg -- z )
cis * ; inline
: gcd ( x y -- z )
#! Greatest common divisor.
abs swap abs 2dup < [ swap ] when (gcd) ;
: align ( offset width -- offset )
2dup mod dup 0 = [ 2drop ] [ - + ] ifte ;

50
library/math/arithmetic.factor → library/math/ratio.factor
View File

@ -2,7 +2,7 @@
! $Id$
!
! Copyright (C) 2003, 2004 Slava Pestov.
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@ -25,36 +25,32 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math
IN: math-internals
USE: generic
USE: kernel
USE: math
: integer? dup fixnum? swap bignum? or ;
: rational? dup integer? swap ratio? or ;
: real? dup number? swap complex? not and ;
: 2>fraction ( a/b c/d -- a c b d )
[ swap numerator swap numerator ] 2keep
swap denominator swap denominator ; inline
: max ( x y -- z )
2dup > [ drop ] [ nip ] ifte ;
M: ratio number= ( a/b c/d -- ? )
2>fraction number= [ number= ] [ 2drop f ] ifte ;
: min ( x y -- z )
2dup < [ drop ] [ nip ] ifte ;
: scale ( a/b c/d -- a*d b*c )
2>fraction >r * swap r> * swap ; inline
: 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 = ;
: ratio+d ( a/b c/d -- b*d )
denominator swap denominator * ; inline
: sq dup * ; inline
M: ratio < scale < ;
M: ratio <= scale <= ;
M: ratio > scale > ;
M: ratio >= scale >= ;
: pred 1 - ; inline
: succ 1 + ; inline
: neg 0 swap - ; inline
: recip 1 swap / ; inline
: rem ( x y -- x%y )
#! Like modulus, but always gives a positive result.
[ mod ] keep over 0 < [ + ] [ drop ] ifte ;
: sgn ( n -- -1/0/1 )
#! Push the sign of a real number.
dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
M: ratio + ( x y -- x+y ) 2dup scale + -rot ratio+d integer/ ;
M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d integer/ ;
M: ratio * ( x y -- x*y ) 2>fraction * >r * r> integer/ ;
M: ratio / scale integer/ ;
M: ratio /i scale /i ;
M: ratio /f scale /f ;

16
library/strings.factor
View File

@ -31,8 +31,14 @@ USE: kernel
USE: lists
USE: math
! Define methods bound to primitives
BUILTIN: string 12
M: string hashcode str-hashcode ;
M: string = str= ;
BUILTIN: sbuf 13
M: sbuf hashcode sbuf-hashcode ;
M: sbuf = sbuf= ;
: f-or-"" ( obj -- ? )
dup not swap "" = or ;
@ -136,11 +142,11 @@ BUILTIN: sbuf 13
-rot 2dup >r >r >r str-nth r> call r> r>
] times* 2drop ; inline
: blank? ( ch -- ? ) " \t\n\r" str-contains? ;
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ;
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ;
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ;
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ;
PREDICATE: integer blank " \t\n\r" str-contains? ;
PREDICATE: integer letter CHAR: a CHAR: z between? ;
PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
: quotable? ( ch -- ? )
#! In a string literal, can this character be used without

14
library/syntax/parse-numbers.factor
View File

@ -40,13 +40,11 @@ USE: unparser
: not-a-number "Not a number" throw ;
: digit> ( ch -- n )
[
[ digit? ] [ CHAR: 0 - ]
[ letter? ] [ CHAR: a - 10 + ]
[ LETTER? ] [ CHAR: A - 10 + ]
[ drop t ] [ not-a-number ]
] cond ;
GENERIC: digit> ( ch -- n )
M: digit digit> CHAR: 0 - ;
M: letter digit> CHAR: a - 10 + ;
M: LETTER digit> CHAR: A - 10 + ;
M: object digit> not-a-number ;
: digit+ ( num digit base -- num )
2dup < [ rot * + ] [ not-a-number ] ifte ;
@ -63,8 +61,6 @@ USE: unparser
#! conversion fails.
swap "-" ?str-head [ (base>) neg ] [ (base>) ] ifte ;
DEFER: str>number
FORGET: str>number
GENERIC: str>number ( str -- num )
M: string str>number 10 base> ;

24
library/test/generic.factor
View File

@ -100,3 +100,27 @@ M: nonempty-list funny-length length ;
[ 0 ] [ [ 1 2 | 3 ] funny-length ] unit-test
[ 3 ] [ [ 1 2 3 ] funny-length ] unit-test
[ "hello" funny-length ] unit-test-fails
! Testing method sorting
GENERIC: sorting-test
M: fixnum sorting-test drop "fixnum" ;
M: object sorting-test drop "object" ;
[ "fixnum" ] [ 3 sorting-test ] unit-test
[ "object" ] [ f sorting-test ] unit-test
! Testing unions
UNION: funnies cons ratio complex ;
GENERIC: funny
M: funnies funny drop 2 ;
M: object funny drop 0 ;
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
PREDICATE: funnies very-funny number? ;
GENERIC: gooey
M: very-funny gooey sq ;
[ 1/4 ] [ 1/2 gooey ] unit-test

4
library/vectors.factor
View File

@ -120,7 +120,7 @@ BUILTIN: vector 11
: vector-length= ( vec vec -- ? )
vector-length swap vector-length number= ;
: vector= ( obj vec -- ? )
M: vector = ( obj vec -- ? )
#! Check if two vectors are equal. Two vectors are
#! considered equal if they have the same length and contain
#! equal elements.
@ -141,7 +141,7 @@ BUILTIN: vector 11
: ?vector-nth ( n vec -- obj/f )
2dup vector-length >= [ 2drop f ] [ vector-nth ] ifte ;
: vector-hashcode ( vec -- n )
M: vector hashcode ( vec -- n )
0 swap 4 [
over ?vector-nth hashcode rot bitxor swap
] times* drop ;

2
library/words.factor
View File

@ -36,6 +36,8 @@ USE: strings
BUILTIN: word 1
M: word hashcode word-hashcode ;
SYMBOL: vocabularies
: word-property ( word pname -- pvalue )

2
native/types.h
View File

@ -43,8 +43,6 @@ CELL T;
#define NUMBER_TYPE 103 /* F_COMPLEX or REAL */
#define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */
/* CELL type_of(CELL tagged); */
bool typep(CELL type, CELL tagged);
INLINE CELL tag_header(CELL cell)