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

before generic arithmetic cleanup

cvs before-generic-arithmetic-cleanup
Slava Pestov 2004-09-19 02:29:29 +00:00
parent 8e20bee820
commit c27b504cc8
35 changed files with 122 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -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 #!

17
library/cross-compiler.factor
View File

@ -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

3
library/math/constants.factor
View File

@ -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 / ;

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

@ -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

2
library/platform/jvm/boot-mini.factor
View File

@ -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

1
library/platform/native/boot.factor
View File

@ -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"

3
library/platform/native/math.factor
View File

@ -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 ;

12
library/platform/native/primitives.factor
View File

@ -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 " ]

41
library/platform/native/types.factor Normal file
View File

@ -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? ;

1
library/vocabularies.factor
View File

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

22
native/arithmetic.c
View File

@ -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 */
}
}

3
native/arithmetic.h
View File

@ -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);

5
native/cons.c
View File

@ -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();

1
native/cons.h
View File

@ -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);

5
native/fixnum.c
View File

@ -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;

3
native/fixnum.h
View File

@ -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);

5
native/float.c
View File

@ -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;

1
native/float.h
View File

@ -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);

2
native/memory.c
View File

@ -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())));
}

2
native/memory.h
View File

@ -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);

5
native/port.c
View File

@ -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;

1
native/port.h
View File

@ -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);

19
native/primitives.c
View File

@ -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_size_of,
primitive_type,
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,

33
native/ratio.c
View File

@ -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)

3
native/ratio.h
View File

@ -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);

5
native/sbuf.c
View File

@ -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()))));

1
native/sbuf.h
View File

@ -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);

5
native/string.c
View File

@ -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));

1
native/string.h
View File

@ -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);

4
native/types.c
View File

@ -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())));
}

4
native/types.h
View File

@ -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_size_of(void);
void primitive_type(void);
void primitive_size(void);

5
native/vector.c
View File

@ -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()))));

1
native/vector.h
View File

@ -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);

5
native/word.c
View File

@ -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)
{

1
native/word.h
View File

@ -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);