Changeset 10426 for trunk/source/level-1/l1-typesys.lisp
- Timestamp:
- Aug 11, 2008, 3:49:48 AM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/level-1/l1-typesys.lisp
r10358 r10426 178 178 `(specifier-type ',(type-specifier c))) 179 179 180 (defmethod make-load-form ((cell type-cell) &optional env) 181 (declare (ignore env)) 182 `(register-type-cell `,(type-cell-type-specifier cell))) 183 184 (defmethod print-object ((cell type-cell) stream) 185 (print-unreadable-object (cell stream :type t :identity t) 186 (format stream "for ~s" (type-cell-type-specifier cell)))) 180 187 181 188 (defun make-key-info (&key name type) … … 1108 1115 type1 type2 1109 1116 :complex-arg1 :complex-subtypep-arg1)))) 1117 1118 ;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache 1119 ;;; a mapping between a type-specifier and a CTYPE. 1120 (defun cell-csubtypep-2 (type-specifier type-cell) 1121 (let* ((type1 (specifier-type type-specifier)) 1122 (type2 (or (type-cell-ctype type-cell) 1123 (let* ((ctype (specifier-type 1124 (type-cell-type-specifier type-cell)))) 1125 (when (cacheable-ctype-p ctype) 1126 (setf (type-cell-ctype type-cell) ctype)) 1127 ctype)))) 1128 (cond ((or (eq type1 type2) 1129 (eq type1 *empty-type*) 1130 (eq type2 *wild-type*)) 1131 (values t t)) 1132 (t 1133 (invoke-type-method :simple-subtypep :complex-subtypep-arg2 1134 type1 type2 1135 :complex-arg1 :complex-subtypep-arg1))))) 1136 1137 1138 1110 1139 ;;; Type= -- Interface 1111 1140 ;;; … … 1648 1677 1649 1678 (defun hairy-ctype-p (x) 1650 (istruct-typep x 'hairy-ctype)) 1679 (or (istruct-typep x 'hairy-ctype) 1680 (istruct-typep x 'unknown-ctype))) 1651 1681 1652 1682 (setf (type-predicate 'hairy-ctype) 'hairy-ctype-p) … … 3606 3636 (let ((fun (second hairy-spec))) 3607 3637 (cond ((and (symbolp fun) (fboundp fun)) 3608 (values (not (null (ignore-errors (funcall fun obj)))) t)) 3638 ;; Binding *BREAK-ON-SIGNALS* here is a modularity 3639 ;; violation intended to improve the signal-to-noise 3640 ;; ratio on a mailing list. 3641 (values (not (null (let* ((*break-on-signals* nil)) 3642 (ignore-errors (funcall fun obj))))) t)) 3609 3643 (t 3610 3644 (values nil nil))))))))))
Note: See TracChangeset
for help on using the changeset viewer.