;;; -*- Mode: Lisp; Package: SYSTEM -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "typespec")

(in-package "lisp")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(typep subtypep coerce deftype check-type))
  (export '(satisfies simple-array keyword
	    standard-char base-character extended-character))
  (export '(proclaim declaim))
  (export '(1+ 1- upgraded-array-element-type concatenate)))

(in-package "system")

(export 'canonicalize-type)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun deftype-1 (lambda-list)
    (when (member '&optional lambda-list :test #'eq)
      (do ((l lambda-list (cdr l))
	   (r nil))
	  ((null l))
	(push (car l) r)
	(when (member (car l) lambda-list-keywords)
	  (unless (eq (car l) '&optional)
	    (return))
	  (while (setq l (cdr l))
	    (let ((x (car l)))
	      (when (member x lambda-list-keywords :test #'eq)
		(return))
	      (push (if (symbolp x) (cons x '('*)) x) r)))
	  (setq lambda-list (nreconc r l))
	  (return))))
    lambda-list))

(defmacro deftype (name (&rest lambda-list) &rest body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (*putprop ',name
	       #'(lambda ,(deftype-1 lambda-list) (block ,name ,@body))
	       'deftype-definition)
     (*putprop ',name
	       ,(lisp::find-documentation body)
	       'lisp::type-documentation)
     ',name))

(deftype eql (x)
  `(member (,x)))

(deftype fixnum ()
  `(integer ,most-negative-fixnum ,most-positive-fixnum))

(deftype mod (n)
  `(integer 0 ,(1- n)))

;;;(deftype bit ()
;;;  '(integer 0 1))
;;;
;;;(deftype signed-byte (&optional s)
;;;  (if (eq s '*)
;;;      '(integer * *)
;;;    `(integer ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
;;;
;;;(deftype unsigned-byte (&optional s)
;;;  (if (eq s '*)
;;;      '(integer 0 *)
;;;    `(integer 0 ,(1- (expt 2 s)))))

(deftype vector (&optional element-type size)
  `(array ,element-type (,size)))

(deftype simple-vector (&optional size)
  `(simple-array t (,size)))

(deftype string (&optional size)
  `(vector character ,size))

(deftype simple-string (&optional size)
  `(simple-array character (,size)))

;;;(deftype bit-vector (&optional size)
;;;  `(vector bit ,size))
;;;
;;;(deftype simple-bit-vector (&optional size)
;;;  `(simple-array bit (,size)))

(defconstant typespec-alist
  '(;; standard types
    (atom . atom)
    (base-character . characterp)
    (bignum . si:*bignump)
    (character . characterp)
    (compiled-function . compiled-function-p)
    (cons . consp)
    (fixnum . si:*fixnump)
    (function . functionp)
    (hash-table . hash-table-p)
    (keyword . keywordp)
    (list . listp)
    (null . null)
    (number . numberp)
    (package . packagep)
    ;(pathname)
    (random-state . random-state-p)
    (ratio . *ratiop)
    (real . realp)
    (readtable . readtablep)
    (sequence . sequencep)
    (stream . streamp)
    (symbol . symbolp)

    ;; non-standard types
    (ed:buffer . ed:bufferp)
    (ed:marker . ed:markerp)
    (ed:process . ed:processp)
    (ed:regexp . ed:regexpp)
    (ed:syntax-table . ed:syntax-table-p)
    (ed:menu . ed:menup)
    (ed:dde-handle . ed:dde-handle-p)
    (ed:window . ed:windowp)
    (ed:oledata . ed:oledatap)))

(dolist (x typespec-alist)
  (setf (get (car x) 'type-predicate) (cdr x)))

(defmacro defpred (name (object r) &body body)
  `(setf (get ',name 'type-specifier-list)
	 #'(lambda (,object ,r)
	     (progn ,@body))))

(defpred satisfies (object r)
  (funcall (car r) object))

(defpred member (object r)
  (member object r))

(defpred eql (object r)
  (eql object (car r)))

(defpred not (object r)
  (not (typep object (car r))))

(defpred and (object r)
  (dolist (x r t)
    (unless (typep object x)
      (return nil))))

(defpred or (object r)
  (dolist (x r nil)
    (when (typep object x)
      (return t))))

(defpred t (x r) t)
(defpred nil (x r) nil)

(defpred standard-char (object r)
  (and (characterp object)
       (standard-char-p object)))

(defpred extended-character (x r) nil)

(defun number-in-range-p (x r)
  (cond ((endp r) t)
	((let ((low (car r)))
	   (cond ((eq low '*) nil)
		 ((consp low)
		  (<= x (car low)))
		 (t (< x low))))
	 nil)
	((endp (cdr r)) t)
	(t (let ((high (cadr r)))
	     (cond ((eq high '*) t)
		   ((consp high)
		    (< x (car high)))
		   (t (<= x high)))))))

(defmacro defpred-number (type pred)
  `(defpred ,type (object r)
     (and (,pred object)
          (number-in-range-p object r))))

(defpred-number integer integerp)
(defpred-number float floatp)
(defpred-number rational rationalp)
(defpred-number short-float short-float-p)
(defpred-number single-float single-float-p)
(defpred-number double-float double-float-p)
(defpred-number long-float long-float-p)

(defpred complex (object r)
   (and (complexp object)
	(or (null r)
	    (typep (realpart object) (car r)))))

(defmacro defpred-vector (type pred)
  `(defpred ,type (object r)
     (and (,pred object)
	  (or (endp r)
	      (eq (car r) '*)
	      (= (array-dimension object 0) (car r))))))

(defpred-vector simple-vector simple-vector-p)
(defpred-vector simple-string simple-string-p)
(defpred-vector string stringp)

(defun array-match-element-type (x r)
  (or (endp r)
      (eq (car r) '*)
      (eq (array-element-type x)
	  (upgraded-array-element-type (car r)))))

(defpred vector (object r)
   (and (vectorp object)
	(array-match-element-type object r)
	(or (endp (cdr r))
	    (eq (cadr r) '*)
	    (= (cadr r) (array-total-size object)))))

(defun array-match-element-type-and-dims (x r)
  (and (array-match-element-type x r)
       (or (endp (cdr r))
	   (let ((dims (cadr r)))
	     (cond ((eq dims '*) t)
		   ((atom dims)
		    (= dims (array-rank x)))
		   (t
		    (and (= (length dims) (array-rank x))
			 (do ((i 0 (1+ i))
			      (d dims (cdr d)))
			     ((endp d) t)
			   (unless (or (eq (car d) '*)
				       (= (car d) (array-dimension x i)))
			     (return nil))))))))))

(defmacro defpred-array (type pred)
  `(defpred ,type (object r)
      (and (,pred object)
	   (array-match-element-type-and-dims object r))))

(defpred-array simple-array si:*simple-array-p)
(defpred-array array arrayp)

(defun typep (object type)
  (let (r)
    (unless (atom type)
      (setq r (cdr type))
      (setq type (car type)))
    (let ((f (get type 'type-predicate)))
      (when f
	(return-from typep (funcall f object))))
    (let ((f (get type 'type-specifier-list)))
      (when f
	(return-from typep (funcall f object r))))
    (let ((f (get type 'structure-definition)))
      (when (and f (*structurep object))
	(return-from typep
	  (*structure-subtypep (*structure-definition object) f)))))
  nil)

(defun number-sub-range-p (r1 r2)
  (let ((low1 (if (endp r1) '* (car r1)))
	(high1 (if (endp (cdr r1)) '* (cadr r1)))
	(low2 (if (endp r2) '* (car r2)))
	(high2 (if (endp (cdr r2)) '* (cadr r2))))
    (cond ((eq low2 '*))
	  ((eq low1 '*)
	   (return-from number-sub-range-p nil))
	  ((consp low1)
	   (when (if (consp low2)
		     (< (car low1) (car low2))
		   (<= (car low1) low2))
	     (return-from number-sub-range-p nil)))
	  ((consp low2)
	   (when (<= low1 (car low2))
	     (return-from number-sub-range-p nil)))
	  (t
	   (when (< low1 low2)
	     (return-from number-sub-range-p nil))))
    (cond ((eq high2 '*) t)
	  ((eq high1 '*) nil)
	  ((consp high1)
	   (if (consp high2)
	       (<= (car high1) (car high2))
	     (< (car high1) high2)))
	  ((consp high2)
	   (< high1 (car high2)))
	  (t
	   (<= high1 high2)))))

(defun array-sub-dims-p (r1 r2)
  (let ((et1 (if (endp r1) '* (car r1)))
	(et2 (if (endp r2) '* (car r2))))
    (cond ((eq et2 '*))
	  ((eq et1 '*)
	   (return-from array-sub-dims-p (values nil t)))
	  ((equal (upgraded-array-element-type et1)
		  (upgraded-array-element-type et2)))
	  (t (return-from array-sub-dims-p (values nil t)))))
  (let ((dims1 (if (endp (cdr r1)) '* (cadr r1)))
	(dims2 (if (endp (cdr r2)) '* (cadr r2))))
    (cond ((eq dims2 '*)
	   (values t t))
	  ((eq dims1 '*)
	   (values nil t))
	  ((atom dims2)
	   (values (if (atom dims1)
		       (= dims1 dims2)
		     (= (length dims1) dims2))
		   t))
	  ((atom dims1)
	   (values (and (= dims1 (length dims2))
			(null (member '* dims2 :test-not #'eq)))
		   t))
	  ((= (length dims1) (length dims2))
	   (do ((d1 dims1 (cdr d1))
		(d2 dims2 (cdr d2)))
	       ((endp d1) (values t t))
	     (cond ((eq (car d2) '*))
		   ((eq (car d1) '*)
		    (return-from array-sub-dims-p (values nil t)))
		   ((= (car d1) (car d2)))
		   (t (return-from array-sub-dims-p (values nil t))))))
	  (t
	   (values nil t)))))

(defun canonicalize-type (type)
  (let (typ r)
    (loop
      (if (atom type)
	  (setq typ type r nil)
	(setq typ (car type) r (cdr type)))
      (if (get typ 'deftype-definition)
	  (setq type (apply (get typ 'deftype-definition) r))
	(return-from canonicalize-type (if (atom type) (list type) type))))))

(defun subtypep (type1 type2)
  (setq type1 (canonicalize-type type1))
  (setq type2 (canonicalize-type type2))
  (when (equal type1 type2)
    (return-from subtypep (values t t)))
  (let ((t1 (car type1))
	(t2 (car type2))
	(r1 (cdr type1))
	(r2 (cdr type2)))
    (cond ((eq t1 'satisfies) (values nil nil))
	  ((eq t1 'member)
	   (dolist (x r1 (values t t))
	     (unless (typep x type2)
	       (return (value nil t)))))
	  ((eq t1 'or)
	   (dolist (x r1 (values t t))
	     (multiple-value-bind (u v)
		 (subtypep x type2)
	       (unless u
		 (return (values nil v))))))
	  ((eq t1 'and)
	   (let ((f t))
	     (dolist (x r1 (values nil f))
	       (multiple-value-bind (u v)
		   (subtypep x type2)
		 (when u
		   (return (values t t)))
		 (or v (setq f nil))))))
	  ((eq t1 'not)
	   (if (eq t2 'not)
	       (subtypep (car r1) (car r2))
	     (values nil nil)))

	  ((eq t2 'satisfies) (values nil nil))
	  ((eq t2 'member) (values nil nil))
	  ((eq t2 'or)
	   (dolist (x r2 (values t t))
	     (unless (subtypep type1 x)
	       (return (values nil nil)))))
	  ((eq t2 'and)
	   (let ((f t))
	     (dolist (x r2 (values nil f))
	       (multiple-value-bind (u v)
		   (subtypep type1 x)
		 (when u
		   (return (values t t)))
		 (or v (setq f nil))))))
	  ((eq t2 'not)
	   (if (subtypep type1 (car r2))
	       (values nil t)
	     (values nil nil)))

	  ((eq t2 't) (values t t))
	  ((eq t1 't) (values nil t))
	  ((null t1) (values t t))
	  ((null t2) (values nil t))

	  ((eq t2 'number)
	   (values (member t1 '(rational float complex real integer ratio
				bignum short-float single-float
				double-float long-float)
			   :test #'eq)
		   t))
	  ((eq t2 'rational)
	   (values (or (and (member t1 '(rational integer) :test #'eq)
			    (number-sub-range-p r1 r2))
		       (member t1 '(ratio bignum) :test #'eq))
		   t))
	  ((eq t2 'integer)
	   (values (or (and (eq t1 'integer)
			    (number-sub-range-p r1 r2))
		       (eq t1 'bignum))
		   t))
	  ((eq t2 'real)
	   (values (member t1 '(rational float integer ratio bignum
				short-float single-float double-float long-float)
			   :test #'eq)
		   t))
	  ((eq t2 'float)
	   (values (and (member t1 '(float short-float single-float
				     double-float long-float) :test #'eq)
			(number-sub-range-p r1 r2))
		   t))
	  ((member t2 '(short-float single-float) :test #'eq)
	   (values (and (member t1 '(short-float single-float) :test #'eq)
			(number-sub-range-p r1 r2))
		   t))
	  ((member t2 '(double-float long-float) :test #'eq)
	   (values (and (member t1 '(double-float long-float) :test #'eq)
			(number-sub-range-p r1 r2))
		   t))
	  ((eq t2 'complex)
	   (values (member t1 '(number complex) :test #'eq) t))
	  ((eq t2 'symbol)
	   (values (member t1 '(null keyword) :test #'eq) t))
	  ((eq t2 'atom)
	   (values (null (member t1 '(cons list) :test #'eq)) t))
	  ((eq t2 'list)
	   (values (member t1 '(null cons) :test #'eq) t))
	  ((eq t2 'character)
	   (values (member t1 '(base-character extended-character
				standard-char) :test #'eq) t))
	  ((eq t2 'base-character)
	   (values (eq t1 'standard-char) t))
	  ((eq t2 'sequence)
	   (values (cond ((member t1 '(list cons null) :test #'eq) t)
			 ((or (eq t1 'array)
			      (eq t1 'simple-array))
			  (if (atom (cadr r1))
			      (eql (cadr r1) 1)
			    (endp (cdadr r1))))
			 (t nil))
		   t))
	  ((eq t2 'stream)
	   (values (member t1 '(two-way-stream echo-stream broadcast-stream
				file-stream synonym-stream string-stream
				concatenated-stream)
			   :test #'eq)
		   t))
	  ((eq t2 'simple-array)
	   (if (eq t1 'simple-array)
	       (array-sub-dims-p r1 r2)
	     (values nil t)))
	  ((eq t2 'array)
	   (if (or (eq t1 'array)
		   (eq t1 'simple-array))
	       (array-sub-dims-p r1 r2)
	     (values nil t)))
	  (t
	   (let ((f1 (get t1 'structure-definition))
		 (f2 (get t2 'structure-definition)))
	     (if (and f1 f2)
		 (values (*structure-subtypep f1 f2) t)
	       (values nil t)))))))

(defun coerce (object type)
  (when (typep object type)
    (return-from coerce object))
  (setq type (canonicalize-type type))
  (case (car type)
    (list
     (concatenate 'list object))
    ((array simple-array)
     (unless (if (atom (caddr type))
		 (eql (caddr type) 1)
	       (endp (cdaddr type)))
       (error "ベクタ以外の配列に変換できません"))
     (concatenate type object))
    (character (character object))
    (float (float object))
    (short-float (float object 0.0s0))
    (single-float (float object 0.0f0))
    (double-float (float object 0.0d0))
    (long-float (float object 0.0l0))
    (complex
     (if (or (null (cdr type))
	     (null (cadr type))
	     (eq (cadr type) '*))
	 (complex (realpart object) (imagpart object))
       (complex (coerce (realpart object) (cadr type))
		(coerce (imagpart object) (cadr type)))))
    (function
     (cond ((symbolp object)
	    (symbol-function object))
	   ((and (listp object)
		 (eq (car object) 'lambda))
	    (eval (list 'function object)))
	   (t
	    (error "~Sのfunctionへの型変換はサポートされていません" object))))
    (t
     (error "~Sの~Sへの型変換はサポートされていません"
       object (if (null (cdr type)) (car type) type)))))

(defun proclaim (decl-spec)
  (when (eq (car decl-spec) 'special)
    (mapc #'(lambda (x)
	      (si:*make-special x))
	  (cdr decl-spec))))

(defmacro declaim (&rest decl-specs)
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (cons 'progn
	  (mapcan #'(lambda (decl-spec)
		      (when (eq (car decl-spec) 'special)
			(mapcar #'(lambda (x) `(defvar ,x))
				(cdr decl-spec))))
		  decl-specs))))
