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

complex numbers in native factor, all of test suite except html and httpd tests runs in native factor

cvs
Slava Pestov 2004-08-06 22:40:44 +00:00
parent 26cc9ba32c
commit 38835c2832
38 changed files with 462 additions and 387 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -12,9 +12,7 @@
+ native: + native:
- native float>bits - native float>bits
- printing floats: append .0 always
- vector= - vector=
- make-image: take a parameter, include le & be images in dist
- do something about "base" variable -- too fragile - do something about "base" variable -- too fragile
ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ] ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ]
- errors: don't show .factor-rc - errors: don't show .factor-rc

2
build.sh
View File

@ -1,5 +1,5 @@
export CC=gcc34 export CC=gcc34
export CFLAGS="-pedantic -Wall -Winline -O3 -march=pentium4 -fomit-frame-pointer" export CFLAGS="-lm -pedantic -Wall -Winline -O3 -march=pentium4 -fomit-frame-pointer"
$CC $CFLAGS -o f native/*.c $CC $CFLAGS -o f native/*.c

3
factor/FactorCompoundDefinition.java
View File

@ -96,7 +96,8 @@ public class FactorCompoundDefinition extends FactorWordDefinition
RecursiveState recursiveCheck) throws Exception RecursiveState recursiveCheck) throws Exception
{ {
// Each word has its own class loader // Each word has its own class loader
FactorClassLoader loader = new FactorClassLoader(); FactorClassLoader loader = new FactorClassLoader(
getClass().getClassLoader());
StackEffect effect = getStackEffect(interp); StackEffect effect = getStackEffect(interp);

17
factor/compiler/FactorClassLoader.java
View File

@ -42,6 +42,13 @@ public class FactorClassLoader extends ClassLoader
{ {
private long id; private long id;
private FactorNamespace table = new FactorNamespace(); private FactorNamespace table = new FactorNamespace();
private ClassLoader delegate;
//{{{ FactorClassLoader constructor
public FactorClassLoader(ClassLoader delegate)
{
this.delegate = delegate;
} //}}}
//{{{ addDependency() method //{{{ addDependency() method
public void addDependency(String name, FactorClassLoader loader) public void addDependency(String name, FactorClassLoader loader)
@ -88,7 +95,15 @@ public class FactorClassLoader extends ClassLoader
System.err.println("WARNING: unknown object in class loader table for " + this + ": " + obj); System.err.println("WARNING: unknown object in class loader table for " + this + ": " + obj);
} }
return super.loadClass(name,resolve); if(delegate == null)
return super.loadClass(name,resolve);
else
{
c = delegate.loadClass(name);
if(resolve)
resolveClass(c);
return c;
}
} }
catch(ClassNotFoundException e) catch(ClassNotFoundException e)
{ {

25
library/cross-compiler.factor
View File

@ -29,7 +29,9 @@ IN: cross-compiler
USE: arithmetic USE: arithmetic
USE: kernel USE: kernel
USE: lists USE: lists
USE: namespaces
USE: parser USE: parser
USE: real-math
USE: stack USE: stack
USE: stdio USE: stdio
USE: streams USE: streams
@ -160,6 +162,19 @@ IN: cross-compiler
<= <=
> >
>= >=
gcd
facos
fasin
fatan
fatan2
fcos
fexp
fcosh
flog
fpow
fsin
fsinh
fsqrt
word? word?
<word> <word>
word-primitive word-primitive
@ -211,12 +226,14 @@ IN: cross-compiler
: version, ( -- ) : version, ( -- )
"version" [ "kernel" ] search version unit compound, ; "version" [ "kernel" ] search version unit compound, ;
: make-image ( -- ) : make-image ( name -- )
#! Make an image for the C interpreter. #! Make an image for the C interpreter.
[ [
"/library/platform/native/boot.factor" run-resource "/library/platform/native/boot.factor" run-resource
] with-image ] with-image
! Uncomment this on sparc and powerpc. swap write-image ;
! "big-endian" on
"factor.image" write-image ; : make-images ( -- )
"big-endian" off "factor.image.le" make-image
"big-endian" on "factor.image.be" make-image ;

68
library/image.factor
View File

@ -69,14 +69,14 @@ USE: words
: untag ( cell tag -- ) tag-mask bitnot bitand ; : untag ( cell tag -- ) tag-mask bitnot bitand ;
: tag ( cell -- tag ) tag-mask bitand ; : tag ( cell -- tag ) tag-mask bitand ;
: fixnum-tag BIN: 000 ; : fixnum-tag BIN: 000 ;
: word-tag BIN: 001 ; : word-tag BIN: 001 ;
: cons-tag BIN: 010 ; : cons-tag BIN: 010 ;
: object-tag BIN: 011 ; : object-tag BIN: 011 ;
: rational-tag BIN: 100 ; : ratio-tag BIN: 100 ;
: complex-tag BIN: 101 ; : complex-tag BIN: 101 ;
: header-tag BIN: 110 ; : header-tag BIN: 110 ;
: gc-fwd-ptr BIN: 111 ; ( we don't output these ) : gc-fwd-ptr BIN: 111 ; ( we don't output these )
: f-type 6 ; : f-type 6 ;
: t-type 7 ; : t-type 7 ;
@ -128,20 +128,19 @@ USE: words
( Floats ) ( Floats )
: 'float ( f -- tagged ) : 'float ( f -- tagged )
object-tag here-as object-tag here-as >r
float-type >header emit float-type >header emit
0 emit ( alignment -- FIXME 64-bit arch ) 0 emit ( alignment -- FIXME 64-bit arch )
float>bits emit64 ; float>bits emit64 r> ;
( Bignums ) ( Bignums )
: 'bignum ( bignum -- tagged ) : 'bignum ( bignum -- tagged )
dup .
#! Very bad! #! Very bad!
object-tag here-as object-tag here-as >r
bignum-type >header emit bignum-type >header emit
0 emit ( alignment -- FIXME 64-bit arch ) 0 emit ( alignment -- FIXME 64-bit arch )
( bignum -- ) emit64 ; ( bignum -- ) emit64 r> ;
( Special objects ) ( Special objects )
@ -196,6 +195,18 @@ DEFER: '
: cons, ( -- pointer ) cons-tag here-as ; : cons, ( -- pointer ) cons-tag here-as ;
: 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ; : 'cons ( c -- tagged ) uncons ' swap ' cons, -rot emit emit ;
( Ratios -- almost the same as a cons )
: ratio, ( -- pointer ) ratio-tag here-as ;
: 'ratio ( a/b -- tagged )
dup denominator ' swap numerator ' ratio, -rot emit emit ;
( Complex -- almost the same as ratio )
: complex, ( -- pointer ) complex-tag here-as ;
: 'complex ( #{ a b } -- tagged )
dup imaginary ' swap real ' complex, -rot emit emit ;
( Strings ) ( Strings )
: pack ( n n -- ) : pack ( n n -- )
@ -299,17 +310,19 @@ IN: cross-compiler
: ' ( obj -- pointer ) : ' ( obj -- pointer )
[ [
[ fixnum? ] [ 'fixnum ] [ fixnum? ] [ 'fixnum ]
[ bignum? ] [ 'bignum ] [ bignum? ] [ 'bignum ]
[ float? ] [ 'float ] [ float? ] [ 'float ]
[ word? ] [ 'word ] [ ratio? ] [ 'ratio ]
[ cons? ] [ 'cons ] [ complex? ] [ 'complex ]
[ char? ] [ 'fixnum ] [ word? ] [ 'word ]
[ string? ] [ 'string ] [ cons? ] [ 'cons ]
[ vector? ] [ 'vector ] [ char? ] [ 'fixnum ]
[ t = ] [ drop "t" get ] [ string? ] [ 'string ]
[ f = ] [ drop "f" get ] [ vector? ] [ 'vector ]
[ drop t ] [ "Cannot cross-compile: " swap cat2 throw ] [ t = ] [ drop "t" get ]
[ f = ] [ drop "f" get ]
[ drop t ] [ "Cannot cross-compile: " swap cat2 throw ]
] cond ; ] cond ;
( End of the image ) ( End of the image )
@ -353,7 +366,7 @@ IN: cross-compiler
: write-image ( image file -- ) : write-image ( image file -- )
<filebw> [ [ write-word ] vector-each ] with-stream ; <filebw> [ [ write-word ] vector-each ] with-stream ;
: with-image ( quot -- image ) : with-minimal-image ( quot -- image )
<namespace> [ <namespace> [
300000 <vector> "image" set 300000 <vector> "image" set
521 <hashtable> "objects" set 521 <hashtable> "objects" set
@ -362,8 +375,11 @@ IN: cross-compiler
! since ; ends up using this variable from nested ! since ; ends up using this variable from nested
! parser namespaces. ! parser namespaces.
1000 <vector> "word-fixups" set 1000 <vector> "word-fixups" set
begin call end call
"image" get "image" get
] bind ; ] bind ;
: with-image ( quot -- image )
[ begin call end ] with-minimal-image ;
: test-image ( quot -- ) with-image vector>list . ; : test-image ( quot -- ) with-image vector>list . ;

8
library/math/arithmetic.factor
View File

@ -43,8 +43,6 @@ USE: stack
: pi 3.14159265358979323846 ; inline : pi 3.14159265358979323846 ; inline
: pi/2 1.5707963267948966 ; inline : pi/2 1.5707963267948966 ; inline
: /f / >float ; inline
: f>0 ( obj -- obj ) : f>0 ( obj -- obj )
#! If f at the top of the stack, turn it into 0. #! If f at the top of the stack, turn it into 0.
[ 0 ] unless* ; [ 0 ] unless* ;
@ -53,9 +51,6 @@ USE: stack
#! If 0 at the top of the stack, turn it into f. #! If 0 at the top of the stack, turn it into f.
dup 0 = [ drop f ] when ; dup 0 = [ drop f ] when ;
: compare ( x y [ if x < y ] [ if x = y ] [ if x > y ] -- )
>=< call ; inline interpret-only
: max ( x y -- z ) : max ( x y -- z )
2dup > [ drop ] [ nip ] ifte ; 2dup > [ drop ] [ nip ] ifte ;
@ -74,9 +69,6 @@ USE: stack
: neg 0 swap - ; inline : neg 0 swap - ; inline
: recip 1 swap / ; inline : recip 1 swap / ; inline
: round ( x to -- y )
dupd rem - ;
: deg2rad pi * 180 / ; : deg2rad pi * 180 / ;
: rad2deg 180 * pi / ; : rad2deg 180 * pi / ;

8
library/platform/jvm/arithmetic.factor
View File

@ -57,6 +57,8 @@ USE: stack
"factor.math.FactorMath" "_divide" "factor.math.FactorMath" "_divide"
jinvoke-static ; inline jinvoke-static ; inline
: /f / >float ; inline
: mod ( a b -- a%b ) : mod ( a b -- a%b )
[ "java.lang.Number" "java.lang.Number" ] [ "java.lang.Number" "java.lang.Number" ]
"factor.math.FactorMath" "mod" "factor.math.FactorMath" "mod"
@ -93,6 +95,9 @@ USE: stack
] ]
"factor.FactorLib" "branch3" jinvoke-static ; "factor.FactorLib" "branch3" jinvoke-static ;
: compare ( x y [ if x < y ] [ if x = y ] [ if x > y ] -- )
>=< call ; inline interpret-only
: bitand ( x y -- x&y ) : bitand ( x y -- x&y )
#! Bitwise and. #! Bitwise and.
[ "java.lang.Number" "java.lang.Number" ] [ "java.lang.Number" "java.lang.Number" ]
@ -140,6 +145,9 @@ USE: stack
[ "double" "double" ] "java.lang.Math" "IEEEremainder" [ "double" "double" ] "java.lang.Math" "IEEEremainder"
jinvoke-static ; inline jinvoke-static ; inline
: round ( x to -- y )
dupd rem - ;
: gcd ( a b -- c ) : gcd ( a b -- c )
[ "java.lang.Number" "java.lang.Number" ] [ "java.lang.Number" "java.lang.Number" ]
"factor.math.FactorMath" "gcd" jinvoke-static ; "factor.math.FactorMath" "gcd" jinvoke-static ;

12
library/platform/jvm/parser.factor
View File

@ -29,6 +29,7 @@ IN: parser
USE: namespaces USE: namespaces
USE: stack USE: stack
USE: streams USE: streams
USE: strings
: parse-file ( file -- list ) : parse-file ( file -- list )
dup <freader> parse-stream ; dup <freader> parse-stream ;
@ -36,6 +37,17 @@ USE: streams
: run-file ( path -- ) : run-file ( path -- )
parse-file call ; parse-file call ;
: parse-resource* ( resource -- list )
dup <rreader> swap "resource:" swap cat2 swap parse-stream ;
: parse-resource ( file -- )
#! Override this to be slightly more useful for development.
global [ "resource-path" get ] bind dup [
swap cat2 parse-file
] [
drop parse-resource*
] ifte ;
: <custom-parser> ( filename reader interactive docs -- parser ) : <custom-parser> ( filename reader interactive docs -- parser )
interpreter interpreter
[ [

6
library/platform/jvm/real-math.factor
View File

@ -35,10 +35,6 @@ USE: arithmetic
USE: kernel USE: kernel
USE: stack USE: stack
: fabs ( x -- abs )
[ "double" ] "java.lang.Math" "abs"
jinvoke-static ; inline
: facos ( x -- acos ) : facos ( x -- acos )
[ "double" ] "java.lang.Math" "acos" [ "double" ] "java.lang.Math" "acos"
jinvoke-static ; inline jinvoke-static ; inline
@ -51,7 +47,7 @@ USE: stack
[ "double" ] "java.lang.Math" "atan" [ "double" ] "java.lang.Math" "atan"
jinvoke-static ; inline jinvoke-static ; inline
: fatan2 ( x y -- atan2 ) : fatan2 ( y x -- atan2 )
[ "double" "double" ] "java.lang.Math" "atan2" [ "double" "double" ] "java.lang.Math" "atan2"
jinvoke-static ; inline jinvoke-static ; inline

28
library/platform/native/arithmetic.factor
View File

@ -1,28 +0,0 @@
! This file will go away very shortly!
IN: arithmetic
USE: combinators
USE: kernel
USE: logic
USE: stack
: integer? dup fixnum? swap bignum? or ;
: 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.
>r dupd max r> min = ;
: pred 1 - ; inline
: succ 1 + ; inline
: neg 0 swap - ; inline
!: e 2.7182818284590452354 ; inline
!: pi 3.14159265358979323846 ; inline
!: pi/2 1.5707963267948966 ; inline

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

@ -78,11 +78,16 @@ primitives,
"/library/vocabularies.factor" "/library/vocabularies.factor"
"/library/vocabulary-style.factor" "/library/vocabulary-style.factor"
"/library/words.factor" "/library/words.factor"
"/library/math/math-combinators.factor" "/library/math/arc-trig-hyp.factor"
"/library/math/arithmetic.factor"
"/library/math/list-math.factor" "/library/math/list-math.factor"
"/library/math/math.factor"
"/library/math/math-combinators.factor"
"/library/math/namespace-math.factor" "/library/math/namespace-math.factor"
"/library/math/pow.factor"
"/library/math/quadratic.factor"
"/library/math/trig-hyp.factor"
"/library/test/test.factor" "/library/test/test.factor"
"/library/platform/native/arithmetic.factor"
"/library/platform/native/errors.factor" "/library/platform/native/errors.factor"
"/library/platform/native/io-internals.factor" "/library/platform/native/io-internals.factor"
"/library/platform/native/stream.factor" "/library/platform/native/stream.factor"

2
library/platform/native/errors.factor
View File

@ -60,11 +60,11 @@ USE: vectors
"Type check: " "Type check: "
"Array range check: " "Array range check: "
"Underflow" "Underflow"
"Bad primitive: "
"Incompatible handle: " "Incompatible handle: "
"I/O error: " "I/O error: "
"Overflow" "Overflow"
"Incomparable types: " "Incomparable types: "
"Float format: "
] ?nth ; ] ?nth ;
: ?kernel-error ( cons -- error# param ) : ?kernel-error ( cons -- error# param )

8
library/platform/native/parse-numbers.factor
View File

@ -62,7 +62,11 @@ USE: unparser
] ifte ; ] ifte ;
: (str>integer) ( str -- num ) : (str>integer) ( str -- num )
0 swap [ digit> digit ] str-each ; dup str-length 0 = [
not-a-number
] [
0 swap [ digit> digit ] str-each
] ifte ;
: str>integer ( str -- num ) : str>integer ( str -- num )
#! Parse a string representation of an integer. #! Parse a string representation of an integer.
@ -70,7 +74,7 @@ USE: unparser
drop not-a-number drop not-a-number
] [ ] [
dup "-" str-head? dup [ dup "-" str-head? dup [
nip str>integer neg nip (str>integer) neg
] [ ] [
drop (str>integer) drop (str>integer)
] ifte ] ifte

5
library/platform/native/parse-syntax.factor
View File

@ -134,6 +134,11 @@ USE: unparser
! Char literal ! Char literal
: CHAR: ( -- ) skip-blank next-ch parse-ch parsed ; parsing : CHAR: ( -- ) skip-blank next-ch parse-ch parsed ; parsing
! Complex literal
: #{
#! Read #{ real imaginary #}
scan str>number scan str>number rect> parsed "}" expect ;
! Comments ! Comments
: ( ")" until drop ; parsing : ( ")" until drop ; parsing
: ! until-eol drop ; parsing : ! until-eol drop ; parsing

10
library/platform/native/parser.factor
View File

@ -104,11 +104,15 @@ USE: unparser
#! Some ugly ugly code to handle [ a | b ] expressions. #! Some ugly ugly code to handle [ a | b ] expressions.
>r nreverse dup last* r> swap set-cdr swons ; >r nreverse dup last* r> swap set-cdr swons ;
: expect-] ( -- ) : expect ( word -- )
scan "]" = not [ "Expected ]" throw ] when ; dup scan = not [
"Expected " swap cat2 throw
] [
drop
] ifte ;
: parsed ( obj -- ) : parsed ( obj -- )
over "|" = [ nip parsed| expect-] ] [ swons ] ifte ; over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ;
: number, ( num -- ) : number, ( num -- )
str>number parsed ; str>number parsed ;

7
library/platform/native/unparser.factor
View File

@ -108,6 +108,11 @@ USE: vocabularies
: unparse-word ( word -- str ) : unparse-word ( word -- str )
word-name dup "#<unnamed>" ? ; word-name dup "#<unnamed>" ? ;
: fix-float ( str -- str )
#! This is terrible. Will go away when we do our own float
#! output.
"." over str-contains? [ ".0" cat2 ] unless ;
: unparse ( obj -- str ) : unparse ( obj -- str )
[ [
[ t eq? ] [ drop "t" ] [ t eq? ] [ drop "t" ]
@ -115,7 +120,7 @@ USE: vocabularies
[ word? ] [ unparse-word ] [ word? ] [ unparse-word ]
[ integer? ] [ unparse-integer ] [ integer? ] [ unparse-integer ]
[ ratio? ] [ unparse-ratio ] [ ratio? ] [ unparse-ratio ]
[ float? ] [ unparse-float ] [ float? ] [ unparse-float fix-float ]
[ complex? ] [ unparse-complex ] [ complex? ] [ unparse-complex ]
[ string? ] [ unparse-str ] [ string? ] [ unparse-str ]
[ drop t ] [ <% "#<" % class-of % ">" % %> ] [ drop t ] [ <% "#<" % class-of % ">" % %> ]

225
library/test/math.factor
View File

@ -1,225 +0,0 @@
IN: scratchpad
USE: arithmetic
USE: compiler
USE: kernel
USE: math
USE: stdio
USE: test
"Testing math words." print
[ 100 ] [ 100 100 ] [ gcd ] test-word
[ 100 ] [ 1000 100 ] [ gcd ] test-word
[ 100 ] [ 100 1000 ] [ gcd ] test-word
[ 4 ] [ 132 64 ] [ gcd ] test-word
[ 4 ] [ -132 64 ] [ gcd ] test-word
[ 4 ] [ -132 -64 ] [ gcd ] test-word
[ 4 ] [ 132 -64 ] [ gcd ] test-word
[ 4 ] [ -132 -64 ] [ gcd ] test-word
! Make sure computation results are sane types.
[ t ] [ 30 2^ ] [ fixnum? ] test-word
[ t ] [ 32 2^ ] [ bignum? ] test-word
[ 2.1 ] [ -2.1 ] [ neg ] test-word
! Make sure equality testing works.
[ t ] [ 1 1.0 ] [ = ] test-word
[ f ] [ #{ 5 12.5 } 5 ] [ = ] test-word
[ t ] [ #{ 1.0 2.0 } #{ 1 2 } ] [ = ] test-word
[ f ] [ #{ 1.0 2.3 } #{ 1 2 } ] [ = ] test-word
! Complex number tests.
[ #{ 2 5 } ] [ 2 5 ] [ rect> ] test-word
[ 2 5 ] [ #{ 2 5 } ] [ >rect ] test-word
[ #{ 1/2 1 } ] [ 1/2 i ] [ + ] test-word
[ #{ 1/2 1 } ] [ i 1/2 ] [ + ] test-word
[ t ] [ #{ 11 64 } #{ 11 64 } ] [ = ] test-word
[ #{ 2 1 } ] [ 2 i ] [ + ] test-word
[ #{ 2 1 } ] [ i 2 ] [ + ] test-word
[ #{ 5 4 } ] [ #{ 2 2 } #{ 3 2 } ] [ + ] test-word
[ 5 ] [ #{ 2 2 } #{ 3 -2 } ] [ + ] test-word
[ #{ 1.0 1 } ] [ 1.0 i ] [ + ] test-word
[ #{ 1/2 -1 } ] [ 1/2 i ] [ - ] test-word
[ #{ -1/2 1 } ] [ i 1/2 ] [ - ] test-word
[ #{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word
[ #{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word
[ #{ 1/5 1/4 } ] [ #{ 3/5 1/2 } #{ 2/5 1/4 } ] [ - ] test-word
[ 4 ] [ #{ 5 10/3 } #{ 1 10/3 } ] [ - ] test-word
[ #{ 1.0 -1 } ] [ 1.0 i ] [ - ] test-word
[ #{ 0 1 } ] [ i 1 ] [ * ] test-word
[ #{ 0 1 } ] [ 1 i ] [ * ] test-word
[ #{ 0 1.0 } ] [ 1.0 i ] [ * ] test-word
[ -1 ] [ i i ] [ * ] test-word
[ #{ 0 1 } ] [ 1 i ] [ * ] test-word
[ #{ 0 1 } ] [ i 1 ] [ * ] test-word
[ #{ 0 1/2 } ] [ 1/2 i ] [ * ] test-word
[ #{ 0 1/2 } ] [ i 1/2 ] [ * ] test-word
[ 2 ] [ #{ 1 1 } #{ 1 -1 } ] [ * ] test-word
[ 1 ] [ i -i ] [ * ] test-word
[ -1 ] [ i -i ] [ / ] test-word
[ #{ 0 1 } ] [ 1 -i ] [ / ] test-word
[ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word
[ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word
! Comparison tests; make sure we're doing appropriate
! comparisons based on operand types.
! bignum -vs- bignum
[ t ]
[ 100000000000000000000000000 100000000000000000000000000 ]
[ = ]
test-word
[ f ]
[ 100000000000000000000000000 100000000000000000000000001 ]
[ = ]
test-word
[ t ]
[ 100000000000000000000000000 100000000000000000000000001 ]
[ < ]
test-word
[ t ]
[ 100000000000000000000000000 100000000000000000000000001 ]
[ <= ]
test-word
[ f ]
[ 100000000000000000000000000 100000000000000000000000001 ]
[ > ]
test-word
[ t ]
[ 100000000000000000000000002 100000000000000000000000001 ]
[ > ]
test-word
[ t ]
[ 100000000000000000000000002 100000000000000000000000001 ]
[ >= ]
test-word
[ f ]
[ 100000000000000000000000002 100000000000000000000000001 ]
[ < ]
test-word
! bignum -vs- fixnum
[ t ]
[ 100000000000000000000000000 1000 ]
[ >= ]
test-word
[ f ]
[ 100000000000000000000000000 1000 ]
[ < ]
test-word
! fixnum -vs- bignum
[ f ]
[ 1000 100000000000000000000000000 ]
[ >= ]
test-word
[ t ]
[ 1000 100000000000000000000000000 ]
[ < ]
test-word
! fixnum -vs- ratio
[ t ]
[ 1000000000/999999 1000 ]
[ > ]
test-word
! ratio -vs- fixnum
[ f ]
[ 100000 100000000000/999999 ]
[ > ]
test-word
! ratio -vs- ratio
[ t ]
[ 1000000000000/999999999999 1000000000001/999999999998 ]
[ < ]
test-word
! float -vs- fixnum
[ t ]
[ pi 3 ]
[ > ]
test-word
! fixnum -vs- float
[ f ]
[ e 2 ]
[ <= ]
test-word
! Test irrationals.
[ [ 1 1 0 0 ] ] [ [ sqrt ] ] [ balance>list ] test-word
[ 4.0 ] [ 16 ] [ sqrt ] test-word
[ #{ 0 4.0 } ] [ -16 ] [ sqrt ] test-word
[ [ 2 1 0 0 ] ] [ [ ^ ] ] [ balance>list ] test-word
[ 4.0 ] [ 2 2 ] [ ^ ] test-word
[ 0.25 ] [ 2 -2 ] [ ^ ] test-word
[ t ] [ 2 0.5 ^ 2 ^ ] [ 2 2.00001 between? ] test-word
[ t ] [ e pi i * ^ real ] [ -1.0 = ] test-word
[ t ] [ e pi i * ^ imaginary ] [ -0.00001 0.00001 between? ] test-word
[ [ 1 1 0 0 ] ] [ [ cosh ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ acosh ] ] [ balance>list ] test-word
[ 1.0 ] [ 0 ] [ cosh ] test-word
[ 0.0 ] [ 1 ] [ acosh ] test-word
[ [ 1 1 0 0 ] ] [ [ cos ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ acos ] ] [ balance>list ] test-word
[ 1.0 ] [ 0 ] [ cos ] test-word
[ 0.0 ] [ 1 ] [ acos ] test-word
[ [ 1 1 0 0 ] ] [ [ sinh ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ asinh ] ] [ balance>list ] test-word
[ 0.0 ] [ 0 ] [ sinh ] test-word
[ 0.0 ] [ 0 ] [ asinh ] test-word
[ [ 1 1 0 0 ] ] [ [ sin ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ asin ] ] [ balance>list ] test-word
[ 0.0 ] [ 0 ] [ sin ] test-word
[ 0.0 ] [ 0 ] [ asin ] test-word
! Make sure shift< is doing bignum upgrading.
[ 4294967296 ]
[ 1 32 ]
[ shift< ]
test-word
[ 18446744073709551616 ]
[ 1 64 ]
[ shift< ]
test-word
[ 340282366920938463463374607431768211456 ]
[ 1 128 ]
[ shift< ]
test-word
"Math tests done." print

45
library/test/math/complex.factor Normal file
View File

@ -0,0 +1,45 @@
IN: scratchpad
USE: arithmetic
USE: kernel
USE: stack
USE: test
[ f ] [ #{ 5 12.5 } 5 ] [ = ] test-word
[ t ] [ #{ 1.0 2.0 } #{ 1 2 } ] [ = ] test-word
[ f ] [ #{ 1.0 2.3 } #{ 1 2 } ] [ = ] test-word
[ #{ 2 5 } ] [ 2 5 ] [ rect> ] test-word
[ 2 5 ] [ #{ 2 5 } ] [ >rect ] test-word
[ #{ 1/2 1 } ] [ 1/2 i ] [ + ] test-word
[ #{ 1/2 1 } ] [ i 1/2 ] [ + ] test-word
[ t ] [ #{ 11 64 } #{ 11 64 } ] [ = ] test-word
[ #{ 2 1 } ] [ 2 i ] [ + ] test-word
[ #{ 2 1 } ] [ i 2 ] [ + ] test-word
[ #{ 5 4 } ] [ #{ 2 2 } #{ 3 2 } ] [ + ] test-word
[ 5 ] [ #{ 2 2 } #{ 3 -2 } ] [ + ] test-word
[ #{ 1.0 1 } ] [ 1.0 i ] [ + ] test-word
[ #{ 1/2 -1 } ] [ 1/2 i ] [ - ] test-word
[ #{ -1/2 1 } ] [ i 1/2 ] [ - ] test-word
[ #{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i * ] [ - ] test-word
[ #{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * + ] [ - ] test-word
[ #{ 1/5 1/4 } ] [ #{ 3/5 1/2 } #{ 2/5 1/4 } ] [ - ] test-word
[ 4 ] [ #{ 5 10/3 } #{ 1 10/3 } ] [ - ] test-word
[ #{ 1.0 -1 } ] [ 1.0 i ] [ - ] test-word
[ #{ 0 1 } ] [ i 1 ] [ * ] test-word
[ #{ 0 1 } ] [ 1 i ] [ * ] test-word
[ #{ 0 1.0 } ] [ 1.0 i ] [ * ] test-word
[ -1 ] [ i i ] [ * ] test-word
[ #{ 0 1 } ] [ 1 i ] [ * ] test-word
[ #{ 0 1 } ] [ i 1 ] [ * ] test-word
[ #{ 0 1/2 } ] [ 1/2 i ] [ * ] test-word
[ #{ 0 1/2 } ] [ i 1/2 ] [ * ] test-word
[ 2 ] [ #{ 1 1 } #{ 1 -1 } ] [ * ] test-word
[ 1 ] [ i -i ] [ * ] test-word
[ -1 ] [ i -i ] [ / ] test-word
[ #{ 0 1 } ] [ 1 -i ] [ / ] test-word
[ t ] [ #{ 12 13 } #{ 13 14 } / #{ 13 14 } * #{ 12 13 } ] [ = ] test-word
[ #{ -3 4 } ] [ #{ 3 -4 } ] [ neg ] test-word

5
library/test/math/float.factor
View File

@ -18,7 +18,7 @@ USE: test
[ f ] [ 1.3 1 = ] unit-test [ f ] [ 1.3 1 = ] unit-test
[ f ] [ 1.3 1 >bignum = ] unit-test [ f ] [ 1.3 1 >bignum = ] unit-test
[ t ] [ 134.3 >fixnum 134 eq? ] unit-test [ t ] [ 134.3 >fixnum 134 = ] unit-test
[ 2.1 ] [ -2.1 neg ] unit-test [ 2.1 ] [ -2.1 neg ] unit-test
@ -27,3 +27,6 @@ USE: test
[ 3 ] [ 3.1415 >fixnum ] unit-test [ 3 ] [ 3.1415 >fixnum ] unit-test
[ 3 ] [ 3.1415 >bignum ] unit-test [ 3 ] [ 3.1415 >bignum ] unit-test
[ t ] [ pi 3 > ] unit-test
[ f ] [ e 2 <= ] unit-test

26
library/test/math/irrational.factor Normal file
View File

@ -0,0 +1,26 @@
IN: scratchpad
USE: arithmetic
USE: kernel
USE: math
USE: test
[ 4.0 ] [ 16 ] [ sqrt ] test-word
[ #{ 0 4.0 } ] [ -16 ] [ sqrt ] test-word
[ 4.0 ] [ 2 2 ] [ ^ ] test-word
[ 0.25 ] [ 2 -2 ] [ ^ ] test-word
[ t ] [ 2 0.5 ^ 2 ^ ] [ 2 2.00001 between? ] test-word
[ t ] [ e pi i * ^ real ] [ -1.0 = ] test-word
[ t ] [ e pi i * ^ imaginary ] [ -0.00001 0.00001 between? ] test-word
[ 1.0 ] [ 0 ] [ cosh ] test-word
[ 0.0 ] [ 1 ] [ acosh ] test-word
[ 1.0 ] [ 0 ] [ cos ] test-word
[ 0.0 ] [ 1 ] [ acos ] test-word
[ 0.0 ] [ 0 ] [ sinh ] test-word
[ 0.0 ] [ 0 ] [ asinh ] test-word
[ 0.0 ] [ 0 ] [ sin ] test-word
[ 0.0 ] [ 0 ] [ asin ] test-word

14
library/test/math/rational.factor
View File

@ -77,5 +77,15 @@ USE: test
[ 1000000000000/999999999999 1000000000001/999999999998 < ] [ 1000000000000/999999999999 1000000000001/999999999998 < ]
unit-test unit-test
[ 3 ] [ 10/3 >integer ] unit-test ! JVM factor doesn't have >integer yet.
[ -3 ] [ -10/3 >integer ] unit-test ! [ 3 ] [ 10/3 >integer ] unit-test
! [ -3 ] [ -10/3 >integer ] unit-test
[ 100 ] [ 100 100 gcd ] unit-test
[ 100 ] [ 1000 100 gcd ] unit-test
[ 100 ] [ 100 1000 gcd ] unit-test
[ 4 ] [ 132 64 gcd ] unit-test
[ 4 ] [ -132 64 gcd ] unit-test
[ 4 ] [ -132 -64 gcd ] unit-test
[ 4 ] [ 132 -64 gcd ] unit-test
[ 4 ] [ -132 -64 gcd ] unit-test

2
library/test/namespaces/namespaces.factor
View File

@ -35,7 +35,7 @@ unit-test
[ t ] [ t ]
[ [
"test-word" intern "test-word" intern
[ "vocabularies" "test" "test-word" ] object-path global [ [ "vocabularies" "test" "test-word" ] object-path ] bind
= =
] unit-test ] unit-test

43
library/test/parse-number.factor
View File

@ -1,11 +1,9 @@
IN: scratchpad IN: scratchpad
USE: arithmetic USE: arithmetic
USE: parser USE: parser
USE: stdio
USE: strings USE: strings
USE: test USE: test
USE: unparser
"Parse number tests" print
[ f ] [ f ]
[ f ] [ f ]
@ -38,23 +36,23 @@ test-word
test-word test-word
[ "100.0" ] [ "100.0" ]
[ "1e2" ] [ "1.0e2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "-100.0" ] [ "-100.0" ]
[ "-1e2" ] [ "-1.0e2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "0.01" ] [ "0.01" ]
[ "1e-2" ] [ "1.0e-2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "-0.01" ] [ "-0.01" ]
[ "-1e-2" ] [ "-1.0e-2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ f ] [ f ]
@ -64,7 +62,7 @@ test-word
[ "3.14" ] [ "3.14" ]
[ "3.14" ] [ "3.14" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ f ] [ f ]
@ -79,27 +77,22 @@ test-word
[ "101.0" ] [ "101.0" ]
[ "1.01e2" ] [ "1.01e2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "-101.0" ] [ "-101.0" ]
[ "-1.01e2" ] [ "-1.01e2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "1.01" ] [ "1.01" ]
[ "101e-2" ] [ "101.0e-2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
[ "-1.01" ] [ "-1.01" ]
[ "-101e-2" ] [ "-101.0e-2" ]
[ parse-number >str ] [ parse-number unparse ]
test-word
[ "123456789123456789123456789" ]
[ "123456789123456789123456789" ]
[ parse-number >str ]
test-word test-word
[ 5 ] [ 5 ]
@ -139,7 +132,5 @@ test-word
[ "33/100" ] [ "33/100" ]
[ "66/200" ] [ "66/200" ]
[ parse-number >str ] [ parse-number unparse ]
test-word test-word
"Parse number tests done" print

7
library/test/test.factor
View File

@ -58,16 +58,19 @@ USE: vocabularies
"namespaces/all" "namespaces/all"
"format" "format"
"parser" "parser"
"parse-number"
"prettyprint" "prettyprint"
"inspector" "inspector"
"vectors" "vectors"
"unparser" "unparser"
"random" "random"
"math/rational"
"math/float"
"math/complex"
"math/irrational"
! !
"html" "html"
"httpd" "httpd"
"math"
"parse-number"
"jvm-compiler/all" "jvm-compiler/all"
] [ ] [
test test

1
native/arithmetic.c
View File

@ -129,3 +129,4 @@ BINARY_OP(less, false, false)
BINARY_OP(lesseq, false, false) BINARY_OP(lesseq, false, false)
BINARY_OP(greater, false, false) BINARY_OP(greater, false, false)
BINARY_OP(greatereq, false, false) BINARY_OP(greatereq, false, false)
BINARY_OP(gcd, false, true)

108
native/arithmetic.h
View File

@ -36,7 +36,7 @@ CELL OP(CELL x, CELL y) \
case RATIO_TYPE: \ case RATIO_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -44,7 +44,7 @@ CELL OP(CELL x, CELL y) \
case COMPLEX_TYPE: \ case COMPLEX_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -54,7 +54,7 @@ CELL OP(CELL x, CELL y) \
case FLOAT_TYPE: \ case FLOAT_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -63,15 +63,17 @@ CELL OP(CELL x, CELL y) \
if(anytype) \ if(anytype) \
return OP##_anytype(x,y); \ return OP##_anytype(x,y); \
else \ else \
type_error(FIXNUM_TYPE,y); \ { \
return F; \ type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
\ \
case RATIO_TYPE: \ case RATIO_TYPE: \
\ \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,x); \ type_error(INTEGER_TYPE,x); \
return F; \ return F; \
} \ } \
\ \
@ -91,15 +93,17 @@ CELL OP(CELL x, CELL y) \
if(anytype) \ if(anytype) \
return OP##_anytype(x,y); \ return OP##_anytype(x,y); \
else \ else \
type_error(FIXNUM_TYPE,y); \ { \
return F; \ type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
\ \
case COMPLEX_TYPE: \ case COMPLEX_TYPE: \
\ \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,x); \ type_error(INTEGER_TYPE,x); \
return F; \ return F; \
} \ } \
\ \
@ -119,8 +123,10 @@ CELL OP(CELL x, CELL y) \
if(anytype) \ if(anytype) \
return OP##_anytype(x,y); \ return OP##_anytype(x,y); \
else \ else \
type_error(FIXNUM_TYPE,y); \ { \
return F; \ type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
\ \
case BIGNUM_TYPE: \ case BIGNUM_TYPE: \
@ -132,7 +138,7 @@ CELL OP(CELL x, CELL y) \
case RATIO_TYPE: \ case RATIO_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(BIGNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -140,7 +146,7 @@ CELL OP(CELL x, CELL y) \
case COMPLEX_TYPE: \ case COMPLEX_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(BIGNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -150,7 +156,7 @@ CELL OP(CELL x, CELL y) \
case FLOAT_TYPE: \ case FLOAT_TYPE: \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(BIGNUM_TYPE,y); \ type_error(INTEGER_TYPE,y); \
return F; \ return F; \
} \ } \
else \ else \
@ -159,15 +165,17 @@ CELL OP(CELL x, CELL y) \
if(anytype) \ if(anytype) \
return OP##_anytype(x,y); \ return OP##_anytype(x,y); \
else \ else \
type_error(BIGNUM_TYPE,y); \ { \
return F; \ type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
\ \
case FLOAT_TYPE: \ case FLOAT_TYPE: \
\ \
if(integerOnly) \ if(integerOnly) \
{ \ { \
type_error(FIXNUM_TYPE,x); \ type_error(INTEGER_TYPE,x); \
return F; \ return F; \
} \ } \
\ \
@ -184,8 +192,13 @@ CELL OP(CELL x, CELL y) \
case FLOAT_TYPE: \ case FLOAT_TYPE: \
return OP##_float(x,y); \ return OP##_float(x,y); \
default: \ default: \
type_error(FLOAT_TYPE,y); \ if(anytype) \
return F; \ return OP##_anytype(x,y); \
else \
{ \
type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
\ \
default: \ default: \
@ -193,8 +206,10 @@ CELL OP(CELL x, CELL y) \
if(anytype) \ if(anytype) \
return OP##_anytype(x,y); \ return OP##_anytype(x,y); \
else \ else \
type_error(FIXNUM_TYPE,x); \ { \
return F; \ type_error(NUMBER_TYPE,x); \
return F; \
} \
} \ } \
} \ } \
\ \
@ -204,6 +219,55 @@ void primitive_##OP(void) \
env.dt = OP(x,y); \ env.dt = OP(x,y); \
} }
#define UNARY_OP(OP,anytype,integerOnly) \
CELL OP(CELL x) \
{ \
switch(type_of(x)) \
{ \
case FIXNUM_TYPE: \
return OP##_fixnum(x); \
case RATIO_TYPE: \
if(integerOnly) \
{ \
type_error(INTEGER_TYPE,x); \
return F; \
} \
else \
return OP##_ratio(x); \
case COMPLEX_TYPE: \
if(integerOnly) \
{ \
type_error(INTEGER_TYPE,x); \
return F; \
} \
else \
return OP##_complex(x); \
case BIGNUM_TYPE: \
return OP##_bignum(x); \
case FLOAT_TYPE: \
if(integerOnly) \
{ \
type_error(INTEGER_TYPE,x); \
return F; \
} \
else \
return OP##_float(x); \
default: \
if(anytype) \
return OP##_anytype(x); \
else \
{ \
type_error(NUMBER_TYPE,x); \
return F; \
} \
} \
} \
\
void primitive_##OP(void) \
{ \
env.dt = OP(env.dt); \
}
bool realp(CELL tagged); bool realp(CELL tagged);
bool numberp(CELL tagged); bool numberp(CELL tagged);
void primitive_numberp(void); void primitive_numberp(void);
@ -252,3 +316,5 @@ CELL shiftleft(CELL x, CELL y);
void primitive_shiftleft(void); void primitive_shiftleft(void);
CELL shiftright(CELL x, CELL y); CELL shiftright(CELL x, CELL y);
void primitive_shiftright(void); void primitive_shiftright(void);
CELL gcd(CELL x, CELL y);
void primitive_gcd(void);

4
native/complex.c
View File

@ -114,7 +114,7 @@ CELL add_complex(CELL x, CELL y)
COMPLEX* cy = (COMPLEX*)UNTAG(y); COMPLEX* cy = (COMPLEX*)UNTAG(y);
return possibly_complex( return possibly_complex(
add(cx->real,cy->real), add(cx->real,cy->real),
add(cx->imaginary,cy->real)); add(cx->imaginary,cy->imaginary));
} }
CELL subtract_complex(CELL x, CELL y) CELL subtract_complex(CELL x, CELL y)
@ -123,7 +123,7 @@ CELL subtract_complex(CELL x, CELL y)
COMPLEX* cy = (COMPLEX*)UNTAG(y); COMPLEX* cy = (COMPLEX*)UNTAG(y);
return possibly_complex( return possibly_complex(
subtract(cx->real,cy->real), subtract(cx->real,cy->real),
subtract(cx->imaginary,cy->real)); subtract(cx->imaginary,cy->imaginary));
} }
CELL multiply_complex(CELL x, CELL y) CELL multiply_complex(CELL x, CELL y)

4
native/complex.h
View File

@ -9,9 +9,9 @@ INLINE COMPLEX* untag_complex(CELL tagged)
return (COMPLEX*)UNTAG(tagged); return (COMPLEX*)UNTAG(tagged);
} }
INLINE CELL tag_complex(RATIO* ratio) INLINE CELL tag_complex(COMPLEX* complex)
{ {
return RETAG(ratio,COMPLEX_TYPE); return RETAG(complex,COMPLEX_TYPE);
} }
COMPLEX* complex(CELL real, CELL imaginary); COMPLEX* complex(CELL real, CELL imaginary);

6
native/error.c
View File

@ -15,9 +15,11 @@ void critical_error(char* msg, CELL tagged)
void fix_stacks(void) void fix_stacks(void)
{ {
if(UNDERFLOW(env.ds,env.ds_bot) || OVERFLOW(env.ds,env.ds_bot)) if(STACK_UNDERFLOW(env.ds,env.ds_bot)
|| STACK_OVERFLOW(env.ds,env.ds_bot))
reset_datastack(); reset_datastack();
if(UNDERFLOW(env.cs,env.cs_bot) || OVERFLOW(env.cs,env.cs_bot)) if(STACK_UNDERFLOW(env.cs,env.cs_bot)
|| STACK_OVERFLOW(env.cs,env.cs_bot))
reset_callstack(); reset_callstack();
} }

10
native/error.h
View File

@ -3,11 +3,11 @@
#define ERROR_TYPE (2<<3) #define ERROR_TYPE (2<<3)
#define ERROR_RANGE (3<<3) #define ERROR_RANGE (3<<3)
#define ERROR_UNDERFLOW (4<<3) #define ERROR_UNDERFLOW (4<<3)
#define ERROR_BAD_PRIMITIVE (5<<3) #define ERROR_HANDLE_INCOMPAT (5<<3)
#define ERROR_HANDLE_INCOMPAT (6<<3) #define ERROR_IO (6<<3)
#define ERROR_IO (7<<3) #define ERROR_OVERFLOW (7<<3)
#define ERROR_OVERFLOW (8<<3) #define ERROR_INCOMPARABLE (8<<3)
#define ERROR_INCOMPARABLE (9<<3) #define ERROR_FLOAT_FORMAT (9<<3)
void fatal_error(char* msg, CELL tagged); void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged); void critical_error(char* msg, CELL tagged);

1
native/factor.h
View File

@ -4,6 +4,7 @@
#include <errno.h> #include <errno.h>
#include <fcntl.h> #include <fcntl.h>
#include <limits.h> #include <limits.h>
#include <math.h>
#include <setjmp.h> #include <setjmp.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>

75
native/float.c
View File

@ -31,14 +31,19 @@ void primitive_to_float(void)
void primitive_str_to_float(void) void primitive_str_to_float(void)
{ {
char* c_str = to_c_string(untag_string(env.dt)); STRING* str = untag_string(env.dt);
env.dt = tag_object(make_float(atof(c_str))); char* c_str = to_c_string(str);
char* end = c_str;
double f = strtod(c_str,&end);
if(end != c_str + str->capacity)
general_error(ERROR_FLOAT_FORMAT,tag_object(str));
env.dt = tag_object(make_float(f));
} }
void primitive_float_to_str(void) void primitive_float_to_str(void)
{ {
char tmp[33]; char tmp[33];
snprintf(&tmp,32,"%.16g",untag_float(env.dt)->n); snprintf(&tmp,32,"%.16g",to_float(env.dt)->n);
tmp[32] = '\0'; tmp[32] = '\0';
env.dt = tag_object(from_c_string(tmp)); env.dt = tag_object(from_c_string(tmp));
} }
@ -107,3 +112,67 @@ CELL greatereq_float(CELL x, CELL y)
return tag_boolean(((FLOAT*)UNTAG(x))->n return tag_boolean(((FLOAT*)UNTAG(x))->n
>= ((FLOAT*)UNTAG(y))->n); >= ((FLOAT*)UNTAG(y))->n);
} }
void primitive_facos(void)
{
env.dt = tag_object(make_float(acos(to_float(env.dt)->n)));
}
void primitive_fasin(void)
{
env.dt = tag_object(make_float(asin(to_float(env.dt)->n)));
}
void primitive_fatan(void)
{
env.dt = tag_object(make_float(atan(to_float(env.dt)->n)));
}
void primitive_fatan2(void)
{
double x = to_float(env.dt)->n;
double y = to_float(dpop())->n;
env.dt = tag_object(make_float(atan2(y,x)));
}
void primitive_fcos(void)
{
env.dt = tag_object(make_float(cos(to_float(env.dt)->n)));
}
void primitive_fexp(void)
{
env.dt = tag_object(make_float(exp(to_float(env.dt)->n)));
}
void primitive_fcosh(void)
{
env.dt = tag_object(make_float(cosh(to_float(env.dt)->n)));
}
void primitive_flog(void)
{
env.dt = tag_object(make_float(log(to_float(env.dt)->n)));
}
void primitive_fpow(void)
{
double x = to_float(env.dt)->n;
double y = to_float(dpop())->n;
env.dt = tag_object(make_float(pow(y,x)));
}
void primitive_fsin(void)
{
env.dt = tag_object(make_float(sin(to_float(env.dt)->n)));
}
void primitive_fsinh(void)
{
env.dt = tag_object(make_float(sinh(to_float(env.dt)->n)));
}
void primitive_fsqrt(void)
{
env.dt = tag_object(make_float(sqrt(to_float(env.dt)->n)));
}

23
native/float.h
View File

@ -14,10 +14,15 @@ INLINE FLOAT* make_float(double n)
return flo; return flo;
} }
INLINE FLOAT* untag_float(CELL tagged) INLINE double untag_float_fast(CELL tagged)
{
return ((FLOAT*)UNTAG(tagged))->n;
}
INLINE double untag_float(CELL tagged)
{ {
type_check(FLOAT_TYPE,tagged); type_check(FLOAT_TYPE,tagged);
return (FLOAT*)UNTAG(tagged); return untag_float_fast(tagged);
} }
void primitive_floatp(void); void primitive_floatp(void);
@ -26,6 +31,7 @@ void primitive_to_float(void);
void primitive_str_to_float(void); void primitive_str_to_float(void);
void primitive_float_to_str(void); void primitive_float_to_str(void);
void primitive_float_to_bits(void); void primitive_float_to_bits(void);
CELL number_eq_float(CELL x, CELL y); CELL number_eq_float(CELL x, CELL y);
CELL add_float(CELL x, CELL y); CELL add_float(CELL x, CELL y);
CELL subtract_float(CELL x, CELL y); CELL subtract_float(CELL x, CELL y);
@ -36,3 +42,16 @@ CELL less_float(CELL x, CELL y);
CELL lesseq_float(CELL x, CELL y); CELL lesseq_float(CELL x, CELL y);
CELL greater_float(CELL x, CELL y); CELL greater_float(CELL x, CELL y);
CELL greatereq_float(CELL x, CELL y); CELL greatereq_float(CELL x, CELL y);
void primitive_facos(void);
void primitive_fasin(void);
void primitive_fatan(void);
void primitive_fatan2(void);
void primitive_fcos(void);
void primitive_fexp(void);
void primitive_fcosh(void);
void primitive_flog(void);
void primitive_fpow(void);
void primitive_fsin(void);
void primitive_fsinh(void);
void primitive_fsqrt(void);

15
native/primitives.c
View File

@ -72,6 +72,19 @@ XT primitives[] = {
primitive_lesseq, primitive_lesseq,
primitive_greater, primitive_greater,
primitive_greatereq, primitive_greatereq,
primitive_gcd,
primitive_facos,
primitive_fasin,
primitive_fatan,
primitive_fatan2,
primitive_fcos,
primitive_fexp,
primitive_fcosh,
primitive_flog,
primitive_fpow,
primitive_fsin,
primitive_fsinh,
primitive_fsqrt,
primitive_wordp, primitive_wordp,
primitive_word, primitive_word,
primitive_word_primitive, primitive_word_primitive,
@ -121,7 +134,7 @@ XT primitives[] = {
CELL primitive_to_xt(CELL primitive) CELL primitive_to_xt(CELL primitive)
{ {
if(primitive < 0 || primitive >= PRIMITIVE_COUNT) if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
general_error(ERROR_BAD_PRIMITIVE,tag_fixnum(primitive)); critical_error("Bad primitive number",primitive);
return (CELL)primitives[primitive]; return (CELL)primitives[primitive];
} }

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[]; extern XT primitives[];
#define PRIMITIVE_COUNT 115 #define PRIMITIVE_COUNT 128
CELL primitive_to_xt(CELL primitive); CELL primitive_to_xt(CELL primitive);

12
native/stack.h
View File

@ -1,15 +1,15 @@
#define UNDERFLOW_CHECKING #define STACK_UNDERFLOW_CHECKING
#define UNDERFLOW(stack,bot) ((stack) < UNTAG(bot) + sizeof(ARRAY)) #define STACK_UNDERFLOW(stack,bot) ((stack) < UNTAG(bot) + sizeof(ARRAY))
#define OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + object_size(bot)) #define STACK_OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + object_size(bot))
INLINE void check_stacks(void) INLINE void check_stacks(void)
{ {
#ifdef UNDERFLOW_CHECKING #ifdef STACK_UNDERFLOW_CHECKING
if(OVERFLOW(env.ds,env.ds_bot)) if(STACK_OVERFLOW(env.ds,env.ds_bot))
general_error(ERROR_OVERFLOW,F); general_error(ERROR_OVERFLOW,F);
if(OVERFLOW(env.cs,env.cs_bot)) if(STACK_OVERFLOW(env.cs,env.cs_bot))
general_error(ERROR_OVERFLOW,F); general_error(ERROR_OVERFLOW,F);
#endif #endif

1
native/types.h
View File

@ -40,6 +40,7 @@ CELL empty;
#define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */ #define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */
#define RATIONAL_TYPE 101 /* INTEGER or RATIO */ #define RATIONAL_TYPE 101 /* INTEGER or RATIO */
#define REAL_TYPE 102 /* RATIONAL or FLOAT */ #define REAL_TYPE 102 /* RATIONAL or FLOAT */
#define NUMBER_TYPE 103 /* COMPLEX or REAL */
bool typep(CELL type, CELL tagged); bool typep(CELL type, CELL tagged);
CELL type_of(CELL tagged); CELL type_of(CELL tagged);