summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--types.lisp102
-rw-r--r--util.lisp6
2 files changed, 55 insertions, 53 deletions
diff --git a/types.lisp b/types.lisp
index 3f8780a..22c9940 100644
--- a/types.lisp
+++ b/types.lisp
@@ -11,40 +11,38 @@
;(defvar *type-table*)
(setq *subtype-relationships*
- '((real . number)
- (complex . number)
- (rational . real)
- (float . real)
- (integer . rational)
- (ratio . rational)
- (fixnum . integer)
- (bignum . integer)
- (short-float . float)
- (long-float . float)
- (single-float . float)
- (double-float . float)
- (null . symbol)
- (null . list)
- (cons . list)
- (standard-char . base-char)
- (base-char . character)
- (extended-char . character)
- (string . vector)
- (bit-vector . vector)
- (vector . array)
- (simple-array . array)
- (simple-vector . simple-array)
- (simple-string . simple-array)
- (simple-bit-vector . simple-array)
- (vector . sequence)
- (list . sequence)
- (two-way-stream . stream)
- (echo-stream . stream)
- (broadcast-stream . stream)
- (file-stream . stream)
- (synonym-stream . stream)
- (string-stream . stream)
- (concatenated-stream . stream)))
+ '((base-char . (character))
+ (bignum . (integer))
+ (bit-vector . (vector))
+ (broadcast-stream . (stream))
+ (complex . (number))
+ (concatenated-stream . (stream))
+ (cons . (list))
+ (double-float . (float))
+ (echo-stream . (stream))
+ (extended-char . (character))
+ (file-stream . (stream))
+ (fixnum . (integer))
+ (float . (real))
+ (integer . (rational))
+ (list . (sequence))
+ (long-float . (float))
+ (null . (list symbol))
+ (ratio . (rational))
+ (rational . (real))
+ (real . (number))
+ (short-float . (float))
+ (simple-array . (array))
+ (simple-bit-vector . (simple-array))
+ (simple-string . (simple-array))
+ (simple-vector . (simple-array))
+ (single-float . (float))
+ (standard-char . (base-char))
+ (string . (vector))
+ (string-stream . (stream))
+ (synonym-stream . (stream))
+ (two-way-stream . (stream))
+ (vector . (array sequence))))
(setq most-positive-fixnum 32767)
@@ -95,7 +93,7 @@
(every1 function (rest list)))))
-(defun expand-type (type)
+(defun expand-type (type &optional environment)
;;FIXME: DEFTYPE
type)
@@ -103,22 +101,25 @@
(defun typep (thing typespec &optional environment)
;;FIXME: DEFTYPE
(let ((type (type-of thing))
- (typespec (expand-type typespec)))
- (if (listp typespec)
- (case (first typespec)
- (and (every1 (lambda (x) (typep thing x environment)) (rest typespec)))
- (or (some1 (lambda (x) (typep thing x environment)) (rest typespec)))
- (not (not (typep thing (second typespec) environment)))
- (satisfies (funcall (second typespec) thing))
- (otherwise
- (subtypep type typespec environment)))
- (subtypep type typespec environment))))
+ (typespec (expand-type typespec environment)))
+ (cond ((eq typespec t) t)
+ ((listp typespec)
+ (case (first typespec)
+ (and (every1 (lambda (x) (typep thing x environment)) (rest typespec)))
+ (or (some1 (lambda (x) (typep thing x environment)) (rest typespec)))
+ (not (not (typep thing (second typespec) environment)))
+ (satisfies (funcall (second typespec) thing))
+ (otherwise
+ (subtypep type typespec environment))))
+ (t (subtypep type typespec environment)))))
(defun subtypep (type1 type2 &optional environment)
- (let ((type1 (expand-type type1))
- (type2 (expand-type type2)))
- (cond ((listp type1)
+ (let ((type1 (expand-type type1 environment))
+ (type2 (expand-type type2 environment)))
+ (cond ((eq type2 t) t)
+ ((eq type1 nil) t)
+ ((listp type1)
(case (first type1)
(and (some1 (lambda (x) (subtypep x type2 environment)) (rest type1)))
(or (every1 (lambda (x) (subtypep x type2 environment)) (rest type1)))
@@ -137,8 +138,5 @@
;;FIXME?
(subtypep type1 (first type2) environment))))
(t (or (eq type1 type2)
- (let ((supertypes (mapcan1 (lambda (x)
- (when (eq (car x) type1)
- (list (cdr x))))
- *subtype-relationships*)))
+ (let ((supertypes (assoc type1 *subtype-relationships* :test 'eq)))
(some1 (lambda (x) (subtypep x type2 environment)) supertypes)))))))
diff --git a/util.lisp b/util.lisp
index f6fbe20..c06305f 100644
--- a/util.lisp
+++ b/util.lisp
@@ -1,5 +1,5 @@
(export '(and or not let* list* case cond append reverse macroexpand
- otherwise unless when))
+ otherwise unless when eq))
(%defmacro %defun args
@@ -203,3 +203,7 @@
(unexport ',symbol (find-package :sys))
(unexport ',symbol (find-package :cl))
(export (intern (symbol-name ',symbol) (find-package :cl)))))
+
+(%shadowing-export eq)
+(%defun* eq (x y)
+ (sys::eq x y))