Plaster
New
List
Login
common-lisp
default
phoe
2019.11.19 12:36:23
(in-package :ccl) (defun neighboring-ctypes-p (left-ctype right-ctype) ;; We need to find a numeric CTYPE whose class is a CSUBTYPE of ;; class of the first CTYPE and ;; which shares its lower bound with the original CTYPE's upper bound. (let ((left-ctype-class (or (numeric-ctype-class left-ctype) 'real)) (right-ctype-class (or (numeric-ctype-class right-ctype) 'real))) (and (numeric-ctype-p right-ctype) (numeric-ctype-low right-ctype) (subtypep left-ctype-class right-ctype-class) (listp (numeric-ctype-low right-ctype)) (= (first (numeric-ctype-high left-ctype)) (first (numeric-ctype-low right-ctype)))))) (defun maybe-merge-numeric-union-with-exclusive-neighboring-ranges (union-ctype) (let* ((ctypes (union-ctype-types union-ctype)) (result (copy-list ctypes))) (dolist (ctype ctypes) (when (and (numeric-ctype-p ctype) (numeric-ctype-high ctype) (listp (numeric-ctype-high ctype)) (find-if (lambda (x) (neighboring-ctypes-p ctype x)) ctypes)) (let* ((bound (first (numeric-ctype-high ctype))) (class (or (numeric-ctype-class ctype) 'real)) (bound-ctype (specifier-type `(,class ,bound ,bound)))) (when (find-if (lambda (x) (csubtypep bound-ctype x)) ctypes) (push bound-ctype result))))) (specifier-type (type-specifier (make-union-ctype result))))) CCL> *ctype* #<UNION-CTYPE (OR (REAL * (-3.5D0)) (NOT INTEGER) (REAL (-3.5D0)))> CCL> (maybe-merge-numeric-union-with-exclusive-neighboring-ranges *ctype*) #<NAMED-CTYPE T>
Raw
Annotate
Repaste
Annotations
common-lisp
default
phoe
2019.11.19 12:45:08
(defun try-merge-numeric-ranges (union-ctype) (let* ((ctypes (union-ctype-types union-ctype)) (result (copy-list ctypes))) (dolist (ctype ctypes) (when (and (numeric-ctype-p ctype) (numeric-ctype-high ctype) (listp (numeric-ctype-high ctype))) (let* ((bound (first (numeric-ctype-high ctype))) (class (or (numeric-ctype-class ctype) 'real)) (bound-ctype (specifier-type `(,class ,bound ,bound)))) (when (find-if (lambda (x) (csubtypep bound-ctype x)) ctypes) (push bound-ctype result))))) (specifier-type (type-specifier (make-union-ctype result))))) CCL> *ctype* #<UNION-CTYPE (OR (REAL * (-3.5D0)) (NOT INTEGER) (REAL (-3.5D0)))> CCL> (try-merge-numeric-ranges *ctype*) #<NAMED-CTYPE T>
Raw
Repaste