Macros for defining new signed and unsigned byte types

coalton.asd

@@ -64,6 +64,7 @@
                              (:file "elementary")
                              (:file "dyadic")
                              (:file "dual")
+                             (:file "define-byte-types")
                              (:file "package")))
                (:file "randomaccess")
                (:file "cell")

library/boolean.lisp

@@ -36,9 +36,9 @@
            ((False) EQ))))))
 
   (define-instance (Default Boolean)
-    (define (default) False)))
+    (define (default) False))
 
-(define-sxhash-hasher Boolean)
+  (define-sxhash-hasher Boolean))
 
 #+sb-package-locks
 (sb-ext:lock-package "COALTON-LIBRARY/BOOLEAN")

library/char.lisp

@@ -145,9 +145,9 @@
      (iter:range-increasing
       1
       (char-code start)
-      (+ 1 (char-code end))))))
+      (+ 1 (char-code end)))))
 
-(define-sxhash-hasher Char)
+  (define-sxhash-hasher Char))
 
 #+sb-package-locks
 (sb-ext:lock-package "COALTON-LIBRARY/CHAR")

library/hash.lisp

@@ -88,14 +88,15 @@ The hash function must satisfy the invariant that `(== left right)` implies `(==
       (lisp Hash ()
         0))))
 
-(cl:defmacro define-sxhash-hasher (type)
-  `(coalton-toplevel
-     (define-instance (Hash ,type)
+(cl:eval-when (:compile-toplevel :load-toplevel)
+  (cl:defmacro define-sxhash-hasher (type)
+    `(define-instance (Hash ,type)
        (define (hash item)
          (lisp Hash (item)
            (cl:sxhash item))))))
 
-(define-sxhash-hasher Hash)
+(coalton-toplevel
+  (define-sxhash-hasher Hash))
 
 #+sb-package-locks
 (sb-ext:lock-package "COALTON-LIBRARY/HASH")

library/math/define-byte-types.lisp

@@ -0,0 +1,70 @@
+(coalton-library/utils:defstdlib-package #:coalton-library/math/define-byte-types
+  (:use
+   #:coalton
+   #:coalton-library/classes)
+  (:import-from
+   #:coalton-library/hash
+   #:define-sxhash-hasher)
+  (:local-nicknames
+   (#:num #:coalton-library/math/num)
+   (#:integral #:coalton-library/math/integral))
+  (:export
+   #:define-signed-byte-type
+   #:define-unsigned-byte-type))
+
+(in-package #:coalton-library/math/define-byte-types)
+
+(named-readtables:in-readtable coalton:coalton)
+
+(cl:eval-when (:compile-toplevel :load-toplevel)
+  (cl:defmacro define-unsigned-byte-type (byte-size)
+    "This macro defines an unsigned byte type of a given size.
+
+The class instances included are:
+(Into <type> Integer), Eq, Ord, Num, Bits, Default, Hash, Integral.
+
+Any conversion instances besides to or from Integer must be handled manually."
+
+    (cl:let ((type (cl:intern (cl:format cl:nil "U~D" byte-size))))
+      `(coalton-toplevel
+         (repr :native (cl:unsigned-byte ,byte-size))
+         (define-type ,type)
+         (define-instance (Into ,type Integer)
+           (define (into x)
+             (lisp Integer (x)
+               x)))
+         (num::define-eq ,type)
+         (num::define-ord ,type)
+         (num::define-num-wrapping ,type ,byte-size)
+         (num::define-bits-wrapping ,type ,byte-size)
+         (num::define-default-num ,type)
+         (num::define-sxhash-hasher ,type)
+         (integral::%define-integral-native ,type cl:nil)))))
+
+(cl:eval-when (:compile-toplevel :load-toplevel)
+  (cl:defmacro define-signed-byte-type (byte-size)
+    "This macro defines a signed byte type of a given size.
+
+The class instances included are:
+(Into <type> Integer), Eq, Ord, Num, Bits, Default, Hash, Integral.
+
+Any conversion instances besides to or from Integer must be handled manually."
+    (cl:let ((type (cl:intern (cl:format cl:nil "I~D" byte-size)))
+             (handler-name (cl:intern (cl:format cl:nil "%handle-~abit-overflow" byte-size))))
+      `(cl:progn
+         (num::%define-overflow-handler ,handler-name ,byte-size)
+         (coalton-toplevel
+           (repr :native (cl:signed-byte ,byte-size))
+           (define-type ,type)
+           (define-instance (Into ,type Integer)
+             (define (into x)
+               (lisp Integer (x)
+                 x)))
+           (num::define-eq ,type)
+           (num::define-ord ,type)
+
+           (num::define-num-checked ,type ,handler-name)
+           (num::define-bits-checked ,type ,handler-name)
+           (num::define-default-num ,type)
+           (num::define-sxhash-hasher ,type)
+           (integral::%define-integral-native ,type cl:nil))))))

library/math/integral.lisp

@@ -180,8 +180,7 @@ are floored and truncated division, respectively."
         (True (error "Cannot take ISQRT of a negative number."))))))
 
 (cl:defmacro %define-remainder-native (type)
-  `(coalton-toplevel
-     (define-instance (Remainder ,type)
+  `(define-instance (Remainder ,type)
        (define (quot a n)
          (lisp ,type (a n)
            (cl:nth-value 0 (cl:truncate a n))))
@@ -197,7 +196,7 @@ are floored and truncated division, respectively."
            (cl:nth-value 0 (cl:floor a n))))
        (define (divMod a n)
          (lisp (Tuple ,type ,type) (a n)
-           (cl:multiple-value-call 'Tuple (cl:floor a n)))))))
+           (cl:multiple-value-call 'Tuple (cl:floor a n))))))
 
 (cl:defmacro %define-integral-native (type signed)
   (cl:let ((even? (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-EVEN?")))
@@ -206,85 +205,84 @@ are floored and truncated division, respectively."
            (^ (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-^")))
            (lcm (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-LCM")))
            (isqrt (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-ISQRT"))))
-    `(cl:progn 
+    `(progn
        (%define-remainder-native ,type)
-
-       (coalton-toplevel
-        (define-instance (Integral ,type)
-          (define toInteger into))
-
-        (specialize even? ,even? (,type -> Boolean))
-        (declare ,even? (,type -> Boolean))
-        (define (,even? n)
-          (lisp Boolean (n) (to-boolean (cl:evenp n))))
-
-        (specialize odd? ,odd? (,type -> Boolean))
-        (declare ,odd? (,type -> Boolean))
-        (define (,odd? n)
-          (lisp Boolean (n) (to-boolean (cl:oddp n))))
-
-        (specialize ^ ,^ (,type -> ,type -> ,type))
-        (declare ,^ (,type -> ,type -> ,type))
-        (define (,^ base power)
-          ,(cl:if signed
-                  `(if (< power 0)
-                        (error "Can't exponentiate with a negative exponent.")
-                        (lisp ,type (base power) (cl:expt base power)))
-                  `(lisp ,type (base power) (cl:expt base power))))
-
-        (specialize gcd ,gcd (,type -> ,type -> ,type))
-        (declare ,gcd (,type -> ,type -> ,type))
-        (define (,gcd a b)
-          (lisp ,type (a b) (cl:gcd a b)))
-
-        (specialize lcm ,lcm (,type -> ,type -> ,type))
-        (declare ,lcm (,type -> ,type -> ,type))
-        (define (,lcm a b)
-          ;; Allow Coalton to handle fixnum overflow
-          (fromInt (lisp Integer (a b) (cl:lcm a b))))
-
-        (specialize isqrt ,isqrt (,type -> ,type))
-        (declare ,isqrt (,type -> ,type))
-        (define (,isqrt a)
-          ,(cl:if signed
-                  `(if (< a 0)
-                        (error "Can't take ISQRT of a negative number.")
-                        (lisp ,type (a) (cl:isqrt a)))
-                  `(lisp ,type (a) (cl:isqrt a))))))))
-
-(%define-integral-native Integer cl:t)
-(%define-integral-native I8 cl:t)
-(%define-integral-native I16 cl:t)
-(%define-integral-native I32 cl:t)
-(%define-integral-native I64 cl:t)
-(%define-integral-native IFix cl:t)
-(%define-integral-native U8 cl:nil)
-(%define-integral-native U16 cl:nil)
-(%define-integral-native U32 cl:nil)
-(%define-integral-native U64 cl:nil)
-(%define-integral-native UFix cl:nil)
-(%define-remainder-native Fraction)
+       (define-instance (Integral ,type)
+         (define toInteger into))
+
+       (specialize even? ,even? (,type -> Boolean))
+       (declare ,even? (,type -> Boolean))
+       (define (,even? n)
+         (lisp Boolean (n) (to-boolean (cl:evenp n))))
+
+       (specialize odd? ,odd? (,type -> Boolean))
+       (declare ,odd? (,type -> Boolean))
+       (define (,odd? n)
+         (lisp Boolean (n) (to-boolean (cl:oddp n))))
+
+       (specialize ^ ,^ (,type -> ,type -> ,type))
+       (declare ,^ (,type -> ,type -> ,type))
+       (define (,^ base power)
+         ,(cl:if signed
+                 `(if (< power 0)
+                      (error "Can't exponentiate with a negative exponent.")
+                      (lisp ,type (base power) (cl:expt base power)))
+                 `(lisp ,type (base power) (cl:expt base power))))
+
+       (specialize gcd ,gcd (,type -> ,type -> ,type))
+       (declare ,gcd (,type -> ,type -> ,type))
+       (define (,gcd a b)
+         (lisp ,type (a b) (cl:gcd a b)))
+
+       (specialize lcm ,lcm (,type -> ,type -> ,type))
+       (declare ,lcm (,type -> ,type -> ,type))
+       (define (,lcm a b)
+         ;; Allow Coalton to handle fixnum overflow
+         (fromInt (lisp Integer (a b) (cl:lcm a b))))
+
+       (specialize isqrt ,isqrt (,type -> ,type))
+       (declare ,isqrt (,type -> ,type))
+       (define (,isqrt a)
+         ,(cl:if signed
+                 `(if (< a 0)
+                      (error "Can't take ISQRT of a negative number.")
+                      (lisp ,type (a) (cl:isqrt a)))
+                 `(lisp ,type (a) (cl:isqrt a)))))))
+
+(coalton-toplevel
+  (%define-integral-native Integer cl:t)
+  (%define-integral-native I8 cl:t)
+  (%define-integral-native I16 cl:t)
+  (%define-integral-native I32 cl:t)
+  (%define-integral-native I64 cl:t)
+  (%define-integral-native IFix cl:t)
+  (%define-integral-native U8 cl:nil)
+  (%define-integral-native U16 cl:nil)
+  (%define-integral-native U32 cl:nil)
+  (%define-integral-native U64 cl:nil)
+  (%define-integral-native UFix cl:nil)
+  (%define-remainder-native Fraction))
 
 (cl:defmacro %define-native-expt (type)
   (cl:let ((^ (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-^")))
            (^^ (cl:intern (cl:concatenate 'cl:string (cl:symbol-name type) "-^^"))))
 
-    `(coalton-toplevel
-       (specialize ^ ,^ (,type -> Integer -> ,type))
-       (declare ,^ (,type -> Integer -> ,type))
-       (define (,^ base power)
-         (if (< power 0)
-             (error "Can't exponentiate with a negative exponent.")
-             (lisp ,type (base power) (cl:expt base power))))
-
-       (specialize ^^ ,^^ (,type -> Integer -> ,type))
-       (declare ,^^ (,type -> Integer -> ,type))
-       (define (,^^ base power)
-         (lisp ,type (base power) (cl:expt base power))))))
-
-(%define-native-expt Fraction)
-(%define-native-expt Single-Float)
-(%define-native-expt Double-Float)
+    `(progn (specialize ^ ,^ (,type -> Integer -> ,type))
+            (declare ,^ (,type -> Integer -> ,type))
+            (define (,^ base power)
+              (if (< power 0)
+                  (error "Can't exponentiate with a negative exponent.")
+                  (lisp ,type (base power) (cl:expt base power))))
+
+            (specialize ^^ ,^^ (,type -> Integer -> ,type))
+            (declare ,^^ (,type -> Integer -> ,type))
+            (define (,^^ base power)
+              (lisp ,type (base power) (cl:expt base power))))))
+
+(coalton-toplevel
+  (%define-native-expt Fraction)
+  (%define-native-expt Single-Float)
+  (%define-native-expt Double-Float))
 
 #+sb-package-locks
 (sb-ext:lock-package "COALTON-LIBRARY/MATH/INTEGRAL")

library/math/num.lisp

@@ -142,8 +142,8 @@
       ;; This is the two's complement conversion of X (interpreted as BITS
       ;; bits) to a signed integer (as a Lisp object).
       (cl:-
-       (cl:ldb (cl:byte (cl:1- bits) 0) x)
-       (cl:dpb 0 (cl:byte (cl:1- bits) 0) x)))
+          (cl:ldb (cl:byte (cl:1- bits) 0) x)
+          (cl:dpb 0 (cl:byte (cl:1- bits) 0) x)))
 
     (cl:defmacro %define-overflow-handler (name bits)
       `(cl:progn
@@ -445,29 +445,27 @@
   (define-bits-wrapping U64 64)
   (define-bits-wrapping UFix #.+unsigned-fixnum-bits+)
 
-
-  (lisp-toplevel ()
-
 ;;; `Hash' instances
 
-    (define-sxhash-hasher Integer)
-    (define-sxhash-hasher I8)
-    (define-sxhash-hasher I16)
-    (define-sxhash-hasher I32)
-    (define-sxhash-hasher I64)
-    (define-sxhash-hasher U8)
-    (define-sxhash-hasher U16)
-    (define-sxhash-hasher U32)
-    (define-sxhash-hasher U64)
-    (define-sxhash-hasher IFix)
-    (define-sxhash-hasher UFix)
-    (define-sxhash-hasher Single-Float)
-    (define-sxhash-hasher Double-Float)
+  (define-sxhash-hasher Integer)
+  (define-sxhash-hasher I8)
+  (define-sxhash-hasher I16)
+  (define-sxhash-hasher I32)
+  (define-sxhash-hasher I64)
+  (define-sxhash-hasher U8)
+  (define-sxhash-hasher U16)
+  (define-sxhash-hasher U32)
+  (define-sxhash-hasher U64)
+  (define-sxhash-hasher IFix)
+  (define-sxhash-hasher UFix)
+  (define-sxhash-hasher Single-Float)
+  (define-sxhash-hasher Double-Float)
 
 ;;;
 ;;; Default instances
 ;;;
 
+  (lisp-toplevel ()
     (cl:eval-when (:compile-toplevel :load-toplevel)
       (cl:defmacro define-default-num (type)
         `(define-instance (Default ,type)

library/string.lisp

@@ -234,9 +234,11 @@ does not have that suffix."
                  (Ok z))))))
 
   (define-instance (Default String)
-    (define (default) "")))
+    (define (default) ""))
+
+  (define-sxhash-hasher String))
+
 
-(define-sxhash-hasher String)
 
 #+sb-package-locks
 (sb-ext:lock-package "COALTON-LIBRARY/STRING")