diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 1c66319c13..9415c55bc7 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,5 +1,16 @@
+- java factor memory leak
+- tail call optimization broken again
+
++ listener:
+
+- link style lingers
+- back space then type: input style gone
+- fedit broken with listener
+- press enter in the middle of a line
+
+ native:
+- native float>bits
- printing floats: append .0 always
- vector=
- make-image: take a parameter, include le & be images in dist
@@ -32,17 +43,8 @@ ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable
- FactorLib.equal() not very good
- IN: format base: work with all types of numbers
-+ listener:
-
-- link style lingers
-- back space then type: input style gone
-- fedit broken with listener
-- press enter in the middle of a line
-- new-listener shouldn't suspend continuation in current listener
-
+ compiler:
-- tail call optimization broken again
- don't compile inline words
- recursive words with code after ifte
- less unnecessary args to auxiliary methods
diff --git a/build.sh b/build.sh
index 056f96997c..8904f74520 100644
--- a/build.sh
+++ b/build.sh
@@ -1,5 +1,5 @@
export CC=gcc34
-export CFLAGS="-pedantic -Wall -Winline -Os -march=pentium4 -fomit-frame-pointer"
+export CFLAGS="-pedantic -Wall -Winline -O3 -march=pentium4 -fomit-frame-pointer"
$CC $CFLAGS -o f native/*.c
diff --git a/build.xml b/build.xml
index 81dd7086dc..08922392c3 100644
--- a/build.xml
+++ b/build.xml
@@ -12,9 +12,22 @@
optimize="true"
>
+
-
+
+
+
+
+
+
+
+
diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java
new file mode 100644
index 0000000000..786519a1ea
--- /dev/null
+++ b/factor/jedit/FactorPlugin.java
@@ -0,0 +1,53 @@
+/* :folding=explicit: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.
+ */
+
+package factor.jedit;
+
+import factor.listener.FactorListenerPanel;
+import factor.FactorInterpreter;
+import org.gjt.sp.jedit.*;
+import java.util.WeakHashMap;
+
+public class FactorPlugin extends EditPlugin
+{
+ private static WeakHashMap views = new WeakHashMap();
+
+ public static FactorInterpreter getInterpreter(View view)
+ {
+ FactorInterpreter interp = (FactorInterpreter)
+ views.get(view);
+ if(interp == null)
+ {
+ interp = FactorListenerPanel.newInterpreter(
+ new String[] { "-jedit" });
+ views.put(view,interp);
+ }
+ return interp;
+ }
+}
diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props
new file mode 100644
index 0000000000..cd17135389
--- /dev/null
+++ b/factor/jedit/FactorPlugin.props
@@ -0,0 +1,21 @@
+### Plugin properties
+
+plugin.factor.jedit.FactorPlugin.activate=defer
+
+plugin.factor.jedit.FactorPlugin.name=Factor
+plugin.factor.jedit.FactorPlugin.version=0.60.10
+plugin.factor.jedit.FactorPlugin.author=Slava Pestov
+plugin.factor.jedit.FactorPlugin.docs=index.html
+
+plugin.factor.jedit.FactorPlugin.depend.0=jedit 04.02.15.00
+
+plugin.factor.jedit.FactorPlugin.menu=factor \
+ - \
+ factor-run-file \
+ factor-eval-selection
+
+factor.label=Factor Listener
+factor-run-file.label=Run Current File
+factor-eval-selection.label=Evaluate Selection
+
+factor.title=Factor
diff --git a/factor/listener/FactorDesktop.java b/factor/listener/FactorDesktop.java
index e3e8075aab..4308b07df2 100644
--- a/factor/listener/FactorDesktop.java
+++ b/factor/listener/FactorDesktop.java
@@ -39,11 +39,6 @@ import javax.swing.text.html.*;
public class FactorDesktop extends JFrame
{
- private JTabbedPane tabs;
- private FactorInterpreter interp;
- private boolean standalone;
- private Map listeners;
-
//{{{ main() method
public static void main(String[] args)
{
@@ -54,26 +49,10 @@ public class FactorDesktop extends JFrame
public FactorDesktop(String[] args, boolean standalone)
{
super("Factor");
- tabs = new JTabbedPane();
- this.standalone = standalone;
- listeners = new HashMap();
- getContentPane().add(BorderLayout.CENTER,tabs);
-
- try
- {
- interp = new FactorInterpreter();
- interp.interactive = false;
- interp.init(args,null);
- interp.global.setVariable("desktop",this);
- }
- catch(Exception e)
- {
- System.err.println("Failed to initialize interpreter:");
- e.printStackTrace();
- }
-
- newListener();
+ getContentPane().add(BorderLayout.CENTER,
+ new FactorListenerPanel(
+ FactorListenerPanel.newInterpreter(args)));
setSize(640,480);
setDefaultCloseOperation(standalone
@@ -81,100 +60,4 @@ public class FactorDesktop extends JFrame
: DISPOSE_ON_CLOSE);
show();
} //}}}
-
- //{{{ newListener() method
- public FactorListener newListener()
- {
- final FactorListener listener = new FactorListener();
- listener.addEvalListener(new EvalHandler());
-
- try
- {
- interp.call(new Cons(listener,
- new Cons(interp.searchVocabulary(
- "listener","new-listener-hook"),
- null)));
- interp.run();
- }
- catch(Exception e)
- {
- System.err.println("Failed to initialize listener:");
- e.printStackTrace();
- }
-
- JScrollPane scroller = new JScrollPane(listener);
- listeners.put(listener,scroller);
- tabs.addTab("Listener",scroller);
-
- SwingUtilities.invokeLater(new Runnable()
- {
- public void run()
- {
- listener.requestFocus();
- }
- });
-
- return listener;
- } //}}}
-
- //{{{ closeListener() method
- public void closeListener(FactorListener listener)
- {
- // remove tab containing the listener
- tabs.remove((Component)listeners.get(listener));
- if(tabs.getTabCount() == 0)
- {
- if(standalone)
- System.exit(0);
- else
- dispose();
- }
- } //}}}
-
- //{{{ getInterpreter() method
- public FactorInterpreter getInterpreter()
- {
- return interp;
- } //}}}
-
- //{{{ eval() method
- public void eval(Cons cmd)
- {
- try
- {
- interp.call(cmd);
- interp.run();
- }
- catch(Exception e)
- {
- System.err.println("Failed to eval " + cmd + ":");
- e.printStackTrace();
- }
- } //}}}
-
- //{{{ EvalHandler class
- class EvalHandler implements EvalListener
- {
- public void eval(Cons cmd)
- {
- FactorDesktop.this.eval(cmd);
- }
- } //}}}
-
- //{{{ EvalAction class
- class EvalAction extends AbstractAction
- {
- private Cons code;
-
- public EvalAction(String label, Cons code)
- {
- super(label);
- this.code = code;
- }
-
- public void actionPerformed(ActionEvent evt)
- {
- FactorDesktop.this.eval(code);
- }
- } //}}}
}
diff --git a/factor/listener/FactorListenerPanel.java b/factor/listener/FactorListenerPanel.java
new file mode 100644
index 0000000000..5eadd78c1a
--- /dev/null
+++ b/factor/listener/FactorListenerPanel.java
@@ -0,0 +1,133 @@
+/* :folding=explicit: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.
+ */
+
+package factor.listener;
+
+import factor.*;
+import java.awt.*;
+import java.awt.event.*;
+import java.util.*;
+import javax.swing.*;
+import javax.swing.text.*;
+import javax.swing.text.html.*;
+
+public class FactorListenerPanel extends JPanel
+{
+ private FactorInterpreter interp;
+ private FactorListener listener;
+
+ //{{{ newInterpreter() method
+ public static FactorInterpreter newInterpreter(String[] args)
+ {
+ try
+ {
+ FactorInterpreter interp = new FactorInterpreter();
+ interp.interactive = false;
+ interp.init(args,null);
+ return interp;
+ }
+ catch(Exception e)
+ {
+ System.err.println("Failed to initialize interpreter:");
+ e.printStackTrace();
+ return null;
+ }
+ } //}}}
+
+ //{{{ FactorListenerPanel constructor
+ public FactorListenerPanel(FactorInterpreter interp)
+ {
+ setLayout(new BorderLayout());
+
+ this.interp = interp;
+
+ add(BorderLayout.CENTER,new JScrollPane(
+ listener = newListener()));
+ } //}}}
+
+ //{{{ newListener() method
+ private FactorListener newListener()
+ {
+ final FactorListener listener = new FactorListener();
+ listener.addEvalListener(new EvalHandler());
+
+ try
+ {
+ interp.call(new Cons(listener,
+ new Cons(interp.searchVocabulary(
+ "listener","new-listener-hook"),
+ null)));
+ interp.run();
+ }
+ catch(Exception e)
+ {
+ System.err.println("Failed to initialize listener:");
+ e.printStackTrace();
+ }
+
+ return listener;
+ } //}}}
+
+ //{{{ requestDefaultFocus() method
+ public boolean requestDefaultFocus()
+ {
+ listener.requestFocus();
+ return true;
+ } //}}}
+
+ //{{{ getInterpreter() method
+ public FactorInterpreter getInterpreter()
+ {
+ return interp;
+ } //}}}
+
+ //{{{ eval() method
+ public void eval(Cons cmd)
+ {
+ try
+ {
+ interp.call(cmd);
+ interp.run();
+ }
+ catch(Exception e)
+ {
+ System.err.println("Failed to eval " + cmd + ":");
+ e.printStackTrace();
+ }
+ } //}}}
+
+ //{{{ EvalHandler class
+ class EvalHandler implements EvalListener
+ {
+ public void eval(Cons cmd)
+ {
+ FactorListenerPanel.this.eval(cmd);
+ }
+ } //}}}
+}
diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index 89d61b4e0e..5a5a198769 100644
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -51,6 +51,8 @@ DEFER: save-image
DEFER: handle?
DEFER: room
DEFER: os-env
+DEFER: type-of
+DEFER: size-of
IN: strings
DEFER: str=
@@ -134,6 +136,7 @@ IN: cross-compiler
float?
str>float
unparse-float
+ float>bits
complex?
real
imaginary
@@ -199,6 +202,8 @@ IN: cross-compiler
millis
init-random
(random-int)
+ type-of
+ size-of
] [
swap succ tuck primitive,
] each drop ;
diff --git a/library/image.factor b/library/image.factor
index a6566cd8b7..ac7a1e8d42 100644
--- a/library/image.factor
+++ b/library/image.factor
@@ -48,6 +48,12 @@ USE: words
: image "image" get ;
: emit ( cell -- ) image vector-push ;
+
+: emit64 ( bignum -- )
+ #! Little endian byte order
+ dup HEX: ffffffff bitand emit
+ 32 shift> HEX: ffffffff bitand emit ;
+
: fixup ( value offset -- ) image set-vector-nth ;
( Object memory )
@@ -72,6 +78,17 @@ USE: words
: header-tag BIN: 110 ;
: gc-fwd-ptr BIN: 111 ; ( we don't output these )
+: f-type 6 ;
+: t-type 7 ;
+: empty-type 8 ;
+: array-type 9 ;
+: vector-type 10 ;
+: string-type 11 ;
+: sbuf-type 12 ;
+: handle-type 13 ;
+: bignum-type 14 ;
+: float-type 15 ;
+
: immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
: >header ( id -- tagged ) header-tag immediate ;
@@ -108,13 +125,31 @@ USE: words
: 'fixnum ( n -- tagged ) fixnum-tag immediate ;
+( Floats )
+
+: 'float ( f -- tagged )
+ object-tag here-as
+ float-type >header emit
+ 0 emit ( alignment -- FIXME 64-bit arch )
+ float>bits emit64 ;
+
+( Bignums )
+
+: 'bignum ( bignum -- tagged )
+ dup .
+ #! Very bad!
+ object-tag here-as
+ bignum-type >header emit
+ 0 emit ( alignment -- FIXME 64-bit arch )
+ ( bignum -- ) emit64 ;
+
( Special objects )
! Padded with fixnums for 8-byte alignment
-: f, object-tag here-as "f" set 6 >header emit 0 'fixnum emit ;
-: t, object-tag here-as "t" set 7 >header emit 0 'fixnum emit ;
-: empty, 8 >header emit 0 'fixnum emit ;
+: f, object-tag here-as "f" set f-type >header emit 0 'fixnum emit ;
+: t, object-tag here-as "t" set t-type >header emit 0 'fixnum emit ;
+: empty, empty-type >header emit 0 'fixnum emit ;
( Beginning of the image )
! The image proper begins with the header, then EMPTY, F, T
@@ -184,7 +219,7 @@ DEFER: '
: string, ( string -- )
object-tag here-as swap
- 11 >header emit
+ string-type >header emit
dup str-length emit
dup hashcode emit
pack-string
@@ -247,7 +282,7 @@ IN: cross-compiler
: 'array ( list -- untagged )
[ ' ] inject
here >r
- 9 >header emit
+ array-type >header emit
dup length emit
( elements -- ) [ emit ] each
pad r> ;
@@ -255,7 +290,7 @@ IN: cross-compiler
: 'vector ( vector -- pointer )
dup vector>list 'array swap vector-length
object-tag here-as >r
- 10 >header emit
+ vector-type >header emit
emit ( length )
emit ( array ptr )
pad r> ;
@@ -265,6 +300,8 @@ IN: cross-compiler
: ' ( obj -- pointer )
[
[ fixnum? ] [ 'fixnum ]
+ [ bignum? ] [ 'bignum ]
+ [ float? ] [ 'float ]
[ word? ] [ 'word ]
[ cons? ] [ 'cons ]
[ char? ] [ 'fixnum ]
diff --git a/library/init.factor b/library/init.factor
index 5f648e11a8..a4eb23b74e 100644
--- a/library/init.factor
+++ b/library/init.factor
@@ -134,6 +134,8 @@ USE: strings
init-toplevel
[
+ print-banner
+ room.
interpreter-loop
] [
[ default-error-handler suspend ] when*
diff --git a/library/platform/jvm/arithmetic.factor b/library/platform/jvm/arithmetic.factor
index 34a7ee3a4b..a5b0068345 100644
--- a/library/platform/jvm/arithmetic.factor
+++ b/library/platform/jvm/arithmetic.factor
@@ -143,3 +143,8 @@ USE: stack
: gcd ( a b -- c )
[ "java.lang.Number" "java.lang.Number" ]
"factor.math.FactorMath" "gcd" jinvoke-static ;
+
+: float>bits ( f -- bignum )
+ [ "double" ]
+ "java.lang.Double" "doubleToRawLongBits"
+ jinvoke-static >bignum ;
diff --git a/library/platform/jvm/init.factor b/library/platform/jvm/init.factor
index 10a1b23ab2..d15521ea74 100644
--- a/library/platform/jvm/init.factor
+++ b/library/platform/jvm/init.factor
@@ -77,5 +77,4 @@ USE: strings
t "startup-done" set
- print-banner
init-interpreter ;
diff --git a/library/platform/jvm/listener.factor b/library/platform/jvm/listener.factor
index cbd9d3c014..f332192848 100644
--- a/library/platform/jvm/listener.factor
+++ b/library/platform/jvm/listener.factor
@@ -143,28 +143,12 @@ USE: unparser
[ this fwrite "\n" this fwrite ] "fprint" set
] extend ;
-: close-listener ( listener -- )
- #! Closes the listener. If no more listeners remain, the
- #! desktop exits.
- "desktop" get
- [ "factor.listener.FactorListener" ]
- "factor.listener.FactorDesktop" "closeListener"
- jinvoke ;
-
: new-listener-hook ( listener -- )
- #! Called when user opens a new listener in the desktop.
+ #! Called when user opens a new listener
[
dup "listener" set
"stdio" set
+ print-banner
+ room.
interpreter-loop
- "listener" get close-listener
] bind ;
-
-: new-listener ( -- )
- #! Opens a new listener.
- "desktop" get
- [ ] "factor.listener.FactorDesktop" "newListener"
- jinvoke ;
-
-: running-desktop? ( -- )
- this "factor.listener.FactorDesktop" is ;
diff --git a/library/platform/native/arithmetic.factor b/library/platform/native/arithmetic.factor
index e39f8e9586..0506083119 100644
--- a/library/platform/native/arithmetic.factor
+++ b/library/platform/native/arithmetic.factor
@@ -22,3 +22,7 @@ USE: stack
: succ 1 + ; inline
: neg 0 swap - ; inline
+
+!: e 2.7182818284590452354 ; inline
+!: pi 3.14159265358979323846 ; inline
+!: pi/2 1.5707963267948966 ; inline
diff --git a/library/platform/native/errors.factor b/library/platform/native/errors.factor
index 19c08005e4..a6d7facfba 100644
--- a/library/platform/native/errors.factor
+++ b/library/platform/native/errors.factor
@@ -64,6 +64,7 @@ USE: vectors
"Incompatible handle: "
"I/O error: "
"Overflow"
+ "Incomparable types: "
] ?nth ;
: ?kernel-error ( cons -- error# param )
diff --git a/library/platform/native/init.factor b/library/platform/native/init.factor
index e80002f49c..bca2ff0e76 100644
--- a/library/platform/native/init.factor
+++ b/library/platform/native/init.factor
@@ -75,10 +75,6 @@ USE: unparser
init-styles
init-vocab-styles
- print-banner
-
run-user-init
- room.
-
init-interpreter ;
diff --git a/library/platform/native/unparser.factor b/library/platform/native/unparser.factor
index 881b450ea7..27601bed06 100644
--- a/library/platform/native/unparser.factor
+++ b/library/platform/native/unparser.factor
@@ -60,6 +60,9 @@ USE: vocabularies
denominator integer- integer%
%> ;
+: unparse-complex ( num -- str )
+ >rect <% "#{ " % swap unparse % " " % unparse % " }" % %> ;
+
: >base ( num radix -- string )
#! Convert a number to a string in a certain base.
[ "base" set unparse-integer ] bind ;
@@ -113,6 +116,7 @@ USE: vocabularies
[ integer? ] [ unparse-integer ]
[ ratio? ] [ unparse-ratio ]
[ float? ] [ unparse-float ]
+ [ complex? ] [ unparse-complex ]
[ string? ] [ unparse-str ]
[ drop t ] [ <% "#<" % class-of % ">" % %> ]
] cond ;
diff --git a/native/bignum.h b/native/bignum.h
index c9ebf0a221..ed1c4b9eba 100644
--- a/native/bignum.h
+++ b/native/bignum.h
@@ -2,6 +2,10 @@ typedef long long BIGNUM_2;
typedef struct {
CELL header;
+/* FIXME */
+#ifndef FACTOR_64
+ CELL alignment;
+#endif
BIGNUM_2 n;
} BIGNUM;
diff --git a/native/complex.c b/native/complex.c
new file mode 100644
index 0000000000..eb6916d912
--- /dev/null
+++ b/native/complex.c
@@ -0,0 +1,191 @@
+#include "factor.h"
+
+COMPLEX* complex(CELL real, CELL imaginary)
+{
+ COMPLEX* complex = allot(sizeof(COMPLEX));
+ complex->real = real;
+ complex->imaginary = imaginary;
+ return complex;
+}
+
+CELL possibly_complex(CELL real, CELL imaginary)
+{
+ if(zerop(imaginary))
+ return real;
+ else
+ return tag_complex(complex(real,imaginary));
+}
+
+void primitive_complexp(void)
+{
+ check_non_empty(env.dt);
+ env.dt = tag_boolean(typep(COMPLEX_TYPE,env.dt));
+}
+
+void primitive_real(void)
+{
+ switch(type_of(env.dt))
+ {
+ case FIXNUM_TYPE:
+ case BIGNUM_TYPE:
+ case FLOAT_TYPE:
+ case RATIO_TYPE:
+ /* No op */
+ break;
+ case COMPLEX_TYPE:
+ env.dt = untag_complex(env.dt)->real;
+ break;
+ default:
+ type_error(COMPLEX_TYPE,env.dt);
+ break;
+ }
+}
+
+void primitive_imaginary(void)
+{
+ switch(type_of(env.dt))
+ {
+ case FIXNUM_TYPE:
+ case BIGNUM_TYPE:
+ case FLOAT_TYPE:
+ case RATIO_TYPE:
+ env.dt = tag_fixnum(0);
+ break;
+ case COMPLEX_TYPE:
+ env.dt = untag_complex(env.dt)->imaginary;
+ break;
+ default:
+ type_error(COMPLEX_TYPE,env.dt);
+ break;
+ }
+}
+
+void primitive_to_rect(void)
+{
+ COMPLEX* c;
+ switch(type_of(env.dt))
+ {
+ case FIXNUM_TYPE:
+ case BIGNUM_TYPE:
+ case FLOAT_TYPE:
+ case RATIO_TYPE:
+ dpush(env.dt);
+ env.dt = tag_fixnum(0);
+ break;
+ case COMPLEX_TYPE:
+ c = untag_complex(env.dt);
+ env.dt = c->imaginary;
+ dpush(c->real);
+ break;
+ default:
+ type_error(COMPLEX_TYPE,env.dt);
+ break;
+ }
+}
+
+void primitive_from_rect(void)
+{
+ CELL imaginary = env.dt;
+ CELL real = dpop();
+ check_non_empty(imaginary);
+ check_non_empty(real);
+
+ if(!realp(imaginary))
+ type_error(REAL_TYPE,imaginary);
+
+ if(!realp(real))
+ type_error(REAL_TYPE,real);
+
+ env.dt = possibly_complex(real,imaginary);
+}
+
+CELL number_eq_complex(CELL x, CELL y)
+{
+ COMPLEX* cx = (COMPLEX*)UNTAG(x);
+ COMPLEX* cy = (COMPLEX*)UNTAG(y);
+ return tag_boolean(
+ untag_boolean(number_eq(cx->real,cy->real)) &&
+ untag_boolean(number_eq(cx->imaginary,cy->imaginary)));
+}
+
+CELL add_complex(CELL x, CELL y)
+{
+ COMPLEX* cx = (COMPLEX*)UNTAG(x);
+ COMPLEX* cy = (COMPLEX*)UNTAG(y);
+ return possibly_complex(
+ add(cx->real,cy->real),
+ add(cx->imaginary,cy->real));
+}
+
+CELL subtract_complex(CELL x, CELL y)
+{
+ COMPLEX* cx = (COMPLEX*)UNTAG(x);
+ COMPLEX* cy = (COMPLEX*)UNTAG(y);
+ return possibly_complex(
+ subtract(cx->real,cy->real),
+ subtract(cx->imaginary,cy->real));
+}
+
+CELL multiply_complex(CELL x, CELL y)
+{
+ COMPLEX* cx = (COMPLEX*)UNTAG(x);
+ COMPLEX* cy = (COMPLEX*)UNTAG(y);
+ return possibly_complex(
+ subtract(
+ multiply(cx->real,cy->real),
+ multiply(cx->imaginary,cy->imaginary)),
+ add(
+ multiply(cx->real,cy->imaginary),
+ multiply(cx->imaginary,cy->real)));
+}
+
+#define COMPLEX_DIVIDE(x,y) \
+ COMPLEX* cx = (COMPLEX*)UNTAG(x); \
+ COMPLEX* cy = (COMPLEX*)UNTAG(y); \
+\
+ CELL mag = add( \
+ multiply(cy->real,cy->real), \
+ multiply(cy->imaginary,cy->imaginary)); \
+\
+ CELL r = add( \
+ multiply(cx->real,cy->real), \
+ multiply(cx->imaginary,cy->imaginary)); \
+ CELL i = subtract( \
+ multiply(cx->imaginary,cy->real), \
+ multiply(cx->real,cy->imaginary));
+
+CELL divide_complex(CELL x, CELL y)
+{
+ COMPLEX_DIVIDE(x,y);
+ return possibly_complex(divide(r,mag),divide(i,mag));
+}
+
+CELL divfloat_complex(CELL x, CELL y)
+{
+ COMPLEX_DIVIDE(x,y);
+ return possibly_complex(divfloat(r,mag),divfloat(i,mag));
+}
+
+CELL less_complex(CELL x, CELL y)
+{
+ general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
+ return F;
+}
+
+CELL lesseq_complex(CELL x, CELL y)
+{
+ general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
+ return F;
+}
+
+CELL greater_complex(CELL x, CELL y)
+{
+ general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
+ return F;
+}
+
+CELL greatereq_complex(CELL x, CELL y)
+{
+ general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
+ return F;
+}
diff --git a/native/complex.h b/native/complex.h
new file mode 100644
index 0000000000..0a6a4dafac
--- /dev/null
+++ b/native/complex.h
@@ -0,0 +1,34 @@
+typedef struct {
+ CELL real;
+ CELL imaginary;
+} COMPLEX;
+
+INLINE COMPLEX* untag_complex(CELL tagged)
+{
+ type_check(COMPLEX_TYPE,tagged);
+ return (COMPLEX*)UNTAG(tagged);
+}
+
+INLINE CELL tag_complex(RATIO* ratio)
+{
+ return RETAG(ratio,COMPLEX_TYPE);
+}
+
+COMPLEX* complex(CELL real, CELL imaginary);
+CELL possibly_complex(CELL real, CELL imaginary);
+
+void primitive_complexp(void);
+void primitive_real(void);
+void primitive_imaginary(void);
+void primitive_to_rect(void);
+void primitive_from_rect(void);
+CELL number_eq_complex(CELL x, CELL y);
+CELL add_complex(CELL x, CELL y);
+CELL subtract_complex(CELL x, CELL y);
+CELL multiply_complex(CELL x, CELL y);
+CELL divide_complex(CELL x, CELL y);
+CELL divfloat_complex(CELL x, CELL y);
+CELL less_complex(CELL x, CELL y);
+CELL lesseq_complex(CELL x, CELL y);
+CELL greater_complex(CELL x, CELL y);
+CELL greatereq_complex(CELL x, CELL y);
diff --git a/native/error.h b/native/error.h
index 57d3be328b..def830d0d7 100644
--- a/native/error.h
+++ b/native/error.h
@@ -7,6 +7,7 @@
#define ERROR_HANDLE_INCOMPAT (6<<3)
#define ERROR_IO (7<<3)
#define ERROR_OVERFLOW (8<<3)
+#define ERROR_INCOMPARABLE (9<<3)
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
diff --git a/native/float.c b/native/float.c
index 92dbff6b16..5d2a8f1e80 100644
--- a/native/float.c
+++ b/native/float.c
@@ -43,6 +43,11 @@ void primitive_float_to_str(void)
env.dt = tag_object(from_c_string(tmp));
}
+void primitive_float_to_bits(void)
+{
+ /* FIXME */
+}
+
CELL number_eq_float(CELL x, CELL y)
{
return tag_boolean(((FLOAT*)UNTAG(x))->n
diff --git a/native/float.h b/native/float.h
index d4d7ecab91..a001f22577 100644
--- a/native/float.h
+++ b/native/float.h
@@ -1,5 +1,9 @@
typedef struct {
CELL header;
+/* FIXME */
+#ifndef FACTOR_64
+ CELL alignment;
+#endif
double n;
} FLOAT;
@@ -21,6 +25,7 @@ FLOAT* to_float(CELL tagged);
void primitive_to_float(void);
void primitive_str_to_float(void);
void primitive_float_to_str(void);
+void primitive_float_to_bits(void);
CELL number_eq_float(CELL x, CELL y);
CELL add_float(CELL x, CELL y);
CELL subtract_float(CELL x, CELL y);
diff --git a/native/primitives.c b/native/primitives.c
index e963313916..97a61f38ea 100644
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -48,6 +48,7 @@ XT primitives[] = {
primitive_floatp,
primitive_str_to_float,
primitive_float_to_str,
+ primitive_float_to_bits,
primitive_complexp,
primitive_real,
primitive_imaginary,
@@ -112,7 +113,9 @@ XT primitives[] = {
primitive_os_env,
primitive_millis,
primitive_init_random,
- primitive_random_int
+ primitive_random_int,
+ primitive_type_of,
+ primitive_size_of
};
CELL primitive_to_xt(CELL primitive)
diff --git a/native/primitives.h b/native/primitives.h
index 3847b25c06..fd371c7d8b 100644
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
extern XT primitives[];
-#define PRIMITIVE_COUNT 112
+#define PRIMITIVE_COUNT 115
CELL primitive_to_xt(CELL primitive);
diff --git a/native/types.c b/native/types.c
index ec7899abb0..413d1d5564 100644
--- a/native/types.c
+++ b/native/types.c
@@ -64,6 +64,9 @@ CELL object_size(CELL pointer)
switch(TAG(pointer))
{
+ case FIXNUM_TYPE:
+ size = 0;
+ break;
case CONS_TYPE:
size = sizeof(CONS);
break;
@@ -130,3 +133,15 @@ CELL untagged_object_size(CELL pointer)
return align8(size);
}
+
+void primitive_type_of(void)
+{
+ check_non_empty(env.dt);
+ env.dt = tag_fixnum(type_of(env.dt));
+}
+
+void primitive_size_of(void)
+{
+ check_non_empty(env.dt);
+ env.dt = tag_fixnum(object_size(env.dt));
+}
diff --git a/native/types.h b/native/types.h
index 5f12ce5c64..ea33053de2 100644
--- a/native/types.h
+++ b/native/types.h
@@ -87,3 +87,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);