├── ext ├── tfun │ ├── packages.lisp │ ├── arrays.lisp │ ├── util.lisp │ ├── conses.lisp │ ├── data-and-control-flow.lisp │ └── tfun.lisp ├── packages.lisp ├── data-structures │ ├── hash-table-of.lisp │ ├── list-of.lisp │ ├── plist.lisp │ └── array-of.lisp ├── README.md └── mod.lisp ├── config ├── unsupported.lisp ├── common-post.lisp ├── cmucl.lisp ├── sbcl.lisp ├── ccl.lisp ├── abcl.lisp ├── ecl.lisp ├── sicl.lisp ├── README.md ├── common.lisp └── clasp.lisp ├── csatisfies.lisp ├── method-combination.lisp ├── LICENSE ├── ccomplex.lisp ├── packages.lisp ├── fpzero.lisp ├── cache.lisp ├── cclass.lisp ├── negation.lisp ├── create.lisp ├── cmember.lisp ├── cvalues.lisp ├── ctype.asd ├── generic-functions.lisp ├── conjunction.lisp ├── classes.lisp ├── trivalent.lisp ├── cfunction.lisp ├── README.md ├── charset.lisp ├── carray.lisp ├── disjunction.lisp ├── ccons.lisp ├── range.lisp ├── pairwise.lisp └── MANUAL.md /ext/tfun/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ctype.ext.tfun 2 | (:use #:cl #:ctype) 3 | (:export #:tfun #:define-tfun #:find-tfun) 4 | (:export #:derive-call #:derive-multiple-value-call)) 5 | -------------------------------------------------------------------------------- /config/unsupported.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (eval-when (:compile-toplevel) 4 | (warn "This implementation is not yet supported by ctype")) 5 | 6 | (error "This implementation is not yet supported by ctype") 7 | -------------------------------------------------------------------------------- /config/common-post.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defconstant +distinct-short-float-zeroes-p+ (not (eql -0s0 0s0))) 4 | (defconstant +distinct-single-float-zeroes-p+ (not (eql -0f0 0f0))) 5 | (defconstant +distinct-double-float-zeroes-p+ (not (eql -0d0 0d0))) 6 | (defconstant +distinct-long-float-zeroes-p+ (not (eql -0L0 0L0))) 7 | 8 | (defmacro range-kindp (objectf kindf) 9 | `(ecase ,kindf 10 | ((integer) (integerp ,objectf)) 11 | ((ratio) (ratiop ,objectf)) 12 | ,@(loop for (kind . pred) in +floats+ 13 | collect `((,kind) (,pred ,objectf))))) 14 | -------------------------------------------------------------------------------- /csatisfies.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct csatisfies)) 4 | (funcall (fdefinition (csatisfies-fname ct)) object)) 5 | 6 | (defmethod subctypep ((ct1 csatisfies) (ct2 csatisfies)) 7 | (if (equal (csatisfies-fname ct1) (csatisfies-fname ct2)) 8 | (values t t) 9 | (values nil nil))) 10 | (defmethod ctype= ((ct1 csatisfies) (ct2 csatisfies)) 11 | (if (equal (csatisfies-fname ct1) (csatisfies-fname ct2)) 12 | (values t t) 13 | (values nil nil))) 14 | 15 | (defmethod unparse ((ct csatisfies)) 16 | `(satisfies ,(csatisfies-fname ct))) 17 | -------------------------------------------------------------------------------- /ext/tfun/arrays.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.tfun) 2 | 3 | (defgeneric array-element-ctype (array-type)) 4 | (defdefaults array-element-ctype (array)) 5 | (defmethod array-element-ctype ((atype negation)) 6 | (negate (array-element-ctype (negation-ctype atype)))) 7 | (defmethod array-element-ctype ((atype carray)) (carray-eaet atype)) 8 | 9 | (define-tfun aref (array &rest indices) 10 | ;; TODO: return bot on index invalidity 11 | (single-value (array-element-ctype array))) 12 | (define-tfun row-major-aref (array index) 13 | ;; TODO: return bot on index invalidity 14 | (single-value (array-element-ctype array))) 15 | -------------------------------------------------------------------------------- /ext/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ctype.ext.data-structures 2 | (:use #:cl #:ctype) 3 | (:import-from #:alexandria 4 | #:map-product 5 | #:iota) 6 | ;; ctypes 7 | (:export 8 | #:clist-of 9 | #:element-ctype 10 | #:carray-of 11 | #:carray-simplicity 12 | #:carray-uaet 13 | #:carray-eaet 14 | #:carray-dims 15 | #:chash-table-of 16 | #:key-ctype 17 | #:value-ctype 18 | #:cproperty-list 19 | #:key-ctypes 20 | #:keys 21 | #:property-ctype) 22 | ;; extended types 23 | (:export 24 | #:list-of 25 | #:array-of 26 | #:simple-array-of 27 | #:vector-of 28 | #:simple-vector-of 29 | #:hash-table-of 30 | #:plist)) 31 | -------------------------------------------------------------------------------- /method-combination.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (define-method-combination basic (operator) 4 | ((around (:around)) 5 | (primary () :required t)) 6 | "This is like standard short form combinations, except 7 | * You write basic operator instead of just operator to refer to the combo. 8 | * You don't need to put the operator name as a qualifier. 9 | * :order and :identity-with-one-argument are not supported because I don't need them. 10 | This is based on the BASIC combination in sellout's method-combination-utilities library." 11 | (let ((form `(,operator 12 | ,@(loop for prim in primary collect `(call-method, prim))))) 13 | (if around 14 | `(call-method ,(first around) (,@(rest around) (make-method ,form))) 15 | form))) 16 | -------------------------------------------------------------------------------- /config/cmucl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | (defun ratiop (object) (ext:ratiop object)) 5 | 6 | (define-constant +floats+ 7 | '((single-float . kernel:single-float-p) 8 | (double-float . kernel:double-float-p)) 9 | :test #'equal) 10 | 11 | (define-constant +standard-charset+ '((10 . 10) (32 . 126))) 12 | (define-constant +base-charset+ '((0 . 65535))) 13 | 14 | (define-constant +string-uaets+ '(base-char) :test #'equal) 15 | 16 | (define-constant +complex-arrays-exist-p+ t) 17 | 18 | (declaim (inline simple-array-p)) 19 | (defun simple-array-p (object) (kernel:simple-array-p object)) 20 | 21 | (define-constant +class-aliases+ () :test #'equal) 22 | 23 | (declaim (inline subclassp)) 24 | (defun subclassp (sub super) 25 | (member super (kernel:std-compute-class-precedence-list sub))) 26 | 27 | (declaim (inline typexpand)) 28 | (defun typexpand (type-specifier environment) 29 | (declare (ignore environment)) 30 | (kernel:type-expand type-specifier)) 31 | 32 | (defmacro complex-ucptp (objectf ucpt) 33 | `(ecase ,ucpt 34 | ((*) t) 35 | ((single-float) (kernel:complex-single-float-p ,objectf)) 36 | ((double-float) (kernel:complex-double-float-p ,objectf)) 37 | ((rational) (kernel:complex-rational-p ,objectf)))) 38 | -------------------------------------------------------------------------------- /config/sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | (defun ratiop (object) (sb-int:ratiop object)) 5 | 6 | (define-constant +floats+ 7 | '((single-float . sb-int:single-float-p) 8 | (double-float . sb-int:double-float-p)) 9 | :test #'equal) 10 | 11 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 12 | (define-constant +base-charset+ '((0 . 127)) :test #'equal) 13 | 14 | (define-constant +string-uaets+ '(nil base-char character) :test #'equal) 15 | 16 | (define-constant +complex-arrays-exist-p+ t) 17 | 18 | (declaim (inline simple-array-p)) 19 | (defun simple-array-p (object) (sb-kernel:simple-array-p object)) 20 | 21 | (define-constant +class-aliases+ () :test #'equal) 22 | 23 | (declaim (inline subclassp)) 24 | (defun subclassp (sub super) (member super (sb-mop:class-precedence-list sub))) 25 | 26 | (declaim (inline typexpand)) 27 | (defun typexpand (type-specifier environment) 28 | (sb-ext:typexpand type-specifier environment)) 29 | 30 | (defmacro complex-ucptp (objectf ucpt) 31 | `(ecase ,ucpt 32 | ((*) t) 33 | ((single-float) (sb-kernel:complex-single-float-p ,objectf)) 34 | ((double-float) (sb-kernel:complex-double-float-p ,objectf)) 35 | ((rational) (sb-kernel:complex-rational-p ,objectf)))) 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Bike (aeshtaer@gmail.com) 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /config/ccl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | (defun ratiop (object) (ccl:ratiop object)) 5 | 6 | (define-constant +floats+ 7 | ;; SHORT-FLOAT is a SINGLE-FLOAT on CCL, but the predicate is on short 8 | ;; float rather than single float for whatever reason. 9 | ;; https://ccl.clozure.com/manual/chapter4.11.html#floating-point 10 | '((single-float . ccl::short-float-p) 11 | (double-float . ccl::double-float-p)) 12 | :test #'equal) 13 | 14 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 15 | (define-constant +base-charset+ '((0 . 55295)) :test #'equal) 16 | 17 | (define-constant +string-uaets+ '(base-char) :test #'equal) 18 | 19 | (define-constant +complex-arrays-exist-p+ t) 20 | 21 | (declaim (inline simple-array-p)) 22 | (defun simple-array-p (object) (ccl::simple-array-p object)) 23 | 24 | (define-constant +class-aliases+ () :test #'equal) 25 | 26 | (declaim (inline subclassp)) 27 | (defun subclassp (sub super) (ccl::subclassp sub super)) 28 | 29 | (declaim (inline typexpand)) 30 | (defun typexpand (type-specifier environment) 31 | (ccl::type-expand type-specifier environment)) 32 | 33 | (defmacro complex-ucptp (objectf ucpt) 34 | `(ecase ,ucpt 35 | ((*) t) 36 | ((single-float) (ccl::complex-single-float-p ,objectf)) 37 | ((double-float) (ccl::complex-double-float-p ,objectf)))) 38 | -------------------------------------------------------------------------------- /config/abcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defun ratiop (object) (typep object 'ratio)) 4 | 5 | (defun single-float-p (number) 6 | (and (floatp number) 7 | (<= most-negative-single-float number most-positive-single-float))) 8 | 9 | (defun double-float-p (number) 10 | (and (floatp number) 11 | (< number most-negative-single-float) 12 | (> number most-positive-single-float) 13 | (>= number most-negative-double-float) 14 | (<= number most-positive-single-float))) 15 | 16 | (define-constant +floats+ 17 | '((single-float . single-float-p) 18 | (double-float . double-float-p)) 19 | :test #'equal) 20 | 21 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 22 | (define-constant +base-charset+ '((0 . 127)) :test #'equal) 23 | (define-constant +string-uaets+ '(nil base-char character) :test #'equal) 24 | 25 | (define-constant +complex-arrays-exist-p+ t) 26 | 27 | (defun simple-array-p (object) (typep object 'simple-array)) 28 | 29 | (define-constant +class-aliases+ () :test #'equal) 30 | 31 | (defun subclassp (sub super) (member super (mop:class-precedence-list sub))) 32 | 33 | (defun typexpand (type-specifier environment) 34 | (declare (ignore environment)) 35 | (system:normalize-type type-specifier)) 36 | 37 | (defmacro complex-ucptp (objectf ucpt) 38 | (declare (ignore objectf)) 39 | `(ecase ,ucpt 40 | ((*) t))) 41 | -------------------------------------------------------------------------------- /ccomplex.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep ((object complex) (ct ccomplex)) 4 | (complex-ucptp object (ccomplex-ucpt ct))) 5 | (defmethod ctypep ((object t) (ct ccomplex)) nil) 6 | 7 | (defmethod subctypep ((ct1 ccomplex) (ct2 ccomplex)) 8 | (values (equal (ccomplex-ucpt ct1) (ccomplex-ucpt ct2)) t)) 9 | 10 | (defmethod ctype= ((ct1 ccomplex) (ct2 ccomplex)) 11 | (values (equal (ccomplex-ucpt ct1) (ccomplex-ucpt ct2)) t)) 12 | 13 | (defmethod disjointp ((ct1 ccomplex) (ct2 ccomplex)) 14 | (let ((ucpt1 (ccomplex-ucpt ct1)) (ucpt2 (ccomplex-ucpt ct2))) 15 | (cond ((eq ucpt1 '*) (values t t)) 16 | ((eq ucpt2 '*) (values t t)) 17 | (t (values (equal ucpt1 ucpt2) t))))) 18 | (defmethod conjointp ((ct1 ccomplex) (ct2 ccomplex)) (values nil t)) 19 | 20 | (defmethod cofinitep ((ct ccomplex)) (values nil t)) 21 | 22 | (defmethod conjoin/2 ((ct1 ccomplex) (ct2 ccomplex)) 23 | (let ((ucpt1 (ccomplex-ucpt ct1)) (ucpt2 (ccomplex-ucpt ct2))) 24 | (cond ((eq ucpt1 '*) ct2) 25 | ((eq ucpt2 '*) ct1) 26 | ((equal ucpt1 ucpt2) ct1) 27 | (t (bot))))) 28 | 29 | (defmethod disjoin/2 ((ct1 ccomplex) (ct2 ccomplex)) 30 | (let ((ucpt1 (ccomplex-ucpt ct1)) (ucpt2 (ccomplex-ucpt ct2))) 31 | (cond ((eq ucpt1 '*) ct1) 32 | ((eq ucpt2 '*) ct2) 33 | ((equal ucpt1 ucpt2) ct1) 34 | (t nil)))) 35 | 36 | (defmethod subtract ((ct1 ccomplex) (ct2 ccomplex)) 37 | (let ((ucpt1 (ccomplex-ucpt ct1)) (ucpt2 (ccomplex-ucpt ct2))) 38 | (cond ((eq ucpt2 '*) (bot)) 39 | ((eq ucpt1 '*) nil) 40 | ((equal ucpt1 ucpt2) (bot)) 41 | (t ct1)))) 42 | 43 | (defmethod unparse ((ct ccomplex)) 44 | (let ((ucpt (ccomplex-ucpt ct))) 45 | (if (eq ucpt '*) 46 | 'complex 47 | `(complex ,ucpt)))) 48 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ctype 2 | (:use #:cl) 3 | (:export #:specifier-ctype #:values-specifier-ctype 4 | #:extended-specifier-ctype 5 | #:extended-values-specifier-ctype) 6 | (:export #:ctypep #:subctypep #:ctype=) 7 | (:export #:disjointp #:conjointp #:cofinitep) 8 | (:export #:negate #:conjoin/2 #:disjoin/2 #:subtract #:unparse 9 | #:conjoin #:disjoin) 10 | ;; Useful for extensions. 11 | (:export #:basic 12 | #:every/tri #:some/tri #:notevery/tri #:notany/tri 13 | #:and/tri #:or/tri #:surely 14 | #:defexistential #:defexclusives 15 | #:define-commutative-method 16 | #:define-extended-type 17 | #:+complex-arrays-exist-p+) 18 | ;; Interface to interrogate information about types. 19 | ;; EXPERIMENTAL, SUBJECT TO CHANGE. 20 | (:export #:ctype 21 | #:top #:bot #:top-p #:bot-p 22 | #:values-top #:values-bot #:values-top-p #:values-bot-p 23 | #:function-top #:lambda-list-top #:function-top-p 24 | #:cclass #:cclass-class 25 | #:negation #:negation-ctype 26 | #:conjunction #:disjunction #:junction-ctypes 27 | #:ccons #:ccons-car #:ccons-cdr 28 | #:range #:range-kind #:range-low #:range-high 29 | #:range-low-exclusive-p #:range-high-exclusive-p 30 | #:fpzero #:fpzero-kind #:fpzero-zero 31 | #:ccomplex #:ccomplex-ucpt 32 | #:cmember #:cmember-members 33 | #:carray #:carray-simplicity 34 | #:carray-uaet #:carray-eaet #:carray-dims 35 | #:charset #:charset-pairs 36 | #:cvalues #:cvalues-required #:cvalues-optional #:cvalues-rest 37 | #:lambda-list #:lambda-list-required #:lambda-list-optional 38 | #:lambda-list-rest #:lambda-list-keyp #:lambda-list-key 39 | #:lambda-list-aokp 40 | #:sub-lambda-list-p 41 | #:cfunction #:cfunction-lambda-list #:cfunction-returns 42 | #:csatisfies #:csatisfies-fname)) 43 | -------------------------------------------------------------------------------- /fpzero.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;;; Floating point negative zeroes lead to an unfortunate special case in the 4 | ;;;; CL type system. 5 | ;;;; To review, if distinct negative zeroes exist, (= -0.0 0.0) is true, but 6 | ;;;; (eql -0.0 0.0) is false. This means that (or (eql 0.0) (float (0.0))) 7 | ;;;; cannot be reduced into a range type (or disjunction of them, whatever), 8 | ;;;; because (typep -0.0 '(or (eql 0.0) (float (0.0)))) is false whereas 9 | ;;;; (typep -0.0 '(float 0.0)) is true. 10 | ;;;; To deal with this, we have an entirely separate ctype class, fpzero. 11 | ;;;; An fpzero ctype represents an (eql floating-point-zero) type specifier. 12 | ;;;; Since the problem is mostly in relating to ranges, the important methods 13 | ;;;; for these are in pairwise.lisp, except we do sometimes form ranges here 14 | ;;;; for (or (eql -0.0) (eql 0.0)). 15 | 16 | (defmethod ctypep (object (ctype fpzero)) 17 | (eql object (fpzero-zero ctype))) 18 | 19 | (defmethod subctypep ((ct1 fpzero) (ct2 fpzero)) 20 | (values (eql (fpzero-zero ct1) (fpzero-zero ct2)) t)) 21 | 22 | (defmethod ctype= ((ct1 fpzero) (ct2 fpzero)) 23 | (values (eql (fpzero-zero ct1) (fpzero-zero ct2)) t)) 24 | 25 | (defmethod disjointp ((ct1 fpzero) (ct2 fpzero)) 26 | (values (not (eql (fpzero-zero ct1) (fpzero-zero ct2))) t)) 27 | (defmethod conjointp ((ct1 fpzero) (ct2 fpzero)) (values nil t)) 28 | 29 | (defmethod cofinitep ((ct fpzero)) (values nil t)) 30 | 31 | (defmethod conjoin/2 ((ct1 fpzero) (ct2 fpzero)) 32 | (if (eql (fpzero-zero ct1) (fpzero-zero ct2)) 33 | ct1 34 | (bot))) 35 | 36 | (defmethod disjoin/2 ((ct1 fpzero) (ct2 fpzero)) 37 | (let ((k1 (fpzero-kind ct1)) 38 | (z1 (fpzero-zero ct1)) (z2 (fpzero-zero ct2))) 39 | (cond ((eql z1 z2) ct1) 40 | ;; (member -0.0 0.0): make a range 41 | ((eql z1 (- z2)) (range k1 z1 nil z1 nil)) 42 | (t nil)))) 43 | 44 | (defmethod subtract ((ct1 fpzero) (ct2 fpzero)) 45 | (if (eql (fpzero-zero ct1) (fpzero-zero ct2)) 46 | (bot) 47 | ct1)) 48 | 49 | (defmethod unparse ((ct fpzero)) `(eql ,(fpzero-zero ct))) 50 | -------------------------------------------------------------------------------- /cache.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;;; TODO: Thread safety 4 | 5 | (defmacro cached ((cache &key (nvals 1) (cache-bits '10) (mix 'logxor) 6 | (compare 'eql) (hasher 'sxhash) (evict 't)) 7 | (&rest keys) &body computer) 8 | (let* ((nkeys (length keys)) 9 | (gkeys (loop repeat nkeys collect (gensym "KEY"))) 10 | (gvals (loop repeat nvals collect (gensym "VAL"))) 11 | (ghash (gensym "HASH")) (gcache (gensym "CACHE")) 12 | (gentry (gensym "ENTRY"))) 13 | `(let* ((,gcache ,cache) 14 | ,@(mapcar #'list gkeys keys) 15 | (,ghash (ldb (byte ,cache-bits 0) 16 | (,mix ,@(loop for gkey in gkeys 17 | collect `(,hasher ,gkey))))) 18 | (,gentry (svref ,gcache ,ghash))) 19 | (if (and ,gentry 20 | ;; Hit an entry; see if the keys match 21 | ,@(loop for gkey in gkeys 22 | for i from 0 23 | collect `(,compare ,gkey (svref ,gentry ,i)))) 24 | ;; Valid. Return the vals. 25 | (values ,@(loop for i from nkeys below (+ nkeys nvals) 26 | collect `(svref ,gentry ,i))) 27 | ;; Miss or collision. Bummer. Since this is the slow path we 28 | ;; redundantly check ,gentry again, who cares? 29 | (multiple-value-bind (,@gvals) 30 | (progn ,@computer) 31 | (,@(if evict '(progn) `(unless ,gentry)) 32 | ;; gensym not required since COMPUTER is the only user code 33 | (let ((new-entry (make-array ,(+ nkeys nvals)))) 34 | (setf ,@(loop for gkey in gkeys 35 | for i from 0 36 | append `((svref new-entry ,i) ,gkey)) 37 | ,@(loop for gval in gvals 38 | for i from nkeys 39 | append `((svref new-entry ,i) ,gval))) 40 | (setf (svref ,gcache ,ghash) new-entry))) 41 | (values ,@gvals)))))) 42 | -------------------------------------------------------------------------------- /ext/tfun/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.tfun) 2 | 3 | (defun single-value (ctype) 4 | (cvalues (list ctype) nil (bot))) 5 | 6 | (defun constant-type-p (ctype) 7 | (and (typep ctype 'cmember) 8 | (= (length (cmember-members ctype)) 1))) 9 | 10 | (defun constant-type-value (ctype) 11 | (first (cmember-members ctype))) 12 | 13 | ;;; Convenience macros to define some methods common to most generic function 14 | ;;; deriver auxiliaries throughout this system. 15 | ;;; Note that we don't do negations by default, since negation is not 16 | ;;; preserved by all (or indeed most, far as I can tell) functions. 17 | 18 | (defun cjaux (fname params jclass funform) 19 | (let ((type (gensym "TYPE"))) 20 | `(progn 21 | ,@(loop with gclasses = (make-list (length params) 22 | :initial-element 'ctype) 23 | for param in params 24 | for i from 0 25 | for classes = (let ((g (copy-list gclasses))) 26 | (setf (nth i g) jclass) 27 | g) 28 | for args = (let ((g (copy-list params))) 29 | (setf (nth i g) type) 30 | g) 31 | collect `(defmethod ,fname (,@(mapcar #'list params classes)) 32 | (apply ,funform 33 | (mapcar (lambda (,type) (,fname ,@args)) 34 | (junction-ctypes ,param)))))))) 35 | 36 | (defmacro defconjunctions (fname (&rest params)) 37 | (cjaux fname params 'conjunction '#'conjoin)) 38 | (defmacro defdisjunctions (fname (&rest params)) 39 | (cjaux fname params 'disjunction '#'disjoin)) 40 | 41 | (defmacro defdefaults (fname (&rest params) 42 | &optional (max-result '(top) mrp)) 43 | `(progn 44 | (defmethod ,fname (,@(loop for param in params 45 | collect `(,param ctype))) 46 | ,max-result) 47 | ,@(when mrp 48 | `((defmethod ,fname :around (,@(loop for param in params 49 | collect `(,param ctype))) 50 | (conjoin (call-next-method) ,max-result)))) 51 | (defconjunctions ,fname (,@params)) 52 | (defdisjunctions ,fname (,@params)))) 53 | -------------------------------------------------------------------------------- /config/ecl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | (defun ratiop (object) (si:ratiop object)) 5 | 6 | (define-constant +floats+ 7 | '((single-float . si:single-float-p) 8 | (double-float . si:double-float-p) 9 | #+long-float 10 | (long-float . si:long-float-p)) 11 | :test #'equal) 12 | 13 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 14 | (define-constant +base-charset+ '((0 . 255)) :test #'equal) 15 | 16 | (define-constant +string-uaets+ '(base-char character) :test #'equal) 17 | 18 | (define-constant +complex-arrays-exist-p+ t) 19 | 20 | (declaim (inline simple-array-p)) 21 | (defun simple-array-p (object) 22 | (si::simple-array-p object)) 23 | 24 | (define-constant +class-aliases+ () :test #'equal) 25 | 26 | (declaim (inline subclassp)) 27 | (defun subclassp (sub super) (si::subclassp sub super)) 28 | 29 | ;;; This is like si::normalize-type, except we return a type specifier and 30 | ;;; whether it expanded, and don't signal an error if something is malformed. 31 | ;;; This obviously uses internals - fragile - but ECL doesn't export this. 32 | (defun typexpand-1 (spec env) 33 | (declare (ignore env)) 34 | (cond ((symbolp spec) 35 | (let ((expander (si:get-sysprop spec 'si::deftype-definition))) 36 | (if expander 37 | (values (funcall expander nil) t) 38 | (values spec nil)))) 39 | ((consp spec) 40 | (let* ((head (car spec)) (args (cdr spec)) 41 | (expander (si:get-sysprop head 'si::deftype-definition))) 42 | (if expander 43 | (values (funcall expander args) t) 44 | (values spec nil)))) 45 | (t (values spec nil)))) 46 | 47 | (defun typexpand (type-specifier environment) 48 | (loop with ever-expanded = nil 49 | do (multiple-value-bind (expansion expandedp) 50 | (typexpand-1 type-specifier environment) 51 | (if expandedp 52 | (setf ever-expanded t type-specifier expansion) 53 | (return (values type-specifier ever-expanded)))))) 54 | 55 | (defmacro complex-ucptp (objectf ucpt) 56 | `(ecase ,ucpt 57 | ((*) t) 58 | ((single-float) (typep ,objectf 'si:complex-single-float)) 59 | ((double-float) (typep ,objectf 'si:complex-double-float)) 60 | ((long-float) (typep ,objectf 'si:complex-long-float)))) 61 | -------------------------------------------------------------------------------- /cclass.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct cclass)) 4 | (subclassp (class-of object) (cclass-class ct))) 5 | 6 | (defmethod subctypep ((ct1 cclass) (ct2 cclass)) 7 | ;; NOTE: If ctypes are supposed to work in the face of future redefinitions, 8 | ;; this should return NIL NIL except with unredefinable classes. 9 | (values (subclassp (cclass-class ct1) (cclass-class ct2)) t)) 10 | 11 | (defmethod ctype= ((ct1 cclass) (ct2 cclass)) 12 | (values (eql (cclass-class ct1) (cclass-class ct2)) t)) 13 | 14 | (defmethod cofinitep ((ct cclass)) (values nil t)) 15 | 16 | ;;; These classes are defined as disjoint in CLHS 4.2.2. 17 | ;;; cons, array, number, and character are not handled as cclasses 18 | ;;; so they don't appear here. function sometimes sort of is. 19 | ;;; condition may not be a class. 20 | ;;; FIXME: Refers to environment 21 | (defparameter *disjoint-classes* 22 | (list (find-class 'symbol) (find-class 'hash-table) (find-class 'function) 23 | (find-class 'readtable) (find-class 'package) (find-class 'pathname) 24 | (find-class 'stream) (find-class 'random-state) (find-class 'restart) 25 | ;; These appear AFTER the system classes, so that even if one of the 26 | ;; system classes is a subclass of structure-object or whatever, it can 27 | ;; be understood to be disjoint from user classes. 28 | (find-class 'structure-object) (find-class 'standard-object))) 29 | 30 | (defmethod disjointp ((ct1 cclass) (ct2 cclass)) 31 | ;; Pick off cases defined by 4.2.2. 32 | (let ((class1 (cclass-class ct1)) (class2 (cclass-class ct2))) 33 | (let ((supct1 (find class1 *disjoint-classes* :test #'subclassp)) 34 | (supct2 (find class2 *disjoint-classes* :test #'subclassp))) 35 | (if (and supct1 supct2 (not (eq supct1 supct2))) 36 | (values t t) 37 | (values nil nil))))) 38 | 39 | (defmethod conjoin/2 ((ct1 cclass) (ct2 cclass)) 40 | (let ((c1 (cclass-class ct1)) (c2 (cclass-class ct2))) 41 | (cond ((eq c1 c2) ct1) 42 | ((disjointp ct1 ct2) (bot)) 43 | ;; These classes may have a common subclass. Who knows? 44 | ;; (Strictly speaking we could check...) 45 | (t nil)))) 46 | 47 | (defmethod disjoin/2 ((ct1 cclass) (ct2 cclass)) 48 | (let ((c1 (cclass-class ct1)) (c2 (cclass-class ct2))) 49 | (cond ((eq c1 c2) ct1) 50 | (t nil)))) 51 | 52 | (defmethod unparse ((ct cclass)) 53 | (class-name (cclass-class ct))) 54 | -------------------------------------------------------------------------------- /config/sicl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | 5 | (defgeneric ratiop (object)) 6 | 7 | (defmethod ratiop (object) 8 | nil) 9 | 10 | (defmethod ratiop ((object ratio)) 11 | t) 12 | 13 | (define-constant +floats+ 14 | '((single-float . sicl-arithmetic:single-float-p) 15 | (double-float . sicl-arithmetic:double-float-p)) 16 | :test #'equal) 17 | 18 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 19 | (define-constant +base-charset+ '((0 . #x10FFFF)) :test #'equal) 20 | 21 | (define-constant +string-uaets+ '(character) :test #'equal) 22 | 23 | (define-constant +complex-arrays-exist-p+ nil) 24 | 25 | (declaim (inline simple-array-p)) 26 | (defun simple-array-p (object) (arrayp object)) 27 | 28 | (define-constant +class-aliases+ 29 | '((sicl-array:array-t (array t)) 30 | (sicl-array:array-bit (array bit)) 31 | (sicl-array:array-unsigned-byte-8 (array (unsigned-byte 8))) 32 | (sicl-array:array-unsigned-byte-32 (array (unsigned-byte 32))) 33 | (sicl-array:array-signed-byte-32 (array (signed-byte 32))) 34 | (sicl-array:array-unsigned-byte-64 (array (unsigned-byte 64))) 35 | (sicl-array:array-signed-byte-64 (array (signed-byte 64))) 36 | (sicl-array:array-character (array character)) 37 | (sicl-array:array-single-float (array single-float)) 38 | (sicl-array:array-double-float (array single-float)) 39 | (sicl-array:array-complex-single-float (array (complex single-float))) 40 | (sicl-array:array-complex-double-float (array (complex double-float))) 41 | (sicl-array:vector-unsigned-byte-8 (vector (unsigned-byte 8))) 42 | (sicl-array:vector-unsigned-byte-32 (vector (unsigned-byte 32))) 43 | (sicl-array:vector-signed-byte-32 (vector (signed-byte 32))) 44 | (sicl-array:vector-unsigned-byte-64 (vector (unsigned-byte 64))) 45 | (sicl-array:vector-signed-byte-64 (vector (signed-byte 64)))) 46 | :test #'equal) 47 | 48 | (declaim (inline subclassp)) 49 | (defun subclassp (sub super) 50 | (member super (sicl-clos:class-precedence-list sub))) 51 | 52 | (defun typexpand (type-specifier environment) 53 | (sicl-type:typexpand type-specifier environment)) 54 | 55 | (defmacro complex-ucptp (objectf ucpt) 56 | `(ecase ,ucpt 57 | ((*) t) 58 | ((single-float) (typep ,objectf 'sicl-arithmetic:complex-single-float)) 59 | ((double-float) (typep ,objectf 'sicl-arithmetic:complex-double-float)) 60 | ((rational) (typep ,objectf 'sicl-arithmetic:complex-rational)))) 61 | -------------------------------------------------------------------------------- /config/README.md: -------------------------------------------------------------------------------- 1 | This system is intended for use in an implementation of `typep` and `subtypep`, and so does not use `cl:typep` or `cl:subtypep` at all. Unfortunately, not all aspects of the type system on a given Lisp system are determinable with standard means without using `typep` and `subtypep`, and must be manually configured per implementation. A config file for an implementation must define the following: 2 | 3 | * `ratiop`: a function that returns true iff its one argument is a ratio. 4 | * `+floats+`: An alist. Each `car` is one of `short-float`, `single-float`, `double-float`, or `long-float`. Each `cdr` is a symbol naming an operator that returns true iff its one argument is of the corresponding type. If the system merges one or more float types, only the float types it actually has should be defined, as explained in the CLHS page on these types. 5 | * `+standard-charset+`: A list of pairs of character codes. Each pair represents an inclusive range. These ranges must not overlap or touch. All character codes for characters of type `standard-char`, and no others, should be included. For example, as mentioned in the file implementations where character codes are as in ASCII will have a `+standard-charset+` of `((10 . 10) (32 . 126))`. 6 | * `+base-charset+`: As `+standard-charset+`, but all and only codes for characters of type `base-char` should be included. 7 | * `+string-uaets+`: A proper list of upgraded array element types. This should be a complete list of all upgraded array element types that are a subtype of `character`. This list is used to parse `string` and `simple-string` types. 8 | * `+complex-arrays-exist-p+`: Must be true iff the implementation has complex arrays, i.e. arrays that are not of type `simple-array`. 9 | * `simple-array-p`: A function that returns true iff its one argument is a simple array. 10 | * `+class-aliases+`: A list. Each element consists of `(class-name type-specifier)`. When the `specifier-ctype` is given the `class-name`, or a class of that name, it will treat it as though it had seen the type specifier instead. This is primarily intended for classes that are subclasses of `array`. 11 | * `subclassp`: A function of two classes, that returns true iff the first is a subclass of the second. 12 | * `typexpand`: A function of a type specifier and an environment, that performs any `deftype` expansions, analogous to `macroexpand`. 13 | * `complex-ucptp`: A macro that expands into code that returns ture iff the object its first form evaluates into, which is a `complex`, has the given upgraded complex part type. 14 | 15 | Additionally, there is a constraint that `char-code-limit` is the actual upper limit of character codes (i.e. there are no positive integers less than `char-code-limit` that are not character codes), and that `cl:upgraded-array-element-type` and `cl:upgraded-complex-part-type` return objects that can be sensibly compared with `cl:equal`. 16 | -------------------------------------------------------------------------------- /negation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct negation)) 4 | (not (ctypep object (negation-ctype ct)))) 5 | 6 | ;;; Negation identities: 7 | ;;; a ^ ~a = 0 8 | ;;; a v ~a = T 9 | ;;; ~~a = a 10 | 11 | ;;; a = a v 0 = a v (b ^ ~b) = (a v b) ^ (a v ~b) 12 | ;;; 0 = a ^ 0 = a ^ (b ^ ~b) = (a ^ b) ^ (a ^ ~b) 13 | ;;; a = a ^ T = a ^ (b v ~b) = (a ^ b) v (a ^ ~b) 14 | ;;; T = a v T = a v (b v ~b) = (a v b) v (a v ~b) 15 | 16 | (defmethod subctypep ((ct1 negation) (ct2 negation)) 17 | ;; ~a <: ~b <=> ~a ^ ~b = ~a <=> ~(a v b) = ~a <=> a v b = a <=> b <: a 18 | (subctypep (negation-ctype ct2) (negation-ctype ct1))) 19 | (defmethod subctypep ((ct1 ctype) (ct2 negation)) 20 | ;; a ^ b = 0 => 0 v (a ^ ~b) = a <=> a ^ ~b = a <=> a <: ~b 21 | ;; a <: ~b <=> a ^ ~b = a => (a ^ b) ^ a = 0 <=> a ^ b = 0 22 | ;; therefore, a ^ b = 0 <=> a <: ~b 23 | (disjointp ct1 (negation-ctype ct2))) 24 | (defmethod subctypep ((ct1 negation) (ct2 ctype)) 25 | ;; ~b <: a <=> ~b v a = a => (a v b) v a = T <=> a v b = T 26 | ;; a v b = T => T ^ (a v ~b) = a <=> a v ~b = a <=> ~b <: a 27 | ;; therefore, a v b = T <=> ~b <: a 28 | (conjointp ct2 (negation-ctype ct1))) 29 | 30 | (defmethod ctype= ((ct1 negation) (ct2 negation)) 31 | (ctype= (negation-ctype ct1) (negation-ctype ct2))) 32 | 33 | (defmethod disjointp ((ct1 negation) (ct2 negation)) 34 | ;; ~a ^ ~b = 0 <=> ~(a v b) = 0 <=> a v b = T 35 | (conjointp (negation-ctype ct1) (negation-ctype ct2))) 36 | (define-commutative-method disjointp ((ct1 negation) (ct2 ctype)) 37 | (subctypep ct2 (negation-ctype ct1))) 38 | 39 | (defmethod conjointp ((ct1 negation) (ct2 negation)) 40 | ;; ~a v ~b = T <=> ~(a ^ b) = T <=> a ^ b = 0 41 | (disjointp (negation-ctype ct1) (negation-ctype ct2))) 42 | (define-commutative-method conjointp ((ct1 negation) (ct2 ctype)) 43 | (subctypep (negation-ctype ct1) ct2)) 44 | 45 | (defmethod negate ((ctype negation)) (negation-ctype ctype)) 46 | 47 | (defmethod conjoin/2 ((ct1 negation) (ct2 negation)) 48 | (let ((nt1 (negation-ctype ct1)) (nt2 (negation-ctype ct2))) 49 | ;; a <: b => ~b <: ~a => ~b ^ ~a = ~b 50 | (cond ((subctypep nt1 nt2) ct2) 51 | ((subctypep nt2 nt1) ct1) 52 | (t 53 | ;; Give de Morgan a shot. 54 | (let ((p (disjoin/2 nt1 nt2))) 55 | (if p 56 | (negate p) 57 | nil)))))) 58 | (define-commutative-method conjoin/2 ((ct1 negation) (ct2 ctype)) 59 | (subtract ct2 (negation-ctype ct1))) 60 | 61 | (defmethod disjoin/2 ((ct1 negation) (ct2 negation)) 62 | (let ((nt1 (negation-ctype ct1)) (nt2 (negation-ctype ct2))) 63 | ;; a <: b => ~b <: ~a => ~b v ~a = ~a 64 | (cond ((subctypep nt1 nt2) ct1) 65 | ((subctypep nt2 nt1) ct2) 66 | (t (let ((p (conjoin/2 nt1 nt2))) 67 | (if p 68 | (negate p) 69 | nil)))))) 70 | (define-commutative-method disjoin/2 ((ct1 negation) (ct2 ctype)) 71 | (if (subctypep (negation-ctype ct1) ct2) 72 | (top) 73 | nil)) 74 | 75 | (defmethod subtract ((ct1 ctype) (ct2 negation)) 76 | (conjoin/2 ct1 (negation-ctype ct2))) 77 | 78 | (defmethod unparse ((ct negation)) 79 | (let ((up (unparse (negation-ctype ct)))) 80 | (if (eq up 'cons) 81 | 'atom 82 | `(not ,up)))) 83 | -------------------------------------------------------------------------------- /create.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;; Make conjunctions and disjunctions. 4 | (defun conjunction (&rest ctypes) 5 | (cond ((null ctypes) (top)) 6 | ((null (rest ctypes)) (first ctypes)) 7 | (t (make-instance 'conjunction :ctypes ctypes)))) 8 | (defun disjunction (&rest ctypes) 9 | (cond ((null ctypes) (bot)) 10 | ((null (rest ctypes)) (first ctypes)) 11 | (t (make-instance 'disjunction :ctypes ctypes)))) 12 | 13 | ;;; top and bottom types are special cases, so we give them particular 14 | ;;; identities. Normalized top ctypes must be identical to (top) and 15 | ;;; normalized bottom ctypes must be identical to (bot). 16 | 17 | (defvar *top* (make-instance 'conjunction :ctypes nil) #+(or)(conjunction nil)) 18 | (defvar *bot* (make-instance 'disjunction :ctypes nil) #+(or)(disjunction nil)) 19 | 20 | (defun top () *top*) 21 | (defun top-p (ctype) (eq ctype *top*)) 22 | 23 | (defun bot () *bot*) 24 | (defun bot-p (ctype) (eq ctype *bot*)) 25 | 26 | ;;; Others 27 | (defun negation (ctype) (make-instance 'negation :ctype ctype)) 28 | 29 | (defun cclass (class) (make-instance 'cclass :class class)) 30 | 31 | (defun ccons (car cdr) 32 | (if (or (bot-p car) (bot-p cdr)) 33 | (bot) 34 | (make-instance 'ccons :car car :cdr cdr))) 35 | 36 | (defun range (kind low lxp high hxp) 37 | (multiple-value-bind (low lxp high hxp) 38 | (if (eq kind 'integer) 39 | (values (if (and low lxp) (1+ low) low) nil 40 | (if (and high hxp) (1- high) high) nil) 41 | (values low lxp high hxp)) 42 | (if (and low high (or (> low high) (and (= low high) (or lxp hxp)))) 43 | (bot) 44 | (make-instance 'range 45 | :kind kind :low low :lxp lxp :high high :hxp hxp)))) 46 | 47 | (defun fpzero (kind zero) (make-instance 'fpzero :kind kind :zero zero)) 48 | 49 | (defun charset (pairs) 50 | (if (null pairs) 51 | (bot) 52 | (make-instance 'charset :pairs pairs))) 53 | 54 | (defun carray (simplicity uaet eaet dims) 55 | (make-instance 'carray 56 | :simplicity simplicity :uaet uaet :eaet eaet :dims dims)) 57 | 58 | (defun ccomplex (ucpt) (make-instance 'ccomplex :ucpt ucpt)) 59 | 60 | (defun cmember (&rest members) 61 | (if members 62 | (make-instance 'cmember :members members) 63 | (bot))) 64 | 65 | (defun cvalues (required optional rest) 66 | (make-instance 'cvalues 67 | :required required :optional optional :rest rest)) 68 | 69 | (defun values-top () (cvalues nil nil (top))) 70 | ;; Note that this is NOT (values &rest nil), the type of (values). 71 | ;; This type indicates no values are possible, as from an error. 72 | ;; In the future, there may be a distinguished representation for this. 73 | (defun values-bot () (cvalues (list (bot)) nil (bot))) 74 | 75 | (defun single-value (ctype) 76 | (assert (not (cvalues-p ctype))) 77 | (cvalues (list ctype) nil (bot))) 78 | 79 | (defun csatisfies (fname) 80 | (make-instance 'csatisfies :fname fname)) 81 | 82 | (defun cfunction (lambda-list returns) 83 | (make-instance 'cfunction :lambda-list lambda-list :returns returns)) 84 | 85 | (defun lambda-list-top () 86 | (make-instance 'lambda-list 87 | :required nil :optional nil :rest (top) 88 | :keyp nil :keys nil :aokp nil)) 89 | 90 | (defun function-top () 91 | (cfunction (lambda-list-top) (values-top))) 92 | -------------------------------------------------------------------------------- /cmember.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct cmember)) 4 | (member object (cmember-members ct))) 5 | 6 | (defmethod subctypep ((ct1 cmember) (ct2 ctype)) 7 | (values (loop for m in (cmember-members ct1) 8 | always (ctypep m ct2)) 9 | t)) 10 | (defmethod subctypep ((ct1 cmember) (ct2 cmember)) 11 | (values (subsetp (cmember-members ct1) (cmember-members ct2)) t)) 12 | 13 | (define-commutative-method disjointp ((cmember cmember) (ctype ctype)) 14 | (values 15 | (notany (lambda (single-member) 16 | (ctypep single-member ctype)) 17 | (cmember-members cmember)) 18 | t)) 19 | 20 | (defmethod conjointp ((ct1 cmember) (ct2 cmember)) (values nil t)) 21 | 22 | (defmethod cofinitep ((ct cmember)) (values nil t)) 23 | 24 | (defmethod conjoin/2 ((ct1 cmember) (ct2 cmember)) 25 | (apply #'cmember 26 | (intersection (cmember-members ct1) (cmember-members ct2)))) 27 | 28 | (define-commutative-method conjoin/2 ((cmember cmember) (ctype ctype)) 29 | ;; FIXME: Could save a little consing by checking subctypep first I guess. 30 | (apply #'cmember 31 | (loop for mem in (cmember-members cmember) 32 | when (ctypep mem ctype) collect mem))) 33 | 34 | (defmethod disjoin/2 ((ct1 cmember) (ct2 cmember)) 35 | (apply #'cmember (union (cmember-members ct1) (cmember-members ct2)))) 36 | 37 | (define-commutative-method disjoin/2 ((cmember cmember) (ctype ctype)) 38 | (let ((non (loop with diff = nil 39 | for mem in (cmember-members cmember) 40 | if (ctypep mem ctype) 41 | do (setf diff t) 42 | else 43 | collect mem 44 | ;; If there's no change, give up to avoid recursion 45 | finally (unless diff (return-from disjoin/2 nil))))) 46 | (if non 47 | (disjunction (apply #'cmember non) ctype) 48 | ctype))) 49 | 50 | (defmethod subtract ((ct1 cmember) (ct2 cmember)) 51 | (apply #'cmember 52 | (set-difference (cmember-members ct1) (cmember-members ct2)))) 53 | (defmethod subtract ((ct1 cmember) (ct2 ctype)) 54 | (apply #'cmember 55 | (loop with some = nil 56 | for mem in (cmember-members ct1) 57 | if (ctypep mem ct2) 58 | do (setf some t) 59 | else 60 | collect mem 61 | finally (unless some (return-from subtract ct1))))) 62 | (defmethod subtract ((ct1 ctype) (ct2 cmember)) 63 | (let ((new 64 | (loop with never = t ; are all members not of the ctype? 65 | with diff = nil ; is some member not of the ctype? 66 | for mem in (cmember-members ct2) 67 | if (ctypep mem ct1) 68 | collect mem 69 | and do (setf never nil) 70 | else do (setf diff t) 71 | finally (cond (never (return-from subtract ct1)) 72 | ((not diff) (return-from subtract nil)))))) 73 | (conjunction ct1 (negation (apply #'cmember new))))) 74 | 75 | (defmethod unparse ((ct cmember)) 76 | (let ((mems (cmember-members ct))) 77 | (cond ((equal mems '(nil)) 'null) 78 | ((or (equal mems '(nil t)) (equal mems '(t nil))) 'boolean) 79 | ((null (rest mems)) `(eql ,(first mems))) 80 | (t `(member ,@(cmember-members ct)))))) 81 | -------------------------------------------------------------------------------- /ext/tfun/conses.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.tfun) 2 | 3 | ;;; This is dangerous, since the result of CONS can be subsequently mutated 4 | ;;; into having some other type. 5 | #+(or) 6 | (progn 7 | ;;; generic so that e.g. (cons foo (list-of foo)) could be (list-of foo) 8 | (defgeneric tcons (car cdr)) 9 | (defmethod tcons ((car ctype) (cdr ctype)) (ccons car cdr)) 10 | 11 | (define-tfun cons (car cdr) (single-value (tcons car cdr))) 12 | ) 13 | 14 | (defgeneric tcar (list)) 15 | (defdefaults tcar (x)) 16 | ;; negation is not preserved: (car (the (cons null) x)) is null, 17 | ;; but (car (the (not (cons null))) x) is T since null <: (not cons) 18 | (defmethod tcar ((list cmember)) 19 | (let* ((members (cmember-members list)) 20 | (ccars (loop for mem in members 21 | when (consp mem) 22 | collect (car mem)))) 23 | (if (member nil members) 24 | (apply #'cmember nil ccars) 25 | (apply #'cmember ccars)))) 26 | (defmethod tcar ((list ccons)) (ccons-car list)) 27 | 28 | (defgeneric tcdr (list)) 29 | (defdefaults tcdr (x)) 30 | (defmethod tcdr ((list cmember)) 31 | (let* ((members (cmember-members list)) 32 | (ccdrs (loop for mem in members 33 | when (consp mem) 34 | collect (cdr mem)))) 35 | (if (member nil members) 36 | (apply #'cmember nil ccdrs) 37 | (apply #'cmember ccdrs)))) 38 | (defmethod tcdr ((list ccons)) (ccons-cdr list)) 39 | 40 | (macrolet ((defcr (name &rest ops) 41 | (labels ((rec (ops) 42 | (if ops 43 | `(,(first ops) ,(rec (rest ops))) 44 | 'x))) 45 | `(define-tfun ,name (x) 46 | (single-value ,(rec ops)))))) 47 | (defcr car tcar) 48 | (defcr cdr tcdr) 49 | 50 | (defcr caar tcar tcar) 51 | (defcr cadr tcar tcdr) 52 | (defcr cdar tcdr tcar) 53 | (defcr cddr tcdr tcdr) 54 | (defcr caaar tcar tcar tcar) 55 | (defcr caadr tcar tcar tcdr) 56 | (defcr cadar tcar tcdr tcar) 57 | (defcr caddr tcar tcdr tcdr) 58 | (defcr cdaar tcdr tcar tcar) 59 | (defcr cdadr tcdr tcar tcdr) 60 | (defcr cddar tcdr tcdr tcar) 61 | (defcr cdddr tcdr tcdr tcdr) 62 | (defcr caaaar tcar tcar tcar tcar) 63 | (defcr caaadr tcar tcar tcar tcdr) 64 | (defcr caadar tcar tcar tcdr tcar) 65 | (defcr caaddr tcar tcar tcdr tcdr) 66 | (defcr cadaar tcar tcdr tcar tcar) 67 | (defcr cadadr tcar tcdr tcar tcdr) 68 | (defcr caddar tcar tcdr tcdr tcar) 69 | (defcr cadddr tcar tcdr tcdr tcdr) 70 | (defcr cdaaar tcdr tcar tcar tcar) 71 | (defcr cdaadr tcdr tcar tcar tcdr) 72 | (defcr cdadar tcdr tcar tcdr tcar) 73 | (defcr cdaddr tcdr tcar tcdr tcdr) 74 | (defcr cddaar tcdr tcdr tcar tcar) 75 | (defcr cddadr tcdr tcdr tcar tcdr) 76 | (defcr cdddar tcdr tcdr tcdr tcar) 77 | (defcr cddddr tcdr tcdr tcdr tcdr) 78 | 79 | (defcr rest tcdr) 80 | (defcr first tcar) 81 | (defcr second tcar tcdr) 82 | (defcr third tcar tcdr tcdr) 83 | (defcr fourth tcar tcdr tcdr tcdr) 84 | (defcr fifth tcar tcdr tcdr tcdr tcdr) 85 | (defcr sixth tcar tcdr tcdr tcdr tcdr tcdr) 86 | (defcr seventh tcar tcdr tcdr tcdr tcdr tcdr tcdr) 87 | (defcr eighth tcar tcdr tcdr tcdr tcdr tcdr tcdr tcdr) 88 | (defcr ninth tcar tcdr tcdr tcdr tcdr tcdr tcdr tcdr tcdr) 89 | (defcr tenth tcar tcdr tcdr tcdr tcdr tcdr tcdr tcdr tcdr tcdr)) 90 | -------------------------------------------------------------------------------- /ext/data-structures/hash-table-of.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.data-structures) 2 | 3 | (defclass chash-table-of (ctype) 4 | ((%key-type :initarg :key :reader key-ctype) 5 | (%value-type :initarg :value :reader value-ctype)) 6 | (:documentation "Homogeneous hash-table ctype.")) 7 | 8 | (defmethod unparse ((object chash-table-of)) 9 | `(hash-table-of ,(unparse (key-ctype object)) 10 | ,(unparse (value-ctype object)))) 11 | 12 | (defun chash-table-of (key-ctype value-ctype) 13 | (make-instance 14 | 'chash-table-of 15 | :key key-ctype 16 | :value value-ctype)) 17 | 18 | (define-extended-type hash-table-of (key-type value-type &environment env) 19 | :documentation "A hash-table whose keys are of type KEY-TYPE and values are of type VALUE-TYPE." 20 | :simple ((declare (ignore key-type value-type env)) 21 | 'hash-table) 22 | :extended 23 | ((chash-table-of (extended-specifier-ctype key-type env) 24 | (extended-specifier-ctype value-type env)))) 25 | 26 | (defmethod ctypep ((object t) (ctype chash-table-of)) nil) 27 | (defmethod ctypep ((object hash-table) (ctype chash-table-of)) 28 | (let ((key-ctype (key-ctype ctype)) 29 | (value-ctype (value-ctype ctype))) 30 | (loop for key being each hash-key of object using (hash-value value) do 31 | (unless (and (ctypep key key-ctype) 32 | (ctypep value value-ctype)) 33 | (return-from ctypep nil)))) 34 | t) 35 | 36 | (defun compare-chash-table-of (predicate combiner ctype1 ctype2) 37 | (let ((key1 (key-ctype ctype1)) 38 | (key2 (key-ctype ctype2)) 39 | (value1 (value-ctype ctype1)) 40 | (value2 (value-ctype ctype2))) 41 | (multiple-value-bind (key-comparison key-valid) (funcall predicate key1 key2) 42 | (multiple-value-bind (value-comparison value-valid) (funcall predicate value1 value2) 43 | (values (funcall combiner #'identity (list key-comparison value-comparison)) 44 | (funcall combiner #'identity (list key-valid value-valid))))))) 45 | 46 | (defmethod subctypep ((ctype1 chash-table-of) (ctype2 cclass)) 47 | (values 48 | (eql (find-class 'hash-table) 49 | (cclass-class ctype2)) 50 | t)) 51 | 52 | (defmethod subctypep ((ctype1 chash-table-of) (ctype2 chash-table-of)) 53 | (compare-chash-table-of 54 | #'subctypep #'every 55 | ctype1 ctype2)) 56 | 57 | (defmethod ctype= ((ctype1 chash-table-of) (ctype2 chash-table-of)) 58 | (compare-chash-table-of 59 | #'ctype= #'every 60 | ctype1 ctype2)) 61 | 62 | (defmethod disjointp ((ctype1 chash-table-of) (ctype2 chash-table-of)) 63 | (compare-chash-table-of 64 | #'disjointp #'some 65 | ctype1 ctype2)) 66 | 67 | (defmethod cofinitep ((ctype chash-table-of)) (values nil t)) 68 | 69 | (defmethod conjoin/2 ((ct1 chash-table-of) (ct2 chash-table-of)) 70 | (let ((key (conjoin (key-ctype ct1) (key-ctype ct2))) 71 | (value (conjoin (value-ctype ct1) (value-ctype ct2)))) 72 | (if (or (bot-p key) (bot-p value)) 73 | (bot) 74 | (chash-table-of key value)))) 75 | 76 | (defmethod subtract ((ct1 chash-table-of) (ct2 chash-table-of)) 77 | (let ((key (conjoin (key-ctype ct1) (negate (key-ctype ct2)))) 78 | (value (conjoin (value-ctype ct1) (negate (value-ctype ct2))))) 79 | (if (or (bot-p key) (bot-p value)) 80 | (bot) 81 | (chash-table-of key value)))) 82 | 83 | (defexclusives chash-table-of range ccomplex carray charset cfunction fpzero) 84 | 85 | (define-commutative-method conjointp ((ct1 cclass) (ct2 chash-table-of)) 86 | (values nil t)) 87 | 88 | (defexistential chash-table-of) 89 | -------------------------------------------------------------------------------- /cvalues.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defun values-top-p (cvalues) 4 | ;; there can be no required values, because we use strict semantics, and 5 | ;; "at least one value" is less inclusive than "any number of values". 6 | (and (null (cvalues-required cvalues)) 7 | (every #'top-p (cvalues-optional cvalues)) 8 | (top-p (cvalues-rest cvalues)))) 9 | 10 | (defun values-bot-p (cvalues) 11 | (some #'bot-p (cvalues-required cvalues))) 12 | 13 | (defmethod ctypep (object (ct cvalues)) 14 | (declare (ignore object)) 15 | (error "Values ctype ~a cannot be used with ~a" ct 'ctypep)) 16 | 17 | (defmethod subctypep ((ct1 cvalues) (ct2 cvalues)) 18 | (let ((req1 (cvalues-required ct1)) (req2 (cvalues-required ct2)) 19 | (opt1 (cvalues-optional ct1)) (opt2 (cvalues-optional ct2)) 20 | (rest1 (cvalues-rest ct1)) (rest2 (cvalues-rest ct2))) 21 | (if (> (length req2) (length req1)) 22 | (values nil t) 23 | (loop with surety = t 24 | for sct1 = (or (pop req1) (pop opt1) rest1) 25 | for sct2 = (or (pop req2) (pop opt2) rest2) 26 | do (multiple-value-bind (val subsurety) 27 | (subctypep sct1 sct2) 28 | (cond ((not subsurety) (setf surety nil)) 29 | ((not val) (return-from subctypep (values nil t))))) 30 | until (and (null req1) (null req2) (null opt1) (null opt2)) 31 | finally (return (if surety (values t t) (values nil nil))))))) 32 | 33 | (defmethod conjoin/2 ((ct1 cvalues) (ct2 cvalues)) 34 | (let ((req1 (cvalues-required ct1)) (req2 (cvalues-required ct2)) 35 | (opt1 (cvalues-optional ct1)) (opt2 (cvalues-optional ct2)) 36 | (rest1 (cvalues-rest ct1)) (rest2 (cvalues-rest ct2))) 37 | (let* ((req (if (and (null req1) (null req2)) 38 | nil 39 | (loop for sct1 = (or (pop req1) (pop opt1) rest1) 40 | for sct2 = (or (pop req2) (pop opt2) rest2) 41 | for conj = (conjoin sct1 sct2) 42 | if (bot-p conj) 43 | do (return-from conjoin/2 conj) 44 | else collect conj 45 | until (and (null req1) (null req2))))) 46 | (opt (if (and (null opt1) (null opt2)) 47 | nil 48 | (loop for sct1 = (or (pop opt1) rest1) 49 | for sct2 = (or (pop opt2) rest2) 50 | for conj = (conjoin sct1 sct2) 51 | if (bot-p conj) 52 | ;; This &optional is bottom, and so neither this 53 | ;; value nor any later values can be provided. 54 | do (return-from conjoin/2 (cvalues req opts conj)) 55 | else collect conj into opts 56 | until (and (null opt1) (null opt2)) 57 | finally (return opts)))) 58 | (rest (conjoin rest1 rest2))) 59 | (cvalues req opt rest)))) 60 | 61 | ;;; Disjunctions are much more limited; for example 62 | ;;; (or (values null null) (values cons cons)) 63 | ;;; is a strict subtype of (values list list), which additionally includes 64 | ;;; (values nil '(nil)) and such. 65 | ;;; If we canonicalize single-value types into not-cvalues I think we don't 66 | ;;; really need to handle values disjunctions specially. 67 | ;;; Negation and subtraction are complicated for similar reasons. 68 | 69 | (defmethod unparse ((ct cvalues)) 70 | `(values ,@(mapcar #'unparse (cvalues-required ct)) 71 | ,@(let ((opt (cvalues-optional ct))) 72 | (when opt 73 | `(&optional ,@(mapcar #'unparse opt)))) 74 | &rest ,(unparse (cvalues-rest ct)))) 75 | -------------------------------------------------------------------------------- /ctype.asd: -------------------------------------------------------------------------------- 1 | (defsystem :ctype 2 | :description "An implementation of the Common Lisp type system." 3 | :license "BSD" 4 | :author "Bike " 5 | :depends-on () 6 | :components 7 | ((:file "packages") 8 | (:file "trivalent" :depends-on ("packages")) 9 | (:file "method-combination" :depends-on ("packages")) 10 | (:module "config" 11 | :serial t 12 | :components ((:file "common") 13 | (:file "abcl" :if-feature :abcl) 14 | (:file "clasp" :if-feature :clasp) 15 | (:file "sbcl" :if-feature :sbcl) 16 | (:file "ccl" :if-feature :ccl) 17 | (:file "cmucl" :if-feature :cmucl) 18 | (:file "sicl" :if-feature :sicl) 19 | (:file "ecl" :if-feature :ecl) 20 | (:file "unsupported" 21 | :if-feature (:not (:or :abcl :clasp :sbcl :ccl :cmucl :sicl :ecl))) 22 | (:file "common-post"))) 23 | (:file "classes" :depends-on ("packages")) 24 | (:file "create" :depends-on ("classes" "packages")) 25 | (:file "generic-functions" 26 | :depends-on ("trivalent" "method-combination" "create" "classes" 27 | "packages")) 28 | (:file "cclass" 29 | :depends-on ("generic-functions" "classes" "config" "packages")) 30 | (:file "negation" 31 | :depends-on ("generic-functions" "create" "classes" "trivalent" "packages")) 32 | (:file "conjunction" 33 | :depends-on ("generic-functions" "create" "classes" "trivalent" "packages")) 34 | (:file "disjunction" 35 | :depends-on ("generic-functions" "create" "classes" "trivalent" "packages")) 36 | (:file "ccons" 37 | :depends-on ("generic-functions" "create" "classes" "trivalent" "packages")) 38 | (:file "range" 39 | :depends-on ("generic-functions" "create" "classes" "config" "packages")) 40 | (:file "fpzero" 41 | :depends-on ("generic-functions" "create" "classes" "packages")) 42 | (:file "ccomplex" 43 | :depends-on ("generic-functions" "create" "classes" "config" "packages")) 44 | (:file "cmember" 45 | :depends-on ("generic-functions" "create" "classes" "packages")) 46 | (:file "carray" 47 | :depends-on ("generic-functions" "create" "classes" "packages")) 48 | (:file "charset" 49 | :depends-on ("generic-functions" "create" "classes" "config" "packages")) 50 | (:file "cvalues" 51 | :depends-on ("generic-functions" "create" "classes" "packages")) 52 | (:file "cfunction" 53 | :depends-on ("cvalues" "generic-functions" "create" "classes" "packages")) 54 | (:file "csatisfies" 55 | :depends-on ("generic-functions" "create" "classes" "packages")) 56 | (:file "pairwise" 57 | :depends-on ("generic-functions" "trivalent" "create" "classes" 58 | "cfunction" "packages")) 59 | (:file "parse" 60 | :depends-on ("generic-functions" "create" "classes" "config" "packages")))) 61 | 62 | (asdf:defsystem :ctype/ext 63 | :license "BSD" 64 | :depends-on (:ctype :alexandria) 65 | :components 66 | ((:module "ext" 67 | :components 68 | ((:file "packages") 69 | (:module "data-structures" 70 | :depends-on ("packages") 71 | :components 72 | ((:file "list-of") 73 | (:file "plist" :depends-on ("list-of")) 74 | (:file "array-of") 75 | (:file "hash-table-of"))))))) 76 | 77 | (defsystem :ctype/tfun 78 | :description "Derived function return types for Common Lisp." 79 | :license "BSD" 80 | :author "Bike " 81 | :depends-on (:ctype :alexandria) 82 | :components 83 | ((:module "ext" 84 | :components 85 | ((:module "tfun" 86 | :components 87 | ((:file "packages") 88 | (:file "util" :depends-on ("packages")) 89 | (:file "tfun" :depends-on ("packages")) 90 | (:file "data-and-control-flow" :depends-on ("util" "tfun" "packages")) 91 | (:file "numbers" :depends-on ("util" "tfun" "packages")) 92 | (:file "conses" :depends-on ("util" "tfun" "packages")) 93 | (:file "arrays" :depends-on ("util" "tfun" "packages")))))))) 94 | -------------------------------------------------------------------------------- /ext/data-structures/list-of.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.data-structures) 2 | 3 | (defclass clist-of (ctype) 4 | ((%etype :initarg :etype :reader element-ctype)) 5 | (:documentation "Proper homogeneous list ctype.")) 6 | 7 | (defmethod unparse ((object clist-of)) 8 | `(list-of ,(unparse (element-ctype object)))) 9 | 10 | (defun clist-of (ect) 11 | (if (bot-p ect) 12 | (cmember nil) 13 | (make-instance 'clist-of :etype ect))) 14 | 15 | (define-extended-type list-of (element-type &environment env) 16 | :documentation "A proper list whose elements are all of type ELEMENT-TYPE." 17 | :simple ((declare (ignore element-type env)) 18 | 'list) 19 | :extended 20 | ((clist-of (extended-specifier-ctype element-type env)))) 21 | 22 | (defmethod ctypep ((object null) (ct clist-of)) t) 23 | (defmethod ctypep ((object cons) (ct clist-of)) 24 | (let ((ect (element-ctype ct))) 25 | (and (ctypep (car object) ect) 26 | ;; Traverse circular lists carefully 27 | (loop for sub = (cdr object) then (cdr sub) 28 | until (or (null sub) (eq sub object)) 29 | unless (ctypep (car sub) ect) 30 | return nil 31 | finally (return t))))) 32 | (defmethod ctypep ((object t) (ct clist-of)) nil) 33 | 34 | (defmethod subctypep ((ct1 clist-of) (ct2 clist-of)) 35 | (subctypep (element-ctype ct1) (element-ctype ct2))) 36 | (defmethod ctype= ((ct1 clist-of) (ct2 clist-of)) 37 | (ctype= (element-ctype ct1) (element-ctype ct2))) 38 | 39 | (defmethod disjointp ((ct1 clist-of) (ct2 clist-of)) 40 | (disjointp (element-ctype ct1) (element-ctype ct2))) 41 | (defmethod conjointp ((ct1 clist-of) (ct2 clist-of)) (values nil t)) 42 | 43 | (defmethod cofinitep ((ct clist-of)) (values nil t)) 44 | 45 | (defmethod conjoin/2 ((ct1 clist-of) (ct2 clist-of)) 46 | (clist-of (conjoin (element-ctype ct1) (element-ctype ct2)))) 47 | (defmethod disjoin/2 ((ct1 clist-of) (ct2 clist-of)) 48 | (clist-of (disjoin (element-ctype ct1) (element-ctype ct2)))) 49 | 50 | (defmethod subtract ((ct1 clist-of) (ct2 clist-of)) 51 | (clist-of (conjoin (element-ctype ct1) (negate (element-ctype ct2))))) 52 | 53 | ;;; 54 | 55 | (defmethod subctypep ((ct1 clist-of) (ct2 ccons)) 56 | ;; clist-of includes nil, a non-cons 57 | (values nil t)) 58 | (defmethod subctypep ((ct1 ccons) (ct2 clist-of)) 59 | (let ((element-type (element-ctype ct2))) 60 | (do ((ct1 ct1 (ccons-cdr ct1))) 61 | ((ctype= (cmember nil) ct1) 62 | (values t t)) 63 | (let ((type (ccons-car ct1))) 64 | (unless (subctypep type element-type) 65 | (return-from subctypep (values nil t))))))) 66 | 67 | (defmethod subctypep ((ct1 cmember) (ct2 clist-of)) 68 | (values (equal (cmember-members ct1) '(nil)) t)) 69 | 70 | (define-commutative-method disjointp ((clist-of clist-of) (ccons ccons)) 71 | (or/tri (disjointp (ccons-car ccons) (element-ctype clist-of)) 72 | (disjointp (ccons-cdr ccons) clist-of))) 73 | 74 | (define-commutative-method disjointp ((clist-of clist-of) (cmember cmember)) 75 | (values (not (member nil (cmember-members cmember))) t)) 76 | 77 | (defexclusives clist-of range ccomplex carray charset cfunction fpzero) 78 | 79 | (define-commutative-method conjointp ((ct1 clist-of) (ct2 cclass)) 80 | (values nil t)) 81 | 82 | ;;; LIST is a subtype of SEQUENCE, so all CLIST-OF types are as well. 83 | (defun sequence-cclass-p (cclass) 84 | (eq (class-name (cclass-class cclass)) 'sequence)) 85 | (defmethod subctypep ((ct1 clist-of) (ct2 cclass)) 86 | (values (sequence-cclass-p ct2) t)) 87 | (defmethod subctypep ((ct1 cclass) (ct2 clist-of)) (values nil t)) 88 | (define-commutative-method disjointp ((ct1 clist-of) (ct2 cclass)) 89 | (values (not (sequence-cclass-p ct2)) t)) 90 | (define-commutative-method conjoin/2 ((ct1 clist-of) (ct2 cclass)) 91 | (if (sequence-cclass-p ct2) ct1 (bot))) 92 | (define-commutative-method disjoin/2 ((ct1 clist-of) (ct2 cclass)) 93 | (if (sequence-cclass-p ct2) ct2 nil)) 94 | (defmethod subtract ((ct1 clist-of) (ct2 cclass)) 95 | (if (sequence-cclass-p ct2) (bot) ct1)) 96 | (defmethod subtract ((ct1 cclass) (ct2 clist-of)) 97 | (if (sequence-cclass-p ct1) nil (bot))) 98 | -------------------------------------------------------------------------------- /config/common.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;; Complex constants - this is a cheap version of alexandria:define-constant 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (defun reconstant (name value test) 7 | (if (not (boundp name)) 8 | value 9 | (let ((old (symbol-value name))) 10 | (if (funcall test value old) 11 | old 12 | (error "Cannot redefine constant ~a to ~a" name value)))))) 13 | 14 | (defmacro define-constant (name value &key (test ''eql)) 15 | `(defconstant ,name (reconstant ',name ,value ,test))) 16 | 17 | ;;; Template for implementation-specific-code 18 | #+(or) 19 | (progn 20 | 21 | ;; Is OBJECT a ratio? 22 | (defun ratiop (object) ...) ; determine whether OBJECT is a ratio 23 | 24 | ;; An alist from existing float subtypes to the names of predicates for them 25 | (define-constant +floats+ '(...) :test #'equal) 26 | 27 | #| 28 | +standard-charset+ and +base-charset+ are lists of conses 29 | and each cons represents a range of character codes. 30 | ((10 . 10) (32 . 126)) means that character codes 10, 32, 33, ... 125, 126 31 | are the standard characters. 32 | 33 | Here is a helper function that can be used to determine these ranges: 34 | 35 | (defun find-ranges (predicate start end) 36 | (loop :with ranges := nil 37 | :with inside-range-p := nil 38 | :with range-start := nil 39 | :with range-end := nil 40 | :for i :from start :to end 41 | :do (if (funcall predicate (code-char i)) 42 | (if inside-range-p 43 | (incf range-end) 44 | (setq range-start i 45 | range-end i 46 | inside-range-p t)) 47 | (when inside-range-p 48 | (progn 49 | (push (cons range-start range-end) ranges) 50 | (setq inside-range-p nil)))) 51 | :finally (return (nreverse ranges)))) 52 | 53 | Discover +standard-charset+ via: (assuming there are less than 2^20 char codes) 54 | 55 | (find-ranges #'standard-char-p 0 (expt 2 20)) 56 | 57 | and base-charset via 58 | (find-ranges (lambda (x) (typep x 'base-char)) 0 (expt 2 20)) 59 | |# 60 | 61 | ;; Charset for standard-char 62 | ;; If the implementation uses a superset of ASCII, 63 | ;; this will be '((10 . 10) (32 . 126)) 64 | (define-constant +standard-charset+ '(...) :test #'equal) 65 | ;; Charset for base-char 66 | (define-constant +base-charset+ '(...) :test #'equal) 67 | 68 | ;; A list of upgraded array element types for arrays that are strings 69 | (define-constant +string-uaets+ '(...) :test #'equal) 70 | 71 | ;;; This should be true unless (and array (not simple-array)) = NIL. 72 | ;;; This is used only in the parser - if you make array ctypes directly be sure 73 | ;;; to always apply simplicity :simple, if complex arrays do not exist. 74 | ;;; FIXME?: Right now there's no provision for partial existence of complex 75 | ;;; arrays - for example if they only exist for vectors. 76 | (define-constant +complex-arrays-exist-p+ ...) 77 | 78 | ;;; List of (classname type-specifier); specifier-ctype will resolve 79 | ;;; classes with the former name in the same way as it would resolve the 80 | ;;; specifier. CL names (e.g. FIXNUM, SIMPLE-BIT-VECTOR) are already handled 81 | ;;; and don't need to be specified here. 82 | (define-constant +class-aliases+ '(...) :test #'equal) 83 | 84 | ;;; Function that determines of SUB is a subclass of SUPERCLASS. 85 | ;;; Only classes are given as arguments (i.e. not names) 86 | (defun subclassp (sub super) ...) 87 | 88 | ;;; Function that resolves macro types (i.e. those defined with DEFTYPE) at top 89 | ;;; level. Analogously to MACROEXPAND, should return the expansion as the first 90 | ;;; value and a boolean indicating whether any expansion was done as the second. 91 | (defun typexpand (type-specifier environment) ...) 92 | 93 | ;;; Macro defined such that 94 | ;;; (typep object '(complex foo)) is equivalent to 95 | ;;; (complex-ucptp object ufoo), where ufoo is (upgraded-complex-part-type 'foo) 96 | (defmacro complex-ucptp (objectf ucpt) 97 | `(ecase ,ucpt 98 | ((*) t) 99 | ...)) 100 | 101 | ) ; #+(or)(progn ...) 102 | -------------------------------------------------------------------------------- /ext/tfun/data-and-control-flow.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.tfun) 2 | 3 | ;;; approximate 4 | (defun append-values (vty1 vty2) 5 | (let ((r1 (cvalues-required vty1)) (o1 (cvalues-optional vty1)) 6 | (r2 (cvalues-required vty2)) (o2 (cvalues-optional vty2)) 7 | (rest1 (cvalues-rest vty1)) (rest2 (cvalues-rest vty2))) 8 | (if (and (null o1) (bot-p rest1)) 9 | (cvalues (append r1 r2) o2 rest2) ; simple exact case 10 | (cvalues (append r1 (make-list (length r2) :initial-element (top))) 11 | nil (top))))) 12 | 13 | (defgeneric tfuncall (ftype argstype)) 14 | (defmethod tfuncall ((ftype ctype) (argstype cvalues)) (values-top)) 15 | (defmethod tfuncall ((ftype conjunction) (argstype cvalues)) 16 | (apply #'conjoin (mapcar (lambda (f) (tfuncall f argstype)) 17 | (junction-ctypes ftype)))) 18 | (defmethod tfuncall ((ftype disjunction) (argstype cvalues)) 19 | (apply #'disjoin (mapcar (lambda (f) (tfuncall f argstype)) 20 | (junction-ctypes ftype)))) 21 | (defmethod tfuncall ((ftype cfunction) (argstype cvalues)) 22 | (declare (ignore argstype)) ; FIXME?: could check it against the LL 23 | (cfunction-returns ftype)) 24 | (defmethod tfuncall ((ftype tfun) (argstype cvalues)) 25 | (funcall (deriver ftype) argstype)) 26 | 27 | ;;; Exported interface functions 28 | (defun derive-call (ftype &rest argtypes) 29 | (tfuncall ftype (cvalues argtypes nil (bot)))) 30 | (defun derive-multiple-value-call (ftype &rest formtypes) 31 | (cond ((null formtypes) (tfuncall ftype (cvalues nil nil (bot)))) 32 | ((null (rest formtypes)) (tfuncall ftype (first formtypes))) 33 | (t (tfuncall ftype (reduce #'append-values formtypes))))) 34 | 35 | (define-tfun funcall (function &rest args) (tfuncall function args)) 36 | 37 | (define-tfun apply (fun &rest vtype) 38 | ;; We try to derive the type based on the function being called, 39 | ;; by treating (apply f x ... z) as 40 | ;; (multiple-value-call f (values x) ... (values-list z)) 41 | (let* ((req (cvalues-required vtype)) 42 | (opt (cvalues-optional vtype)) 43 | (rest (cvalues-rest vtype)) 44 | (fargstype 45 | (cond ((and (not (null req)) (null opt) (bot-p rest)) 46 | ;; We have the exact arguments to apply, so we can work 47 | ;; out the type of the arguments to the function easily. 48 | (append-values (cvalues (butlast req) nil (bot)) 49 | (tvalues-list (first (last req))))) 50 | (t 51 | ;; We could do better at the general case, but for now, 52 | ;; mostly just punt except getting as many arguments as 53 | ;; possible that definitely aren't the final list. 54 | (cvalues (butlast req) nil (top)))))) 55 | (tfuncall fun fargstype))) 56 | 57 | ;;; 58 | 59 | (define-tfun not (x) 60 | (let ((null (specifier-ctype 'null))) 61 | (cond ((disjointp x null) null) 62 | ((subctypep x null) (negate null)) 63 | (t (top))))) 64 | 65 | (define-tfun eql (x y) 66 | (let ((null (specifier-ctype 'null))) 67 | (single-value 68 | (cond ((disjointp x y) null) 69 | #+(or) 70 | ((and (constantp x) (constantp y) 71 | (eql (constant-value x) (constant-value y))) 72 | (negate null)) 73 | (t (top)))))) 74 | 75 | (define-tfun identity (x) (single-value x)) 76 | 77 | (define-tfun values (&rest input) 78 | ;; VALUES is IDENTITY on the values level 79 | input) 80 | 81 | (defgeneric tvalues-list (list)) 82 | (defmethod tvalues-list ((list ctype)) (values-top)) 83 | (defmethod tvalues-list ((list conjunction)) 84 | (apply #'conjoin (mapcar #'tvalues-list (junction-ctypes list)))) 85 | (defmethod tvalues-list ((list disjunction)) 86 | (apply #'disjoin (mapcar #'tvalues-list (junction-ctypes list)))) 87 | (defmethod tvalues-list ((list ccons)) 88 | (append-values (cvalues (list (ccons-car list)) () (bot)) 89 | (tvalues-list (ccons-cdr list)))) 90 | (defmethod tvalues-list ((list cmember)) 91 | (if (member nil (cmember-members list)) 92 | (cvalues () () (bot)) 93 | (values-bot))) 94 | 95 | (define-tfun values-list (list) (tvalues-list list)) 96 | -------------------------------------------------------------------------------- /generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmacro define-commutative-method (name (arg1 arg2) &body body) 4 | `(progn 5 | (defmethod ,name (,arg1 ,arg2) ,@body) 6 | (defmethod ,name (,arg2 ,arg1) ,@body))) 7 | 8 | (defgeneric ctypep (object ctype) 9 | (:argument-precedence-order ctype object)) 10 | 11 | ;;; To avoid infinite recursion, subctypep must not call negate, conjoin/2, or 12 | ;;; disjoin/2, and so those functions may call subctypep all they want. 13 | ;;; When subctypep or disjointp call themselves or each other, it must be 14 | ;;; ensured that the problem is simpler, e.g. by dropping negations. 15 | (defgeneric subctypep (ctype1 ctype2) 16 | (:method-combination basic surely) 17 | (:method ((ct1 ctype) (ct2 ctype)) (values nil nil))) 18 | 19 | ;;; Optional wrapper to speed up subctypep and make usage clearer. 20 | (defgeneric ctype= (ctype1 ctype2) 21 | (:method-combination basic surely) 22 | (:method ((ct1 ctype) (ct2 ctype)) 23 | (and/tri (subctypep ct1 ct2) (subctypep ct2 ct1)))) 24 | 25 | ;;; Is the conjunction of these types bottom? 26 | ;;; Ditto the restrictions on calling negate etc. 27 | (defgeneric disjointp (ctype1 ctype2) 28 | (:method-combination basic surely) 29 | (:method ((ct1 ctype) (ct2 ctype)) (values nil nil))) 30 | ;;; Dual to disjointp: Is the disjunction of these types top? 31 | (defgeneric conjointp (ctype1 ctype2) 32 | (:method-combination basic surely) 33 | (:method ((ct1 ctype) (ct2 ctype)) (values nil nil))) 34 | 35 | ;;; Ditto the restrictions etc., and returns the same kinds of values. 36 | ;;; Determines whether the negation of a type is finite. This is used to 37 | ;;; resolve questions like (subtypep '(not X) '(member ...)) 38 | (defgeneric cofinitep (ctype) 39 | (:method-combination basic surely) 40 | (:method ((ct ctype)) (values nil nil))) 41 | 42 | (defgeneric negate (ctype) 43 | (:method ((ctype ctype)) (negation ctype))) 44 | 45 | ;;; These two return NIL if no special simplification is possible; 46 | ;;; CONJOIN and DISJOIN will then make a conjunction/disjunction ctype. 47 | (defgeneric conjoin/2 (ctype1 ctype2) 48 | (:method-combination basic or) 49 | (:method ((ct1 ctype) (ct2 ctype)) 50 | (cond ((disjointp ct1 ct2) (bot)) 51 | ((subctypep ct1 ct2) ct1) 52 | ((subctypep ct2 ct1) ct2) 53 | (t nil)))) 54 | (defgeneric disjoin/2 (ctype1 ctype2) 55 | (:method-combination basic or) 56 | (:method ((ct1 ctype) (ct2 ctype)) 57 | (cond ((conjointp ct1 ct2) (top)) ; for completeness more than practicality 58 | ((subctypep ct1 ct2) ct2) 59 | ((subctypep ct2 ct1) ct1) 60 | (t nil)))) 61 | 62 | ;;; Simplifier for (conjoin/2 ct1 (negate ct2)). 63 | ;;; Like the /2, returns NIL if no simplification is apparent. 64 | (defgeneric subtract (ctype1 ctype2) 65 | (:method-combination basic or) 66 | (:argument-precedence-order ctype2 ctype1) 67 | (:method ((ct1 ctype) (ct2 ctype)) 68 | (cond ((disjointp ct1 ct2) ct1) 69 | ((subctypep ct1 ct2) (bot)) 70 | (t nil)))) 71 | 72 | (defgeneric unparse (ctype)) 73 | 74 | (defmethod print-object ((ct ctype) stream) 75 | (multiple-value-bind (unparse failure) 76 | (ignore-errors (unparse ct)) 77 | (if failure 78 | (call-next-method) 79 | (print-unreadable-object (ct stream :type t) 80 | (write unparse :stream stream)))) 81 | ct) 82 | 83 | (macrolet 84 | ((defjoin (name simp junct) 85 | `(defun ,name (&rest ctypes) 86 | ;; If any pairwise junctions are simplifiable, recurse with that. 87 | ;; Otherwise dump into a junction type. 88 | (loop for (ctype1 . rest) on ctypes 89 | do (loop for ctype2 in rest 90 | for j = (,simp ctype1 ctype2) 91 | when j 92 | do (return-from ,name 93 | (apply #',name 94 | (append (substitute j ctype2 rest 95 | :count 1) 96 | unsimplified)))) 97 | collect ctype1 into unsimplified 98 | finally (return (apply #',junct unsimplified)))))) 99 | (defjoin conjoin conjoin/2 conjunction) 100 | (defjoin disjoin disjoin/2 disjunction)) 101 | -------------------------------------------------------------------------------- /ext/tfun/tfun.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.tfun) 2 | 3 | (defclass tfun (ctype) 4 | ((%deriver :initarg :deriver :reader deriver :type cl:function))) 5 | 6 | (defun tfun (deriver) 7 | (make-instance 'tfun :deriver deriver)) 8 | 9 | (defmethod conjointp ((ct1 tfun) (ct2 tfun)) (values nil t)) 10 | (defmethod cofinitep ((ct tfun)) (values nil t)) 11 | 12 | (defmethod subctypep ((ct1 tfun) (ct2 cfunction)) 13 | (if (function-top-p ct2) (values t t) (values nil nil))) 14 | (defmethod subctypep ((ct1 cfunction) (ct2 tfun)) (values nil t)) 15 | (define-commutative-method disjointp ((ct1 tfun) (ct2 cfunction)) 16 | (if (function-top-p ct2) (values nil t) (values nil nil))) 17 | (define-commutative-method conjointp ((ct1 tfun) (ct2 cfunction)) 18 | (values nil t)) 19 | 20 | (defexclusives tfun cclass ccomplex carray charset fpzero range) 21 | 22 | ;;; 23 | 24 | (defmacro destructure-tfunbind (lambda-list values-type &body body) 25 | "Bind LAMBDA-LIST to VALUES-TYPE for the duration of BODY. 26 | LAMBDA-LIST is an ordinary lambda list, except that default forms and suppliedp variables are ignored. 27 | VALUES-TYPE is evaluated to a values ctype. 28 | Variables in the lambda list are bound to the values. For example, with a lambda list of (A B) and type (values integer &optional cons), A would be bound to the INTEGER ctype and B to the CONS ctype. The &rest parameter is bound to a values ctype containing all values not used by the required and optional parameters. 29 | (values-bot) is returned without the body being evaluated in any of the following situations: 30 | * There are fewer values than there are required parameters (i.e. subsequent values are bottom) 31 | * There is no &rest parameter and there are more required values than there are required and optional parameters 32 | * &allow-other-keys was specified, it can be determined that :allow-other-keys true was not passed, and there is an unrecognized keyword" 33 | (multiple-value-bind (required optional rest keys aokp aux keyp) 34 | (alexandria:parse-ordinary-lambda-list lambda-list) 35 | (declare (ignore keys)) 36 | (when aokp 37 | (error "~s not allowed in TFUN lambda list" '&allow-other-keys)) 38 | (when aux 39 | (error "~s not allowed in TFUN lambda list" '&aux)) 40 | (when keyp (error "~s not supported yet" '&key)) 41 | (let ((optional 42 | (loop for (var init suppliedp) in optional 43 | when (or init suppliedp) 44 | do (warn "~s ignoring initform and/or suppliedp variable for ~s" 45 | 'destructure-tfunbind var) 46 | collect var)) 47 | (vtype (gensym "VALUES-TYPE")) 48 | (vreq (gensym "REQUIRED")) 49 | (vopt (gensym "OPTIONAL")) 50 | (vrest (gensym "REST"))) 51 | `(let* ((,vtype ,values-type) 52 | (,vreq (cvalues-required ,vtype)) 53 | (,vopt (cvalues-optional ,vtype)) 54 | (,vrest (cvalues-rest ,vtype))) 55 | (let (,@(loop for r in required 56 | collect `(,r (or (pop ,vreq) (pop ,vopt) ,vrest))) 57 | ,@(loop for o in optional 58 | collect `(,o (or (pop ,vreq) (pop ,vopt) ,vrest))) 59 | ,@(when rest 60 | `((,rest (cvalues ,vreq ,vopt ,vrest))))) 61 | ;; declarations are annoying to work out, so 62 | (declare (ignorable ,@required ,@optional ,@(when rest `(,rest)))) 63 | ;; Enforce too many args, strictness, too few args 64 | (cond ,@(unless rest 65 | `((,vreq (values-bot)))) ; too many (vreq remains) 66 | ,@(loop for r in required ; too few 67 | collect `((bot-p ,r) (values-bot))) 68 | ;; specific code 69 | (t ,@body))))))) 70 | 71 | (defmacro tlambda (name (&rest lambda-list) &body body) 72 | (let ((vtype (gensym "VALUES-TYPE"))) 73 | `(lambda (,vtype) 74 | (block ,name 75 | (destructure-tfunbind (,@lambda-list) ,vtype ,@body))))) 76 | 77 | (defparameter *tfuns* (make-hash-table :test #'equal)) 78 | 79 | (defmacro define-tfun (name (&rest lambda-list) &body body) 80 | `(setf (gethash ',name *tfuns*) (tfun (tlambda ,name ,lambda-list ,@body)))) 81 | 82 | (defun find-tfun (name &optional errorp) 83 | (cond ((gethash name *tfuns*)) 84 | (errorp (error "No TFUN known for ~s" name)) 85 | (t (function-top)))) 86 | -------------------------------------------------------------------------------- /conjunction.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct conjunction)) 4 | (loop for sct in (junction-ctypes ct) 5 | always (ctypep object sct))) 6 | 7 | (defmethod subctypep ((ct1 conjunction) (ct2 ctype)) 8 | ;; This is dual to the (ctype disjunction) method in disjunction.lisp. 9 | ;; Check that comment if you want to see how this works. 10 | ;; Knowing conjointness is much rarer than knowing conjointness, but does 11 | ;; happen occasionally; an example is that we can know that 12 | ;; (subtypep '(and (not integer) (not cons)) 'integer) => NIL, T 13 | (loop with surety = t 14 | with not-subtype = 0 15 | with not-subtype-and-not-conjoint = 0 16 | for sct in (junction-ctypes ct1) 17 | do (multiple-value-bind (val subsurety) (subctypep sct ct2) 18 | (cond ((not subsurety) (setf surety nil)) 19 | (val (return (values t t))) 20 | (surety 21 | (incf not-subtype) 22 | (multiple-value-bind (val subsurety) (conjointp sct ct2) 23 | (cond ((not subsurety) (setf surety nil)) 24 | ((not val) (incf not-subtype-and-not-conjoint))))))) 25 | finally (return (if (and surety 26 | (or (= not-subtype-and-not-conjoint 1) 27 | (and (> not-subtype 0) 28 | (= not-subtype-and-not-conjoint 0)))) 29 | (values nil t) 30 | (values nil nil))))) 31 | (defmethod subctypep ((ct1 ctype) (ct2 conjunction)) 32 | ;; if a ~<: z then a ~<: z ^ y, as z ^ y <: z. 33 | ;; if a <: z and a <: y, a ^ z = a and a ^ y = a 34 | ;; a <: z ^ y <=> a ^ z ^ y = a <=> (a ^ z) ^ (a ^ y) = a <=> a ^ a = a 35 | ;; this also covers the case of ct2 being top. 36 | (every/tri (lambda (sct) (subctypep ct1 sct)) (junction-ctypes ct2))) 37 | 38 | (define-commutative-method disjointp ((ct1 conjunction) (ct2 ctype)) 39 | ;; if a ^ z = 0 then a ^ b ^ z = 0. 40 | ;; doesn't follow the other way, though. 41 | (if (some/tri (lambda (sct) (disjointp sct ct2)) (junction-ctypes ct1)) 42 | (values t t) 43 | (values nil nil))) 44 | 45 | (define-commutative-method conjointp ((ct1 conjunction) (ct2 ctype)) 46 | ;; (a ^ b) v z = T <=> (a v z) ^ (b v z) = T 47 | (every/tri (lambda (sct) (conjointp sct ct2)) (junction-ctypes ct1))) 48 | 49 | (defmethod negate ((ctype conjunction)) 50 | ;; de Morgan: ~(a & b) = ~a | ~b 51 | (apply #'disjoin (mapcar #'negate (junction-ctypes ctype)))) 52 | 53 | (defmethod conjoin/2 ((ct1 conjunction) (ct2 conjunction)) 54 | (apply #'conjoin (append (junction-ctypes ct1) (junction-ctypes ct2)))) 55 | (define-commutative-method conjoin/2 ((ct1 conjunction) (ct2 ctype)) 56 | (apply #'conjoin ct2 (junction-ctypes ct1))) 57 | 58 | (define-commutative-method disjoin/2 ((conjunction conjunction) (ctype ctype)) 59 | ;; If any disjunction is uninteresting, give up - except that if some 60 | ;; of the disjunctions are T, factor those out. 61 | ;; (This factoring is important for correctly computing that (or x (not x)) 62 | ;; is top when X involves complicated intersections, for example.) 63 | ;; This is more complicated than the analogous conjoin-disjunction in order 64 | ;; to avoid infinite recursion while preferring a sum of products. 65 | (loop with topseent = nil 66 | for sct in (junction-ctypes conjunction) 67 | for dis = (disjoin/2 sct ctype) 68 | if (not dis) 69 | collect sct into uninteresting 70 | else if (top-p dis) 71 | do (setf topseent t) 72 | else collect dis into djs 73 | and collect sct into uninteresting 74 | finally (return 75 | (cond ((null uninteresting) (apply #'conjoin djs)) 76 | (topseent 77 | (disjunction ctype 78 | (apply #'conjunction uninteresting))) 79 | (t nil))))) 80 | 81 | (defmethod unparse ((ct conjunction)) 82 | (let ((ups (mapcar #'unparse (junction-ctypes ct)))) 83 | ;; Pick off special cases 84 | (when (null ups) (return-from unparse 't)) 85 | ;; compiled-function 86 | (when (and (member 'function ups) 87 | (member '(satisfies compiled-function-p) ups :test #'equal)) 88 | (setf ups (delete 'function ups) 89 | ups (delete '(satisfies compiled-function-p) ups :test #'equal)) 90 | (push 'compiled-function ups)) 91 | ;; keyword 92 | (when (and (member 'symbol ups) 93 | (member '(satisfies keywordp) ups :test #'equal)) 94 | (setf ups (delete 'symbol ups) 95 | ups (delete '(satisfies keywordp) ups :test #'equal)) 96 | (push 'keyword ups)) 97 | ;; finally, 98 | (if (= (length ups) 1) 99 | (first ups) 100 | `(and ,@ups)))) 101 | -------------------------------------------------------------------------------- /classes.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defclass ctype () ()) 4 | (defmethod make-load-form ((obj ctype) &optional env) 5 | (make-load-form-saving-slots obj :environment env)) 6 | 7 | ;; A ctype corresponding to a class. 8 | ;; Note that to avoid complication, classes that could be some other ctype must 9 | ;; be instead of this. E.g. T, CONS, LIST, ARRAY, INTEGER must not end up as 10 | ;; cclass ctypes. SEQUENCE and subclasses of FUNCTION are handled specially 11 | ;; in pairwise.lisp (FUNCTION itself ends up as a CFUNCTION). 12 | (defclass cclass (ctype) 13 | ((%class :initarg :class :reader cclass-class :type class))) 14 | 15 | (defclass negation (ctype) 16 | ((%ctype :initarg :ctype :reader negation-ctype :type ctype))) 17 | 18 | (defclass junction (ctype) 19 | ((%ctypes :initarg :ctypes :reader junction-ctypes 20 | :type list))) 21 | 22 | (defclass conjunction (junction) ()) 23 | (defclass disjunction (junction) ()) 24 | 25 | (defclass ccons (ctype) 26 | ((%car :initarg :car :reader ccons-car :type ctype) 27 | (%cdr :initarg :cdr :reader ccons-cdr :type ctype))) 28 | 29 | (defclass range (ctype) 30 | ((%kind :initarg :kind :reader range-kind 31 | :type (member integer ratio 32 | short-float single-float double-float long-float)) 33 | ;; NIL means no bound, i.e. * in the type specifier. 34 | (%low :initarg :low :reader range-low :type (or real null)) 35 | (%high :initarg :high :reader range-high :type (or real null)) 36 | (%low-xp :initarg :lxp :reader range-low-exclusive-p :type boolean) 37 | (%high-xp :initarg :hxp :reader range-high-exclusive-p :type boolean))) 38 | 39 | (defclass fpzero (ctype) 40 | ((%kind :initarg :kind :reader fpzero-kind 41 | :type (member short-float single-float double-float long-float)) 42 | (%zero :initarg :zero :reader fpzero-zero :type float))) 43 | 44 | (defclass ccomplex (ctype) 45 | (;; The upgraded complex part type is some thing that can be meaningfully 46 | ;; compared with EQUAL. CL:* is always allowed and has the standard meaning. 47 | (%ucpt :initarg :ucpt :reader ccomplex-ucpt))) 48 | 49 | (defclass cmember (ctype) 50 | ((%members :initarg :members :reader cmember-members :type list))) 51 | 52 | (defclass carray (ctype) 53 | ((%simplicity :initarg :simplicity :reader carray-simplicity 54 | :type (member :simple :complex)) 55 | ;; Can be * to indicate all possible. Should be more efficient that way. 56 | ;; Other than that, it's just something equal-comparable. Also should 57 | ;; be what's returned by array-element-type. 58 | (%uaet :initarg :uaet :reader carray-uaet) 59 | ;; Expressed element type. Provided for use by compilers, but does not 60 | ;; affect typep, subtypep, etc. 61 | (%eaet :initarg :eaet :reader carray-eaet :type ctype) 62 | ;; Either a list of dimensions (which are either positive integers or *) 63 | ;; or * indicating nothing specified. 64 | (%dims :initarg :dims :reader carray-dims :type (or list (eql *))))) 65 | 66 | (defclass charset (ctype) 67 | ((%pairs :initarg :pairs :reader charset-pairs 68 | ;; A list of (char-code . char-code) pairs, each representing 69 | ;; an inclusive interval of codepoints, in order and exclusive. 70 | :type list))) 71 | 72 | (defclass cvalues (ctype) 73 | ((%required :initarg :required :reader cvalues-required 74 | ;; A proper list of ctypes. 75 | :type list) 76 | (%optional :initarg :optional :reader cvalues-optional 77 | ;; A proper list of ctypes. 78 | :type list) 79 | (%rest :initarg :rest :reader cvalues-rest :type ctype))) 80 | 81 | ;;; Used to avoid (typep foo 'cvalues) in a few places in this library, 82 | ;;; which is important to avoid infinite regress. 83 | (defgeneric cvalues-p (ctype) 84 | (:method ((ctype cvalues)) t) 85 | (:method ((ctype ctype)) nil)) 86 | 87 | (defclass lambda-list (ctype) 88 | ((%required :initarg :required :reader lambda-list-required 89 | ;; A proper list of ctypes. 90 | :type list) 91 | (%optional :initarg :optional :reader lambda-list-optional 92 | ;; A proper list of ctypes. 93 | :type list) 94 | (%rest :initarg :rest :reader lambda-list-rest 95 | ;; Having no &rest is indicated by setting this to (bot). 96 | :type ctype) 97 | ;; Is there a &key? This may be true even if no actual ctypes are 98 | ;; specified for keyword parameters. 99 | (%keyp :initarg :keyp :reader lambda-list-keyp :type boolean) 100 | (%keys :initarg :keys :reader lambda-list-key 101 | ;; A proper list of (keyword . ctype) pairs. 102 | :type list) 103 | ;; Is there &allow-other-keys? 104 | (%aokp :initarg :aokp :reader lambda-list-aokp :type boolean))) 105 | 106 | (defclass cfunction (ctype) 107 | (;; A specification of * is equivalent to (&rest t). 108 | (%lambda-list :initarg :lambda-list :reader cfunction-lambda-list 109 | :type lambda-list) 110 | ;; A specification of * is equivalent to (values &rest t). 111 | (%returns :initarg :returns :reader cfunction-returns :type cvalues))) 112 | 113 | (defclass csatisfies (ctype) 114 | ((%fname :initarg :fname :reader csatisfies-fname))) 115 | -------------------------------------------------------------------------------- /trivalent.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (flet ((expand (name invert-test-p success predicate sequences) 4 | ;; In separate function to avoid double backquote. 5 | (let* ((nsequences (length sequences)) 6 | (params (loop repeat nsequences collect (gensym "ELEM"))) 7 | (ssym (gensym "SURETY")) 8 | (psym (gensym "PREDICATE")) 9 | (msym (gensym "MAPPER"))) 10 | `(block ,name 11 | (let ((,ssym t) (,psym ,predicate)) 12 | (flet ((,msym (,@params) 13 | (multiple-value-bind (val subsurety) 14 | (funcall ,psym ,@params) 15 | (cond ((not subsurety) (setf ,ssym nil)) 16 | ((,(if invert-test-p 'not 'identity) val) 17 | (return-from ,name 18 | (values ,(not success) t))))))) 19 | (declare (inline ,msym) (dynamic-extent (function ,msym))) 20 | (map nil (function ,msym) ,@sequences) 21 | (if ,ssym (values ,success t) (values nil nil)))))))) 22 | (macrolet ((defpred (name invert-test-p success) 23 | `(progn 24 | (defun ,name (predicate sequence &rest sequences) 25 | (let ((surety t)) 26 | (flet ((mapper (&rest elems) 27 | (multiple-value-bind (val subsurety) 28 | (apply predicate elems) 29 | (cond ((not subsurety) (setf surety nil)) 30 | ((,(if invert-test-p 'not 'identity) val) 31 | (return-from ,name 32 | (values ,(not success) t))))))) 33 | (declare (inline mapper) (dynamic-extent #'mapper)) 34 | (apply #'map nil #'mapper sequence sequences) 35 | (if surety (values ,success t) (values nil nil))))) 36 | ;; Open code to avoid the apply. 37 | (define-compiler-macro ,name 38 | (predicate sequence &rest sequences) 39 | (expand ',name ',invert-test-p ',success predicate 40 | (list* sequence sequences)))))) 41 | ;; If the predicate is true of all sequence members, returns T T. 42 | ;; If it is definitely false on at least one member, returns NIL T. 43 | ;; Otherwise returns NIL NIL. 44 | ;; Like the CL map functions, only checks as many elements as the shortest 45 | ;; input, so make sure all inputs have the same length. 46 | (defpred every/tri t t) 47 | ;; If the predicate is definitely false of all sequence members, NIL T. 48 | ;; If true of at least one member, T T. 49 | ;; Otherwise NIL NIL. 50 | (defpred some/tri nil nil) 51 | ;; If true of all, NIL T. 52 | ;; If false of at least one member, T T. 53 | ;; Otherwise NIL NIL. 54 | (defpred notevery/tri t nil) 55 | ;; If false of all, T T. 56 | ;; If true of at least one member, NIL T. 57 | ;; Otherwise NIL NIL. 58 | (defpred notany/tri nil t))) 59 | 60 | ;;; Like AND, but returns both values. 61 | ;;; i.e., if a form returns false, returns those two values immediately. 62 | ;;; if all forms are true, returns the two values of the last form. 63 | ;;; Otherwise returns unknown. 64 | (defmacro and/tri (&rest forms) 65 | (cond ((null forms) '(values t t)) 66 | ((null (rest forms)) (first forms)) 67 | (t (let ((val1 (gensym "VAL")) (surety1 (gensym "SURETY")) 68 | (val2 (gensym "VAL")) (surety2 (gensym "SURETY"))) 69 | `(multiple-value-bind (,val1 ,surety1) ,(first forms) 70 | (if (and ,surety1 (not ,val1)) 71 | (values nil ,surety1) 72 | (multiple-value-bind (,val2 ,surety2) 73 | (and/tri ,@(rest forms)) 74 | (if (or ,val1 (and ,surety2 (not ,val2))) 75 | (values ,val2 ,surety2) 76 | (values nil nil))))))))) 77 | 78 | ;;; Like OR, but returns both values. 79 | ;;; i.e., if a form returns true, returns those two values immediately. 80 | ;;; If all forms are false, returns the two values of the last form. 81 | ;;; Otherwise returns unknown. 82 | (defmacro or/tri (&rest forms) 83 | (cond ((null forms) '(values nil t)) 84 | ((null (rest forms)) (first forms)) 85 | (t (let ((val1 (gensym "VAL")) (surety1 (gensym "SURETY")) 86 | (val2 (gensym "VAL")) (surety2 (gensym "SURETY"))) 87 | `(multiple-value-bind (,val1 ,surety1) ,(first forms) 88 | (if ,val1 89 | (values ,val1 ,surety1) 90 | (multiple-value-bind (,val2 ,surety2) 91 | (or/tri ,@(rest forms)) 92 | (if (or ,surety1 ,val2) 93 | (values ,val2 ,surety2) 94 | (values nil nil))))))))) 95 | 96 | ;;; Evaluate the forms left to right until one has sure results; return those 97 | ;;; results. If no form has surety just returns NIL NIL. 98 | (defmacro surely (&rest forms) 99 | (cond ((null forms) '(values nil nil)) 100 | ((null (rest forms)) (first forms)) 101 | (t (let ((val (gensym "VAL")) (surety (gensym "SURETY"))) 102 | `(multiple-value-bind (,val ,surety) ,(first forms) 103 | (if ,surety 104 | (values ,val ,surety) 105 | (surely ,@(rest forms)))))))) 106 | -------------------------------------------------------------------------------- /ext/README.md: -------------------------------------------------------------------------------- 1 | # Modular arithmetic 2 | 3 | The `mod.lisp` file is a self contained implementation of integer residues as types. A `congruence` ctype represents the set of all integers that have some value mod the congruence's modulus. A congruence object can represent more than one residue with the same modulus. Each residue is stored as a bit in a bitfield. 4 | 5 | For example, the set of all `evenp` integers is `(ctype.ext.mod:congruence 2 #b01)`. The least significant bit of `#b01` is one, so the class includes 0 mod 2. The next bit is zero, so the class does not include 1 mod 2. That, the set of all `oddp` integers, would be `(congruence 2 #b10)`. The usual ctype operators work on these types, so for example `conjoin`ing them gets you the empty type and `disjoin`ing them gets you the type of all integers. The constructor and methods automatically detect and reduce these sorts of degeneracies. 6 | 7 | The type of all integers that are not a multiple of three (i.e. that are 1 mod 3 or 2 mod 3) would be `(congruence 3 #b110)`. This too can be conjoined and disjoined at will, e.g. `(conjoin (congruence 3 #b110) (congruence 2 #b01))` => 2 or 4 mod 6, while `(disjoin (congruence 3 #b110) (congruence 2 #b01))` => 0, 1, 2, 4, or 5 mod 6. The conjunctions and disjunctions of congruences are always either congruences, `integer`, or `nil`. 8 | 9 | # Homogeneous Data Structures 10 | 11 | They can be loaded with the `ctype/ext` ASDF system which has ctype and alexandria as dependencies. 12 | 13 | The `list-of` extended type is an implementation of the type of lists of some element type. This type cannot be expressed in the Common Lisp type system but is sometimes desired. In a little more detail, `(list-of x)` can be expressed recursively as being the object `nil` plus all objects of type `(cons x (list-of x))`. This includes circular lists, but not dotted lists. 14 | 15 | Types for arrays and hash-tables of some element type(s) have also been defined as `array-of` and `hash-table-of`. 16 | 17 | # Type-level functions 18 | 19 | The largest extension so far is for tfuns, short for "type-level functions". This system can determine upper bounds for the result type of function calls, given knowledge of the function being called and upper bounds on the types of its arguments. 20 | 21 | It can be loaded as the `ctype/tfun` ASDF system. This system has ctype proper as well as alexandria as dependencies. 22 | 23 | The primary entry points are `derive-call` and `derive-multiple-value-call`. `derive-call` accepts a tfun (or other ctypes, but this will be less useful) as well as single value ctypes for the arguments to the call. For example, in order to approximate the type of `(+ (the (single-float 3.9 48.2) x) (the (rational 8 32) y))`, you would do 24 | 25 | ``` 26 | (ctype.ext.tfun:derive-call 27 | (ctype.ext.tfun:find-tfun '+) 28 | (ctype:specifier-ctype '(single-float 3.9 48.2)) 29 | (ctype:specifier-ctype '(rational 8 32))) 30 | => # 31 | ``` 32 | 33 | This indicates that exactly one value is returned, a `(single-float 11.9 80.2)`. 34 | 35 | `find-tfun` returns a tfun for the given function name. It accepts an `errorp` argument that works like that of `cl:find-class`. If there is no tfun, and errorp is false, a generic function ctype will be returned instead. 36 | 37 | As you may have gathered, tfuns are themselves ctypes. This is intended to facilitate static analyses that track functions as variables in Lisp programs. As ctypes, tfuns will conjoin/disjoin/etc correctly with non-function ctypes, and will give usually subpar but correct results with function ctypes. 38 | 39 | ## Available functions 40 | 41 | Currently the set of standard functions with tfuns defined is quite limited, but it is intended to expand: 42 | 43 | * Data and control flow: `funcall`, `apply`, `not`, `eql`, `identity`, `values`, `values-list` 44 | * Numbers: `=`, `<`, `>`, `<=`, `>=`, `+`, `-`, `*`, `/`, `abs`, `exp`, `random`, `float`, `ash`, `integer-length`, `logcount` 45 | * Conses: `car`, `cdr`, `caar` etc. 46 | * Arrays: `aref`, `row-major-aref` 47 | 48 | ## Extension & how it works 49 | 50 | New tfuns can be defined with the `define-tfun` operator. This will define a (Lisp) function that accepts a values ctype as arguments, and should return a values ctype for the return values. A lambda list can be provided to make parsing the values ctype easy, so that for functions not involving &rest the fact the input type is a values ctype can be safely ignored. 51 | 52 | Tfuns operate on values ctypes for the sake of coherence. Lisp functions can be conceived of as taking and returning exactly one "value" - a multiple value structure. For a conventional call, the input values type has all required values, no optional values, and a &rest type of bottom, meaning that the number of arguments is exactly known. For a `multiple-value-call` or `apply`, the values type may be more complicated. Arranging things this way allows deriver functions to work on calls with unknown argument counts. 53 | 54 | ## Caveats 55 | 56 | Unlike the ctype system proper, tfuns only provide upper bounds. This is probably fine for most applications (e.g. type inference for optimization purposes), but should be kept in mind. As an example, `(derive-call (find-tfun 'ash) (specifier-ctype '(eql 1)) (specifier-ctype '(integer 0 4)))` gives `(integer 1 16)`, but this is too broad: it includes e.g. 3, which `(ash 1 anything)` will obviously never be. The exact answer would be `(member 1 2 4 8 16)`. 57 | 58 | The system assumes that if argument restrictions are violated, functions will return the bottom type (i.e. signal an error or otherwise transfer control). This is true in most Lisp implementations, but is not always technically defined to be the case by the standard. A user concerned with strict conformity should be careful. In the future, this is intended to be configurable or otherwise possible to deal with. Making this assumption is important to getting decent results without too much fussing over exact correctness. 59 | -------------------------------------------------------------------------------- /cfunction.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defun lambda-list-top-p (lambda-list) 4 | (and (null (lambda-list-required lambda-list)) 5 | (every #'top-p (lambda-list-optional lambda-list)) 6 | (top-p (lambda-list-rest lambda-list)) 7 | (not (lambda-list-keyp lambda-list)))) 8 | 9 | ;;; Does this function ctype = FUNCTION unadorned? 10 | (defun function-top-p (cfunction) 11 | (and (lambda-list-top-p (cfunction-lambda-list cfunction)) 12 | (values-top-p (cfunction-returns cfunction)))) 13 | 14 | (defmethod ctypep (object (ct cfunction)) 15 | (if (functionp object) 16 | (if (function-top-p ct) 17 | t 18 | (error "Cannot use complex function type ~a for ~a" 19 | ct 'ctypep)) 20 | nil)) 21 | 22 | (defun sub-lambda-list-p (ll1 ll2) 23 | (let ((req1 (lambda-list-required ll1)) (req2 (lambda-list-required ll2)) 24 | (rest1 (lambda-list-rest ll1)) (rest2 (lambda-list-rest ll2)) 25 | (surety t)) 26 | (when (> (length req2) (length req1)) 27 | (return-from sub-lambda-list-p (values nil t))) 28 | (multiple-value-bind (val subsurety) (subctypep rest1 rest2) 29 | (unless val 30 | (if subsurety 31 | (return-from sub-lambda-list-p (values nil t)) 32 | (setf surety nil)))) 33 | (loop with opt1 = (lambda-list-optional ll1) 34 | with opt2 = (lambda-list-optional ll2) 35 | for sct1 = (or (pop req1) (pop opt1) rest1) 36 | for sct2 = (or (pop req2) (pop opt2) rest2) 37 | do (multiple-value-bind (val subsurety) (subctypep sct1 sct2) 38 | (cond ((not subsurety) (setf surety nil)) 39 | ((not val) (return-from sub-lambda-list-p 40 | (values nil t))))) 41 | until (and (null req1) (null opt1) (null req2) (null opt2))) 42 | ;: TODO 43 | (when (or (lambda-list-keyp ll1) (lambda-list-keyp ll2)) 44 | (setf surety nil)) 45 | (if surety 46 | (values t t) 47 | (values nil nil)))) 48 | 49 | (defmethod subctypep ((ct1 cfunction) (ct2 cfunction)) 50 | (multiple-value-bind (val1 surety1) 51 | (subctypep (cfunction-returns ct1) (cfunction-returns ct2)) 52 | (if (and surety1 (not val1)) 53 | (values nil t) 54 | (multiple-value-bind (val2 surety2) 55 | (sub-lambda-list-p (cfunction-lambda-list ct1) 56 | (cfunction-lambda-list ct2)) 57 | (cond ((not surety2) (values nil nil)) 58 | ((not val2) (values nil t)) 59 | (surety1 (values t t)) 60 | (t (values nil nil))))))) 61 | 62 | (defmethod cofinitep ((ct cfunction)) (values nil t)) 63 | 64 | (defun lambda-list-conjoin (ll1 ll2) 65 | (let* ((req1 (lambda-list-required ll1)) (req2 (lambda-list-required ll2)) 66 | (opt1 (lambda-list-optional ll1)) (opt2 (lambda-list-optional ll2)) 67 | (rest1 (lambda-list-rest ll1)) (rest2 (lambda-list-rest ll2)) 68 | (req (if (or req1 req2) 69 | (loop for sct1 = (or (pop req1) (pop opt1) rest1) 70 | for sct2 = (or (pop req2) (pop opt2) rest2) 71 | for conj = (conjoin sct1 sct2) 72 | if (bot-p conj) 73 | do (return-from lambda-list-conjoin conj) 74 | else collect conj 75 | until (and (null req1) (null req2))) 76 | nil)) 77 | (rest (conjoin rest1 rest2)) 78 | (opt (if (or opt1 opt2) 79 | (loop for sct1 = (or (pop opt1) rest1) 80 | for sct2 = (or (pop opt2) rest2) 81 | for conj = (conjoin sct1 sct2) 82 | if (bot-p conj) 83 | do (setf rest conj) 84 | (loop-finish) 85 | else collect conj 86 | until (and (null opt1) (null opt2))) 87 | nil))) 88 | (if (or (lambda-list-keyp ll1) (lambda-list-keyp ll2)) 89 | ;; TODO 90 | nil 91 | (make-instance 'lambda-list :required req :optional opt :rest rest 92 | :keyp nil :keys nil :aokp nil)))) 93 | 94 | (defmethod conjoin/2 ((ct1 cfunction) (ct2 cfunction)) 95 | (let ((ll (lambda-list-conjoin (cfunction-lambda-list ct1) 96 | (cfunction-lambda-list ct2))) 97 | ;; We use conjoin/2 rather than conjoin because we know both are values 98 | ;; types, and that conjoin/2 always simplifies such types. 99 | (rv (conjoin/2 (cfunction-returns ct1) 100 | (cfunction-returns ct2)))) 101 | (cond ((bot-p ll) ll) 102 | ((and ll rv) 103 | (make-instance 'cfunction :lambda-list ll :returns rv)) 104 | (t nil)))) 105 | 106 | (defun unparse-lambda-list (lambda-list) 107 | (if (lambda-list-top-p lambda-list) 108 | '* 109 | `(,@(mapcar #'unparse (lambda-list-required lambda-list)) 110 | ,@(let ((opt (lambda-list-optional lambda-list))) 111 | (when opt 112 | `(&optional ,@(mapcar #'unparse opt)))) 113 | ,@(let ((rest (lambda-list-rest lambda-list))) 114 | (unless (bot-p rest) 115 | `(&rest ,(unparse rest)))) 116 | ,@(when (lambda-list-keyp lambda-list) '(&key)) 117 | ,@(loop for (keyword . ctype) in (lambda-list-key lambda-list) 118 | collect `(,keyword ,(unparse ctype))) 119 | ,@(when (lambda-list-aokp lambda-list) '(&allow-other-keys))))) 120 | 121 | (defmethod unparse ((ct cfunction)) 122 | (let ((ull (unparse-lambda-list (cfunction-lambda-list ct))) 123 | (rv (cfunction-returns ct))) 124 | (if (values-top-p rv) 125 | (if (eq ull '*) 126 | 'function 127 | `(function ,ull)) 128 | `(function ,ull ,(unparse rv))))) 129 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This system is an implementation of the Common Lisp type system; particularly `cl:typep` and `cl:subtypep`. 2 | 3 | The function `specifier-ctype` takes a type specifier and environment as input, and returns a "ctype": a reified representation of a type, independent of any environment. Ctypes are a precise reflection of their input specifier, i.e. information independent of the environment is not lost. They are however simplified as much as possible, so they will not reflect redundant information in the specifier. For example, `(and list cons)` and `cons` are interpreted as the same ctype. 4 | 5 | The `ctypep` and `subctypep` functions implement `cl:typep` and `cl:subtypep`, except that they take ctype objects as arguments, rather than type specifiers. Then the CL functions could be defined as 6 | 7 | ```lisp 8 | (defun typep (object type-specifier &optional environment) 9 | (ctypep object (specifier-ctype type-specifier environment))) 10 | 11 | (defun subtypep (type-specifier-1 type-specifier-2 &optional environment) 12 | (subctypep (specifier-ctype type-specifier-1 environment) 13 | (specifier-ctype type-specifier-2 environment))) 14 | ``` 15 | 16 | The functions `negate`, `disjoin`, and `conjoin` can be used to compute functions of ctypes. They are analogous to the compound type specifiers `not`, `or`, and `and` respectively. 17 | 18 | The functions `top` and `bot` return the top ctype and bottom ctype (`t` and `nil`), respectively. `top-p` and `bot-p` determine whether a given ctype is the top or the bottom ctype, respectively. 19 | 20 | # Configuration 21 | 22 | This system is intended for use in an implementation of `typep` and `subtypep`, and so does not use `cl:typep` or `cl:subtypep` at all. Unfortunately, not all aspects of the type system on a given Lisp system are determinable with standard means without using `typep` and `subtypep`, and must be manually configured per implementation. See config/ for more information. 23 | 24 | Currently, the following Lisps are supported: 25 | 26 | * ABCL (preliminary) 27 | * CCL 28 | * Clasp 29 | * CMUCL 30 | * ECL 31 | * SBCL 32 | * SICL 33 | 34 | # Classes 35 | 36 | Ctypes are of class `ctype`. Various subclasses of `ctype` implement kinds of types in the CL type system. The following subclasses are defined by the system: 37 | 38 | * `cclass`: a ctype representing a class. The class may be read with the `cclass-class` function. 39 | * `negation`: The negation of its `negation-ctype`. 40 | * `conjunction`/`disjunction`: Represents uses of the `and`/`or` (resp.) type specifier that could not be further simplified. `junction-ctypes` returns a list of the ctypes it is a con/disjunction of. 41 | * `ccons`: A cons type. `ccons-car` and `ccons-cdr` read the `car` and `cdr` types respectively. 42 | * `range`: A range of real numbers. `range-kind` is one of `integer`, `ratio`, `short-float`, `single-float`, `double-float`, or `long-float`. `range-low`, `range-low-exclusive-p`, `range-high`, and `range-high-exclusive-p` read the properties of the range. 43 | * `ccomplex`: A `complex` type. `ccomplex-ucpt` reads the upgraded complex part type, which is either the symbol `cl:*`, or something returned by `cl:upgraded-complex-part-type`. 44 | * `cmember`: A `member` or `eql` type. `cmember-members` returns a list of the objects of the type. 45 | * `carray`: An array type. `carray-simplicity` reads `:simple` or `:complex` accordingly; array types including both are represented as disjunctions. `carray-uaet` reads the upgraded array element type. `carray-dims` reads the dimension specification, which is a `dimension-spec` as accepted by the `cl:array` compound type specifier. 46 | * `charset`: A subtype of `character`. `charset-pairs` reads the description of the codes included, which is as described above for `+standard-charset+` in the configuration section. 47 | * `cvalues`: A `values` type. 48 | * `cfunction`: A `function` type. 49 | * `csatisfies`: A `satisfies` type. 50 | 51 | Additional classes may be defined by the programmer. 52 | 53 | # Generic functions 54 | 55 | Methods on `ctypep` and `subctypep` must be implemented for subclasses of `ctype` in order for those functions to work correctly. 56 | 57 | Methods on `subctypep` should return the result of `(call-next-method)` if they cannot determine a conclusive answer, i.e. if they would return `(values nil nil)`. This ensures that all applicable methods can have a shot at giving a definitive answer. 58 | 59 | A method on `unparse` must be defined for ctypes to print correctly. `unparse` should return a type specifier that could specify the given ctype. This is only used for display purposes, so it doesn't have strict requirements. 60 | 61 | The additional generic functions `disjointp`, `negate`, `conjoin/2`, `disjoin/2`, and `subtract` may also need methods in order for `subctypep` and `specifier-ctype` to work correctly. Particularly, if the conjunction of two types is recognizably (with `subctypep`) the bottom type, `conjoin/2` must return `(bot)` and `disjointp` must return definite truth, and similarly with disjunction and `(top)`. 62 | 63 | * `disjointp` has the same return value convention as `subtypep`, and similarly, methods should use `call-next-method` if the answer cannot be determined. `disjointp` can be used to determine if two ctypes are completely disjoint: `(disjointp (specifier-ctype x) (specifier-ctype y))` is equivalent to `(subctypep (conjoin (specifier-ctype x) (specifier-ctype y)) (specifier-ctype nil))`. 64 | * `negate` computes the negation of a ctype, i.e. if a ctype is specified by `x`, `(negate that-ctype)` is specified by `(not x)`. The default method makes a `negation` ctype. These ctypes do not provide enough information for all functions to work well, e.g. they may result in `nil nil` answers from `subctypep`. As such, if the negation of a type can be expressed in a better way, a specializing method on `negate` should be defined. 65 | * `conjoin/2` and `disjoin/2` are the two-argument functions underlying `conjoin` and `disjoin` respectively. If no special behavior is defined, `conjoin` and `disjoin` will create `conjunction` and `disjunction` types, which do not always provide enough information for precise answers from `subctypep`. 66 | * `subtract`, given ctypes specified by `x` and `y`, may compute the ctype specified by `(and x (not y))`. If no special behavior is defined with a method, a `conjunction` ctype will be made, which is suboptimal. 67 | 68 | # Extensions 69 | 70 | While ctype implements the Common Lisp type system, some users may be interested in defining extensions to said type system. One can do so by defining subclasses of CTYPE and defining methods on some or all of the above functions. 71 | 72 | The ext/ directory contains a few example extensions. See the README in that directory for more information. 73 | 74 | Custom ctypes can be represented as type specifiers using `define-extended-type` and accessed using `extended-specifier-ctype` . See the documentation strings for more information. 75 | -------------------------------------------------------------------------------- /ext/data-structures/plist.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.data-structures) 2 | 3 | (defclass cproperty-list (ctype) 4 | ((%key-ctypes :initarg :key-ctypes :reader key-ctypes :type list)) 5 | (:documentation 6 | "Property list where each can can be of a different type. Other 7 | properties are allowed. Absent properties are considered to be 8 | `nil'.")) 9 | 10 | (defmethod property-ctype ((plist cproperty-list) property-key) 11 | (or (cdr (assoc property-key (key-ctypes plist))) 12 | (ctype:top))) 13 | 14 | (defmethod keys ((plist cproperty-list)) 15 | (mapcar #'car (key-ctypes plist))) 16 | 17 | (defmethod unparse ((object cproperty-list)) 18 | (with-accessors ((key-ctypes key-ctypes)) object 19 | (if key-ctypes 20 | `(plist ,@(loop for (key . type) in key-ctypes 21 | collect key 22 | collect (unparse type))) 23 | 'plist))) 24 | 25 | (defun cproperty-list (key-ctypes) 26 | (make-instance 27 | 'cproperty-list 28 | :key-ctypes key-ctypes)) 29 | 30 | (define-extended-type plist (&rest property-ctypes &environment env) 31 | :documentation 32 | "A property list where the keys are the keys of the members of this 33 | type and the values are the required types of the property 34 | associated with the key." 35 | :simple ((declare (ignore property-ctypes env)) 36 | 'list) 37 | :extended 38 | ((cproperty-list 39 | (loop for (key type) on property-ctypes by #'cddr 40 | collect (cons key (extended-specifier-ctype type env)))))) 41 | 42 | (defmethod ctypep ((list list) (ct cproperty-list)) 43 | (and (evenp (length list)) 44 | (loop for (key . type) in (key-ctypes ct) 45 | always 46 | (ctypep (getf list key) type)))) 47 | (defmethod ctypep ((object t) (ct cproperty-list)) nil) 48 | 49 | (defmethod subctypep ((ct1 cproperty-list) (ct2 cproperty-list)) 50 | (values 51 | (loop for (key . type2) in (key-ctypes ct2) 52 | always 53 | (subctypep (property-ctype ct1 key) type2)) 54 | t)) 55 | 56 | (defmethod disjointp ((ct1 cproperty-list) (ct2 cproperty-list)) 57 | (let (total-disjointp (total-surep t)) 58 | (loop for key in (union (keys ct1) (keys ct2)) do 59 | (multiple-value-bind (disjointp surep) (disjointp (property-ctype ct1 key) (property-ctype ct2 key)) 60 | (setq total-disjointp (or total-disjointp disjointp) 61 | total-surep (and total-surep surep)))) 62 | (values total-disjointp total-surep))) 63 | 64 | (defmethod conjointp ((ct1 cproperty-list) (ct2 cproperty-list)) (values nil t)) 65 | 66 | (defmethod cofinitep ((ct cproperty-list)) (values nil t)) 67 | 68 | (defmethod conjoin/2 ((ct1 cproperty-list) (ct2 cproperty-list)) 69 | (cproperty-list 70 | (loop for key in (union (keys ct1) (keys ct2)) 71 | collect 72 | (let ((type (conjoin (property-ctype ct1 key) 73 | (property-ctype ct2 key)))) 74 | (if (bot-p type) 75 | (return-from conjoin/2 (ctype:bot)) 76 | (cons key type)))))) 77 | 78 | (defmethod disjoin/2 ((ct1 cproperty-list) (ct2 cproperty-list)) 79 | (cproperty-list 80 | (loop for key in (union (keys ct1) (keys ct2)) 81 | collect 82 | (cons key (disjoin (property-ctype ct1 key) 83 | (property-ctype ct2 key)))))) 84 | 85 | (defmethod subtract ((ct1 cproperty-list) (ct2 cproperty-list)) 86 | (cproperty-list 87 | (loop for key in (union (keys ct1) (keys ct2)) 88 | collect 89 | (cons key (conjoin (property-ctype ct1 key) 90 | (negate (property-ctype ct2 key))))))) 91 | 92 | ;;; 93 | 94 | (defmethod subctypep ((ct1 cproperty-list) (ct2 ccons)) 95 | (values 96 | (and 97 | (top-p (ccons-car ct2)) 98 | (top-p (ccons-cdr ct2)) 99 | (loop for (key . type) in (key-ctypes ct1) 100 | never 101 | (subctypep (cmember nil) type))) 102 | t)) 103 | 104 | (defmethod subctypep ((ct1 ccons) (ct2 cproperty-list)) 105 | (let ((not-present-keys (keys ct2))) 106 | (do ((ct1 ct1 (ccons-cdr (ccons-cdr ct1)))) 107 | ((ctype= (cmember nil) ct1)) 108 | (when (ctype= (cmember nil) (ccons-cdr ct1)) 109 | (return-from subctypep (values nil t))) 110 | (let ((key-spot (ccons-car ct1)) 111 | (type (ccons-car (ccons-cdr ct1)))) 112 | (if (typep key-spot 'cmember) 113 | (dolist (key (cmember-members key-spot)) 114 | (setq not-present-keys (delete key not-present-keys)) 115 | (unless (subctypep type (property-ctype ct2 key)) 116 | (return-from subctypep (values nil t)))) 117 | (return-from subctypep (values nil nil))))) 118 | (dolist (key not-present-keys) 119 | (unless (subctypep (cmember nil) (property-ctype ct2 key)) 120 | (return-from subctypep (values nil t)))) 121 | (values t t))) 122 | 123 | (defmethod subctypep ((ct1 cmember) (ct2 cproperty-list)) 124 | (values 125 | (and (equal (cmember-members ct1) '(nil)) 126 | (every 127 | (lambda (property-ctype) 128 | (subctypep (cmember nil) (cdr property-ctype))) 129 | (key-ctypes ct2))) 130 | t)) 131 | 132 | (define-commutative-method disjointp ((plist cproperty-list) (ccons ccons)) 133 | (multiple-value-bind (subctypep surep) 134 | (or/tri (subctypep plist ccons) 135 | (subctypep ccons plist)) 136 | (values (not subctypep) surep))) 137 | 138 | (define-commutative-method disjointp ((plist cproperty-list) (cmember cmember)) 139 | (values (not (and (member nil (cmember-members cmember)) 140 | (ctypep nil plist))) 141 | t)) 142 | 143 | (defexclusives cproperty-list range ccomplex carray charset cfunction fpzero) 144 | 145 | (defun sequence-cclass-p (cclass) 146 | (eq (class-name (cclass-class cclass)) 'sequence)) 147 | (defmethod subctypep ((ct1 cproperty-list) (ct2 cclass)) 148 | (values (sequence-cclass-p ct2) t)) 149 | (defmethod subctypep ((ct1 cclass) (ct2 cproperty-list)) (values nil t)) 150 | (define-commutative-method disjointp ((ct1 cproperty-list) (ct2 cclass)) 151 | (values (not (sequence-cclass-p ct2)) t)) 152 | (define-commutative-method conjoin/2 ((ct1 cproperty-list) (ct2 cclass)) 153 | (if (sequence-cclass-p ct2) ct1 (bot))) 154 | (define-commutative-method disjoin/2 ((ct1 cproperty-list) (ct2 cclass)) 155 | (if (sequence-cclass-p ct2) ct2 nil)) 156 | (defmethod subtract ((ct1 cproperty-list) (ct2 cclass)) 157 | (if (sequence-cclass-p ct2) (bot) ct1)) 158 | (defmethod subtract ((ct1 cclass) (ct2 cproperty-list)) 159 | (if (sequence-cclass-p ct1) nil (bot))) 160 | 161 | (defmethod subctypep ((plist cproperty-list) (list-of clist-of)) 162 | (if (top-p (element-ctype list-of)) 163 | (values t t) 164 | (values nil t))) 165 | -------------------------------------------------------------------------------- /charset.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;;; a lot of the code in this file is cribbed from sbcl's character-set types. 4 | 5 | (defmethod ctypep (object (ct charset)) 6 | (and (characterp object) 7 | (loop with code = (char-code object) 8 | for (begin . end) in (charset-pairs ct) 9 | when (<= begin code end) 10 | return t 11 | finally (return nil)))) 12 | 13 | (defmethod subctypep ((ct1 charset) (ct2 charset)) 14 | (values 15 | (flet ((subrangep (pair1 pair2) 16 | (let ((low1 (car pair1)) (high1 (cdr pair1)) 17 | (low2 (car pair2)) (high2 (cdr pair2))) 18 | (and (>= low1 low2) (<= high1 high2))))) 19 | (loop with pairs2 = (charset-pairs ct2) 20 | for pair1 in (charset-pairs ct1) 21 | always (position pair1 pairs2 :test #'subrangep))) 22 | t)) 23 | 24 | (defmethod ctype= ((ct1 charset) (ct2 charset)) 25 | (values (equal (charset-pairs ct1) (charset-pairs ct2)) t)) 26 | 27 | (defmethod disjointp ((ct1 charset) (ct2 charset)) 28 | (values 29 | (flet ((overlap-p (pair1 pair2) 30 | (let ((low1 (car pair1)) (high1 (cdr pair1)) 31 | (low2 (car pair2)) (high2 (cdr pair2))) 32 | (and (<= low1 high2) (<= low2 high1))))) 33 | (loop with pairs2 = (charset-pairs ct2) 34 | for pair1 in (charset-pairs ct1) 35 | never (position pair1 pairs2 :test #'overlap-p))) 36 | t)) 37 | (defmethod conjointp ((ct1 charset) (ct2 charset)) (values nil t)) 38 | 39 | (defmethod cofinitep ((ct charset)) (values nil t)) 40 | 41 | (defun negate-charset-pairs (pairs) 42 | (if (null pairs) 43 | `((0 . ,(1- char-code-limit))) 44 | (let ((not-pairs nil)) 45 | (when (plusp (caar pairs)) 46 | (push (cons 0 (1- (caar pairs))) not-pairs)) 47 | (loop for tail on pairs 48 | for high1 = (cdar tail) 49 | for low2 = (caadr tail) 50 | until (null (rest tail)) 51 | do (push (cons (1+ high1) (1- low2)) not-pairs) 52 | finally (when (< (cdar tail) (1- char-code-limit)) 53 | (push (cons (1+ (cdar tail)) (1- char-code-limit)) 54 | not-pairs)) 55 | (return (nreverse not-pairs)))))) 56 | 57 | (defmethod negate ((ct charset)) 58 | (let ((pairs (charset-pairs ct))) 59 | (if (equal pairs `((0 . ,(1- char-code-limit)))) 60 | (call-next-method) 61 | (let ((not-character 62 | (negation 63 | (charset `((0 . ,(1- char-code-limit))))))) 64 | (disjunction 65 | not-character 66 | (charset (negate-charset-pairs pairs))))))) 67 | 68 | (defun conjoin-charset-pairs (pairs1 pairs2) 69 | (if (and pairs1 pairs2) 70 | (let ((res nil) 71 | (pair1 (pop pairs1)) 72 | (pair2 (pop pairs2))) 73 | (loop 74 | ;; Put the higher pair on the right. 75 | (when (> (car pair1) (car pair2)) 76 | (rotatef pair1 pair2) 77 | (rotatef pairs1 pairs2)) 78 | (let ((pair1-high (cdr pair1))) 79 | (cond 80 | ((> (car pair2) pair1-high) 81 | ;; no overlap -- discard pair1 and move on 82 | (if (null pairs1) 83 | (return) 84 | (setf pair1 (pop pairs1)))) 85 | ((<= (cdr pair2) pair1-high) 86 | ;; pair2 is a subrange of pair1 87 | (push (cons (car pair2) (cdr pair2)) res) 88 | (cond 89 | ((= (cdr pair2) pair1-high) 90 | ;; both pairs are now in the result, so advance both 91 | (if (null pairs1) 92 | (return) 93 | (setf pair1 (pop pairs1))) 94 | (if (null pairs2) 95 | (return) 96 | (setf pair2 (pop pairs2)))) 97 | (t 98 | ;; (< (cdr pair2) pair1-high) 99 | ;; so pair2 is a strict subrange of pair1 - advance 2 only, 100 | ;; and "modify" pair1 accordingly 101 | (if (null pairs2) 102 | (return) 103 | (setf pair2 (pop pairs2))) 104 | (setf pair1 (cons (1+ (cdr pair2)) pair1-high))))) 105 | (t 106 | ;; (> (cdr pair2) (cdr pair1)) 107 | ;; so the ranges overlap, but only partially. 108 | ;; push the overlap and advance 2 and modify 1. 109 | (push (cons (car pair2) pair1-high) res) 110 | (if (null pairs1) 111 | (return) 112 | (setf pair1 (pop pairs1))) 113 | (setf pair2 (cons (1+ pair1-high) (cdr pair2))))))) 114 | ;; done 115 | (nreverse res)) 116 | ;; One of the charsets is degenerate (empty) 117 | ;; which ought to have been normalized away, but as long as we're here 118 | nil)) 119 | 120 | (defmethod conjoin/2 ((ct1 charset) (ct2 charset)) 121 | (charset (conjoin-charset-pairs (charset-pairs ct1) (charset-pairs ct2)))) 122 | 123 | (defun disjoin-charset-pairs (pairs1 pairs2) 124 | (cond 125 | ((not pairs1) pairs2) 126 | ((not pairs2) pairs1) 127 | (t 128 | (let ((res nil)) 129 | (loop (let* ((current (if (> (caar pairs2) (caar pairs1)) 130 | (pop pairs1) 131 | (pop pairs2))) 132 | (low (car current)) (high (cdr current))) 133 | ;; Keep grabbing overlapping pairs until we run out. 134 | (loop (cond ((and pairs1 135 | (<= (caar pairs1) (1+ high))) 136 | (setf high (max high (cdr (pop pairs1))))) 137 | ((and pairs2 138 | (<= (caar pairs2) (1+ high))) 139 | (setf high (max high (cdr (pop pairs2))))) 140 | (t (return)))) ; ran out 141 | (push (cons low high) res) 142 | ;; Check to see if we're really done. 143 | (unless (or pairs1 pairs2) 144 | (return (nreverse res))))))))) 145 | 146 | (defmethod disjoin/2 ((ct1 charset) (ct2 charset)) 147 | (charset (disjoin-charset-pairs (charset-pairs ct1) (charset-pairs ct2)))) 148 | 149 | (defmethod subtract ((ct1 charset) (ct2 charset)) 150 | ;; lazy 151 | (charset (conjoin-charset-pairs (charset-pairs ct1) 152 | (negate-charset-pairs (charset-pairs ct2))))) 153 | 154 | (defmethod unparse ((ct charset)) 155 | (let ((pairs (charset-pairs ct))) 156 | (cond ((equal pairs +standard-charset+) 157 | 'standard-char) 158 | ((equal pairs +base-charset+) 159 | 'base-char) 160 | ((equal pairs `((0 . ,(1- char-code-limit)))) 161 | 'character) 162 | ((equal pairs (negate-charset-pairs +standard-charset+)) 163 | '(and character (not standard-char))) 164 | ((equal pairs (negate-charset-pairs +base-charset+)) 165 | 'extended-char) 166 | (t ; something weird. do a member type. 167 | `(member 168 | ,@(loop for (low . high) in pairs 169 | nconc (loop for i from low upto high 170 | collect (code-char i)))))))) 171 | -------------------------------------------------------------------------------- /carray.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep ((object array) (ct carray)) 4 | (let ((uaet (carray-uaet ct)) 5 | (dims (carray-dims ct)) 6 | (simplicity (carray-simplicity ct))) 7 | (and (if (eq simplicity :simple) 8 | (simple-array-p object) 9 | (not (simple-array-p object))) 10 | (or (eq uaet '*) 11 | (equal uaet (array-element-type object))) 12 | (or (eq dims '*) 13 | (let ((rank (length dims))) 14 | (and (= (array-rank object) rank) 15 | (loop for i from 0 below rank 16 | for dim in dims 17 | always (or (eq dim '*) 18 | (= (array-dimension object i) dim))))))))) 19 | (defmethod ctypep ((object t) (ct carray)) nil) 20 | 21 | (defmethod subctypep ((ct1 carray) (ct2 carray)) 22 | (let ((uaet1 (carray-uaet ct1)) (dims1 (carray-dims ct1)) 23 | (simplicity1 (carray-simplicity ct1)) 24 | (uaet2 (carray-uaet ct2)) (dims2 (carray-dims ct2)) 25 | (simplicity2 (carray-simplicity ct2))) 26 | (values 27 | (and (eq simplicity1 simplicity2) 28 | (or (eq uaet2 '*) 29 | (equal uaet1 uaet2)) 30 | (or (eq dims2 '*) 31 | (and (not (eq dims1 '*)) 32 | (= (length dims1) (length dims2)) 33 | (loop for dim1 in dims1 34 | for dim2 in dims2 35 | always (or (eq dim2 '*) 36 | (and (not (eq dim1 '*)) 37 | (= dim1 dim2))))))) 38 | t))) 39 | 40 | (defmethod disjointp ((ct1 carray) (ct2 carray)) 41 | (let ((uaet1 (carray-uaet ct1)) (dims1 (carray-dims ct1)) 42 | (simplicity1 (carray-simplicity ct1)) 43 | (uaet2 (carray-uaet ct2)) (dims2 (carray-dims ct2)) 44 | (simplicity2 (carray-simplicity ct2))) 45 | (values (or (not (eq simplicity1 simplicity2)) 46 | (and (not (eq uaet1 '*)) (not (eq uaet2 '*)) 47 | (not (equal uaet1 uaet2))) 48 | (and (not (eq dims1 '*)) (not (eq dims2 '*)) 49 | (or (/= (length dims1) (length dims2)) 50 | (loop for dim1 in dims1 51 | for dim2 in dims2 52 | never (or (eq dim1 '*) (eq dim2 '*) 53 | (unless (= dim1 dim2) (return t))))))) 54 | t))) 55 | (defmethod conjointp ((ct1 carray) (ct2 carray)) (values nil t)) 56 | 57 | (defmethod ctype= ((ct1 carray) (ct2 carray)) 58 | (values (and (eq (carray-simplicity ct1) (carray-simplicity ct2)) 59 | (equal (carray-uaet ct1) (carray-uaet ct2)) 60 | (equal (carray-dims ct1) (carray-dims ct2))) 61 | t)) 62 | 63 | (defmethod cofinitep ((ct carray)) (values nil t)) 64 | 65 | (defmethod conjoin/2 ((ct1 carray) (ct2 carray)) 66 | (let ((uaet1 (carray-uaet ct1)) (eaet1 (carray-eaet ct1)) 67 | (dims1 (carray-dims ct1)) (simplicity1 (carray-simplicity ct1)) 68 | (uaet2 (carray-uaet ct2)) (eaet2 (carray-eaet ct2)) 69 | (dims2 (carray-dims ct2)) (simplicity2 (carray-simplicity ct2))) 70 | (let ((new-simplicity 71 | (cond ((eq simplicity1 :simple) 72 | (unless (eq simplicity2 :simple) 73 | ;; simplicity mismatch 74 | (return-from conjoin/2 (bot))) 75 | simplicity1) 76 | ((eq simplicity1 :complex) 77 | (unless (eq simplicity2 :complex) 78 | (return-from conjoin/2 (bot))) 79 | simplicity2))) 80 | (new-uaet 81 | (cond ((eq uaet1 '*) uaet2) 82 | ((eq uaet2 '*) uaet1) 83 | ((equal uaet1 uaet2) uaet1) 84 | ;; UAET mismatch 85 | (t (return-from conjoin/2 (bot))))) 86 | (new-dims 87 | (cond ((eq dims2 '*) dims1) 88 | ((eq dims1 '*) dims2) 89 | ((= (length dims1) (length dims2)) 90 | (loop for dim1 in dims1 91 | for dim2 in dims2 92 | collect (cond ((eq dim1 '*) dim2) 93 | ((eq dim2 '*) dim1) 94 | ((= dim1 dim2) dim1) 95 | ;; Dimension mismatch 96 | (t (return-from conjoin/2 (bot)))))) 97 | (t ;; Rank mismatch 98 | (return-from conjoin/2 (bot))))) 99 | (new-eaet (conjoin eaet1 eaet2))) 100 | (carray new-simplicity new-uaet new-eaet new-dims)))) 101 | 102 | (defmethod subtract ((ct1 carray) (ct2 carray)) 103 | (let ((uaet1 (carray-uaet ct1)) (dims1 (carray-dims ct1)) 104 | (simplicity1 (carray-simplicity ct1)) 105 | (uaet2 (carray-uaet ct2)) (dims2 (carray-dims ct2)) 106 | (simplicity2 (carray-simplicity ct2))) 107 | ;; Since we don't really keep track of array types with chunks taken out 108 | ;; of them, our goal here is just to reduce things to bottom or ct1. 109 | (cond ((not (eq simplicity1 simplicity2)) ct1) 110 | ((or (eq uaet2 '*) (equal uaet1 uaet2)) 111 | (cond ((eq dims2 '*) (bot)) ; all dimension forbidden 112 | ((eq dims1 '*) nil) ; can't remove chunks 113 | ((/= (length dims1) (length dims2)) 114 | ct1) ; different rank, dis joint 115 | ((loop for dim1 in dims1 116 | for dim2 in dims2 117 | always (or (eq dim2 '*) 118 | (and (not (eq dim1 '*)) 119 | (or (= dim1 dim2) 120 | ;; dim mismatch 121 | (return-from subtract ct1))))) 122 | ;; ct2's dimensions are a superset of ct1's 123 | (bot)) 124 | (t ; too complicated; e.g. for dims (3 *) - (* 3) 125 | nil))) 126 | ;; If we have (array * ...) - (array something ...), we can ignore 127 | ;; the subtrahend if it's of a distinct rank. 128 | ((eq uaet1 '*) 129 | (if (and (not (eq dims1 '*)) (not (eq dims2 '*)) 130 | (/= (length dims1) (length dims2))) 131 | ct1 132 | nil)) 133 | ;; Distinct uaets 134 | (t ct1)))) 135 | 136 | (defun unparse-vector-simple (uaet length) 137 | (let* ((front (case uaet 138 | ((bit) '(simple-bit-vector)) 139 | ((base-char) '(simple-base-string)) 140 | ((t) '(simple-vector)) 141 | (otherwise (return-from unparse-vector-simple nil)))) 142 | (back (if (eq length '*) 143 | nil 144 | (list length))) 145 | (all (append front back))) 146 | (if (= (length all) 1) 147 | (first all) 148 | all))) 149 | 150 | (defmethod unparse ((ct carray)) 151 | (let* ((uaet (carray-uaet ct)) (dims (carray-dims ct)) 152 | (tail (if (eq dims '*) 153 | (if (eq uaet '*) 154 | nil 155 | `(,uaet)) 156 | `(,uaet ,dims)))) 157 | (if (eq (carray-simplicity ct) :simple) 158 | (cond ((null tail) 'simple-array) 159 | ((and (not (eq dims '*)) 160 | (= (length dims) 1) 161 | (unparse-vector-simple uaet (first dims)))) 162 | (t `(simple-array ,@tail))) 163 | (if (null tail) 164 | '(and array (not simple-array)) 165 | `(and (array ,@tail) (not simple-array)))))) 166 | -------------------------------------------------------------------------------- /disjunction.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct disjunction)) 4 | (loop for sct in (junction-ctypes ct) 5 | thereis (ctypep object sct))) 6 | 7 | (defmethod subctypep ((ct1 disjunction) (ct2 ctype)) 8 | ;; if a ~<: z then a v b ~<: z as a <: a v b. 9 | ;; if a <: z and b <: z, a v b <: z, as can be seen from a <: z <=> a ^ z = a: 10 | ;; a v b <: z <=> (a v b) ^ z = a v b <=> (a ^ z) v (b ^ z) = a v b 11 | ;; this also covers the case of ct1 being bot. 12 | (every/tri (lambda (sct) (subctypep sct ct2)) (junction-ctypes ct1))) 13 | (defmethod subctypep ((ct1 ctype) (ct2 disjunction)) 14 | #+(or) 15 | (or/tri 16 | (some/tri (lambda (sct) (subctypep ct1 sct)) (junction-ctypes ct2)) 17 | (call-next-method)) 18 | ;; a <: (z v y) <=> a ^ (z v y) = a <=> (a ^ z) v (a ^ y) = a 19 | ;; Obviously if a <: z this reduces to a v (a ^ y) = a which is true. Ditto y. 20 | ;; Getting a definite negative result is a little more challenging. 21 | ;; First, we can see that if a ^ z = 0, (a ^ z) v (a ^ y) = a <=> a ^ y = a 22 | ;; <=> a <: y. With more elements, say a <: (z v y v x), the reduction is 23 | ;; to (a ^ y) v (a ^ x) = a <=> a <: (y v x), i.e. z becomes irrelevant. 24 | ;; So: if a <: z, a <: (z v y). If a is disjoint with all but one, the 25 | ;; result for that last one controls. 26 | ;; If a ^ z = 0 and a ^ y = 0, the question becomes a = 0, which we can answer 27 | ;; false if we also know that a ~<: z or a ~<: y. 28 | ;; The ambiguous case is when we don't know that a is a subtype of at least 29 | ;; one and don't know that a is disjoint with all or all but one. 30 | ;; These are sufficient but not necessary conditions. 31 | ;; This all covers questions like 32 | ;; (subtypep '(integer 10) '(rational 11)) 33 | ;; (where the rational is broken up into an integer and a ratio range). 34 | (loop with surety = t 35 | with not-subtype = 0 36 | with not-subtype-and-not-disjoint = 0 37 | for sct in (junction-ctypes ct2) 38 | do (multiple-value-bind (val subsurety) (subctypep ct1 sct) 39 | (cond ((not subsurety) (setf surety nil)) 40 | (val (return (values t t))) 41 | (surety ; if we're unsure, this fancier stuff is out 42 | (incf not-subtype) 43 | (multiple-value-bind (val subsurety) (disjointp ct1 sct) 44 | (cond ((not subsurety) (setf surety nil)) 45 | ((not val) (incf not-subtype-and-not-disjoint))))))) 46 | finally (return (if (and surety 47 | (or (= not-subtype-and-not-disjoint 1) 48 | (and (> not-subtype 0) 49 | (= not-subtype-and-not-disjoint 0)))) 50 | (values nil t) 51 | (values nil nil))))) 52 | 53 | (define-commutative-method disjointp ((ct1 disjunction) (ct2 ctype)) 54 | ;; (a v b) ^ z = 0 <=> (a ^ z) v (b ^ z) = 0 55 | (every/tri (lambda (sct) (disjointp sct ct2)) (junction-ctypes ct1))) 56 | (define-commutative-method conjointp ((ct1 disjunction) (ct2 ctype)) 57 | (if (some/tri (lambda (sct) (conjointp sct ct2)) (junction-ctypes ct1)) 58 | (values t t) 59 | (values nil nil))) 60 | 61 | (defmethod negate ((ctype disjunction)) 62 | (apply #'conjoin (mapcar #'negate (junction-ctypes ctype)))) 63 | 64 | (defmethod disjoin/2 ((ct1 disjunction) (ct2 disjunction)) 65 | (apply #'disjoin (append (junction-ctypes ct1) 66 | (junction-ctypes ct2)))) 67 | (define-commutative-method disjoin/2 ((ct1 disjunction) (ct2 ctype)) 68 | (apply #'disjoin ct2 (junction-ctypes ct1))) 69 | 70 | (define-commutative-method conjoin/2 ((disjunction disjunction) (ctype ctype)) 71 | (apply #'disjoin 72 | (loop for sct in (junction-ctypes disjunction) 73 | collect (conjoin sct ctype)))) 74 | 75 | (defmethod unparse ((ct disjunction)) 76 | (let ((ups (mapcar #'unparse (junction-ctypes ct)))) 77 | ;; special cases 78 | (when (null ups) (return-from unparse 'nil)) 79 | ;; list 80 | (when (and (member 'null ups) (member 'cons ups)) 81 | (setf ups (delete 'null ups) 82 | ups (delete 'cons ups)) 83 | (push 'list ups)) 84 | ;; float 85 | ;; only unbounded ranges; bounded ones get weird because we coerced the 86 | ;; bounds into other float formats 87 | (when (and (or (not (assoc 'short-float +floats+)) 88 | (member 'short-float ups)) 89 | (member 'single-float ups) 90 | (or (not (assoc 'double-float +floats+)) 91 | (member 'double-float ups)) 92 | (or (not (assoc 'long-float +floats+)) 93 | (member 'long-float ups))) 94 | (setf ups (delete 'short-float ups) 95 | ups (delete 'single-float ups) 96 | ups (delete 'double-float ups) 97 | ups (delete 'long-float ups)) 98 | (push 'float ups)) 99 | ;; rational (i.e. (rational * *)) 100 | (when (and (member 'integer ups) (member 'ratio ups)) 101 | (setf ups (delete 'integer ups) 102 | ups (delete 'ratio ups)) 103 | (push 'rational ups)) 104 | ;; real (again, unbounded only) 105 | (when (and (member 'float ups) (member 'rational ups)) 106 | (setf ups (delete 'float ups) 107 | ups (delete 'rational ups)) 108 | (push 'real ups)) 109 | ;; bounded rational 110 | (let ((integer-ranges 111 | (loop for up in ups 112 | when (and (listp up) (eq (first up) 'integer)) 113 | collect up)) 114 | (ratio-ranges 115 | ;; ratios are unparsed as (and (not integer) (rational ...)) 116 | (loop for up in ups 117 | when (and (listp up) (= (length up) 3) 118 | (eq (first up) 'and) 119 | (equal (second up) '(not integer)) 120 | (listp (third up)) 121 | (eq (car (third up)) 'rational)) 122 | collect up))) 123 | (loop for ratio-range in ratio-ranges 124 | do (destructuring-bind (_ &optional (low '*) (high '*)) 125 | (third ratio-range) 126 | (declare (ignore _)) 127 | ;; FIXME: Collapse (or (ratio (0)) (integer 0)) 128 | (let* ((ilow (cond ((eq low '*) low) 129 | ((listp low) 130 | (let ((l (car low))) 131 | (if (integerp l) 132 | (1+ l) 133 | (ceiling l)))) 134 | (t (ceiling low)))) 135 | (ihigh (cond ((eq high '*) high) 136 | ((listp high) 137 | (let ((h (car high))) 138 | (if (integerp h) 139 | (1- h) 140 | (floor h)))) 141 | (t (floor high)))) 142 | (tail (if (eq ihigh '*) 143 | (list ilow) 144 | (list ilow ihigh))) 145 | (integer-range (find tail integer-ranges 146 | :key #'cdr :test #'equal))) 147 | (when integer-range 148 | (setf ups (delete ratio-range ups) 149 | ups (delete integer-range ups)) 150 | (push (if (eq ihigh '*) 151 | `(rational ,low) 152 | `(rational ,low ,high)) 153 | ups)))))) 154 | ;; finally, 155 | (if (= (length ups) 1) 156 | (first ups) 157 | `(or ,@ups)))) 158 | -------------------------------------------------------------------------------- /config/clasp.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (declaim (inline ratiop)) 4 | (defun ratiop (object) (core:ratiop object)) 5 | 6 | (define-constant +floats+ 7 | '(#+short-float 8 | (short-float . core:short-float-p) 9 | (single-float . core:single-float-p) 10 | (double-float . core:double-float-p) 11 | #+long-float 12 | (long-float . core:long-float-p)) 13 | :test #'equal) 14 | 15 | (define-constant +standard-charset+ '((10 . 10) (32 . 126)) :test #'equal) 16 | (define-constant +base-charset+ '((0 . 255)) :test #'equal) 17 | 18 | (define-constant +string-uaets+ '(base-char character) :test #'equal) 19 | 20 | (define-constant +complex-arrays-exist-p+ t) 21 | (declaim (inline simple-array-p)) 22 | (defun simple-array-p (object) 23 | (if (cleavir-primop:typeq object core:abstract-simple-vector) t nil)) 24 | 25 | (define-constant +class-aliases+ 26 | '((core:abstract-simple-vector (simple-array * (*))) 27 | (core:simple-vector-fixnum (simple-array fixnum (*))) 28 | (core:simple-vector-byte2-t (simple-array ext:byte2 (*))) 29 | (core:simple-vector-byte4-t (simple-array ext:byte4 (*))) 30 | (core:simple-vector-byte8-t (simple-array ext:byte8 (*))) 31 | (core:simple-vector-byte16-t (simple-array ext:byte16 (*))) 32 | (core:simple-vector-byte32-t (simple-array ext:byte32 (*))) 33 | (core:simple-vector-byte64-t (simple-array ext:byte64 (*))) 34 | (core:simple-vector-int2-t (simple-array ext:integer2 (*))) 35 | (core:simple-vector-int4-t (simple-array ext:integer4 (*))) 36 | (core:simple-vector-int8-t (simple-array ext:integer8 (*))) 37 | (core:simple-vector-int16-t (simple-array ext:integer16 (*))) 38 | (core:simple-vector-int32-t (simple-array ext:integer32 (*))) 39 | (core:simple-vector-int64-t (simple-array ext:integer64 (*))) 40 | (core:simple-vector-float (simple-array single-float (*))) 41 | (core:simple-vector-double (simple-array double-float (*))) 42 | (core:simple-character-string (simple-array character (*))) 43 | 44 | (core:complex-vector (and (not simple-array) (array * (*)))) 45 | (core:bit-vector-ns (and (not simple-array) (array bit (*)))) 46 | (core:complex-vector-fixnum 47 | (and (not simple-array) (array fixnum (*)))) 48 | (core:complex-vector-byte2-t 49 | (and (not simple-array) (array ext:byte2 (*)))) 50 | (core:complex-vector-byte4-t 51 | (and (not simple-array) (array ext:byte4 (*)))) 52 | (core:complex-vector-byte8-t 53 | (and (not simple-array) (array ext:byte8 (*)))) 54 | (core:complex-vector-byte16-t 55 | (and (not simple-array) (array ext:byte16 (*)))) 56 | (core:complex-vector-byte32-t 57 | (and (not simple-array) (array ext:byte32 (*)))) 58 | (core:complex-vector-byte64-t 59 | (and (not simple-array) (array ext:byte64 (*)))) 60 | (core:complex-vector-int2-t 61 | (and (not simple-array) (array ext:integer2 (*)))) 62 | (core:complex-vector-int4-t 63 | (and (not simple-array) (array ext:integer4 (*)))) 64 | (core:complex-vector-int8-t 65 | (and (not simple-array) (array ext:integer8 (*)))) 66 | (core:complex-vector-int16-t 67 | (and (not simple-array) (array ext:integer16 (*)))) 68 | (core:complex-vector-int32-t 69 | (and (not simple-array) (array ext:integer32 (*)))) 70 | (core:complex-vector-int64-t 71 | (and (not simple-array) (array ext:integer64 (*)))) 72 | (core:complex-vector-float 73 | (and (not simple-array) (array single-float (*)))) 74 | (core:complex-vector-double 75 | (and (not simple-array) (array double-float (*)))) 76 | (core:str8ns (and (not simple-array) (array base-char (*)))) 77 | (core:str-wns (and (not simple-array) (array character (*)))) 78 | (core:complex-vector-t (and (not simple-array) (array t (*)))) 79 | 80 | (core:simple-mdarray (and (not vector) simple-array)) 81 | (core:simple-mdarray-bit (and (not vector) (simple-array bit))) 82 | (core:simple-mdarray-fixnum 83 | (and (not vector) (simple-array fixnum))) 84 | (core:simple-mdarray-byte2-t 85 | (and (not vector) (simple-array ext:byte2))) 86 | (core:simple-mdarray-byte4-t 87 | (and (not vector) (simple-array ext:byte4))) 88 | (core:simple-mdarray-byte8-t 89 | (and (not vector) (simple-array ext:byte8))) 90 | (core:simple-mdarray-byte16-t 91 | (and (not vector) (simple-array ext:byte16))) 92 | (core:simple-mdarray-byte32-t 93 | (and (not vector) (simple-array ext:byte32))) 94 | (core:simple-mdarray-byte64-t 95 | (and (not vector) (simple-array ext:byte64))) 96 | (core:simple-mdarray-int2-t 97 | (and (not vector) (simple-array ext:integer2))) 98 | (core:simple-mdarray-int4-t 99 | (and (not vector) (simple-array ext:integer4))) 100 | (core:simple-mdarray-int8-t 101 | (and (not vector) (simple-array ext:integer8))) 102 | (core:simple-mdarray-int16-t 103 | (and (not vector) (simple-array ext:integer16))) 104 | (core:simple-mdarray-int32-t 105 | (and (not vector) (simple-array ext:integer32))) 106 | (core:simple-mdarray-int64-t 107 | (and (not vector) (simple-array ext:integer64))) 108 | (core:simple-mdarray-float 109 | (and (not vector) (simple-array single-float))) 110 | (core:simple-mdarray-double 111 | (and (not vector) (simple-array double-float))) 112 | (core:simple-mdarray-base-char 113 | (and (not vector) (simple-array base-char))) 114 | (core:simple-mdarray-character 115 | (and (not vector) (simple-array character))) 116 | (core:simple-mdarray-t 117 | (and (not vector) (simple-array t))) 118 | 119 | (core:mdarray (and array (not vector))) 120 | (core:mdarray-bit 121 | (and (not simple-array) (not vector) (array bit))) 122 | (core:mdarray-fixnum 123 | (and (not simple-array) (not vector) (array fixnum))) 124 | (core:mdarray-byte2-t 125 | (and (not simple-array) (not vector) (array ext:byte2))) 126 | (core:mdarray-byte4-t 127 | (and (not simple-array) (not vector) (array ext:byte4))) 128 | (core:mdarray-byte8-t 129 | (and (not simple-array) (not vector) (array ext:byte8))) 130 | (core:mdarray-byte16-t 131 | (and (not simple-array) (not vector) (array ext:byte16))) 132 | (core:mdarray-byte32-t 133 | (and (not simple-array) (not vector) (array ext:byte32))) 134 | (core:mdarray-byte64-t 135 | (and (not simple-array) (not vector) (array ext:byte64))) 136 | (core:mdarray-int2-t 137 | (and (not simple-array) (not vector) (array ext:integer2))) 138 | (core:mdarray-int4-t 139 | (and (not simple-array) (not vector) (array ext:integer4))) 140 | (core:mdarray-int8-t 141 | (and (not simple-array) (not vector) (array ext:integer8))) 142 | (core:mdarray-int16-t 143 | (and (not simple-array) (not vector) (array ext:integer16))) 144 | (core:mdarray-int32-t 145 | (and (not simple-array) (not vector) (array ext:integer32))) 146 | (core:mdarray-int64-t 147 | (and (not simple-array) (not vector) (array ext:integer64))) 148 | (core:mdarray-float 149 | (and (not simple-array) (not vector) (array single-float))) 150 | (core:mdarray-double 151 | (and (not simple-array) (not vector) (array double-float))) 152 | (core:mdarray-base-char 153 | (and (not simple-array) (not vector) (array base-char))) 154 | (core:mdarray-character 155 | (and (not simple-array) (not vector) (array character))) 156 | (core:mdarray-t 157 | (and (not simple-array) (not vector) (array t)))) 158 | :test #'equal) 159 | 160 | (declaim (inline subclassp)) 161 | (defun subclassp (sub super) (core:subclassp sub super)) 162 | 163 | (declaim (inline typexpand)) 164 | (defun typexpand (type-specifier environment) 165 | (cleavir-env:type-expand environment type-specifier)) 166 | 167 | (defmacro complex-ucptp (objectf ucpt) 168 | `(ecase ,ucpt 169 | ((*) t))) 170 | -------------------------------------------------------------------------------- /ext/mod.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ctype.ext.mod 2 | (:use #:cl #:ctype) 3 | (:export #:congruence)) 4 | 5 | (in-package #:ctype.ext.mod) 6 | 7 | (defclass congruence (ctype) 8 | ((%modulus :initarg :modulus :reader modulus :type (integer 2)) 9 | ;; A field of MODULUS bits. The Nth bit being set indicates that this type 10 | ;; includes integers that are N mod MODULUS. 11 | (%congruences :initarg :congruences :reader congruences 12 | :type (integer 1)))) 13 | 14 | (defun %congruence (modulus congruences) 15 | (make-instance 'congruence :modulus modulus :congruences congruences)) 16 | 17 | (defun canonicalize-congruence (modulus congruences) 18 | ;; This function is to avoid "degenerate" congruences. A congruence is 19 | ;; degenerate if it is equivalent to a congruence with a smaller modulus. 20 | ;; For example, {1, 3} mod 4 is the same as {1} mod 2, so it's degenerate. 21 | ;; In more detail, if our bitfield is repetitive, 22 | ;; the congruence is degenerate. 23 | ;; Avoiding degeneracies makes some computations easier. 24 | (loop for i from 2 upto (floor modulus 2) 25 | when (multiple-value-bind (div mod) (floor modulus i) 26 | (and (zerop mod) 27 | (loop with byte = (byte i 0) 28 | with canon = (ldb byte congruences) 29 | for subcong = congruences 30 | then (ash subcong (- i)) 31 | repeat div 32 | always (= (ldb byte subcong) canon)))) 33 | return (values i (ldb (byte i 0) congruences)) 34 | finally (return (values modulus congruences)))) 35 | 36 | (defun congruence (modulus congruences) 37 | (cond ((zerop congruences) (bot)) ; empty 38 | ((= congruences (1- (ash 1 modulus))) ; full 39 | (range 'integer nil nil nil nil)) 40 | (t (multiple-value-bind (modulus congruences) 41 | (canonicalize-congruence modulus congruences) 42 | (%congruence modulus congruences))))) 43 | 44 | (defmethod ctypep (object (ct congruence)) 45 | (and (integerp object) 46 | (logbitp (mod object (modulus ct)) (congruences ct)))) 47 | 48 | (defmethod subctypep ((ct1 congruence) (ct2 congruence)) 49 | (let ((mod1 (modulus ct1)) (cong1 (congruences ct1)) 50 | (mod2 (modulus ct2)) (cong2 (congruences ct2))) 51 | ;; We assume there are no degenerate congruences. 52 | ;; As such, there is no possibility of a mod4 being a subtype of a mod2, 53 | ;; for example. 54 | (multiple-value-bind (div mod) (truncate mod2 mod1) 55 | (and (zerop mod) 56 | ;; Imagine we have a mod2 and a mod4. 57 | ;; The mod2 is a subtype of the mod4 only if the mod4 has 58 | ;; all the congruences of the mod2. 59 | ;; E.g., if it's {1} mod2, we'd need at least {1,3} mod4. 60 | ;; To compute this, we take sections of cong2 that are mod1 long, 61 | ;; and ensure that each has at least the bits set that cong1 does. 62 | (dotimes (i div (values t t)) 63 | (unless (zerop (logandc2 cong1 cong2)) 64 | (return-from subctypep (values nil t))) 65 | (setf cong1 (ash cong2 (- mod1)))))))) 66 | 67 | (defmethod ctype= ((ct1 congruence) (ct2 congruence)) 68 | ;; Again, we need the canonicalization above for this to be valid 69 | (and (= (modulus ct1) (modulus ct2)) 70 | (= (congruences ct1) (congruences ct2)))) 71 | 72 | (defmethod disjointp ((ct1 congruence) (ct2 congruence)) 73 | (let ((mod1 (modulus ct1)) (cong1 (congruences ct1)) 74 | (mod2 (modulus ct2)) (cong2 (congruences ct2))) 75 | (let ((mod (lcm mod1 mod2))) 76 | ;; NOTE: The truncations are even 77 | (values 78 | (zerop (logand (repeat-bits cong1 mod1 (truncate mod mod1)) 79 | (repeat-bits cong2 mod2 (truncate mod mod2)))) 80 | t)))) 81 | 82 | (defmethod conjointp ((ct1 congruence) (ct2 congruence)) (values nil t)) 83 | (defmethod cofinitep ((ct1 congruence)) (values nil t)) 84 | 85 | (defmethod negate ((ct congruence)) 86 | ;; (not (satisfies evenp)) = (or (not integer) (satisfies oddp)) 87 | (disjunction (negation (range 'integer nil nil nil nil)) 88 | (let ((m (modulus ct))) 89 | ;; if the input is nondegenerate the negation must be too, 90 | ;; so skip canonicalization 91 | (%congruence m (ldb (byte m 0) (lognot (congruences ct))))))) 92 | 93 | ;; (repeat-bits #b101 3 4) => #b101101101101 94 | (defun repeat-bits (bits len repeats) 95 | (let ((byte (ldb (byte len 0) bits))) 96 | (loop repeat repeats 97 | for result = byte 98 | then (logior (ash result len) byte) 99 | finally (return result)))) 100 | 101 | (defmethod conjoin/2 ((ct1 congruence) (ct2 congruence)) 102 | (let ((mod1 (modulus ct1)) (cong1 (congruences ct1)) 103 | (mod2 (modulus ct2)) (cong2 (congruences ct2))) 104 | (let* ((mod (lcm mod1 mod2)) 105 | ;; NOTE: The truncations are even 106 | (cong (logand (repeat-bits cong1 mod1 (truncate mod mod1)) 107 | (repeat-bits cong2 mod2 (truncate mod mod2))))) 108 | (congruence mod cong)))) 109 | 110 | (defmethod disjoin/2 ((ct1 congruence) (ct2 congruence)) 111 | (let ((mod1 (modulus ct1)) (cong1 (congruences ct1)) 112 | (mod2 (modulus ct2)) (cong2 (congruences ct2))) 113 | (let* ((mod (lcm mod1 mod2)) 114 | ;; NOTE: The truncations are even 115 | (cong (logior (repeat-bits cong1 mod1 (truncate mod mod1)) 116 | (repeat-bits cong2 mod2 (truncate mod mod2))))) 117 | (congruence mod cong)))) 118 | 119 | (defmethod subtract ((ct1 congruence) (ct2 congruence)) 120 | (let ((mod1 (modulus ct1)) (cong1 (congruences ct1)) 121 | (mod2 (modulus ct2)) (cong2 (congruences ct2))) 122 | (let* ((mod (lcm mod1 mod2)) 123 | ;; NOTE: The truncations are even 124 | (cong (logandc2 (repeat-bits cong1 mod1 (truncate mod mod1)) 125 | (repeat-bits cong2 mod2 (truncate mod mod2))))) 126 | (congruence mod cong)))) 127 | 128 | (defmethod print-object ((object congruence) stream) 129 | (print-unreadable-object (object stream :type t) 130 | (let ((mod (modulus object)) (cong (congruences object))) 131 | (write (loop for i below mod 132 | when (logbitp i cong) 133 | collect i) 134 | :stream stream) 135 | (write-char #\Space stream) 136 | (write 'cl:mod :stream stream) 137 | (write-char #\Space stream) 138 | (write mod :stream stream))) 139 | object) 140 | 141 | ;;; 142 | 143 | (defmethod subctypep ((ct1 congruence) (ct2 range)) 144 | (values (and (eq (range-kind ct2) 'integer) 145 | (null (range-low ct2)) 146 | (null (range-high ct2))) 147 | t)) 148 | (defmethod subctypep ((ct1 range) (ct2 congruence)) 149 | ;; FIXME: This is pretty inaccurate; e.g. we could check small ranges. 150 | (if (or (not (eq (range-kind ct1) 'integer)) 151 | ;; A range unbounded on one side necessarily includes all 152 | ;; congruences at some point, and we don't allow all-inclusive 153 | ;; congruence types like that. 154 | (null (range-low ct1)) 155 | (null (range-high ct1))) 156 | (values nil t) 157 | (values nil nil))) 158 | 159 | (define-commutative-method disjointp ((congruence congruence) (range range)) 160 | ;; FIXME: Inaccurate in basically the same way. 161 | (if (or (not (eq (range-kind range) 'integer)) 162 | ;; A range unbounded on one side necessarily includes all 163 | ;; congruences at some point, and we don't allow all-inclusive 164 | ;; congruence types like that. 165 | (null (range-low range)) 166 | (null (range-high range))) 167 | (values t t) 168 | (values nil nil))) 169 | 170 | (define-commutative-method conjointp ((ct1 congruence) (ct2 range)) 171 | (values nil t)) 172 | 173 | (defexclusives congruence cclass ccomplex carray charset cfunction fpzero) 174 | -------------------------------------------------------------------------------- /ccons.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep ((object cons) (ct ccons)) 4 | (and (ctypep (car object) (ccons-car ct)) 5 | (ctypep (cdr object) (ccons-cdr ct)))) 6 | (defmethod ctypep ((object t) (ct ccons)) nil) 7 | 8 | (defmethod subctypep ((ct1 ccons) (ct2 ccons)) 9 | (and/tri (subctypep (ccons-car ct1) (ccons-car ct2)) 10 | (subctypep (ccons-cdr ct1) (ccons-cdr ct2)))) 11 | 12 | (defmethod ctype= ((ct1 ccons) (ct2 ccons)) 13 | (and/tri (ctype= (ccons-car ct1) (ccons-car ct2)) 14 | (ctype= (ccons-cdr ct1) (ccons-cdr ct2)))) 15 | 16 | (defmethod disjointp ((ct1 ccons) (ct2 ccons)) 17 | (or/tri (disjointp (ccons-car ct1) (ccons-car ct2)) 18 | (disjointp (ccons-cdr ct1) (ccons-cdr ct2)))) 19 | (defmethod conjointp ((ct1 ccons) (ct2 ccons)) (values nil t)) 20 | 21 | (defmethod cofinitep ((ct1 ccons)) (values nil t)) 22 | 23 | (defmethod negate ((ctype ccons)) 24 | ;; (not (cons a b)) 25 | ;; = (or (not cons) (cons a (not b)) (cons (not a) b) (cons (not a) (not b))) 26 | ;; Or if A or B is the top type, some of these are eliminated. 27 | (let* ((car (ccons-car ctype)) (cdr (ccons-cdr ctype)) 28 | (ncar (negate car)) (ncdr (negate cdr))) 29 | (if (bot-p ncar) 30 | (if (bot-p ncdr) 31 | ;; (not cons) 32 | (call-next-method) 33 | ;; car is t and cdr is not, so (or (not cons) (cons a (not b))) 34 | (disjunction 35 | (negation (ccons car car)) 36 | (ccons car ncdr))) 37 | (if (bot-p ncdr) 38 | ;; (or (not cons) (cons (not a) b)) 39 | (disjunction 40 | (negation (ccons cdr cdr)) 41 | (ccons ncar cdr)) 42 | ;; as in the main comment, 43 | ;; except we reduce the last two to (cons (not a) t) 44 | (let ((top (top))) 45 | (disjunction 46 | (negation (ccons top top)) 47 | (ccons car ncdr) 48 | (ccons ncar top))))))) 49 | 50 | (defmethod conjoin/2 ((ct1 ccons) (ct2 ccons)) 51 | (ccons (conjoin (ccons-car ct1) (ccons-car ct2)) 52 | (conjoin (ccons-cdr ct1) (ccons-cdr ct2)))) 53 | 54 | (defmethod disjoin/2 ((ct1 ccons) (ct2 ccons)) 55 | ;; (or (cons a b) (cons c d)) is in general a strict subtype of 56 | ;; (cons (or a b) (or c d)), which includes (cons a d) etc. 57 | ;; It can be written out more explicitly as 58 | ;; (or (cons (and a (not c)) (and b (not d))) 59 | ;; (cons (and a (not c)) (and b d)) 60 | ;; (cons (and a c) (and b (not d))) 61 | ;; (cons (and a c) (and b d)) 62 | ;; (cons (and a c) (and (not b) d)) 63 | ;; (cons (and (not a) c) (and (not b) d)) 64 | ;; (cons (and (not a) c) (and b d))) 65 | ;; using a = (or (and a c) (and a (not c))), etc., 66 | ;; and in which all the cons types are pairwise disjoint. 67 | ;; But that's pretty ugly in general. 68 | ;; If a <: c, (and a (not c)) = nil, and (and a c) = a, so we have 69 | ;; (or (cons a (and b (not d))) 70 | ;; (cons a (and b d)) 71 | ;; (cons a (and (not b) d)) 72 | ;; (cons (and (not a) c) (and (not b) d)) 73 | ;; (cons (and (not a) c) (and b d))) 74 | ;; which could be further reduced to 75 | ;; (or (cons a (or b d)) 76 | ;; (cons (and (not a) c) d)) 77 | ;; if c <: a as well (i.e. a = c), (and (not a) c) = nil, so it's just 78 | ;; (cons a (or b d)). 79 | ;; You can swap a and c, or do this with b and d, obviously. 80 | ;; Alternately, if a and c are disjoint, (and a c) = nil, (and a (not c)) = a, 81 | ;; and (and (not a) c) = c, so we have 82 | ;; (or (cons a (and b (not d))) 83 | ;; (cons a (and b d)) 84 | ;; (cons c (and (not b) d)) 85 | ;; (cons c (and b d))) 86 | ;; which can be further reduced to (or (cons a b) (cons c d)) again 87 | ;; but with the understanding that they are disjoint. Not too helpful? 88 | ;; SO, in order of preference, if there's a type equality we can reduce 89 | ;; to a cons type; or if there's a subtype we can reduce to two modified 90 | ;; cons types; or we just make a general union. 91 | ;; We can also check if a <: (not c) and such, but I think at that point we 92 | ;; may as well actually computer intersections anyway. 93 | ;; We have to be careful to avoid "flipping". With the above rules, 94 | ;; (or (cons t (not symbol)) (cons (not symbol) symbol)) 95 | ;; is "simplified" to (or (cons (not symbol) t) (cons symbol (not symbol))) 96 | ;; which in turn "simplifies" back to where it started! Very bad. 97 | ;; So we only do it on the cdrs (arbitrarily chosen) if we know that the 98 | ;; cons types are not disjoint. 99 | (let* ((car1 (ccons-car ct1)) (cdr1 (ccons-cdr ct1)) 100 | (car2 (ccons-car ct2)) (cdr2 (ccons-cdr ct2))) 101 | (cond ((ctype= car1 car2) (ccons car1 (disjoin cdr1 cdr2))) 102 | ((ctype= cdr1 cdr2) (ccons (disjoin car1 car2) cdr1)) 103 | ;; In the following, the subtractions should really never be bottom, 104 | ;; because one is a strict subtype of the other. If one is bottom it 105 | ;; would indicate that the simplifier (like conjoin/2) is smarter 106 | ;; than subctypep, which is unfortunate. 107 | ((subctypep car1 car2) 108 | (let ((car-2-1 (conjoin car2 (negate car1))) 109 | (reg (ccons car1 (disjoin cdr1 cdr2)))) 110 | (if (bot-p car-2-1) 111 | reg 112 | (disjunction reg (ccons car-2-1 cdr2))))) 113 | ((subctypep car2 car1) 114 | (let ((car-1-2 (conjoin car1 (negate car2))) 115 | (reg (ccons car2 (disjoin cdr1 cdr2)))) 116 | (if (bot-p car-1-2) 117 | reg 118 | (disjunction reg (ccons car-1-2 cdr1))))) 119 | ;; Give up unless we can prove nondisjointness. 120 | ((multiple-value-bind (val1 surety1) (disjointp car1 car2) 121 | (or val1 122 | (not surety1) 123 | (multiple-value-bind (val2 surety2) (disjointp cdr1 cdr2) 124 | (or val2 (not surety2))))) 125 | nil) 126 | ((subctypep cdr1 cdr2) 127 | (let ((cdr-2-1 (conjoin cdr2 (negate cdr1))) 128 | (reg (ccons (disjoin car1 car2) cdr1))) 129 | (if (bot-p cdr-2-1) 130 | reg 131 | (disjunction reg (ccons car2 cdr-2-1))))) 132 | ((subctypep cdr2 cdr1) 133 | (let ((cdr-1-2 (conjoin cdr1 (negate cdr2))) 134 | (reg (ccons (disjoin car1 car2) cdr2))) 135 | (if (bot-p cdr-1-2) 136 | reg 137 | (disjunction reg (ccons car1 cdr-1-2))))) 138 | (t nil)))) 139 | 140 | (defmethod subtract ((ct1 ccons) (ct2 ccons)) 141 | ;; as in the negate method, (not (cons a b)) = 142 | ;; (or (not cons) (cons a (not b)) (cons (not a) b) (cons (not a) (not b))) 143 | ;; We're conjoining this with (cons c d). 144 | ;; (and (cons c d) (not cons)) is obviously nil. 145 | ;; (and (cons c d) (cons a (not b))) = (cons (and c a) (and d (not b))) 146 | ;; (and (cons c d) (cons (not a) b)) = (cons (and c (not a)) (and d b)) 147 | ;; (and (cons c d) (cons (not a) (not b))) 148 | ;; = (cons (and c (not a)) (and d (not b))) 149 | ;; These types are obviously pairwise disjoint so we can just use disjunction 150 | ;; directly and save a bit of time. And there are special cases: 151 | ;; If (and c a) = 0, (and c (not a)) = c, so we have 152 | ;; (or (cons c (and d b)) (cons c (and d (not b)))) = (cons c d) 153 | ;; If c <: a, (and c a) = c and (and c (not a)) = 0, so we have 154 | ;; (cons c (and d (not b))); if also d <: b this is 0. 155 | (let ((car1 (ccons-car ct1)) (cdr1 (ccons-cdr ct1)) 156 | (car2 (ccons-car ct1)) (cdr2 (ccons-cdr ct2))) 157 | (cond ((disjointp car1 car2) ct1) 158 | ((disjointp cdr1 cdr2) ct1) 159 | ((subctypep car1 car2) 160 | (if (subctypep cdr1 cdr2) 161 | (bot) 162 | (ccons car1 (conjoin cdr1 (negate cdr2))))) 163 | ((subctypep cdr1 cdr2) 164 | (ccons (conjoin car1 (negate car2)) cdr1)) 165 | (t (let ((car1-2 (conjoin car1 (negate car2))) 166 | (cdr1-2 (conjoin cdr1 (negate cdr2)))) 167 | (disjunction (ccons (conjoin car1 car2) cdr1-2) 168 | (ccons car1-2 (conjoin cdr1 cdr2)) 169 | (ccons car1-2 cdr1-2))))))) 170 | 171 | (defmethod unparse ((ct ccons)) 172 | (let ((car (ccons-car ct)) (cdr (ccons-cdr ct))) 173 | (if (top-p cdr) 174 | (if (top-p car) 175 | 'cons 176 | `(cons ,(unparse car))) 177 | `(cons ,(unparse car) ,(unparse cdr))))) 178 | -------------------------------------------------------------------------------- /ext/data-structures/array-of.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype.ext.data-structures) 2 | 3 | (defclass carray-of (carray) () 4 | (:documentation "Homogeneous array ctype.")) 5 | 6 | (defun carray-of (element-ctype &optional (dims '*) (upgraded-element-type '*) simplicity) 7 | (if simplicity 8 | (make-instance 9 | 'carray-of 10 | :simplicity simplicity :uaet upgraded-element-type :eaet element-ctype :dims dims) 11 | (let ((simple 12 | (make-instance 13 | 'carray-of 14 | :simplicity :simple :uaet upgraded-element-type :eaet element-ctype :dims dims))) 15 | (if ctype:+complex-arrays-exist-p+ 16 | (disjoin simple 17 | (make-instance 18 | 'carray-of 19 | :simplicity :complex :uaet upgraded-element-type :eaet element-ctype :dims dims)) 20 | simple)))) 21 | 22 | (define-extended-type array-of (element-type &optional (dims '*) (upgraded-element-type '*) &environment env) 23 | :documentation "An array whose elements are of type ELEMENT-TYPE." 24 | :simple ((declare (ignore upgraded-element-type env)) 25 | `(array ,element-type ,dims)) 26 | :extended 27 | ((carray-of (extended-specifier-ctype element-type env) dims upgraded-element-type))) 28 | 29 | (defun simple-carray-of (element-ctype &optional (dims '*) (upgraded-element-type '*)) 30 | (make-instance 31 | 'carray-of 32 | :simplicity :simple :uaet upgraded-element-type :eaet element-ctype :dims dims)) 33 | 34 | (define-extended-type simple-array-of (element-type &optional (dims '*) (upgraded-element-type '*) &environment env) 35 | :documentation "A simple array whose elements are of type ELEMENT-TYPE." 36 | :simple ((declare (ignore upgraded-element-type env)) 37 | `(simple-array ,element-type ,dims)) 38 | :extended 39 | ((simple-carray-of (extended-specifier-ctype element-type env) dims upgraded-element-type))) 40 | 41 | (defun cvector-of (element-ctype &optional (length '*) (upgraded-element-type '*) simplicity) 42 | (carray-of 43 | element-ctype 44 | (if (eq length '*) 45 | length 46 | (list length)) 47 | upgraded-element-type simplicity)) 48 | 49 | (define-extended-type vector-of (element-type &optional (length '*) (upgraded-element-type '*) &environment env) 50 | :documentation "A vector whose elements are of type ELEMENT-TYPE." 51 | :simple ((declare (ignore upgraded-element-type env)) 52 | `(vector ,element-type ,length)) 53 | :extended 54 | ((cvector-of (extended-specifier-ctype element-type env) length upgraded-element-type))) 55 | 56 | (defun simple-cvector-of (element-ctype &optional (length '*) (upgraded-element-type '*)) 57 | (simple-carray-of 58 | element-ctype 59 | (if (eq length '*) 60 | length 61 | (list length)) 62 | upgraded-element-type)) 63 | 64 | (define-extended-type simple-vector-of (element-type &optional (length '*) (upgraded-element-type '*) &environment env) 65 | :documentation "A simple vector whose elements are of type ELEMENT-TYPE." 66 | :simple ((declare (ignore upgraded-element-type env)) 67 | `(simple-vector ,element-type ,length)) 68 | :extended 69 | ((simple-cvector-of (extended-specifier-ctype element-type env) length upgraded-element-type))) 70 | 71 | (defun unparse-vector-simple (type length) 72 | (let* ((front `(simple-vector-of ,type)) 73 | (back (if (eq length '*) 74 | nil 75 | (list length))) 76 | (all (append front back))) 77 | (if (= (length all) 1) 78 | (first all) 79 | all))) 80 | 81 | (defmethod unparse ((ct carray-of)) 82 | (let* ((element-type (unparse (carray-eaet ct))) 83 | (dims (carray-dims ct)) 84 | (tail (if (eq dims '*) 85 | (if (eq element-type '*) 86 | nil 87 | `(,element-type)) 88 | `(,element-type ,dims)))) 89 | (if (eq (carray-simplicity ct) :simple) 90 | (cond ((null tail) 'simple-array) 91 | ((and (not (eq dims '*)) 92 | (= (length dims) 1) 93 | (unparse-vector-simple element-type (first dims)))) 94 | (t `(simple-array-of ,@tail))) 95 | (if (null tail) 96 | '(and array (not simple-array)) 97 | `(and (array ,@tail) (not simple-array)))))) 98 | 99 | (defmethod ctypep ((object array) (ct carray-of)) 100 | (let ((element-ctype (carray-eaet ct)) 101 | (dims (carray-dims ct))) 102 | (and (or (eq dims '*) 103 | (let ((rank (length dims))) 104 | (and (= (array-rank object) rank) 105 | (loop for i from 0 below rank 106 | for dim in dims 107 | always (or (eq dim '*) 108 | (= (array-dimension object i) dim)))))) 109 | (let ((all-indexes (mapcar #'iota (array-dimensions object)))) 110 | (block check-elements-types 111 | (apply #'map-product 112 | (lambda (&rest indexes) 113 | (unless (ctypep (apply #'aref object indexes) element-ctype) 114 | (return-from check-elements-types nil))) 115 | all-indexes) 116 | t))))) 117 | (defmethod ctypep ((object t) (ct carray-of)) nil) 118 | 119 | (defmethod subctypep ((ct1 carray-of) (ct2 carray-of)) 120 | (let ((element-ctype1 (carray-eaet ct1)) 121 | (dims1 (carray-dims ct1)) 122 | (simplicity1 (carray-simplicity ct1)) 123 | (element-ctype2 (carray-eaet ct2)) 124 | (dims2 (carray-dims ct2)) 125 | (simplicity2 (carray-simplicity ct2))) 126 | (and/tri 127 | (subctypep element-ctype1 element-ctype2) 128 | (values 129 | (and (eq simplicity1 simplicity2) 130 | (or (eq dims2 '*) 131 | (and (not (eq dims1 '*)) 132 | (= (length dims1) (length dims2)) 133 | (loop for dim1 in dims1 134 | for dim2 in dims2 135 | always (or (eq dim2 '*) 136 | (and (not (eq dim1 '*)) 137 | (= dim1 dim2))))))) 138 | t)))) 139 | 140 | (defmethod conjoin/2 ((array1 carray-of) (array2 carray-of)) 141 | (let ((uaet1 (carray-uaet array1)) 142 | (eaet1 (carray-eaet array1)) 143 | (dims1 (carray-dims array1)) 144 | (simplicity1 (carray-simplicity array1)) 145 | (uaet2 (carray-uaet array2)) 146 | (eaet2 (carray-eaet array2)) 147 | (dims2 (carray-dims array2)) 148 | (simplicity2 (carray-simplicity array2))) 149 | (let ((new-simplicity 150 | (cond ((eq simplicity1 :simple) 151 | (unless (eq simplicity2 :simple) 152 | ;; simplicity mismatch 153 | (return-from conjoin/2 (bot))) 154 | simplicity1) 155 | ((eq simplicity1 :complex) 156 | (unless (eq simplicity2 :complex) 157 | (return-from conjoin/2 (bot))) 158 | simplicity2))) 159 | (new-uaet 160 | (cond ((eq uaet1 '*) uaet2) 161 | ((eq uaet2 '*) uaet1) 162 | ((equal uaet1 uaet2) uaet1) 163 | ;; UAET mismatch 164 | (t (return-from conjoin/2 (bot))))) 165 | (new-dims 166 | (cond ((eq dims2 '*) dims1) 167 | ((eq dims1 '*) dims2) 168 | ((= (length dims1) (length dims2)) 169 | (loop for dim1 in dims1 170 | for dim2 in dims2 171 | collect (cond ((eq dim1 '*) dim2) 172 | ((eq dim2 '*) dim1) 173 | ((= dim1 dim2) dim1) 174 | ;; Dimension mismatch 175 | (t (return-from conjoin/2 (bot)))))) 176 | (t ;; Rank mismatch 177 | (return-from conjoin/2 (bot))))) 178 | (new-eaet (conjoin eaet1 eaet2))) 179 | (if (bot-p new-eaet) 180 | (bot) 181 | (carray-of new-eaet new-dims new-uaet new-simplicity))))) 182 | 183 | (define-commutative-method conjoin/2 ((cclass cclass) (carray carray-of)) 184 | (if (sequence-cclass-p cclass) 185 | (let ((dims (carray-dims carray))) 186 | (cond ((eq dims '*) 187 | (carray-of (carray-eaet carray) 188 | '(*) 189 | (carray-uaet carray) 190 | (carray-simplicity carray))) 191 | ((= (length dims) 1) carray) 192 | (t (bot)))) 193 | (bot))) 194 | -------------------------------------------------------------------------------- /range.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | (defmethod ctypep (object (ct range)) 4 | (and (range-kindp object (range-kind ct)) 5 | (let ((low (range-low ct))) 6 | (or (not low) 7 | (if (range-low-exclusive-p ct) 8 | (< low object) 9 | (<= low object)))) 10 | (let ((high (range-high ct))) 11 | (or (not high) 12 | (if (range-high-exclusive-p ct) 13 | (< object high) 14 | (<= object high)))))) 15 | 16 | (defmethod subctypep ((ct1 range) (ct2 range)) 17 | (values 18 | (and (eq (range-kind ct1) (range-kind ct2)) 19 | (let ((low1 (range-low ct1)) (low2 (range-low ct2))) 20 | (or (not low2) 21 | (and low1 22 | (or (< low2 low1) 23 | (and (= low2 low1) 24 | (or (range-low-exclusive-p ct1) 25 | (not (range-low-exclusive-p ct2)))))))) 26 | (let ((high1 (range-high ct1)) (high2 (range-high ct2))) 27 | (or (not high2) 28 | (and high1 29 | (or (< high1 high2) 30 | (and (= high1 high2) 31 | (or (range-high-exclusive-p ct1) 32 | (not (range-high-exclusive-p ct2))))))))) 33 | t)) 34 | 35 | (defmethod ctype= ((ct1 range) (ct2 range)) 36 | (values (and (eq (range-kind ct1) (range-kind ct2)) 37 | (let ((low1 (range-low ct1)) (low2 (range-low ct2))) 38 | (if low1 39 | (and low2 (= low1 low2)) 40 | (not low2))) 41 | (eql (range-low-exclusive-p ct1) (range-low-exclusive-p ct2)) 42 | (let ((high1 (range-high ct1)) (high2 (range-high ct2))) 43 | (if high1 44 | (and high2 (= high1 high2)) 45 | (not high2))) 46 | (eql (range-high-exclusive-p ct1) (range-high-exclusive-p ct2))) 47 | t)) 48 | 49 | (defun ranges-disjoint-p (low1 lxp1 high1 hxp1 low2 lxp2 high2 hxp2) 50 | (or (and high1 low2 51 | (or (< high1 low2) (and (= high1 low2) (or hxp1 lxp2)))) 52 | (and high2 low1 53 | (or (< high2 low1) (and (= high2 low1) (or hxp2 lxp1)))))) 54 | 55 | (defmethod disjointp ((ct1 range) (ct2 range)) 56 | (let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2)) 57 | (low1 (range-low ct1)) (low2 (range-low ct2)) 58 | (lxp1 (range-low-exclusive-p ct1)) 59 | (lxp2 (range-low-exclusive-p ct2)) 60 | (high1 (range-high ct1)) (high2 (range-high ct2)) 61 | (hxp1 (range-high-exclusive-p ct1)) 62 | (hxp2 (range-high-exclusive-p ct2))) 63 | (values 64 | (or (not (eq rk1 rk2)) 65 | (ranges-disjoint-p low1 lxp1 high1 hxp1 low2 lxp2 high2 hxp2)) 66 | t))) 67 | 68 | (defmethod conjointp ((ct1 range) (ct2 range)) (values nil t)) 69 | 70 | (defmethod cofinitep ((ct range)) (values nil t)) 71 | 72 | (defmethod negate ((ct range)) 73 | ;; (not (real x (y))) = (or (not real) (real * (x)) (real y *)) 74 | (let* ((kind (range-kind ct)) 75 | (negk (negation (range kind nil nil nil nil))) 76 | (low (range-low ct)) (high (range-high ct)) 77 | (lxp (range-low-exclusive-p ct)) (hxp (range-high-exclusive-p ct))) 78 | (cond ((and low high) 79 | (disjunction negk (range kind nil nil low (not lxp)) 80 | (range kind high (not hxp) nil nil))) 81 | (low (disjunction negk (range kind nil nil low (not lxp)))) 82 | (high (disjunction negk (range kind high (not hxp) nil nil))) 83 | (t negk)))) 84 | 85 | (defmethod conjoin/2 ((ct1 range) (ct2 range)) 86 | (if (eq (range-kind ct1) (range-kind ct2)) 87 | (multiple-value-bind (low lxp) 88 | (let ((low1 (range-low ct1)) (low2 (range-low ct2)) 89 | (lxp1 (range-low-exclusive-p ct1)) 90 | (lxp2 (range-low-exclusive-p ct2))) 91 | (cond ((not low1) (values low2 lxp2)) 92 | ((not low2) (values low1 lxp1)) 93 | ((< low1 low2) (values low2 lxp2)) 94 | ((< low2 low1) (values low1 lxp1)) 95 | (t (values low1 (or lxp1 lxp2))))) 96 | (multiple-value-bind (high hxp) 97 | (let ((high1 (range-high ct1)) (high2 (range-high ct2)) 98 | (hxp1 (range-high-exclusive-p ct1)) 99 | (hxp2 (range-high-exclusive-p ct2))) 100 | (cond ((not high1) (values high2 hxp2)) 101 | ((not high2) (values high1 hxp1)) 102 | ((< high1 high2) (values high1 hxp1)) 103 | ((< high2 high1) (values high2 hxp2)) 104 | (t (values high1 (or hxp1 hxp2))))) 105 | (range (range-kind ct1) low lxp high hxp))) 106 | ;; Different kinds of range - conjunction is empty 107 | (bot))) 108 | 109 | (defmethod disjoin/2 ((ct1 range) (ct2 range)) 110 | (let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2)) 111 | (low1 (range-low ct1)) (low2 (range-low ct2)) 112 | (lxp1 (range-low-exclusive-p ct1)) 113 | (lxp2 (range-low-exclusive-p ct2)) 114 | (high1 (range-high ct1)) (high2 (range-high ct2)) 115 | (hxp1 (range-high-exclusive-p ct1)) 116 | (hxp2 (range-high-exclusive-p ct2))) 117 | ;; If the range kinds don't match, give up. 118 | (unless (eq rk1 rk2) (return-from disjoin/2 nil)) 119 | ;; If ct2 has a lesser infinum, swap. 120 | (when (or (not low2) 121 | (and low1 (< low2 low1))) 122 | (rotatef low1 low2) (rotatef lxp1 lxp2) 123 | (rotatef high1 high2) (rotatef hxp1 hxp2)) 124 | ;; Actually try to merge ranges. 125 | (cond 126 | ((or (not high1) (not low2) 127 | (> high1 low2) 128 | (and (= high1 low2) 129 | (or (not hxp1) (not lxp2)))) 130 | (multiple-value-bind (low lxp) 131 | (cond ((not low1) (values low1 lxp1)) 132 | ((not low2) (values low2 lxp2)) 133 | ((< low1 low2) (values low1 lxp1)) 134 | ((< low2 low1) (values low2 lxp2)) 135 | (t (values low1 (and lxp1 lxp2)))) 136 | (multiple-value-bind (high hxp) 137 | (cond ((not high1) (values high1 hxp1)) 138 | ((not high2) (values high2 hxp2)) 139 | ((< high1 high2) (values high2 hxp2)) 140 | ((< high2 high1) (values high1 hxp1)) 141 | (t (values high1 (and hxp1 hxp2)))) 142 | (range rk1 low lxp high hxp)))) 143 | ;; We can merge integer ranges that are off by one, 144 | ;; e.g. (or (integer 1 5) (integer 6 10)) = (integer 1 10). 145 | ((and (eq rk1 'integer) 146 | high1 low2 ; already covered by the above, but let's be clear 147 | (not hxp1) (not lxp2) 148 | (= (1+ high1) low2)) 149 | (range rk1 low1 lxp1 high2 hxp2)) 150 | (t ;; Ranges are not contiguous - give up 151 | nil)))) 152 | 153 | (defmethod subtract ((ct1 range) (ct2 range)) 154 | (let ((rk1 (range-kind ct1)) (rk2 (range-kind ct2)) 155 | (low1 (range-low ct1)) (low2 (range-low ct2)) 156 | (lxp1 (range-low-exclusive-p ct1)) 157 | (lxp2 (range-low-exclusive-p ct2)) 158 | (high1 (range-high ct1)) (high2 (range-high ct2)) 159 | (hxp1 (range-high-exclusive-p ct1)) 160 | (hxp2 (range-high-exclusive-p ct2))) 161 | (cond ((not (eq rk1 rk2)) ct1) 162 | ((and low1 high2 163 | (or (< high2 low1) (and (= high2 low1) (or hxp2 lxp1)))) 164 | ;; ct2 is too negative to overlap with ct1 165 | ct1) 166 | ((and high1 low2 167 | (or (> low2 high1) (and (= low2 high1) (or lxp2 hxp1)))) 168 | ;; ct2 is too positive to overlap with ct1 169 | ct1) 170 | ;; ct2 overlaps ct1, so we actually need to do something here. 171 | ((or (not low2) 172 | (and low1 (or (< low2 low1) 173 | (and (= low2 low1) (or lxp1 (not lxp2)))))) 174 | (if (or (not high2) 175 | (and high1 (or (> high2 high1) 176 | (and (= high2 high1) (or hxp1 (not hxp2)))))) 177 | ;; ct1 is a strict subrange of ct1 178 | (bot) 179 | ;; ct2's low is <= that of ct1, so chop off the low end of ct1. 180 | (range rk1 high2 (not hxp2) high1 hxp1))) 181 | ((or (not high2) 182 | (and high1 (or (> high2 high1) 183 | (and (= high2 high1) (or hxp1 (not hxp2)))))) 184 | ;; ct2's high is >= that of ct1, so chop off the high end of ct1. 185 | (range rk1 low1 lxp1 low2 (not lxp2))) 186 | (t 187 | ;; ct2 is a strict subrange of ct1 188 | (disjunction (range rk1 low1 lxp1 low2 (not lxp2)) 189 | (range rk1 high2 (not hxp2) high1 hxp1)))))) 190 | 191 | (defmethod unparse ((ct range)) 192 | (let ((kind (range-kind ct)) 193 | (low (range-low ct)) (high (range-high ct))) 194 | (case kind 195 | ((integer) 196 | (cond ((and low high) 197 | ;; we should have normalized out exclusivities and stuff. 198 | (assert (integerp low)) (assert (integerp high)) 199 | (assert (>= high low)) 200 | ;; sbcl crib 201 | (let ((high-count (logcount high)) 202 | (high-length (integer-length high))) 203 | (cond ((zerop low) 204 | (cond ((zerop high) '(integer 0 0)) 205 | ((= high 1) 'bit) 206 | ((= high-count high-length) 207 | `(unsigned-byte ,high-length)) 208 | (t `(mod ,(1+ high))))) 209 | ((and (= low most-negative-fixnum) 210 | (= high most-positive-fixnum)) 211 | 'fixnum) 212 | ((and (= low (lognot high)) 213 | (= high-count high-length)) 214 | `(signed-byte ,(1+ high-length))) 215 | (t `(integer ,low ,high))))) 216 | (high `(,kind ,(or low '*) ,high)) 217 | (low (if (zerop low) 'unsigned-byte `(,kind ,low))) 218 | (t kind))) 219 | ((ratio) 220 | (if (or low high) 221 | (let ((low (if (range-low-exclusive-p ct) (list low) low)) 222 | (high (if (range-high-exclusive-p ct) (list high) high))) 223 | `(and (not integer) 224 | ,(if high `(rational ,(or low '*) ,high) `(rational ,low)))) 225 | 'ratio)) 226 | (otherwise 227 | (let ((low (if (and low (range-low-exclusive-p ct)) (list low) low)) 228 | (high 229 | (if (and high (range-high-exclusive-p ct)) (list high) high))) 230 | (cond (high `(,kind ,(or low '*) ,high)) 231 | (low `(,kind ,low)) 232 | (t kind))))))) 233 | -------------------------------------------------------------------------------- /pairwise.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ctype) 2 | 3 | ;;;; Pair methods 4 | ;;;; That is, methods on two specific ctype classes. 5 | 6 | ;;; cclass ctypes are excluded from several other ctypes (when things are 7 | ;;; normalized correctly), so we can mark their conjunctions as empty, etc. 8 | 9 | (defmacro defexclusive/2 (class1 class2) 10 | `(progn 11 | (define-commutative-method subctypep ((ct1 ,class1) (ct2 ,class2)) 12 | (values nil t)) 13 | (define-commutative-method disjointp ((ct1 ,class1) (ct2 ,class2)) 14 | (values t t)) 15 | (define-commutative-method conjointp ((ct1 ,class1) (ct2 ,class2)) 16 | (values nil t)))) 17 | 18 | (defmacro defexclusive (&rest classes) 19 | `(progn 20 | ,@(loop for (class1 . rest) on classes 21 | nconc (loop for class2 in rest 22 | collect `(defexclusive/2 ,class1 ,class2))))) 23 | 24 | (defmacro defexclusives (main &rest classes) 25 | `(progn ,@(loop for class in classes 26 | collect `(defexclusive ,main ,class)))) 27 | 28 | (defexclusive range ccomplex carray charset cfunction) 29 | (defexclusives cclass range ccomplex charset) 30 | (defexclusives fpzero cmember ccomplex carray charset cfunction) 31 | 32 | ;;; cons types are unfortunately ambiguous: (cons (satisfies foo)) MIGHT be 33 | ;;; bottom "in disguise", and might not be. 34 | ;;; This is basically (subctypep ccons (bot)), but we use this in subctypep 35 | ;;; methods themselves, so we have to reduce it to mimic the usual subctypep 36 | ;;; method in ccons.lisp. 37 | ;;; To be clear, the idea here is not that a subctypep will ever return true- 38 | ;;; thanks to normalization, it won't. But whether the cons is definitely NOT 39 | ;;; bottom can vary. 40 | (defun ccons-bottom-p (ccons) 41 | (or/tri (subctypep (ccons-car ccons) (bot)) 42 | (subctypep (ccons-cdr ccons) (bot)))) 43 | 44 | (defmethod subctypep ((ct1 ccons) (ct2 ctype)) 45 | (if (ccons-bottom-p ct1) (values t t) (values nil nil))) 46 | 47 | (macrolet ((consxclusive/1 (class) 48 | `(progn 49 | (defmethod subctypep ((ct1 ccons) (ct2 ,class)) 50 | ;; ct1 and ct2 are basically exclusive, so if ct1 is 51 | ;; definitely NOT bottom, they really are exclusive. 52 | ;; That's why this is different from the general method above. 53 | (ccons-bottom-p ct1)) 54 | (defmethod subctypep ((ct1 ,class) (ct2 ccons)) (values nil t)) 55 | (define-commutative-method disjointp ((ct1 ccons) (ct2 ,class)) 56 | (values t t)))) 57 | (consxclusive (&rest classes) 58 | `(progn ,@(loop for class in classes 59 | collect `(consxclusive/1 ,class))))) 60 | (consxclusive range ccomplex carray charset cfunction fpzero)) 61 | 62 | (macrolet ((defnonconjoint/2 (c1 c2) 63 | `(define-commutative-method conjointp ((ct1 ,c1) (ct2 ,c2)) 64 | (values nil t))) 65 | (defnonconjoint (&rest classes) 66 | `(progn 67 | ,@(loop for (class1 . rest) on classes 68 | nconc (loop for class2 in rest 69 | collect `(defnonconjoint/2 70 | ,class1 ,class2)))))) 71 | (defnonconjoint cclass ccons range fpzero ccomplex cmember carray 72 | charset cfunction)) 73 | 74 | ;;; Some cclass ctype relations we unfortunately have to handle specially. 75 | (defun sequence-cclass-p (cclass) 76 | (eq (class-name (cclass-class cclass)) 'sequence)) 77 | ;;; CONS is a subclass of SEQUENCE. Therefore, all CONS types are subtypes of 78 | ;;; SEQUENCE, regardless of whether they actually describe proper sequences, 79 | ;;; and even if they don't. 80 | (defmethod subctypep ((ct1 ccons) (ct2 cclass)) 81 | (or/tri (ccons-bottom-p ct1) (values (sequence-cclass-p ct2) t))) 82 | (defmethod subctypep ((ct1 cclass) (ct2 ccons)) (values nil t)) 83 | (define-commutative-method disjointp ((ct1 ccons) (ct2 cclass)) 84 | (or/tri (ccons-bottom-p ct1) (values (not (sequence-cclass-p ct2)) t))) 85 | (define-commutative-method conjoin/2 ((ct1 cclass) (ct2 ccons)) 86 | (if (sequence-cclass-p ct1) ct2 (bot))) 87 | (define-commutative-method disjoin/2 ((ct1 cclass) (ct2 ccons)) 88 | (if (sequence-cclass-p ct1) ct1 nil)) 89 | (defmethod subtract ((ct1 ccons) (ct2 cclass)) 90 | (if (sequence-cclass-p ct2) (bot) ct1)) 91 | (defmethod subtract ((ct1 cclass) (ct2 ccons)) 92 | (if (sequence-cclass-p ct1) nil (bot))) 93 | ;;; NULL is (MEMBER NIL), and cmember methods should already handle things. 94 | (defmethod subctypep ((ct1 carray) (ct2 cclass)) 95 | (values (and (sequence-cclass-p ct2) 96 | (let ((dims (carray-dims ct1))) 97 | (and (listp dims) (= (length dims) 1)))) 98 | t)) 99 | (defmethod subctypep ((ct1 cclass) (ct2 carray)) (values nil t)) 100 | (define-commutative-method disjointp ((ct1 carray) (ct2 cclass)) 101 | (values (not (and (sequence-cclass-p ct2) 102 | (let ((dims (carray-dims ct1))) 103 | (or (eq dims '*) (= (length dims) 1))))) 104 | t)) 105 | (define-commutative-method conjoin/2 ((cclass cclass) (carray carray)) 106 | (if (sequence-cclass-p cclass) 107 | (let ((dims (carray-dims carray))) 108 | (cond ((eq dims '*) 109 | (carray (carray-simplicity carray) 110 | (carray-uaet carray) (carray-eaet carray) 111 | '(*))) 112 | ((= (length dims) 1) carray) 113 | (t (bot)))) 114 | (bot))) 115 | (defmethod subtract ((ct1 cclass) (ct2 carray)) 116 | (if (sequence-cclass-p ct1) 117 | (let ((dims (carray-dims ct2))) 118 | (if (or (eq dims '*) (= (length dims) 1)) 119 | nil 120 | ct1)) 121 | ct1)) 122 | (defmethod subtract ((ct1 carray) (ct2 cclass)) 123 | (if (sequence-cclass-p ct2) 124 | (let ((dims (carray-dims ct1))) 125 | (cond ((eq dims '*) nil) 126 | ((= (length dims) 1) (bot)) 127 | (t ct1))) 128 | ct1)) 129 | 130 | (defun subfunction-cclass-p (cclass) 131 | ;; FIXME: We skip the env here, is that okay? 132 | (subclassp (cclass-class cclass) (find-class 'function t))) 133 | (defmethod subctypep ((ct1 cfunction) (ct2 cclass)) 134 | ;; FUNCTION itself is never a cclass, so 135 | (values nil t)) 136 | (defmethod subctypep ((ct1 cclass) (ct2 cfunction)) 137 | (if (subfunction-cclass-p ct1) 138 | (if (function-top-p ct2) (values t t) (values nil nil)) 139 | (values nil t))) 140 | (define-commutative-method conjoin/2 ((ct1 cclass) (ct2 cfunction)) 141 | (if (subfunction-cclass-p ct1) 142 | (if (function-top-p ct2) ct1 nil) 143 | (bot))) 144 | (defmethod subtract ((ct1 cclass) (ct2 cfunction)) 145 | (if (subfunction-cclass-p ct1) 146 | (if (function-top-p ct2) (bot) nil) 147 | ct1)) 148 | (defmethod subtract ((ct1 cfunction) (ct2 cclass)) 149 | (if (subfunction-cclass-p ct2) 150 | nil 151 | ct1)) 152 | 153 | ;;; Some ctypes are never empty and also never top. Define this explicitly. 154 | (defmacro defexistential (class) 155 | `(progn 156 | (defmethod subctypep ((ct1 ,class) (ct2 disjunction)) 157 | (if (bot-p ct2) 158 | (values nil t) 159 | (values nil nil))) 160 | (defmethod subctypep ((ct1 conjunction) (ct2 ,class)) 161 | (if (top-p ct1) 162 | (values nil t) 163 | (values nil nil))))) 164 | (defexistential cclass) 165 | (defexistential range) 166 | (defexistential ccomplex) 167 | (defexistential carray) 168 | (defexistential charset) 169 | (defexistential cfunction) 170 | 171 | ;;; See ccons-bottom-p above 172 | (defmethod subctypep ((ct1 ccons) (ct2 disjunction)) 173 | (if (bot-p ct2) 174 | (ccons-bottom-p ct1) 175 | (values nil nil))) 176 | (defmethod subctypep ((ct1 conjunction) (ct2 ccons)) 177 | (if (top-p ct1) 178 | (values nil t) 179 | (values nil nil))) 180 | 181 | ;;; Some ctypes represent an infinite number of possible objects, so they are 182 | ;;; never subctypes of any member ctype. 183 | 184 | (defmacro definfinite (class) 185 | `(defmethod subctypep ((ct1 ,class) (ct2 cmember)) (values nil t))) 186 | 187 | (definfinite range) 188 | (definfinite ccomplex) 189 | (definfinite carray) 190 | (definfinite cfunction) 191 | 192 | ;; note that e.g. (cons (eql 1) (eql 1)) is still infinite, since you can keep 193 | ;; calling cons to get fresh conses of (1 . 1). 194 | (defmethod subctypep ((ct1 ccons) (ct2 cmember)) 195 | (or/tri (ccons-bottom-p ct1) (values nil t))) 196 | 197 | ;;; We normalize characters out of member types, so members never contain 198 | ;;; characters. charsets are not infinite, though. 199 | (defmethod subctypep ((ct1 charset) (ct2 cmember)) (values nil t)) 200 | 201 | ;;; Resolve some (subtypep '(not X) '(member ...)) questions negatively. 202 | (defmethod subctypep ((ct1 negation) (ct2 cmember)) 203 | (multiple-value-bind (cofinitep surety) 204 | (cofinitep (negation-ctype ct1)) 205 | (if (and surety (not cofinitep)) 206 | (values nil t) 207 | (values nil nil)))) 208 | 209 | ;;; These methods exist so that disjoin-cmember doesn't produce nested 210 | ;;; disjunctions, e.g. from (or boolean list) => (or (eql t) (or cons null)) 211 | (define-commutative-method disjoin/2 ((cmember cmember) (disjunction disjunction)) 212 | (let* ((scts (junction-ctypes disjunction)) 213 | (non (loop for elem in (cmember-members cmember) 214 | unless (loop for sct in scts 215 | thereis (ctypep elem sct)) 216 | collect elem))) 217 | ;; We use disjoin instead of creating a disjunction in case one of our 218 | ;; disjunction ctypes is another cmember to be merged. 219 | ;; Inefficient? Probably. 220 | (apply #'disjoin (apply #'cmember non) scts))) 221 | 222 | ;;; Deal with fpzeros and ranges. 223 | (defmethod subctypep ((ct1 fpzero) (ct2 range)) 224 | (values (ctypep (fpzero-zero ct1) ct2) t)) 225 | (defmethod subctypep ((ct1 range) (ct2 fpzero)) (values nil t)) 226 | 227 | (define-commutative-method disjointp ((ct1 fpzero) (ct2 range)) 228 | (values (not (ctypep (fpzero-zero ct1) ct2)) t)) 229 | 230 | (define-commutative-method conjoin/2 ((ct1 fpzero) (ct2 range)) 231 | (if (ctypep (fpzero-zero ct1) ct2) 232 | ct1 233 | (bot))) 234 | 235 | (define-commutative-method disjoin/2 ((ct1 fpzero) (ct2 range)) 236 | (if (ctypep (fpzero-zero ct1) ct2) 237 | ct2 238 | nil)) 239 | 240 | (defmethod subtract ((ct1 fpzero) (ct2 range)) 241 | (if (ctypep (fpzero-zero ct1) ct2) 242 | (bot) 243 | ct1)) 244 | (defmethod subtract ((ct1 range) (ct2 fpzero)) 245 | (let ((zero (fpzero-zero ct2))) 246 | (if (ctypep zero ct1) 247 | ;; Here's the pain. 248 | (let ((k (range-kind ct1)) 249 | (low (range-low ct1)) (lxp (range-low-exclusive-p ct1)) 250 | (high (range-high ct1)) (hxp (range-high-exclusive-p ct1))) 251 | (cond ((and low (= zero low)) 252 | (disjunction (fpzero k (- zero)) 253 | (range k low t high hxp))) 254 | ((and high (= zero high)) 255 | (disjunction (fpzero k (- zero)) 256 | (range k low lxp high t))) 257 | (t 258 | (disjunction (fpzero k (- zero)) 259 | (range k low lxp zero t) 260 | (range k zero t high hxp))))) 261 | nil))) 262 | 263 | ;;; This is sort of the hardest method - including both 264 | ;;; (subtypep t ...) and (subtypep ... nil), which are hard problems in general. 265 | ;;; If you're wondering, the (disjunction conjunction) is easy - the methods on 266 | ;;; both (disjunction ctype) and (ctype conjunction) give comprehensive answers. 267 | ;;; FIXME: Hard it may be, but we can improve on this. 268 | (defmethod subctypep ((ct1 conjunction) (ct2 disjunction)) 269 | (let ((cjs (junction-ctypes ct1)) (djs (junction-ctypes ct2))) 270 | (cond ((null cjs) ; (subtypep 't '(or ...)) 271 | (case (length djs) 272 | ((0) (values nil t)) ; (subtypep 't 'nil) 273 | ;; degenerate; normalization ought to make this impossible 274 | ((1) (subctypep ct1 (first djs))) 275 | ((2) 276 | ;; Special case: we can use conjointp, which will sometimes 277 | ;; give definitive negative answers: e.g. 278 | ;; (subtypep 't '(or cons integer)) is false. 279 | (conjointp (first djs) (second djs))) 280 | (t (values nil nil)))) 281 | ((null djs) ; (subtypep '(and ...) 'nil) 282 | (case (length cjs) 283 | ((1) (subctypep (first cjs) ct2)) ; degenerate 284 | ((2) (disjointp (first cjs) (second cjs))) 285 | (t (values nil nil)))) 286 | (t ; (subtypep '(and ...) '(or ...)) 287 | (values nil nil))))) 288 | -------------------------------------------------------------------------------- /MANUAL.md: -------------------------------------------------------------------------------- 1 | Ctype can be divided into a few subsystems: 2 | 3 | * The _parsing_ subsystem parses type specifiers into ctype objects. 4 | * The _relations_ interface computes relations between types. 5 | * The _operations_ interface constructs new type objects from old ones through set operations. 6 | * The _objects_ system defines the various kinds of ctypes, and accessors for getting their particular properties. 7 | 8 | These are not (at least at the moment) actual distinct ASDF systems or packages. The _objects_ system does not have dependencies, and is entirely in classes.lisp. The _parsing_ system depends on all of the other systems, and is defined entirely in parse.lisp. The _relations_ and _operations_ interfaces are defined in generic-functions.lisp, and methods are defined throughout most of the rest of the system. The _operations_ system depends on the _relations_ system and not vice versa; this is to make the implementation clearer, and so that queries on types don't cons up new types. 9 | 10 | If ctype is just to be used to implement the Lisp type system, the entry points to the library are just `specifier-ctype`, `ctypep`, and `subctypep`. The first of these is part of the parser and the latter two are relations. More sophisticated usage my implicate the operations interface directly. Anyone defining their own kinds of type will need to define methods in several places. 11 | 12 | # Parsing 13 | 14 | ## Definitions 15 | 16 | [Function] 17 | 18 | **specifier-ctype** *type-specifier* `&optional` *environment* => *ctype* 19 | 20 | Parses a type specifier to a ctype in the given environment. The default environment is `nil`, representing the current global environment. The environment is used to get information about type macros defined with `deftype`. 21 | 22 | --- 23 | 24 | [Function] 25 | 26 | **extended-specifier-ctype** *type-specifier* `&optional` *environment* => *ctype* 27 | 28 | Parses a type specifier to a ctype in the given environment. Parts of the type-specifier might be using extended types. The default environment is `nil`, representing the current global environment. The environment is used to get information about type macros defined with `deftype`. 29 | 30 | --- 31 | 32 | [Macro] 33 | 34 | **define-extended-type** *name* *lambda-list* `&key` *documentation* *simple* *extended* => *name* 35 | 36 | Defines an extended type specifier called name. If it is parsed using `specifier-ctype` or some other non-extended parsing facility, the simple forms are used to create a more primitive type specifier. If it is parsed using `extended-type-specifier`, the extended forms are used to create a ctype. Both the simple and extended forms are required. 37 | 38 | --- 39 | 40 | # Relations 41 | 42 | ## Definitions 43 | 44 | [Generic Function] 45 | 46 | **ctypep** *object* *ctype* => *generalized-boolean* 47 | 48 | The ctype analogy to `cl:typep`. It has the same semantics, except that it takes a ctype object rather than a type specifier, and because ctypes are independent of the environment there is no need for an environment parameter. 49 | 50 | No default method is provided; programmers implementing their own kinds of ctype should define appropriate methods on **ctypep**. Without such methods, library functions may signal errors, including other library functions, as operations on `cl:member` types need to test types of objects. 51 | 52 | --- 53 | 54 | [Generic Function] 55 | 56 | **subctypep** *ctype1* *ctype2* => *subtypep-p*, *valid-p* 57 | 58 | The ctype analogy to `cl:subtypep`. It has the same semantics, except that it takes ctype objects rather than type specifiers, and because ctypes are independent of the environment there is no need for an environment parameter. 59 | 60 | A default method is provided that returns `nil nil`, i.e. uncertainty. 61 | 62 | --- 63 | 64 | [Generic Function] 65 | 66 | **ctype=** *ctype1* *ctype2* => *type-equal-p*, *valid-p* 67 | 68 | Determines whether the two ctypes are identical, i.e. represent the same set of objects. 69 | 70 | A default method is provided that calls *subctypep* in both directions. If each is a subtype of the other, the default method returns true; if at least one is not a subtype of the other, the default method returns false; and otherwise it returns uncertainty. 71 | 72 | --- 73 | 74 | [Generic Functions] 75 | 76 | **disjointp**, **conjointp** *ctype1* *ctype2* => *joint-p*, *valid-p* 77 | 78 | Determines whether two ctypes are disjoint or conjoint. Two ctypes are disjoint if their conjunction is bottom, i.e. they share no elements. Two ctypes are conjoint if the disjunction is top, i.e. between them they include all possible objects. 79 | 80 | A default method is provided that returns `nil nil`, i.e. uncertainty. 81 | 82 | Because programmers can define new classes, types are essentially never conjoint unless one is a negation, and as described under "Custom methods" below, programmers do not need to define this behavior themselves. Usually the only **conjointp** method necessary is one to define that two ctypes of whatever kind are never conjoint. For example, the built in cons ctypes, array ctypes, etc. have **conjointp** methods like this, as well as methods to indicate that e.g. a cons ctype and array ctype are never conjoint. 83 | 84 | --- 85 | 86 | [Generic Function] 87 | 88 | **cofinitep** *ctype* => *cofinite-p*, *valid-p* 89 | 90 | Determines whether the complement/negation of a given ctype is finite. This is used to resolve questions like `(subtypep '(not X) '(member ...))`: if X is cofinite, this is surely false even if nothing else is known about X. 91 | 92 | A default method is provided that returns `nil nil`, i.e. uncertainty. 93 | 94 | Most kinds of ctype are always cofinite. 95 | 96 | --- 97 | 98 | ## Laws 99 | 100 | Several relations imply other relations. We have the following logical laws, given any ctypes `c1`, `c2`, and `c3`, and understanding that the possible values for a relation are true, false, and unknown (so e.g. "not true" means "false or unknown"): 101 | 102 | * If `(subctypep c1 c2)` and `(subctypep c2 c3)` are true, `(subtypep c1 c3)` is not false. 103 | * If `(subctypep c1 c2)` is true and `(subctypep c2 c1)` is true, `(ctype= c1 c2)` is not false. 104 | * If `(ctype= c1 c2)` is true, `(subctypep c1 c2)` and `(subctypep c2 c1)` are not false. 105 | * If `(ctype= c1 c2)` and `(ctype= c2 c3)` are true, `(ctype= c1 c3)` is not false. 106 | * If `(subctypep c1 c2)` is false or `(subctypep c2 c1)` is false, `(ctype= c1 c2)` is not true. 107 | * If `(ctype= c1 c2)` is false, `(subctypep c1 c2)` and `(subctypep c2 c1)` are not both true. 108 | * If `(disjointp c1 c2)` is true, `(subtypep c1 c2)` and `(subtypep c2 c1)` are not, unless one or both are the bottom type. 109 | * If `(conjointp c1 c2)` is true, `(subtypep c1 c2)` and `(subtypep c2 c1)` are not, unless one or both are the top type. 110 | 111 | ## Custom methods 112 | 113 | Custom methods on these generic functions should be written carefully to avoid infinite regress. In general, they should call each other directly on their arguments as little as possible to avoid accidents. 114 | 115 | The functions **subctypep**, **ctype=**, **disjointp**, etc. may return unsure results. These results mean what `cl:subtypep`'s result values do: Two true values mean the relation definitely holds, false and true mean it definitely doesn't, and false and false mean it cannot be determined. Users of these functions, including custom methods on ctype functions, should be prepared to deal with all three possible results. Unsure results may always be returned, and will be dealt with appropriately by other ctype functions. 116 | 117 | If a given method cannot determine that the relation is true or false, it must return `(values nil nil)`. A custom (unexported) method combination takes care of combining results from multiple methods; each method should work totally independently, and only return a sure result if it's definitely correct. Similar to a built-in short form method combination, `call-next-method` is not available in primary methods. 118 | 119 | Custom methods should *not* define generic methods, i.e. unspecialized beyond **ctype**, because ctype kinds may overlap with each other. For example, a custom "proper list of X" ctype would overlap with the existing cons ctypes. If there was a method defining cons ctypes to not be subtypes of unknown ctypes, inconsistency would result unless everything was overriden completely correctly; because there isn't, the built in method just returns uncertainty, which is always consistent. 120 | 121 | User methods on these functions must preserve the above laws in order for the system to work correctly. 122 | 123 | Unless otherwise noted, all of these functions have generic methods on set-theoretic kinds, i.e. conjunctions, disjunctions, negation, bottom, and top. Custom ctype kinds do not need to define methods for relations with these kinds of ctypes. However, methods are *not* especially provided that will apply between a custom ctype and other built in kinds of ctype (i.e. standard types), so programmers should define such methods. 124 | 125 | User methods on _relations_ functions should not call _operations_ functions directly on their arguments. This is because _operations_ functions are permitted to call _relations_ functions on their arguments, so infinite recursion could result. Additionally, this arrangement keeps as much actual logic as possible in the non-consing, conceptually pure _relations_ functions rather than the _operations_ functions. 126 | 127 | # Operations 128 | 129 | ## Defintions 130 | 131 | [Functions] 132 | 133 | **disjoin**, **conjoin** `&rest` *ctypes* => *ctype* 134 | 135 | Computes the disjunction or conjunction of the given ctypes, respectively. The disjunction of ctypes is the ctype representing the disjunction of the sets of objects represented by the ctypes, and conjunction is analogous. 136 | 137 | If no ctypes are provided, **disjoin** returns the bottom ctype, and **conjoin** the top ctype, as per basic mathematics. If only one ctype is provided, it is returned. Otherwise, **disjoin** uses **disjoin/2** and **conjoin** uses **conjoin/2** to simplify the result as much as possible, and otherwise constructs generic disjunction or conjunction types. The order **conjoin/2** or **disjoin/2** are called in, and how often (or if they are called at all), is unspecified. 138 | 139 | --- 140 | 141 | [Generic Function] 142 | 143 | **negate** *ctype* => *ctype* 144 | 145 | Computes the negation/complement of the given ctype. This is the ctype representing the set of all objects that are not included in the set of objects represented by the given ctype. 146 | 147 | A default method is provided that returns a generic negation type. This function uses the standard method combination, and `call-next-method` should be used by custom methods if no simplification is possible. 148 | 149 | --- 150 | 151 | [Generic Functions] 152 | 153 | **disjoin/2**, **conjoin/2** *ctype1* *ctype2* => *maybe-ctype* 154 | 155 | The generic functions **disjoin/2** and **conjoin/2** are not intended to be called by programmers. Programmers may define methods for them. They are called by **disjoin** or **conjoin** respectively, as described for those functions. 156 | 157 | **disjoin/2** and **conjoin/2** attempt to compute a simple disjunction or conjunction (respectively) of the given ctypes. If no simplification is possible, they return `nil`, indicating that a generic disjunction or conjunction should be constructed instead. 158 | 159 | Default methods are provided that check for conjointness/disjointness (respectively) and subtype relations, and otherwise return `nil`. These functions use a custom unexported method combination; `call-next-method` is not available in primary methods, and methods should work independently. 160 | 161 | --- 162 | 163 | [Generic Function] 164 | 165 | **subtract** *ctype1* *ctype2* => *maybe-ctype* 166 | 167 | The generic function **subtract** is not intended to be called by programmers. Programmers may define methods for it. **subtract** is called by the system when computing certain conjunctions. 168 | 169 | **subtract** attempts to compute a simple difference of `ctype1` and `ctype2`, i.e. the type that includes all of `ctype1`'s objects but none of `ctype2`'s. If no simplification is possible, it returns `nil`, indicating that a generic conjunction should be constructed instead. 170 | 171 | Default methods are provided that check for the special cases of disjointness and `ctype` being a subtype of `ctype2`, and otherwise return `nil`. This function uses a custom unexported method combination; `call-next-method` is not available in primary methods, and methods should work independently. 172 | 173 | --- 174 | 175 | ## Laws 176 | 177 | Similarly to the _relations_, many set-theoretic laws are in place. Given ctypes `c1` and `c2`, their conjunction `C` and disjunction `D`, and the negation of `c1`, `c1p`: 178 | 179 | * `(subtypep C c1)` and `(subtypep C c2)` are not false. 180 | * `(subtypep c1 D)` and `(subtypep c2 D)` are not false. 181 | * `(subtypep c1 c1p)` is not true unless c1 is bottom. 182 | * `(subtypep c1p c1)` is not true unless c1 is top. 183 | * `(disjointp c1 c1p)` and `(conjointp c1 c1p)` are not false. 184 | 185 | ## Custom methods 186 | 187 | Custom methods on these generic functions should be written carefully to avoid infinite regress. In general, they should call each other directly on their arguments as little as possible to avoid accidents. 188 | 189 | User methods on these functions must preserve the above laws in order for the system to work correctly. 190 | 191 | What counts as "simplification" is sometimes not obvious. The general rule is that regardless of what simplifications are applied or not applied, relations between constructed types must work correctly; i.e. they may return unknown, but they may not return a "sure" incorrect answer. Simplification should ideally result in a ctype that can be related more precisely. 192 | 193 | Unless otherwise noted, all of these functions have generic methods on set-theoretic kinds, i.e. conjunctions, disjunctions, negation, bottom, and top. Custom ctype kinds do not need to define methods for relations with these kinds of ctypes. However, methods are *not* especially provided that will apply between a custom ctype and other built in kinds of ctype (i.e. standard types), so programmers should define such methods. In particular, the system does not assume that new kinds are disjoint from existing ones. 194 | 195 | # Objects 196 | 197 | TODO 198 | --------------------------------------------------------------------------------