47 |
`(,tp ,(upgraded-array-element-type (array-element-type object))) |
`(,tp ,(upgraded-array-element-type (array-element-type object))) |
48 |
tp)))) |
tp)))) |
49 |
|
|
50 |
|
(defmacro dt-apply (x y) |
51 |
|
(let ((l (gensym))) |
52 |
|
`(let ((,l (length ,y))) |
53 |
|
(case ,l |
54 |
|
(0 (funcall ,x)) |
55 |
|
(1 (funcall ,x (car ,y))) |
56 |
|
(2 (funcall ,x (car ,y) (cadr ,y))) |
57 |
|
(otherwise (apply ,x ,y)))))) |
58 |
|
|
59 |
(defun typep-int (object type &aux tp i tem) |
(defun typep-int (object type &aux tp i tem) |
60 |
(if (atom type) |
(if (atom type) |
61 |
(setq tp type i nil) |
(setq tp type i nil) |
133 |
broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp)) |
broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp)) |
134 |
(t (cond |
(t (cond |
135 |
((setq tem (when (symbolp tp) (get tp 'deftype-definition))) |
((setq tem (when (symbolp tp) (get tp 'deftype-definition))) |
136 |
(typep-int object (apply tem i))) |
(typep-int object (dt-apply tem i))) |
137 |
((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data)) |
((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data)) |
138 |
(let ((z (structure-subtype-p object tp))) z)) |
(let ((z (structure-subtype-p object tp))) z)) |
139 |
((classp tp) |
((classp tp) |
290 |
((assert-type object type)))) |
((assert-type object type)))) |
291 |
|
|
292 |
;;; DEFTYPE macro. |
;;; DEFTYPE macro. |
293 |
(defmacro deftype (name lambda-list &rest body &aux decls) |
(defmacro deftype (name lambda-list &rest body &aux decls prot) |
294 |
;; Replace undefaultized optional parameter X by (X '*). |
;; Replace undefaultized optional parameter X by (X '*). |
295 |
(declare (optimize (safety 1))) |
(declare (optimize (safety 1))) |
296 |
(do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls)) |
(do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls)) |
300 |
(do ((l lambda-list (cdr l)) |
(do ((l lambda-list (cdr l)) |
301 |
(m nil (cons (car l) m))) |
(m nil (cons (car l) m))) |
302 |
((null l)) |
((null l)) |
303 |
(when (member (car l) lambda-list-keywords) |
(cond ((member (car l) lambda-list-keywords) |
304 |
(unless (member (car l) '(&optional &key)) (return nil)) |
(unless (eq (car prot) '*) (push '* prot)) |
305 |
(setq m (cons (car l) m)) |
(unless (member (car l) '(&optional &key)) (return nil)) |
306 |
(setq l (cdr l)) |
(setq m (cons (car l) m)) |
307 |
(do () |
(setq l (cdr l)) |
308 |
((or (null l) (member (car l) lambda-list-keywords))) |
(do () |
309 |
(if (symbolp (car l)) |
((or (null l) (member (car l) lambda-list-keywords))) |
310 |
(setq m (cons (list (car l) ''*) m)) |
(if (symbolp (car l)) |
311 |
(setq m (cons (car l) m))) |
(setq m (cons (list (car l) ''*) m)) |
312 |
(setq l (cdr l))) |
(setq m (cons (car l) m))) |
313 |
(setq lambda-list (nreconc m l)) |
(setq l (cdr l))) |
314 |
(return nil))) |
(setq lambda-list (nreconc m l)) |
315 |
`(eval-when (compile eval load) |
(return nil)) |
316 |
(putprop ',name |
((push t prot)))) |
317 |
'(deftype ,name ,lambda-list ,@body) |
(let ((fun-name (gensym (string name))) (prot (nreverse prot))) |
318 |
'deftype-form) |
`(eval-when (compile eval load) |
319 |
(putprop ',name |
(putprop ',name |
320 |
(if (null ',lambda-list) |
'(deftype ,name ,lambda-list ,@body) |
321 |
(lambda nil ,@decls (block ,name ,`(progn ,@body))) |
'deftype-form) |
322 |
(lambda ,lambda-list ,@decls (block ,name ,@body))) |
(proclaim '(ftype (function ,prot t) ,fun-name)) |
323 |
'deftype-definition) |
(defun ,fun-name ,lambda-list ,@decls (block ,name ,@body)) |
324 |
(putprop ',name |
(putprop ',name ',fun-name 'deftype-definition) |
325 |
,(find-documentation body) |
(putprop ',name |
326 |
'type-documentation) |
,(find-documentation body) |
327 |
',name)) |
'type-documentation) |
328 |
|
',name))) |
329 |
|
|
330 |
;;; Some DEFTYPE definitions. |
;;; Some DEFTYPE definitions. |
331 |
(deftype seqind () |
(deftype seqind () |
434 |
(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high))) |
(deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high))) |
435 |
(deftype number () `(or real complex)) |
(deftype number () `(or real complex)) |
436 |
(deftype atom () `(not cons)) |
(deftype atom () `(not cons)) |
437 |
(deftype function (&optional as vs) `(or interpreted-function compiled-function generic-function)) |
(deftype function (&optional as vs) |
438 |
|
(declare (ignore as vs)) |
439 |
|
`(or interpreted-function compiled-function generic-function)) |
440 |
|
|
441 |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
(deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high)) |
442 |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
(deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high)) |
647 |
;;FIXME loose the ar and default to t |
;;FIXME loose the ar and default to t |
648 |
(defun normalize-type-int (type ar &aux tem) |
(defun normalize-type-int (type ar &aux tem) |
649 |
(cond ((atom type) (normalize-type-int (list type) ar)) |
(cond ((atom type) (normalize-type-int (list type) ar)) |
650 |
;;These are deftype accelerators |
;;These are deftype accelerators FIXME may no longer be necessary with faster deftype |
651 |
((member (car type) +range-types+) |
((member (car type) +range-types+) |
652 |
(let* ((l (cadr type)) |
(let* ((l (cadr type)) |
653 |
(ln (if (cdr type) (maybe-eval l) '*)) |
(ln (if (cdr type) (maybe-eval l) '*)) |
694 |
(mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x)) |
(mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x)) |
695 |
(cdr type)) |
(cdr type)) |
696 |
(cdr type))) |
(cdr type))) |
697 |
(nt (and dt (or (apply dt rr) '(nil))))) |
(nt (and dt (or (dt-apply dt rr) '(nil))))) |
698 |
(when (and nt (not (equal type nt))) |
(when (and nt (not (equal type nt))) |
699 |
(normalize-type-int nt ar)))) |
(normalize-type-int nt ar)))) |
700 |
((member (car type) '(and or not)) |
((member (car type) '(and or not)) |