From 0b73b1c864ee9c71e7a850c0a259d54818e04b10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Aug 2004 06:51:32 +0000 Subject: [PATCH] Factor jEdit plugin! --- TODO.FACTOR.txt | 20 ++- build.sh | 2 +- build.xml | 17 +- factor/jedit/FactorPlugin.java | 53 ++++++ factor/jedit/FactorPlugin.props | 21 +++ factor/listener/FactorDesktop.java | 123 +------------- factor/listener/FactorListenerPanel.java | 133 +++++++++++++++ library/cross-compiler.factor | 5 + library/image.factor | 49 +++++- library/init.factor | 2 + library/platform/jvm/arithmetic.factor | 5 + library/platform/jvm/init.factor | 1 - library/platform/jvm/listener.factor | 22 +-- library/platform/native/arithmetic.factor | 4 + library/platform/native/errors.factor | 1 + library/platform/native/init.factor | 4 - library/platform/native/unparser.factor | 4 + native/bignum.h | 4 + native/complex.c | 191 ++++++++++++++++++++++ native/complex.h | 34 ++++ native/error.h | 1 + native/float.c | 5 + native/float.h | 5 + native/primitives.c | 5 +- native/primitives.h | 2 +- native/types.c | 15 ++ native/types.h | 2 + 27 files changed, 567 insertions(+), 163 deletions(-) create mode 100644 factor/jedit/FactorPlugin.java create mode 100644 factor/jedit/FactorPlugin.props create mode 100644 factor/listener/FactorListenerPanel.java create mode 100644 native/complex.c create mode 100644 native/complex.h 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); -- 2.34.1