before generic arithmetic cleanup

TODO.FACTOR.txt

@@ -1,6 +1,7 @@
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
 
+- buffer change handler in sidekick is screwed
 - dec> bin> oct> hex> throw errors
 - parse-number doesn't
 - eval with multilien strings and #!

library/cross-compiler.factor

@@ -78,7 +78,6 @@ DEFER: cwd
 DEFER: cd
 
 IN: io-internals
-DEFER: port?
 DEFER: open-file
 DEFER: client-socket
 DEFER: server-socket
@@ -100,7 +99,8 @@ DEFER: next-io-task
 
 IN: math
 DEFER: number=
-DEFER: /i
+DEFER: >fraction
+DEFER: fraction>
 
 IN: parser
 DEFER: str>float
@@ -139,19 +139,16 @@ IN: image
         execute
         call
         ifte
-        cons?
         cons
         car
         cdr
         set-car
         set-cdr
-        vector?
         <vector>
         vector-length
         set-vector-length
         vector-nth
         set-vector-nth
-        string?
         str-length
         str-nth
         str-compare
@@ -160,7 +157,6 @@ IN: image
         index-of*
         substring
         str-reverse
-        sbuf?
         <sbuf>
         sbuf-length
         set-sbuf-length
@@ -176,16 +172,13 @@ IN: image
         >bignum
         >float
         number=
-        fixnum?
-        bignum?
-        ratio?
         numerator
         denominator
-        float?
+        >fraction
+        fraction>
         str>float
         unparse-float
         float>bits
-        complex?
         real
         imaginary
         >rect
@@ -219,7 +212,6 @@ IN: image
         fsin
         fsinh
         fsqrt
-        word?
         <word>
         word-hashcode
         word-xt
@@ -252,7 +244,6 @@ IN: image
         callstack
         set-datastack
         set-callstack
-        port?
         exit*
         client-socket
         server-socket

library/math/constants.factor

@@ -35,3 +35,6 @@ USE: kernel
 : e 2.7182818284590452354 ; inline
 : pi 3.14159265358979323846 ; inline
 : pi/2 1.5707963267948966 ; inline
+
+: deg>rad pi * 180 / ;
+: rad>deg 180 * pi / ;

library/math/trig-hyp.factor

@@ -38,9 +38,6 @@ USE: stack
 ! Hyperbolic functions:
 !    cosh sech sinh cosech tanh coth
 
-: deg>rad pi * 180 / ;
-: rad>deg 180 * pi / ;
-
 : cos ( z -- cos )
     >rect 2dup
     fcosh swap fcos * -rot

library/platform/jvm/boot-mini.factor

@@ -75,11 +75,13 @@ USE: parser
 
 !!! Math library.
 "/library/platform/jvm/real-math.factor" run-resource ! real-math
+"/library/math/constants.factor"         run-resource ! math
 "/library/math/math.factor"              run-resource ! math
 "/library/math/pow.factor"               run-resource ! math
 "/library/math/list-math.factor"         run-resource ! math
 
 !!! Development tools.
+"/library/platform/jvm/processes.factor"   run-resource ! processes
 "/library/vocabulary-style.factor"         run-resource ! style
 "/library/prettyprint.factor"              run-resource ! prettyprint
 "/library/platform/jvm/prettyprint.factor" run-resource ! prettyprint

library/platform/native/boot.factor

@@ -32,6 +32,7 @@ primitives,
 [
     "/library/platform/native/kernel.factor"
     "/library/platform/native/stack.factor"
+    "/library/platform/native/types.factor"
     "/library/cons.factor"
     "/library/combinators.factor"
     "/library/logic.factor"

library/platform/native/math.factor

@@ -30,9 +30,6 @@ USE: combinators
 USE: kernel
 USE: stack
 
-: bignum? ( obj -- ? ) type-of 13 eq? ;
-: complex? ( obj -- ? ) type-of 5 eq? ;
-
 : (gcd) ( x y -- z )
     dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
 

library/platform/native/primitives.factor

@@ -47,19 +47,16 @@ USE: words
     [ execute                | " word -- " ]
     [ call                   | " quot -- " ]
     [ ifte                   | " cond true false -- " ]
-    [ cons?                  | " obj -- ? " ]
     [ cons                   | " car cdr -- [ car | cdr ] " ]
     [ car                    | " [ car | cdr ] -- car " ]
     [ cdr                    | " [ car | cdr ] -- cdr " ]
     [ set-car                | " car cons -- " ]
     [ set-cdr                | " cdr cons -- " ]
-    [ vector?                | " obj -- ? " ]
     [ <vector>               | " capacity -- vector" ]
     [ vector-length          | " vector -- n " ]
     [ set-vector-length      | " n vector -- " ]
     [ vector-nth             | " n vector -- obj " ]
     [ set-vector-nth         | " obj n vector -- " ]
-    [ string?                | " obj -- ? " ]
     [ str-length             | " str -- n " ]
     [ str-nth                | " n str -- ch " ]
     [ str-compare            | " str str -- -1/0/1 " ]
@@ -67,7 +64,6 @@ USE: words
     [ str-hashcode           | " str -- n " ]
     [ index-of*              | " n str/ch str -- n " ]
     [ substring              | " start end str -- str "]
-    [ sbuf?                  | " obj -- ? " ]
     [ <sbuf>                 | " capacity -- sbuf " ]
     [ sbuf-length            | " sbuf -- n " ]
     [ set-sbuf-length        | " n sbuf -- " ]
@@ -83,12 +79,10 @@ USE: words
     [ >bignum                | " n -- bignum " ]
     [ >float                 | " n -- float " ]
     [ number=                | " n n -- ? " ]
-    [ fixnum?                | " obj -- ? " ]
-    [ bignum?                | " obj -- ? " ]
-    [ ratio?                 | " obj -- ? " ]
     [ numerator              | " a/b -- a " ]
     [ denominator            | " a/b -- b " ]
-    [ float?                 | " obj -- ? " ]
+    [ >fraction              | " a/b -- a b " ]
+    [ fraction>              | " a b -- a/b " ]
     [ str>float              | " str -- float " ]
     [ unparse-float          | " float -- str " ]
     [ float>bits             | " float -- n " ]
@@ -126,7 +120,6 @@ USE: words
     [ fsin                   | " x -- y " ]
     [ fsinh                  | " x -- y " ]
     [ fsqrt                  | " x -- y " ]
-    [ word?                  | " obj -- ? " ]
     [ <word>                 | " prim param plist -- word " ]
     [ word-hashcode          | " word -- n " ]
     [ word-primitive         | " word -- n " ]
@@ -157,7 +150,6 @@ USE: words
     [ callstack              | " -- cs " ]
     [ set-datastack          | " ds -- " ]
     [ set-callstack          | " cs -- " ]
-    [ port?                  | " obj -- ? " ]
     [ exit*                  | " n -- " ]
     [ client-socket          | " host port -- in out " ]
     [ server-socket          | " port -- server " ]

library/platform/native/types.factor

@@ -0,0 +1,41 @@
+! :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.
+
+USE: kernel
+
+IN: math         : fixnum?  ( obj -- ? ) type-of 0  eq? ;
+IN: words        : word?    ( obj -- ? ) type-of 1  eq? ;
+IN: lists        : cons?    ( obj -- ? ) type-of 2  eq? ;
+IN: math         : ratio?   ( obj -- ? ) type-of 4  eq? ;
+IN: math         : complex? ( obj -- ? ) type-of 5  eq? ;
+IN: vectors      : vector?  ( obj -- ? ) type-of 9  eq? ;
+IN: strings      : string?  ( obj -- ? ) type-of 10 eq? ;
+IN: strings      : sbuf?    ( obj -- ? ) type-of 11 eq? ;
+IN: io-internals : port?    ( obj -- ? ) type-of 12 eq? ;
+IN: math         : bignum?  ( obj -- ? ) type-of 13 eq? ;
+IN: math         : float?   ( obj -- ? ) type-of 14 eq? ;
+IN: alien        : dll?     ( obj -- ? ) type-of 15 eq? ;

library/vocabularies.factor

@@ -92,6 +92,7 @@ USE: strings
         "namespaces"
         "parser"
         "prettyprint"
+        "processes"
         "stack"
         "streams"
         "stdio"

native/arithmetic.c

@@ -113,9 +113,29 @@ bool zerop(CELL tagged)
 	case FLOAT_TYPE:
 		return ((FLOAT*)UNTAG(tagged))->n == 0.0;
 	case RATIO_TYPE:
+	case COMPLEX_TYPE:
 		return false;
 	default:
-		critical_error("Bad parameter to zerop",tagged);
+		type_error(NUMBER_TYPE,tagged);
+		return false; /* Can't happen */
+	}
+}
+
+bool onep(CELL tagged)
+{
+	switch(type_of(tagged))
+	{
+	case FIXNUM_TYPE:
+		return tagged == 1;
+	case BIGNUM_TYPE:
+		return BIGNUM_ONE_P((ARRAY*)UNTAG(tagged),0);
+	case FLOAT_TYPE:
+		return ((FLOAT*)UNTAG(tagged))->n == 1.0;
+	case RATIO_TYPE:
+	case COMPLEX_TYPE:
+		return false;
+	default:
+		type_error(NUMBER_TYPE,tagged);
 		return false; /* Can't happen */
 	}
 }

native/arithmetic.h

@@ -138,6 +138,7 @@ bool realp(CELL tagged);
 void primitive_numberp(void);
 
 bool zerop(CELL tagged);
+bool onep(CELL tagged);
 
 void primitive_to_fixnum(void);
 void primitive_to_bignum(void);
@@ -177,4 +178,4 @@ void primitive_xor(void);
 CELL shift(CELL x, FIXNUM y);
 void primitive_shift(void);
 CELL gcd(CELL x, CELL y);
-void primitive_gcd(void);
+void primitive_not(void);

native/cons.c

@@ -8,11 +8,6 @@ CELL cons(CELL car, CELL cdr)
 	return tag_cons(cons);
 }
 
-void primitive_consp(void)
-{
-	drepl(tag_boolean(typep(CONS_TYPE,dpeek())));
-}
-
 void primitive_cons(void)
 {
 	CELL cdr = dpop();

native/cons.h

@@ -26,7 +26,6 @@ INLINE CELL cdr(CELL cons)
 	return untag_cons(cons)->cdr;
 }
 
-void primitive_consp(void);
 void primitive_cons(void);
 void primitive_car(void);
 void primitive_cdr(void);

native/fixnum.c

@@ -1,10 +1,5 @@
 #include "factor.h"
 
-void primitive_fixnump(void)
-{
-	drepl(tag_boolean(TAG(dpeek()) == FIXNUM_TYPE));
-}
-
 FIXNUM to_fixnum(CELL tagged)
 {
 	RATIO* r;

native/fixnum.h

@@ -13,9 +13,6 @@ INLINE CELL tag_fixnum(FIXNUM untagged)
 	return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
 }
 
-void primitive_fixnump(void);
-void primitive_not(void);
-
 FIXNUM to_fixnum(CELL tagged);
 void primitive_to_fixnum(void);
 

native/float.c

@@ -1,10 +1,5 @@
 #include "factor.h"
 
-void primitive_floatp(void)
-{
-	drepl(tag_boolean(typep(FLOAT_TYPE,dpeek())));
-}
-
 FLOAT* to_float(CELL tagged)
 {
 	RATIO* r;

native/float.h

@@ -21,7 +21,6 @@ INLINE double untag_float(CELL tagged)
 	return untag_float_fast(tagged);
 }
 
-void primitive_floatp(void);
 FLOAT* to_float(CELL tagged);
 void primitive_to_float(void);
 void primitive_str_to_float(void);

native/memory.c

@@ -113,7 +113,7 @@ void primitive_allot_profiling(void)
 #endif
 }
 
-void primitive_address_of(void)
+void primitive_address(void)
 {
 	dpush(tag_object(s48_ulong_to_bignum(dpop())));
 }

native/memory.h

@@ -69,4 +69,4 @@ bool in_zone(ZONE* z, CELL pointer);
 
 void primitive_room(void);
 void primitive_allot_profiling(void);
-void primitive_address_of(void);
+void primitive_address(void);

native/port.c

@@ -44,11 +44,6 @@ void init_line_buffer(PORT* port, FIXNUM count)
 		port->line = tag_object(sbuf(LINE_SIZE));
 }
 
-void primitive_portp(void)
-{
-	drepl(tag_boolean(typep(PORT_TYPE,dpeek())));
-}
-
 void fixup_port(PORT* port)
 {
 	port->fd = -1;

native/port.h

@@ -36,7 +36,6 @@ typedef struct {
 PORT* untag_port(CELL tagged);
 PORT* port(PORT_MODE type, CELL fd);
 void init_line_buffer(PORT* port, FIXNUM count);
-void primitive_portp(void);
 void fixup_port(PORT* port);
 void collect_port(PORT* port);
 void postpone_io_error(PORT* port, const char* func);

native/primitives.c

@@ -6,19 +6,16 @@ XT primitives[] = {
 	primitive_execute,
 	primitive_call,
 	primitive_ifte,
-	primitive_consp,
 	primitive_cons,
 	primitive_car,
 	primitive_cdr,
 	primitive_set_car,
 	primitive_set_cdr,
-	primitive_vectorp,
 	primitive_vector,
 	primitive_vector_length,
 	primitive_set_vector_length,
 	primitive_vector_nth,
 	primitive_set_vector_nth,
-	primitive_stringp,
 	primitive_string_length,
 	primitive_string_nth,
 	primitive_string_compare,
@@ -27,7 +24,6 @@ XT primitives[] = {
 	primitive_index_of,
 	primitive_substring,
 	primitive_string_reverse,
-	primitive_sbufp,
 	primitive_sbuf,
 	primitive_sbuf_length,
 	primitive_set_sbuf_length,
@@ -43,16 +39,13 @@ XT primitives[] = {
 	primitive_to_bignum,
 	primitive_to_float,
 	primitive_number_eq,
-	primitive_fixnump,
-	primitive_bignump,
-	primitive_ratiop,
 	primitive_numerator,
 	primitive_denominator,
-	primitive_floatp,
+	primitive_to_fraction,
+	primitive_from_fraction,
 	primitive_str_to_float,
 	primitive_float_to_str,
 	primitive_float_to_bits,
-	primitive_complexp,
 	primitive_real,
 	primitive_imaginary,
 	primitive_to_rect,
@@ -86,7 +79,6 @@ XT primitives[] = {
         primitive_fsin,
         primitive_fsinh,
         primitive_fsqrt,
-	primitive_wordp,
 	primitive_word,
 	primitive_word_hashcode,
 	primitive_word_xt,
@@ -119,7 +111,6 @@ XT primitives[] = {
 	primitive_callstack,
 	primitive_set_datastack,
 	primitive_set_callstack,
-	primitive_portp,
 	primitive_exit,
 	primitive_client_socket,
 	primitive_server_socket,
@@ -143,8 +134,8 @@ XT primitives[] = {
 	primitive_millis,
 	primitive_init_random,
 	primitive_random_int,
-	primitive_type_of,
+	primitive_type,
-	primitive_size_of,
+	primitive_size,
 	primitive_call_profiling,
 	primitive_word_call_count,
 	primitive_set_word_call_count,
@@ -160,7 +151,7 @@ XT primitives[] = {
 	primitive_set_compiled_offset,
 	primitive_literal_top,
 	primitive_set_literal_top,
-	primitive_address_of,
+	primitive_address,
 	primitive_dlopen,
 	primitive_dlsym,
 	primitive_dlsym_self,

native/ratio.c

@@ -8,6 +8,19 @@ RATIO* ratio(CELL numerator, CELL denominator)
 	return ratio;
 }
 
+/* Does not reduce to lowest terms, so should only be used by math
+library implementation, to avoid breaking invariants. */
+void primitive_from_fraction(void)
+{
+	CELL denominator = dpop();
+	CELL numerator = dpop();
+	if(zerop(denominator))
+		raise(SIGFPE);
+	if(onep(denominator))
+		dpush(numerator);
+	dpush(tag_ratio(ratio(numerator,denominator)));
+}
+
 RATIO* to_ratio(CELL x)
 {
 	switch(type_of(x))
@@ -23,9 +36,25 @@ RATIO* to_ratio(CELL x)
 	}
 }
 
-void primitive_ratiop(void)
+void primitive_to_fraction(void)
 {
-	drepl(tag_boolean(typep(RATIO_TYPE,dpeek())));
+	RATIO* r;
+
+	switch(type_of(dpeek()))
+	{
+	case FIXNUM_TYPE:
+	case BIGNUM_TYPE:
+		dpush(tag_fixnum(1));
+		break;
+	case RATIO_TYPE:
+		r = untag_ratio(dpeek());
+		drepl(r->numerator);
+		dpush(r->denominator);
+		break;
+	default:
+		type_error(RATIONAL_TYPE,dpeek());
+		break;
+	}
 }
 
 void primitive_numerator(void)

native/ratio.h

@@ -17,9 +17,10 @@ INLINE CELL tag_ratio(RATIO* ratio)
 RATIO* ratio(CELL numerator, CELL denominator);
 RATIO* to_ratio(CELL x);
 
-void primitive_ratiop(void);
 void primitive_numerator(void);
 void primitive_denominator(void);
+void primitive_from_fraction(void);
+void primitive_to_fraction(void);
 CELL number_eq_ratio(RATIO* x, RATIO* y);
 CELL add_ratio(RATIO* x, RATIO* y);
 CELL subtract_ratio(RATIO* x, RATIO* y);

native/sbuf.c

@@ -8,11 +8,6 @@ SBUF* sbuf(FIXNUM capacity)
 	return sbuf;
 }
 
-void primitive_sbufp(void)
-{
-	drepl(tag_boolean(typep(SBUF_TYPE,dpeek())));
-}
-
 void primitive_sbuf(void)
 {
 	drepl(tag_object(sbuf(to_fixnum(dpeek()))));

native/sbuf.h

@@ -15,7 +15,6 @@ INLINE SBUF* untag_sbuf(CELL tagged)
 
 SBUF* sbuf(FIXNUM capacity);
 
-void primitive_sbufp(void);
 void primitive_sbuf(void);
 void primitive_sbuf_length(void);
 void primitive_set_sbuf_length(void);

native/string.c

@@ -92,11 +92,6 @@ BYTE* to_c_string(STRING* s)
 	return c_str;
 }
 
-void primitive_stringp(void)
-{
-	drepl(tag_boolean(typep(STRING_TYPE,dpeek())));
-}
-
 void primitive_string_length(void)
 {
 	drepl(tag_fixnum(untag_string(dpeek())->capacity));

native/string.h

@@ -36,7 +36,6 @@ INLINE void set_string_nth(STRING* string, CELL index, CHAR value)
 	cput(SREF(string,index),value);
 }
 
-void primitive_stringp(void);
 void primitive_string_length(void);
 void primitive_string_nth(void);
 FIXNUM string_compare_head(STRING* s1, STRING* s2, CELL len);

native/types.c

@@ -115,12 +115,12 @@ CELL untagged_object_size(CELL pointer)
 	return align8(size);
 }
 
-void primitive_type_of(void)
+void primitive_type(void)
 {
 	drepl(tag_fixnum(type_of(dpeek())));
 }
 
-void primitive_size_of(void)
+void primitive_size(void)
 {
 	drepl(tag_fixnum(object_size(dpeek())));
 }

native/types.h

@@ -82,5 +82,5 @@ INLINE CELL object_type(CELL tagged)
 void* allot_object(CELL type, CELL length);
 CELL untagged_object_size(CELL pointer);
 CELL object_size(CELL pointer);
-void primitive_type_of(void);
+void primitive_type(void);
-void primitive_size_of(void);
+void primitive_size(void);

native/vector.c

@@ -8,11 +8,6 @@ VECTOR* vector(FIXNUM capacity)
 	return vector;
 }
 
-void primitive_vectorp(void)
-{
-	drepl(tag_boolean(typep(VECTOR_TYPE,dpeek())));
-}
-
 void primitive_vector(void)
 {
 	drepl(tag_object(vector(to_fixnum(dpeek()))));

native/vector.h

@@ -15,7 +15,6 @@ INLINE VECTOR* untag_vector(CELL tagged)
 
 VECTOR* vector(FIXNUM capacity);
 
-void primitive_vectorp(void);
 void primitive_vector(void);
 void primitive_vector_length(void);
 void primitive_set_vector_length(void);

native/word.c

@@ -22,11 +22,6 @@ void update_xt(WORD* word)
 	word->xt = primitive_to_xt(word->primitive);
 }
 
-void primitive_wordp(void)
-{
-	drepl(tag_boolean(typep(WORD_TYPE,dpeek())));
-}
-
 /* <word> ( primitive parameter plist -- word ) */
 void primitive_word(void)
 {

native/word.h

@@ -32,7 +32,6 @@ INLINE CELL tag_word(WORD* word)
 
 WORD* word(CELL primitive, CELL parameter, CELL plist);
 void update_xt(WORD* word);
-void primitive_wordp(void);
 void primitive_word(void);
 void primitive_word_hashcode(void);
 void primitive_word_primitive(void);