Add a new macro, define-scheme-type

Author: Aethaeryn

scheme-core.lisp

@@ -69,8 +69,8 @@ rules provided in the r7rs-small specification.
 "
   (typecase x
     (symbol (typecase y (symbol (%symbol= x y))))
-    (inexact (typecase y (inexact (= x y))))
-    (exact (typecase y (exact (= x y))))
+    (inexact? (typecase y (inexact? (= x y))))
+    (exact? (typecase y (exact? (= x y))))
     (character (typecase y (character (char= x y))))
     (t (eq x y))))
 

scheme-types.lisp

@@ -2,70 +2,68 @@
 
 (in-package #:airship-scheme)
 
-;;;; Type Definitions
-
-(deftype exact ()
+;;;; Define type definitions
+
+;;; TODO: The define-scheme-predicate could go here, too
+(defmacro define-scheme-type ((name &rest lambda-list) &body body)
+  (let ((docstring (if (and (stringp (car body)) (cdr body))
+                       (list (car body))
+                       nil)))
+    `(progn
+       (deftype ,name ,lambda-list
+         ,@body)
+       (define-function (,name :inline t) (object)
+         ,@docstring
+         (and (typep object ',name) t)))))
+
+;;;; Type definitions
+
+(define-scheme-type (exact?)
   "An exact number might be real or complex, but is not a float."
   `(or rational (complex rational)))
 
-(deftype exact-integer ()
-  "An exact-integer in Scheme is just a CL integer."
+(define-scheme-type (exact-integer?)
+  "An exact integer in Scheme is just a CL integer."
   `integer)
 
-(deftype inexact ()
+(define-scheme-type (inexact?)
   "An inexact number is just a float, real or complex."
   `(or float (complex float)))
 
-(deftype flonum ()
+(define-scheme-type (flonum?)
   "A Scheme flonum is just a double-float."
   'double-float)
 
-(deftype scheme-boolean ()
+(define-scheme-type (boolean?)
   "
 The two symbols that represent a Scheme Boolean, which externally are
 known as #t or #f
 "
   `(or (eql t) (eql %scheme-boolean:f)))
 
-(deftype scheme-vector ()
+(define-scheme-type (vector?)
   "A Scheme vector is just a T vector"
   `simple-vector)
 
-(deftype scheme-string ()
+(define-scheme-type (string?)
   "A Scheme string is just a simple string."
   'simple-string)
 
-(deftype bytevector ()
+(define-scheme-type (bytevector?)
   "A Scheme bytevector is just an octet vector"
   `(simple-array octet (*)))
 
-;;;; Type Predicates
-
-(define-function (exactp :inline t) (number)
-  "Tests if a number is exact"
-  (and (typep number 'exact) t))
-
-(define-function (inexactp :inline t) (number)
-  "Tests if a number is inexact"
-  (and (typep number 'inexact) t))
-
-(define-function (scheme-boolean-p :inline t) (object)
-  "Tests if an object is either a Scheme #t or a Scheme #f"
-  (and (typep object 'scheme-boolean) t))
-
-(define-function (scheme-symbol-p :inline t) (object)
+(define-scheme-type (symbol?)
   "Tests if an object is a Scheme symbol"
-  (and object
-       (symbolp object)
-       (not (scheme-boolean-p object))))
+  `(and symbol (not null) (not boolean?)))
 
 ;;;; Type Conversion
 
 (define-function (inexact :inline t) ((z number))
   "Converts a number to a Scheme inexact."
   (etypecase z
-    ((and complex exact) (coerce z '(complex double-float)))
-    (exact (coerce z 'double-float))
+    ((and complex exact?) (coerce z '(complex double-float)))
+    (exact? (coerce z 'double-float))
     (number z)))
 
 ;;; Note: This uses rationalize. cl:rationalize is not the same thing
@@ -75,7 +73,7 @@ known as #t or #f
 (define-function (exact :inline t) ((z number))
   "Converts a number to a Scheme exact."
   (etypecase z
-    ((and complex inexact) (complex (rationalize (realpart z))
+    ((and complex inexact?) (complex (rationalize (realpart z))
                                     (rationalize (imagpart z))))
-    (inexact (rationalize z))
+    (inexact? (rationalize z))
     (number z)))

standard-procedures.lisp

@@ -60,13 +60,13 @@
       (and (numberp obj) (zerop (nth-value 1 (round obj))))))
 
 (define-scheme-predicate (exact? z)
-  (exactp z))
+  (exact? z))
 
 (define-scheme-predicate (inexact? z)
-  (inexactp z))
+  (inexact? z))
 
 (define-scheme-predicate (exact-integer? z)
-  (integerp z))
+  (exact-integer? z))
 
 (define-scheme-predicate (finite? z)
   (finitep z))
@@ -276,7 +276,7 @@
   (eq obj '%scheme-boolean:f))
 
 (define-scheme-predicate (boolean? obj)
-  (scheme-boolean-p obj))
+  (boolean? obj))
 
 (define-scheme-predicate (boolean=? . booleans)
   (cond ((null booleans) t)
@@ -398,7 +398,7 @@
 ;;;; 6.5 Symbols
 
 (define-scheme-predicate (symbol? obj)
-  (scheme-symbol-p obj))
+  (symbol? obj))
 
 (define-scheme-predicate (symbol=? . symbols)
   (apply #'symbol= symbols))
@@ -480,7 +480,7 @@
 ;;;; 6.7 Strings
 
 (define-scheme-predicate (string? obj)
-  (typep obj 'scheme-string))
+  (string? obj))
 
 (define-scheme-procedure (make-string k &optional (char #.(code-char 0)))
   (make-string k :initial-element char))
@@ -561,7 +561,7 @@
 ;;;; 6.8 Vectors
 
 (define-scheme-predicate (vector? obj)
-  (typep obj 'scheme-vector))
+  (vector? obj))
 
 (define-scheme-procedure (make-vector k &optional (fill nil))
   (make-array k :initial-element fill))
@@ -570,7 +570,7 @@
   (apply #'vector obj))
 
 (define-scheme-procedure (vector-length vector)
-  (check-type vector scheme-vector)
+  (check-type vector vector?)
   (length vector))
 
 (define-scheme-procedure (vector-ref vector k)
@@ -580,39 +580,39 @@
   (setf (svref vector k) obj))
 
 (define-scheme-procedure (vector->list vector &optional start end)
-  (check-type vector scheme-vector)
+  (check-type vector vector?)
   (coerce-subseq vector 'list start end))
 
 (define-scheme-procedure (list->vector list)
-  (coerce list 'scheme-vector))
+  (coerce list 'vector?))
 
 (define-scheme-procedure (vector->string vector &optional start end)
-  (check-type vector scheme-vector)
+  (check-type vector vector?)
   (coerce-subseq vector 'string start end))
 
 (define-scheme-procedure (string->vector string &optional start end)
   (coerce-subseq string 'scheme-vector start end))
 
 (define-scheme-procedure (vector-copy vector &optional start end)
-  (check-type vector scheme-vector)
+  (check-type vector vector?)
   (copy-seq-or-subseq vector start end))
 
 (define-scheme-procedure (vector-copy! to at from &optional (start 0) end)
-  (check-type to scheme-vector)
-  (check-type from scheme-vector)
+  (check-type to vector?)
+  (check-type from vector?)
   (replace to from :start1 at :start2 start :end2 end))
 
 (define-scheme-procedure (vector-append . vector)
   (apply #'concatenate 'simple-vector vector))
 
 (define-scheme-procedure (vector-fill! vector fill &optional (start 0) end)
-  (check-type vector scheme-vector)
+  (check-type vector vector?)
   (fill vector fill :start start :end end))
 
 ;;;; 6.9 Bytevectors
 
 (define-scheme-predicate (bytevector? obj)
-  (typep obj 'bytevector))
+  (bytevector? obj))
 
 (define-scheme-procedure (make-bytevector k &optional (byte 0))
   (make-array k :element-type 'octet :initial-element byte))
@@ -621,31 +621,31 @@
   (make-array (length byte) :element-type 'octet :initial-contents byte))
 
 (define-scheme-procedure (bytevector-length bytevector)
-  (check-type bytevector bytevector)
+  (check-type bytevector bytevector?)
   (length bytevector))
 
 (define-scheme-procedure (bytevector-u8-ref bytevector k)
-  (check-type bytevector bytevector)
+  (check-type bytevector bytevector?)
   (aref bytevector k))
 
 (define-scheme-procedure (bytevector-u8-set! bytevector k byte)
-  (check-type bytevector bytevector)
+  (check-type bytevector bytevector?)
   (setf (aref bytevector k) byte))
 
 (define-scheme-procedure (bytevector-copy bytevector &optional start end)
-  (check-type bytevector bytevector)
+  (check-type bytevector bytevector?)
   (copy-seq-or-subseq bytevector start end))
 
 (define-scheme-procedure (bytevector-copy! to at from &optional start end)
-  (check-type to bytevector)
-  (check-type from bytevector)
+  (check-type to bytevector?)
+  (check-type from bytevector?)
   (replace to from :start1 at :start2 start :end2 end))
 
 (define-scheme-procedure (bytevector-append . bytevector)
   (apply #'concatenate 'bytevector bytevector))
 
 (define-scheme-procedure (utf8->string bytevector &optional (start 0) end)
-  (check-type bytevector bytevector)
+  (check-type bytevector bytevector?)
   (utf8-to-string bytevector :start start :end end))
 
 (define-scheme-procedure (string->utf8 string &optional (start 0) end)