[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 9b85ae6 1/8: Initial constraint negation support
From: |
Andrea Corallo |
Subject: |
feature/native-comp 9b85ae6 1/8: Initial constraint negation support |
Date: |
Sat, 5 Dec 2020 17:07:32 -0500 (EST) |
branch: feature/native-comp
commit 9b85ae6aa5d73649c0a48d5168d4de52ee83ac28
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Initial constraint negation support
* lisp/emacs-lisp/comp-cstr.el (comp-cstr): Add `neg' slot.
(comp-range-negation, comp-cstr-negation)
(comp-cstr-negation-make): New functions.
(comp-type-spec-to-cstr): Enable `not` in type specifiers.
(comp-cstr-to-type-spec): Update logic to handle negation.
* test/lisp/emacs-lisp/comp-cstr-tests.el
(comp-cstr-typespec-tests-alist): Add a test.
---
lisp/emacs-lisp/comp-cstr.el | 65 ++++++++++++++++++++++++---------
test/lisp/emacs-lisp/comp-cstr-tests.el | 3 +-
2 files changed, 50 insertions(+), 18 deletions(-)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 40fa48e..dcf835b 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -66,7 +66,9 @@ Each element cannot be a subtype of any other element of this
slot.")
:documentation "List of possible values the mvar can assume.
Integer values are handled in the `range' slot.")
(range () :type list
- :documentation "Integer interval."))
+ :documentation "Integer interval.")
+ (neg nil :type boolean
+ :documentation "Non-nil if the constraint is negated"))
(cl-defstruct comp-cstr-f
"Internal constraint representation for a function."
@@ -235,6 +237,20 @@ Integer values are handled in the `range' slot.")
(cl-decf nest)
finally (cl-return (reverse res))))
+(defun comp-range-negation (range)
+ "Negate range RANGE."
+ (cl-loop
+ with res = ()
+ with last-h = '-
+ for (l . h) in range
+ unless (eq l '-)
+ do (push `(,(comp-range-1+ last-h) . ,(1- l)) res)
+ do (setf last-h h)
+ finally
+ (unless (eq '+ last-h)
+ (push `(,(1+ last-h) . +) res))
+ (cl-return (reverse res))))
+
;;; Entry points.
@@ -332,6 +348,19 @@ DST is returned."
"Combine SRCS by intersection set operation and return a new constraint."
(apply #'comp-cstr-intersection (make-comp-cstr) srcs))
+(defun comp-cstr-negation (dst src)
+ "Negate SRC setting the result in DST.
+DST is returned."
+ (setf (comp-cstr-typeset dst) (comp-cstr-typeset src)
+ (comp-cstr-valset dst) (comp-cstr-valset src)
+ (comp-cstr-range dst) (comp-cstr-range src)
+ (comp-cstr-neg dst) (not (comp-cstr-neg src)))
+ dst)
+
+(defun comp-cstr-negation-make (src)
+ "Negate SRC and return a new constraint."
+ (comp-cstr-negation (make-comp-cstr) src))
+
(defun comp-type-spec-to-cstr (type-spec &optional fn)
"Convert a type specifier TYPE-SPEC into a `comp-cstr'.
FN non-nil indicates we are parsing a function lambda list."
@@ -356,10 +385,7 @@ FN non-nil indicates we are parsing a function lambda
list."
(apply #'comp-cstr-intersection-make
(mapcar #'comp-type-spec-to-cstr rest)))
(`(not ,cstr)
- (cl-assert nil)
- ;; TODO
- ;; (comp-cstr-negate-make (comp-type-spec-to-cstr cstr))
- )
+ (comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
(`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
(comp-irange-to-cstr `(,l . ,h)))
(`(integer * ,(and (pred integerp) h))
@@ -383,7 +409,8 @@ FN non-nil indicates we are parsing a function lambda list."
"Given CSTR return its type specifier."
(let ((valset (comp-cstr-valset cstr))
(typeset (comp-cstr-typeset cstr))
- (range (comp-cstr-range cstr)))
+ (range (comp-cstr-range cstr))
+ (negated (comp-cstr-neg cstr)))
(when valset
(when (memq nil valset)
@@ -412,17 +439,21 @@ FN non-nil indicates we are parsing a function lambda
list."
(valset `(member ,@valset))
(t
;; Empty type specifier
- nil))))
- (pcase res
- (`(,(or 'integer 'member) . ,rest)
- (if rest
- res
- (car res)))
- ((pred atom) res)
- (`(,_first . ,rest)
- (if rest
- `(or ,@res)
- (car res)))))))
+ nil)))
+ (final
+ (pcase res
+ (`(,(or 'integer 'member) . ,rest)
+ (if rest
+ res
+ (car res)))
+ ((pred atom) res)
+ (`(,_first . ,rest)
+ (if rest
+ `(or ,@res)
+ (car res))))))
+ (if negated
+ `(not ,final)
+ final))))
(provide 'comp-cstr)
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el
b/test/lisp/emacs-lisp/comp-cstr-tests.el
index c98ff80..5415336 100644
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -77,7 +77,8 @@
((and (integer -1 2) (integer 3 5)) . nil)
((and (integer -1 3) (integer 3 5)) . (integer 3 3))
((and (integer -1 4) (integer 3 5)) . (integer 3 4))
- ((and (integer -1 5) nil) . nil))
+ ((and (integer -1 5) nil) . nil)
+ ((not symbol) . (not symbol)))
"Alist type specifier -> expected type specifier.")
(defmacro comp-cstr-synthesize-tests ()
- feature/native-comp updated (eb8d155 -> 09ec39e), Andrea Corallo, 2020/12/05
- feature/native-comp 9b85ae6 1/8: Initial constraint negation support,
Andrea Corallo <=
- feature/native-comp 7c1d90a 3/8: Initial support for union of negated constraints, Andrea Corallo, 2020/12/05
- feature/native-comp 726e40f 5/8: Fix union of homogeneously negated input constraints, Andrea Corallo, 2020/12/05
- feature/native-comp f923de6 6/8: * Fix `comp-cstr-to-type-spec', Andrea Corallo, 2020/12/05
- feature/native-comp 09ec39e 8/8: * Memoize `comp-cstr-union-1', Andrea Corallo, 2020/12/05
- feature/native-comp 1fb249f 2/8: * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-no-range): Cosmetic., Andrea Corallo, 2020/12/05
- feature/native-comp cbbdb4e 4/8: * Add `with-comp-cstr-accessors' macro., Andrea Corallo, 2020/12/05
- feature/native-comp 2eb41ec 7/8: More improvements to `comp-cstr-union-1' for mixed positive/negative cases, Andrea Corallo, 2020/12/05