diff --git a/coalton.asd b/coalton.asd index 30a8da1b..debb7847 100644 --- a/coalton.asd +++ b/coalton.asd @@ -64,6 +64,7 @@ (:file "elementary") (:file "dyadic") (:file "dual") + (:file "define-byte-types") (:file "package"))) (:file "randomaccess") (:file "cell") diff --git a/library/boolean.lisp b/library/boolean.lisp index 00964c54..9a1af289 100644 --- a/library/boolean.lisp +++ b/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") diff --git a/library/char.lisp b/library/char.lisp index 650f06a8..ab318c6b 100644 --- a/library/char.lisp +++ b/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") diff --git a/library/hash.lisp b/library/hash.lisp index 561b8dd6..8d2b9604 100644 --- a/library/hash.lisp +++ b/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") diff --git a/library/math/define-byte-types.lisp b/library/math/define-byte-types.lisp new file mode 100644 index 00000000..c453080c --- /dev/null +++ b/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 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 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)))))) diff --git a/library/math/integral.lisp b/library/math/integral.lisp index f418e2b8..0eb90883 100644 --- a/library/math/integral.lisp +++ b/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") diff --git a/library/math/num.lisp b/library/math/num.lisp index 6947e875..8106cca4 100644 --- a/library/math/num.lisp +++ b/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) diff --git a/library/string.lisp b/library/string.lisp index e2e7fb6c..0447702b 100644 --- a/library/string.lisp +++ b/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")