Add more Scheme type definitions

Author: Aethaeryn

equality.lisp

@@ -1,6 +1,9 @@
 ;;;; -*- mode: common-lisp; -*-
 
 ;;;; Non-string equality testing
+;;;;
+;;;; The core three equivalents predicates are described in r7rs.pdf
+;;;; section 6.1.
 
 (in-package #:airship-scheme)
 

scheme-types.lisp

@@ -4,8 +4,8 @@
 
 ;;;; Define type definitions
 
-;;; TODO: The define-scheme-predicate could go here, too
-(defmacro define-scheme-type ((name &rest lambda-list) &body body)
+;;;; TODO: The define-scheme-predicate could go here, too
+(defmacro %define-scheme-type ((name &rest lambda-list) predicate &body body)
   (let ((docstring (if (and (stringp (car body)) (cdr body))
                        (list (car body))
                        nil)))
@@ -14,7 +14,17 @@
          ,@body)
        (define-function (,name :inline t) (object)
          ,@docstring
-         (and (typep object ',name) t)))))
+         (and ,predicate t)))))
+
+;;; For types with no built-in predicate
+(defmacro define-scheme-type ((name &rest lambda-list) &body body)
+  `(%define-scheme-type (,name ,@lambda-list) (typep object ',name)
+     ,@body))
+
+;;; For CL types that use a predicate instead of typep
+(defmacro define-scheme-type* ((name &rest lambda-list) predicate &body body)
+  `(%define-scheme-type (,name ,@lambda-list) (,predicate object)
+     ,@body))
 
 ;;;; Type definitions
 
@@ -49,6 +59,10 @@ known as #t or #f
   "A Scheme string is just a simple string."
   'simple-string)
 
+(define-scheme-type (char?)
+  "A Scheme char is just a character."
+  'character)
+
 (define-scheme-type (bytevector?)
   "A Scheme bytevector is just an octet vector"
   `(simple-array octet (*)))
@@ -57,6 +71,25 @@ known as #t or #f
   "Tests if an object is a Scheme symbol"
   `(and symbol (not null) (not boolean?)))
 
+(define-scheme-type* (list?) a:proper-list-p
+  "Scheme's list? tests for a proper list"
+  `a:proper-list)
+
+(define-scheme-type* (%list?) listp
+  "
+A lower-level, faster list test that permits improper lists, which
+don't end in NIL.
+"
+  `list)
+
+(define-scheme-type* (pair?) consp
+  "A pair? in Scheme is a cons cell."
+  `cons)
+
+(define-scheme-type* (null?) null
+  "A null? in Scheme is nil."
+  `null)
+
 ;;;; Type Conversion
 
 (define-function (inexact :inline t) ((z number))

standard-procedures.lisp

@@ -24,11 +24,6 @@
 ;;;; todo: add errors when errors are required
 
 ;;;; 6.1 - Equivalence predicates
-;;;;
-;;;; Note: These have to be implemented last to make sure that they
-;;;; follow Scheme equivalence rules... except for eq? which is
-;;;; sufficiently under-specified that being synonymous with EQ is not
-;;;; an issue.
 
 (define-scheme-predicate (eqv? obj1 obj2)
   (eqv? obj1 obj2))
@@ -291,7 +286,7 @@
 ;;; Basic cons pair procedures
 
 (define-scheme-predicate (pair? obj)
-  (consp obj))
+  (pair? obj))
 
 (define-scheme-procedure (cons obj1 obj2)
   (cons obj1 obj2))
@@ -341,10 +336,10 @@
 ;;; List procedures
 
 (define-scheme-predicate (null? obj)
-  (null obj))
+  (null? obj))
 
 (define-scheme-predicate (list? obj)
-  (a:proper-list-p obj))
+  (list? obj))
 
 (define-scheme-procedure (make-list k &optional (fill nil))
   (make-list k :initial-element fill))
@@ -412,7 +407,7 @@
 ;;;; 6.6 Characters
 
 (define-scheme-predicate (char? obj)
-  (typep obj 'character))
+  (char? obj))
 
 (define-scheme-predicate (char=? char . more-chars)
   (apply #'char= char more-chars))