From cad99c8888d0598cd28b19db237b172298cd825b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Dec 2004 04:18:32 +0000 Subject: [PATCH] redid = hashcode and math words using new object system --- TODO.FACTOR.txt | 4 - library/bootstrap/boot-stage2.factor | 11 +- library/bootstrap/boot.factor | 11 +- library/bootstrap/image.factor | 9 +- library/generic/builtin.factor | 12 +- library/generic/generic.factor | 81 ++- library/generic/object.factor | 17 +- library/generic/predicate.factor | 35 +- library/generic/traits.factor | 13 +- library/generic/union.factor | 78 +++ library/kernel.factor | 79 +-- library/lists.factor | 13 +- library/math/complex.factor | 78 +++ library/math/float.factor | 43 ++ library/math/generic.factor | 492 ------------------ library/math/integer.factor | 84 +++ library/math/math-combinators.factor | 3 + library/math/math.factor | 99 +++- .../math/{arithmetic.factor => ratio.factor} | 50 +- library/strings.factor | 16 +- library/syntax/parse-numbers.factor | 14 +- library/test/generic.factor | 24 + library/vectors.factor | 4 +- library/words.factor | 2 + native/types.h | 2 - 25 files changed, 571 insertions(+), 703 deletions(-) create mode 100644 library/generic/union.factor create mode 100644 library/math/complex.factor create mode 100644 library/math/float.factor delete mode 100644 library/math/generic.factor create mode 100644 library/math/integer.factor rename library/math/{arithmetic.factor => ratio.factor} (62%) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index be259c9506..19a4d2fd31 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -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: diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 1ab3b31c41..b64b0c82ee 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -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" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index ab98dcd980..3e0cc50df0 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -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 diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index adc60e4d25..857338c7d1 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -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 diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 7f35ef8ec9..c4dea751f9 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -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 diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 5c97b81423..a756b949c6 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -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 ; +: ( -- vtable ) + num-types [ drop [ undefined-method ] ] vector-project ; -: ( 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 ; + +: ( methods -- 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 ] 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 "methods" set-word-property + [ 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 ] - 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 diff --git a/library/generic/object.factor b/library/generic/object.factor index 81a1f1e14b..540e0595f8 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -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 -- ) - 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 diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor index 1dee08db87..84694e78a0 100644 --- a/library/generic/predicate.factor +++ b/library/generic/predicate.factor @@ -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 diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 518dc02db5..ae7ba9f031 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -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 ; diff --git a/library/generic/union.factor b/library/generic/union.factor new file mode 100644 index 0000000000..fdcaa3304f --- /dev/null +++ b/library/generic/union.factor @@ -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 diff --git a/library/kernel.factor b/library/kernel.factor index 8a0fe0020e..50daf12ddd 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -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? diff --git a/library/lists.factor b/library/lists.factor index 83c80d1547..6fffa3ba60 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -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 diff --git a/library/math/complex.factor b/library/math/complex.factor new file mode 100644 index 0000000000..00aadbf662 --- /dev/null +++ b/library/math/complex.factor @@ -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 ; diff --git a/library/math/float.factor b/library/math/float.factor new file mode 100644 index 0000000000..b05d1be45f --- /dev/null +++ b/library/math/float.factor @@ -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 ; diff --git a/library/math/generic.factor b/library/math/generic.factor deleted file mode 100644 index 82c7aaac30..0000000000 --- a/library/math/generic.factor +++ /dev/null @@ -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< ( 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 ; diff --git a/library/math/integer.factor b/library/math/integer.factor new file mode 100644 index 0000000000..312a12ed5b --- /dev/null +++ b/library/math/integer.factor @@ -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 ; diff --git a/library/math/math-combinators.factor b/library/math/math-combinators.factor index c3e8835cbc..79a257440e 100644 --- a/library/math/math-combinators.factor +++ b/library/math/math-combinators.factor @@ -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 }. diff --git a/library/math/math.factor b/library/math/math.factor index 4b5ad9c31b..2c48ca9a7f 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -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 ; diff --git a/library/math/arithmetic.factor b/library/math/ratio.factor similarity index 62% rename from library/math/arithmetic.factor rename to library/math/ratio.factor index 9fa79ecb4b..7ac630d47f 100644 --- a/library/math/arithmetic.factor +++ b/library/math/ratio.factor @@ -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 ; diff --git a/library/strings.factor b/library/strings.factor index 901145131f..2f8f14d2ac 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -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 diff --git a/library/syntax/parse-numbers.factor b/library/syntax/parse-numbers.factor index da8438c34d..a80449f8ac 100644 --- a/library/syntax/parse-numbers.factor +++ b/library/syntax/parse-numbers.factor @@ -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> ; diff --git a/library/test/generic.factor b/library/test/generic.factor index 012f2bf3e3..8bae61a655 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -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 diff --git a/library/vectors.factor b/library/vectors.factor index 3791ef25d0..cac9cb666d 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -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 ; diff --git a/library/words.factor b/library/words.factor index 406c72bce9..e7a5ad9b11 100644 --- a/library/words.factor +++ b/library/words.factor @@ -36,6 +36,8 @@ USE: strings BUILTIN: word 1 +M: word hashcode word-hashcode ; + SYMBOL: vocabularies : word-property ( word pname -- pvalue ) diff --git a/native/types.h b/native/types.h index 7bc6ab6288..6255423c78 100644 --- a/native/types.h +++ b/native/types.h @@ -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)