Added optional test to unique-elt-of

js2/semantics/Calculus.lisp

@@ -3655,18 +3655,30 @@
     (error "unique-elt-of called on a set with other than one element"))
   (assert-non-null (nth (integer-length set) keywords)))
 
-; (unique-elt-of <elt-expr>)
+; (unique-elt-of <elt-expr> [<var> <condition-expr>])
-; Returns any element of <set-expr>, which must be a nonempty set.
+; Returns the one element of <set-expr>, which must have exactly one element.  If <var> and <condition-expr> are given,
-(defun scan-unique-elt-of (world type-env special-form set-expr)
+; then return the one element of <set-expr> that satisfies <condition-expr>; there must be exactly one such element.
+; <var> may shadow an existing local variable.
+(defun scan-unique-elt-of (world type-env special-form set-expr &optional var-source condition-expr)
   (multiple-value-bind (set-code set-type set-annotated-expr) (scan-set-value world type-env set-expr)
     (let ((elt-type (set-element-type set-type)))
-      (values
+      (if var-source
-       (ecase (type-kind set-type)
+        (let* ((var (scan-name world var-source))
-         (:list-set (list 'unique-elt-of set-code))
+               (local-type-env (type-env-add-binding type-env var elt-type :const t)))
-         (:range-set (range-set-out-converter-expr elt-type (list 'range-set-unique-elt-of set-code)))
+          (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world))
-         ((:bit-set :restricted-set) (list 'bit-set-unique-elt-of set-code (list 'quote (set-type-keywords set-type)))))
+            (unless (eq (type-kind set-type) :list-set)
-       elt-type
+              (error "Not implemented"))
-       (list 'expr-annotation:special-form special-form set-annotated-expr)))))
+            (values
+             `(unique-elt-of (remove-if-not #'(lambda (,var) ,condition-code) ,set-code))
+             elt-type
+             (list 'expr-annotation:special-form special-form set-annotated-expr var condition-annotated-expr))))
+        (values
+         (ecase (type-kind set-type)
+           (:list-set (list 'unique-elt-of set-code))
+           (:range-set (range-set-out-converter-expr elt-type (list 'range-set-unique-elt-of set-code)))
+           ((:bit-set :restricted-set) (list 'bit-set-unique-elt-of set-code (list 'quote (set-type-keywords set-type)))))
+         elt-type
+         (list 'expr-annotation:special-form special-form set-annotated-expr))))))
 
 
 ;;; Vectors or Sets

js2/semantics/CalculusMarkup.lisp

@@ -803,11 +803,20 @@
     (depict-expression markup-stream world set-annotated-expr %prefix%)))
 
 
-; (unique-elt-of <elt-expr>)
+; (unique-elt-of <elt-expr> [<var> <condition-expr>])
-(defun depict-unique-elt-of (markup-stream world level set-annotated-expr)
+(defun depict-unique-elt-of (markup-stream world level set-annotated-expr &optional var condition-annotated-expr)
   (depict-expr-parentheses (markup-stream level %expr%)
-    (depict markup-stream "the one element of ")
+    (cond
-    (depict-expression markup-stream world set-annotated-expr %prefix%)))
+     (var
+       (depict markup-stream "the one element ")
+       (depict-local-variable markup-stream var)
+       (depict markup-stream " " :member-10 " ")
+       (depict-expression markup-stream world set-annotated-expr %term%)
+       (depict markup-stream " that satisfies ")
+       (depict-expression markup-stream world condition-annotated-expr %logical%))
+     (t
+      (depict markup-stream "the one element of ")
+      (depict-expression markup-stream world set-annotated-expr %prefix%)))))
 
 
 ;;; Vectors or Sets