add quotient, reciprocal, <division-by-zero>

arvyy · Apr 22, 2024 · 9f9e044 · 9f9e044
1 parent b8baf8f
commit 9f9e044
Show file tree

Hide file tree

Showing 8 changed files with 197 additions and 6 deletions.
diff --git a/language/src/main/java/com/github/arvyy/islisp/ISLISPContext.java b/language/src/main/java/com/github/arvyy/islisp/ISLISPContext.java
@@ -192,6 +192,7 @@ void initGlobalFunctions() {
         initGlobalFunction("preview-char", ISLISPPreviewChar::makeLispFunction);
         initGlobalFunction("probe-file", ISLISPProbeFile::makeLispFunction);
         initGlobalFunction("property", ISLISPProperty::makeLispFunction);
+        initGlobalFunction("quotient", ISLISPQuotient::makeLispFunction);
         initGlobalFunction("read", ISLISPRead::makeLispFunction);
         initGlobalFunction("read-byte", ISLISPReadByte::makeLispFunction);
         initGlobalFunction("read-char", ISLISPReadChar::makeLispFunction);

diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPQuotient.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPQuotient.java
@@ -0,0 +1,111 @@
+package com.github.arvyy.islisp.functions;
+
+import com.github.arvyy.islisp.ISLISPContext;
+import com.github.arvyy.islisp.exceptions.ISLISPError;
+import com.github.arvyy.islisp.nodes.ISLISPErrorSignalerNode;
+import com.github.arvyy.islisp.nodes.ISLISPTypes;
+import com.github.arvyy.islisp.runtime.LispBigInteger;
+import com.github.arvyy.islisp.runtime.LispFunction;
+import com.oracle.truffle.api.CompilerDirectives;
+import com.oracle.truffle.api.TruffleLanguage;
+import com.oracle.truffle.api.dsl.Fallback;
+import com.oracle.truffle.api.dsl.Specialization;
+import com.oracle.truffle.api.dsl.TypeSystemReference;
+import com.oracle.truffle.api.frame.VirtualFrame;
+import com.oracle.truffle.api.nodes.ExplodeLoop;
+import com.oracle.truffle.api.nodes.RootNode;
+
+import java.math.BigDecimal;
+
+/**
+ * Implements numeric division function `quotient`.
+ */
+@TypeSystemReference(ISLISPTypes.class)
+public abstract class ISLISPQuotient extends RootNode {
+
+    @Child
+    private ISLISPErrorSignalerNode errorSignalerNode;
+
+    ISLISPQuotient(TruffleLanguage<?> language) {
+        super(language);
+        errorSignalerNode = new ISLISPErrorSignalerNode(this);
+    }
+
+    abstract Object executeGeneric(Object a, Object b);
+
+    @Override
+    @ExplodeLoop
+    public final Object execute(VirtualFrame frame) {
+        if (frame.getArguments().length < 2) {
+            return errorSignalerNode.signalWrongArgumentCount(frame.getArguments().length - 1, 2, -1);
+        }
+        Object result = frame.getArguments()[1];
+        for (int i = 2; i < frame.getArguments().length; i++) {
+            result = executeGeneric(result, frame.getArguments()[i]);
+        }
+        return result;
+    }
+
+    @Specialization
+    Object doInts(int a, int b) {
+        try {
+            int result = a / b;
+            if (a % b == 0) {
+                return result;
+            } else {
+                return ((double) a) / b;
+            }
+        } catch (ArithmeticException e) {
+            return handleArithmeticException(e, b == 0);
+        }
+    }
+
+    @Specialization
+    @CompilerDirectives.TruffleBoundary
+    Object doBigInts(LispBigInteger a, LispBigInteger b) {
+        try {
+            var result = a.data().divideAndRemainder(b.data());
+            if (result[1].signum() == 0) {
+                return new LispBigInteger(result[0]);
+            } else {
+                return new BigDecimal(a.data()).divide(new BigDecimal(b.data())).doubleValue();
+            }
+        } catch (ArithmeticException e) {
+            return handleArithmeticException(e, b.data().signum() == 0);
+        }
+    }
+
+    @Specialization
+    Object doDoubles(double a, double b) {
+        if (b == 0) {
+            return errorSignalerNode.signalDivisionByZero();
+        }
+        return a / b;
+    }
+
+    @CompilerDirectives.TruffleBoundary
+    Object handleArithmeticException(ArithmeticException e, boolean divisorIsZero) {
+        if (divisorIsZero) {
+            return errorSignalerNode.signalDivisionByZero();
+        } else {
+            throw new ISLISPError(e.getMessage(), this);
+        }
+    }
+
+    @Fallback
+    Object notNumbers(Object a, Object b) {
+        var ctx = ISLISPContext.get(this);
+        var numberClass = ctx.lookupClass("<number>");
+        return errorSignalerNode.signalWrongType(b, numberClass);
+    }
+
+    /**
+     * Construct LispFunction using this root node.
+     * @param lang truffle language reference
+     * @return lisp function
+     */
+    public static LispFunction makeLispFunction(TruffleLanguage<?> lang) {
+        return new LispFunction(ISLISPQuotientNodeGen.create(lang).getCallTarget());
+    }
+
+}
diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSubtract.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSubtract.java
@@ -1,23 +1,32 @@
 package com.github.arvyy.islisp.functions;
 
-import com.github.arvyy.islisp.exceptions.ISLISPError;
+import com.github.arvyy.islisp.ISLISPContext;
+import com.github.arvyy.islisp.nodes.ISLISPErrorSignalerNode;
+import com.github.arvyy.islisp.nodes.ISLISPTypes;
 import com.github.arvyy.islisp.runtime.LispBigInteger;
 import com.github.arvyy.islisp.runtime.LispFunction;
 import com.oracle.truffle.api.CompilerDirectives;
 import com.oracle.truffle.api.TruffleLanguage;
 import com.oracle.truffle.api.dsl.Fallback;
 import com.oracle.truffle.api.dsl.Specialization;
+import com.oracle.truffle.api.dsl.TypeSystemReference;
 import com.oracle.truffle.api.frame.VirtualFrame;
 import com.oracle.truffle.api.nodes.ExplodeLoop;
 import com.oracle.truffle.api.nodes.RootNode;
 
 /**
  * Implements numeric subtraction function `-`.
  */
+@TypeSystemReference(ISLISPTypes.class)
 public abstract class ISLISPSubtract extends RootNode {
 
+
+    @Child
+    private ISLISPErrorSignalerNode errorSignalerNode;
+
     ISLISPSubtract(TruffleLanguage<?> language) {
         super(language);
+        errorSignalerNode = new ISLISPErrorSignalerNode(this);
     }
 
     abstract Object executeGeneric(Object a, Object b);
@@ -53,7 +62,9 @@ LispBigInteger doBigInts(LispBigInteger a, LispBigInteger b) {
 
     @Fallback
     Object notNumbers(Object a, Object b) {
-        throw new ISLISPError("Not numbers", this);
+        var ctx = ISLISPContext.get(this);
+        var numberClass = ctx.lookupClass("<number>");
+        return errorSignalerNode.signalWrongType(b, numberClass);
     }
 
     /**

diff --git a/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPErrorSignalerNode.java b/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPErrorSignalerNode.java
@@ -182,4 +182,18 @@ public Object signalEndOfStream() {
         );
         return getSignalCallNode().call(null, condition, ctx.getNil());
     }
+
+    /**
+     * Signal division by zero.
+     *
+     * @return undefined object, value of which shouldn't be relied upon.
+     */
+    public Object signalDivisionByZero() {
+        var ctx = ISLISPContext.get(this);
+        var condition = getCreateCallNode().call(
+            null,
+            ctx.lookupClass("ROOT", ctx.namedSymbol("<division-by-zero>").identityReference())
+        );
+        return getSignalCallNode().call(null, condition, ctx.getNil());
+    }
 }
diff --git a/language/src/main/resources/islispprelude.lisp b/language/src/main/resources/islispprelude.lisp
@@ -26,6 +26,11 @@
 
 (defclass <error> (<serious-condition>) ())
 
+(defclass <arithmetic-error> (<error>) ())
+(defclass <division-by-zero> (<arithmetic-error>) ())
+(defclass <floating-point-overflow> (<arithmetic-error>) ())
+(defclass <floating-point-underflow> (<arithmetic-error>) ())
+
 (defclass <stream-error> (<error>) ())
 
 (defclass <end-of-stream> (<stream-error>) ())
@@ -86,6 +91,11 @@
     (format-char stream #\newline)
     (call-next-method))
 
+(defmethod report-condition ((condition <division-by-zero>) (stream <stream>))
+    (format-object stream "Division by zero" nil)
+    (format-char stream #\newline)
+    (call-next-method))
+
 (defun min (first :rest xs)
   (for ((value first (let ((x (car xs)))
                        (if (< x value)
@@ -102,6 +112,9 @@
         (xs xs (cdr xs)))
        ((null xs) value)))
 
+(defun reciprocal (arg)
+  (quotient 1.0 arg))
+
 (defun /= (x1 x2)
   (not (= x1 x2)))
 
@@ -265,4 +278,4 @@
 
 (define-with-file-macro with-open-input-file open-input-file)
 (define-with-file-macro with-open-output-file open-output-file)
-(define-with-file-macro with-open-io-file open-io-file)
+(define-with-file-macro with-open-io-file open-io-file)
diff --git a/tests/nonportable/stacktrace.expect.txt b/tests/nonportable/stacktrace.expect.txt
@@ -1,4 +1,7 @@
 Unbound variable: unbound-var
-	at stacktrace.lisp:10
-	at stacktrace.lisp:7
-	at stacktrace.lisp:17
+	at stacktrace.lisp:11
+	at stacktrace.lisp:8
+	at stacktrace.lisp:18
+
+Division by zero
+	at stacktrace.lisp:28
diff --git a/tests/nonportable/stacktrace.lisp b/tests/nonportable/stacktrace.lisp
@@ -2,6 +2,7 @@
     (format-object (standard-output) str nil)
     (format-char (standard-output) #\newline))
 
+;;;;; undefined variable
 (defun f1 ()
     (+ 1
        (f2)))
@@ -16,4 +17,15 @@
             (return-from exit nil))
         (f1)
         (print "FAIL")))
+(print "")
+
+;;;;;;; division by zero
+(block exit
+    (with-handler
+        (lambda (condition)
+            (report-condition condition (standard-output))
+            (return-from exit nil))
+        (quotient 1 0)
+        (print "FAIL")))
+
 (finish-output (standard-output))
diff --git a/tests/portable/number.lisp b/tests/portable/number.lisp
@@ -35,6 +35,15 @@
       (+ 1 "2")
       (test-equal nil t)))
 
+;; subtraction
+(test-equal (- 1) -1)
+(test-equal (- -4.0) 4.0)
+(test-equal (- 4.0) -4.0)
+(test-equal (- 1 2) -1)
+(test-equal (- 92 43) 49)
+(test-equal (- 0.0 0.0) 0.0)
+(test-equal (- 3 4 5) -6)
+
 ;; multiplication; tests taken from spec
 (test-equal
   (* 12 3)
@@ -56,6 +65,23 @@
   (*)
   1)
 
+;; division / reciprocal
+(test-equal (reciprocal 2) 0.5)
+(test-equal (quotient 10 5) 2)
+(test-equal (quotient 1 2) 0.5)
+(test-equal (quotient 2 -0.5) -4.0)
+(test-equal (quotient 2 4 8) 0.0625)
+(block exit
+    (with-handler
+      (lambda (condition)
+        (test-equal
+            (instancep condition (class <division-by-zero>))
+            t)
+        (return-from exit nil))
+      (quotient 0.0 0.0)
+      (test-equal nil t)))
+
+
 ;; trigonometry
 (test-equal
     (and (> (sin 1) 0.841)