(in-package :alexandria)

(deftype array-index (&optional (length array-dimension-limit))
  "Type designator for an index into array of LENGTH: an integer between
0 (inclusive) and LENGTH (exclusive). LENGTH defaults to
ARRAY-DIMENSION-LIMIT."
  `(integer 0 (,length)))

(deftype array-length (&optional (length array-dimension-limit))
  "Type designator for a dimension of an array of LENGTH: an integer between
0 (inclusive) and LENGTH (inclusive). LENGTH defaults to
ARRAY-DIMENSION-LIMIT."
  `(integer 0 ,length))

;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
;; except the RATIO related definitions and ARRAY-INDEX.
(macrolet
    ((frob (type &optional (base-type type))
       (let ((subtype-names (list))
             (predicate-names (list)))
         (flet ((make-subtype-name (format-control)
                  (let ((result (format-symbol :alexandria format-control
                                               (symbol-name type))))
                    (push result subtype-names)
                    result))
                (make-predicate-name (sybtype-name)

                  (let ((result (format-symbol :alexandria '#:~A-p

                                               (symbol-name sybtype-name))))
                    (push result predicate-names)

                    result))
		(make-docstring (range-beg range-end range-type)
		  (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
		    (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
			    type
			    (if (equal range-beg ''*) inf (ensure-car range-beg))
			    (if (equal range-end ''*) inf (ensure-car range-end))))))

           (let* ((negative-name     (make-subtype-name '#:negative-~a))
                  (non-positive-name (make-subtype-name '#:non-positive-~a))
                  (non-negative-name (make-subtype-name '#:non-negative-~a))
                  (positive-name     (make-subtype-name '#:positive-~a))

                  (negative-p-name     (make-predicate-name negative-name))
                  (non-positive-p-name (make-predicate-name non-positive-name))
                  (non-negative-p-name (make-predicate-name non-negative-name))
                  (positive-p-name     (make-predicate-name positive-name))
                  (negative-extremum)
                  (positive-extremum)
                  (below-zero)
                  (above-zero)
                  (zero))
             (setf (values negative-extremum below-zero
                           above-zero positive-extremum zero)
                   (ecase type
                     (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))

                     (integer      (values ''* -1       1        ''* 0))
                     (rational     (values ''* '(0)     '(0)     ''* 0))
                     (real         (values ''* '(0)     '(0)     ''* 0))
                     (float        (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
                     (short-float  (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
                     (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
                     (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
                     (long-float   (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))

             `(progn
                (deftype ,negative-name ()

		  ,(make-docstring negative-extremum below-zero :negative)
		  `(,',base-type ,,negative-extremum ,',below-zero))

                (deftype ,non-positive-name ()

		  ,(make-docstring negative-extremum zero :negative)
		  `(,',base-type ,,negative-extremum ,',zero))

                (deftype ,non-negative-name ()

		  ,(make-docstring zero positive-extremum :positive)
		  `(,',base-type ,',zero ,,positive-extremum))

                (deftype ,positive-name ()

		  ,(make-docstring above-zero positive-extremum :positive)
		  `(,',base-type ,',above-zero ,,positive-extremum))

                (declaim (inline ,@predicate-names))

                (defun ,negative-p-name (n)
                  (and (typep n ',type)
                       (< n ,zero)))

                (defun ,non-positive-p-name (n)
                  (and (typep n ',type)
                       (<= n ,zero)))

                (defun ,non-negative-p-name (n)
                  (and (typep n ',type)
                       (<= ,zero n)))

                (defun ,positive-p-name (n)
                  (and (typep n ',type)

                       (< ,zero n)))))))))

  (frob fixnum integer)
  (frob integer)
  (frob rational)
  (frob real)
  (frob float)
  (frob short-float)
  (frob single-float)
  (frob double-float)
  (frob long-float))

(defun of-type (type)
  "Returns a function of one argument, which returns true when its argument is
of TYPE."
  (lambda (thing) (typep thing type)))

(define-compiler-macro of-type (&whole form type &environment env)
  ;; This can yeild a big benefit, but no point inlining the function
  ;; all over the place if TYPE is not constant.
  (if (constantp type env)
      (with-gensyms (thing)
        `(lambda (,thing)
           (typep ,thing ,type)))
      form))

(declaim (inline type=))
(defun type= (type1 type2)
  "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
and a secondary value that is true is the type equality could be reliably
determined: primary value of NIL and secondary value of T indicates that the
types are not equivalent."
  (multiple-value-bind (sub ok) (subtypep type1 type2)
    (cond ((and ok sub)
           (subtypep type2 type1))
          (ok
           (values nil ok))
          (t
           (multiple-value-bind (sub ok) (subtypep type2 type1)

             (declare (ignore sub))

             (values nil ok))))))