diff options
| -rw-r--r-- | types.lisp | 102 | ||||
| -rw-r--r-- | util.lisp | 6 |
2 files changed, 55 insertions, 53 deletions
@@ -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))))))) @@ -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)) |