Revert "implement #:predicate" and remove predicate from <lambda-case>

Turns out this was not a very useful idea, and semantically tricky to
boot.

This reverts commit 24bf130fd1, and makes
the following additional changes:

* module/ice-9/optargs.scm (parse-lambda-case, let-optional)
  (let-optional*, let-keywords, let-keywords*):
* module/language/tree-il.scm: (<lambda-case>, parse-tree-il)
  (unparse-tree-il, tree-il->scheme, tree-il-fold,
  make-tree-il-folder)
  (post-order!, pre-order!):
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/compile-glil.scm (compile-glil):
* module/language/tree-il/inline.scm (inline!): Remove all traces of
  #:predicate from tree-il.

* module/ice-9/psyntax.scm (build-simple-lambda, build-lambda-case)
  (chi-lambda-case): Adapt to tree-il change.
* module/ice-9/psyntax-pp.scm: Regenerated.

* module/language/brainfuck/compile-tree-il.scm (compile-body):
* module/language/ecmascript/compile-tree-il.scm (comp, comp-body):
* test-suite/tests/tree-il.test: Adapt to tree-il change.

* doc/ref/api-procedures.texi (Case-lambda): Remove mention of
  #:predicate.

doc/ref/api-procedures.texi

@@ -594,25 +594,6 @@ A @code{case-lambda*} clause matches if the arguments fill the
 required arguments, but are not too many for the optional and/or rest
 arguments.
 
-@code{case-lambda*} is particularly useful in combination with an
-obscure @code{lambda*} feature, @code{#:predicate}. @code{lambda*}
-argument lists may contain a @code{#:predicate @var{expr}} clause at
-the end -- before the rest argument, if any. This expression is
-evaluated in the context of all of the arguments, and if false, causes
-the @code{case-lambda*} expression not to match. This can be used to
-make a simple form of type dispatch:
-
-@lisp
-(define type-of
-  (case-lambda*
-    ((a #:predicate (symbol? a)) 'symbol)
-    ((a #:predicate (string? a)) 'string)
-    ((a) 'unknown)))
-(type-of 'foo) @result{} symbol
-(type-of "foo") @result{} string
-(type-of '(foo)) @result{} unknown
-@end lisp
-
 Keyword arguments are possible with @code{case-lambda*}, but they do
 not contribute to the ``matching'' behavior. That is to say,
 @code{case-lambda*} matches only on required, optional, and rest

module/ice-9/optargs.scm

@@ -110,7 +110,6 @@
                  (apply (lambda vars b0 b1 ...)
                         (or (parse-lambda-case '(0 n n n+1 #f '())
                                                (list t ...)
-                                               #f
                                                rest-arg)
                             (error "sth" rest-arg)))))))))))
 
@@ -127,7 +126,6 @@
              #'(apply (lambda vars b0 b1 ...)
                       (or (parse-lambda-case '(0 n n n+1 #f '())
                                              (list (lambda vars i) ...)
-                                             #f
                                              rest-arg)
                           (error "sth" rest-arg))))))))))
 
@@ -166,7 +164,6 @@
                  (apply (lambda vars b0 b1 ...)
                         (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
                                                (list t ...)
-                                               #f
                                                rest-arg)
                             (error "sth" rest-arg))))))))
       ((_ rest-arg aok (binding ...) b0 b1 ...)
@@ -188,7 +185,6 @@
              #'(apply (lambda vars b0 b1 ...)
                       (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
                                              (list (lambda vars i) ...)
-                                             #f
                                              rest-arg)
                           (error "sth" rest-arg)))))))
       ((_ rest-arg aok (binding ...) b0 b1 ...)
@@ -285,7 +281,7 @@
 
 ;;; Support for optional & keyword args with the interpreter.
 (define *uninitialized* (list 'uninitialized))
-(define (parse-lambda-case spec inits predicate args)
+(define (parse-lambda-case spec inits args)
   (pmatch spec
     ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
      (define (req args prev tail n)
@@ -325,12 +321,12 @@
         ((pair? args-tail)
          #f) ;; fail
         (else
-         (pred slots))))
+         slots)))
      (define (key slots slots-tail args-tail inits)
        (cond
         ((null? args-tail)
          (if (null? inits)
-             (pred slots)
+             slots
              (begin
                (if (eq? (car slots-tail) *uninitialized*)
                    (set-car! slots-tail (apply (car inits) slots)))
@@ -351,13 +347,6 @@
               allow-other-keys?)
          (key slots slots-tail (cddr args-tail) inits))
         (else (error "unrecognized keyword" args-tail))))
-     (define (pred slots)
-       (cond
-        (predicate
-         (if (apply predicate slots)
-             slots
-             #f))
-        (else slots)))
      (let ((args (list-copy args)))
        (req args #f args nreq)))
     (else (error "unexpected spec" spec))))

module/ice-9/psyntax.scm

@@ -449,10 +449,10 @@
         (else (decorate-source `(define ,var ,exp) source)))))
 
   ;; Ideally we would have all lambdas be case lambdas, but that would
-  ;; need special support in the interpreter for the full capabilities of
-  ;; case-lambda, with optional and keyword args, predicates, and else
-  ;; clauses. This will come with the new interpreter, but for now we
-  ;; separate the cases.
+  ;; need special support in the interpreter for the full capabilities
+  ;; of case-lambda, with optional and keyword args and else clauses.
+  ;; This will come with the new interpreter, but for now we separate
+  ;; the cases.
   (define build-simple-lambda
     (lambda (src req rest vars docstring exp)
       (case (fluid-ref *mode*)
@@ -460,8 +460,8 @@
               (if docstring `((documentation . ,docstring)) '())
               ;; hah, a case in which kwargs would be nice.
               ((@ (language tree-il) make-lambda-case)
-               ;; src req opt rest kw inits vars predicate body else
-               src req #f rest #f '() vars #f exp #f)))
+               ;; src req opt rest kw inits vars body else
+               src req #f rest #f '() vars exp #f)))
         (else (decorate-source
                `(lambda ,(if rest (apply cons* vars) vars)
                   ,@(if docstring (list docstring) '())
@@ -490,14 +490,13 @@
     ;; vars: (sym ...)
     ;; vars map to named arguments in the following order:
     ;;  required, optional (positional), rest, keyword.
-    ;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded
     ;; the body of a lambda: anything, already expanded
     ;; else: lambda-case | #f
-    (lambda (src req opt rest kw inits vars predicate body else-case)
+    (lambda (src req opt rest kw inits vars body else-case)
       (case (fluid-ref *mode*)
         ((c)
          ((@ (language tree-il) make-lambda-case)
-          src req opt rest kw inits vars predicate body else-case))
+          src req opt rest kw inits vars body else-case))
         (else
          ;; Very much like the logic of (language tree-il compile-glil).
          (let* ((nreq (length req))
@@ -519,7 +518,6 @@
             `((((@@ (ice-9 optargs) parse-lambda-case)
                 '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
                 (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
-                ,(if predicate `(lambda ,vars ,predicate) #f)
                 %%args)
                ;; FIXME: This _ is here to work around a bug in the
                ;; memoizer. The %%% makes it different from %%, also a
@@ -1585,7 +1583,7 @@
       (define (check req rest)
         (cond
          ((distinct-bound-ids? (if rest (cons rest req) req))
-          (values req #f rest #f #f))
+          (values req #f rest #f))
          (else
           (syntax-violation 'lambda "duplicate identifier in argument list"
                             orig-args))))
@@ -1610,44 +1608,40 @@
       (define (req args rreq)
         (syntax-case args ()
           (()
-           (check (reverse rreq) '() #f '() #f))
+           (check (reverse rreq) '() #f '()))
           ((a . b) (id? #'a)
            (req #'b (cons #'a rreq)))
           ((a . b) (eq? (syntax->datum #'a) #:optional)
            (opt #'b (reverse rreq) '()))
           ((a . b) (eq? (syntax->datum #'a) #:key)
            (key #'b (reverse rreq) '() '()))
-          ((a . b) (eq? (syntax->datum #'a) #:predicate)
-           (pred #'b (reverse rreq) '() '()))
           ((a b) (eq? (syntax->datum #'a) #:rest)
-           (rest #'b (reverse rreq) '() '() #f))
+           (rest #'b (reverse rreq) '() '()))
           (r (id? #'r)
-             (rest #'r (reverse rreq) '() '() #f))
+             (rest #'r (reverse rreq) '() '()))
           (else
            (syntax-violation 'lambda* "invalid argument list" orig-args args))))
       (define (opt args req ropt)
         (syntax-case args ()
           (()
-           (check req (reverse ropt) #f '() #f))
+           (check req (reverse ropt) #f '()))
           ((a . b) (id? #'a)
            (opt #'b req (cons #'(a #f) ropt)))
           (((a init) . b) (id? #'a)
            (opt #'b req (cons #'(a init) ropt)))
           ((a . b) (eq? (syntax->datum #'a) #:key)
            (key #'b req (reverse ropt) '()))
-          ((a . b) (eq? (syntax->datum #'a) #:predicate)
-           (pred #'b req (reverse ropt) '()))
           ((a b) (eq? (syntax->datum #'a) #:rest)
-           (rest #'b req (reverse ropt) '() #f))
+           (rest #'b req (reverse ropt) '()))
           (r (id? #'r)
-             (rest #'r req (reverse ropt) '() #f))
+             (rest #'r req (reverse ropt) '()))
           (else
            (syntax-violation 'lambda* "invalid optional argument list"
                              orig-args args))))
       (define (key args req opt rkey)
         (syntax-case args ()
           (()
-           (check req opt #f (cons #f (reverse rkey)) #f))
+           (check req opt #f (cons #f (reverse rkey))))
           ((a . b) (id? #'a)
            (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
              (key #'b req opt (cons #'(k a #f) rkey))))
@@ -1658,48 +1652,33 @@
                                  (keyword? (syntax->datum #'k)))
            (key #'b req opt (cons #'(k a init) rkey)))
           ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
-           (check req opt #f (cons #t (reverse rkey)) #f))
-          ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
-                            (eq? (syntax->datum #'a) #:predicate))
-           (pred #'b req opt (cons #t (reverse rkey))))
+           (check req opt #f (cons #t (reverse rkey))))
           ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
                           (eq? (syntax->datum #'a) #:rest))
-           (rest #'b req opt (cons #t (reverse rkey)) #f))
+           (rest #'b req opt (cons #t (reverse rkey))))
           ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
                           (id? #'r))
-           (rest #'r req opt (cons #t (reverse rkey)) #f))
-          ((a . b) (eq? (syntax->datum #'a) #:predicate)
-           (pred #'b req opt (cons #f (reverse rkey))))
+           (rest #'r req opt (cons #t (reverse rkey))))
           ((a b) (eq? (syntax->datum #'a) #:rest)
-           (rest #'b req opt (cons #f (reverse rkey)) #f))
+           (rest #'b req opt (cons #f (reverse rkey))))
           (r (id? #'r)
-             (rest #'r req opt (cons #f (reverse rkey)) #f))
+             (rest #'r req opt (cons #f (reverse rkey))))
           (else
            (syntax-violation 'lambda* "invalid keyword argument list"
                              orig-args args))))
-      (define (pred args req opt kw)
-        (syntax-case args ()
-          ((x) (check req opt #f kw #'x))
-          ((x a b) (eq? (syntax->datum #'a) #:rest)
-           (rest #'b req opt kw #f))
-          ((x . b) (id? #'b)
-           (rest #'b req opt kw #f))
-          (else
-           (syntax-violation 'lambda* "invalid argument list following #:predicate"
-                             orig-args args))))
-      (define (rest args req opt kw pred)
+      (define (rest args req opt kw)
         (syntax-case args ()
           (r (id? #'r)
-             (check req opt #'r kw pred))
+             (check req opt #'r kw))
           (else
            (syntax-violation 'lambda* "invalid rest argument"
                              orig-args args))))
-      (define (check req opt rest kw pred)
+      (define (check req opt rest kw)
         (cond
          ((distinct-bound-ids?
            (append req (map car opt) (if rest (list rest) '())
                    (if (pair? kw) (map cadr (cdr kw)) '())))
-          (values req opt rest kw pred))
+          (values req opt rest kw))
          (else
           (syntax-violation 'lambda* "duplicate identifier in argument list"
                             orig-args))))
@@ -1707,14 +1686,14 @@
 
   (define chi-lambda-case
     (lambda (e r w s mod get-formals clauses)
-      (define (expand-req req opt rest kw pred body)
+      (define (expand-req req opt rest kw body)
         (let ((vars (map gen-var req))
               (labels (gen-labels req)))
           (let ((r* (extend-var-env labels vars r))
                 (w* (make-binding-wrap req labels w)))
             (expand-opt (map syntax->datum req)
-                        opt rest kw pred body (reverse vars) r* w* '() '()))))
-      (define (expand-opt req opt rest kw pred body vars r* w* out inits)
+                        opt rest kw body (reverse vars) r* w* '() '()))))
+      (define (expand-opt req opt rest kw body vars r* w* out inits)
         (cond
          ((pair? opt)
           (syntax-case (car opt) ()
@@ -1723,7 +1702,7 @@
                     (l (gen-labels (list v)))
                     (r** (extend-var-env l (list v) r*))
                     (w** (make-binding-wrap (list #'id) l w*)))
-               (expand-opt req (cdr opt) rest kw pred body (cons v vars)
+               (expand-opt req (cdr opt) rest kw body (cons v vars)
                            r** w** (cons (syntax->datum #'id) out)
                            (cons (chi #'i r* w* mod) inits))))))
          (rest
@@ -1734,16 +1713,16 @@
             (expand-kw req (if (pair? out) (reverse out) #f)
                        (syntax->datum rest)
                        (if (pair? kw) (cdr kw) kw)
-                       pred body (cons v vars) r* w* 
+                       body (cons v vars) r* w* 
                        (if (pair? kw) (car kw) #f)
                        '() inits)))
          (else
           (expand-kw req (if (pair? out) (reverse out) #f) #f
                      (if (pair? kw) (cdr kw) kw)
-                     pred body vars r* w*
+                     body vars r* w*
                      (if (pair? kw) (car kw) #f)
                      '() inits))))
-      (define (expand-kw req opt rest kw pred body vars r* w* aok out inits)
+      (define (expand-kw req opt rest kw body vars r* w* aok out inits)
         (cond
          ((pair? kw)
           (syntax-case (car kw) ()
@@ -1752,7 +1731,7 @@
                     (l (gen-labels (list v)))
                     (r** (extend-var-env l (list v) r*))
                     (w** (make-binding-wrap (list #'id) l w*)))
-               (expand-kw req opt rest (cdr kw) pred body (cons v vars)
+               (expand-kw req opt rest (cdr kw) body (cons v vars)
                           r** w** aok
                           (cons (list (syntax->datum #'k)
                                       (syntax->datum #'id)
@@ -1760,20 +1739,17 @@
                                 out)
                           (cons (chi #'i r* w* mod) inits))))))
          (else
-          (expand-pred req opt rest
+          (expand-body req opt rest
                        (if (or aok (pair? out)) (cons aok (reverse out)) #f)
-                       pred body (reverse vars) r* w* (reverse inits)))))
-      (define (expand-pred req opt rest kw pred body vars r* w* inits)
-        (expand-body req opt rest kw (and pred (chi pred r* w* mod))
-                     body vars r* w* inits))
-      (define (expand-body req opt rest kw pred body vars r* w* inits)
+                       body (reverse vars) r* w* (reverse inits)))))
+      (define (expand-body req opt rest kw body vars r* w* inits)
         (syntax-case body ()
           ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
-           (values (syntax->datum #'docstring) req opt rest kw inits vars pred
+           (values (syntax->datum #'docstring) req opt rest kw inits vars
                    (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
                              r* w* mod)))
           ((e1 e2 ...)
-           (values #f req opt rest kw inits vars pred
+           (values #f req opt rest kw inits vars
                    (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
                              r* w* mod)))))
 
@@ -1781,10 +1757,10 @@
         (() (values #f #f))
         (((args e1 e2 ...) (args* e1* e2* ...) ...)
          (call-with-values (lambda () (get-formals #'args))
-           (lambda (req opt rest kw pred)
+           (lambda (req opt rest kw)
              (call-with-values (lambda ()
-                                 (expand-req req opt rest kw pred #'(e1 e2 ...)))
-               (lambda (docstring req opt rest kw inits vars pred body)
+                                 (expand-req req opt rest kw #'(e1 e2 ...)))
+               (lambda (docstring req opt rest kw inits vars body)
                  (call-with-values
                      (lambda ()
                        (chi-lambda-case e r w s mod get-formals
@@ -1793,7 +1769,7 @@
                      (values
                       (or docstring docstring*)
                       (build-lambda-case s req opt rest kw inits vars
-                                         pred body else*))))))))))))
+                                         body else*))))))))))))
 
 ;;; data
 
@@ -2055,12 +2031,12 @@
                    (syntax-case e ()
                      ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring))
                       (call-with-values (lambda () (lambda-formals #'args))
-                        (lambda (req opt rest kw pred)
+                        (lambda (req opt rest kw)
                           (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring)
                                              #'(e1 e2 ...)))))
                      ((_ args e1 e2 ...)
                       (call-with-values (lambda () (lambda-formals #'args))
-                        (lambda (req opt rest kw pred)
+                        (lambda (req opt rest kw)
                           (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...)))))
                      (_ (syntax-violation 'lambda "bad lambda" e)))))
 

module/language/brainfuck/compile-tree-il.scm

@@ -170,7 +170,7 @@
            (emit `(letrec (iterate) (,iterate)
                           ((lambda ()
                              (lambda-case
-                              ((() #f #f #f () () #f)
+                              ((() #f #f #f () ())
                                (if (apply (primitive =)
                                           (apply (primitive vector-ref)
                                                  (lexical tape) (lexical pointer))

module/language/ecmascript/compile-tree-il.scm

@@ -337,14 +337,14 @@
                         formals)))
          `(lambda ()
             (lambda-case
-             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms #f)
+             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
               ,(comp-body e body formals syms))))))
       ((call/this ,obj ,prop . ,args)
        (@impl call/this*
               obj
               (-> (lambda '() 
                     `(lambda-case
-                      ((() #f #f #f () () #f)
+                      ((() #f #f #f () ())
                        (apply ,(@impl pget obj prop) ,@args)))))))
       ((call (pref ,obj ,prop) ,args)
        (comp `(call/this ,(comp obj e)
@@ -447,13 +447,13 @@
            (-> (letrec '(%loop %continue) (list %loop %continue)
                        (list (-> (lambda '()
                                    (-> (lambda-case
-                                        `((() #f #f #f () () #f)
+                                        `((() #f #f #f () ())
                                           ,(-> (begin
                                                  (comp statement e)
                                                  (-> (apply (-> (lexical '%continue %continue)))))))))))
                              (-> (lambda '()
                                    (-> (lambda-case
-                                        `((() #f #f #f () () #f)
+                                        `((() #f #f #f () ())
                                           ,(-> (if (@impl ->boolean (comp test e))
                                                    (-> (apply (-> (lexical '%loop %loop))))
                                                    (@implv *undefined*)))))))))
@@ -464,7 +464,7 @@
            (-> (letrec '(%continue) (list %continue)
                        (list (-> (lambda '()
                                    (-> (lambda-case
-                                        `((() #f #f #f () () #f)
+                                        `((() #f #f #f () ())
                                           ,(-> (if (@impl ->boolean (comp test e))
                                                    (-> (begin (comp statement e)
                                                               (-> (apply (-> (lexical '%continue %continue))))))
@@ -477,7 +477,7 @@
            (-> (letrec '(%continue) (list %continue)
                        (list (-> (lambda '()
                                    (-> (lambda-case
-                                        `((() #f #f #f () () #f)
+                                        `((() #f #f #f () ())
                                           ,(-> (if (if test
                                                        (@impl ->boolean (comp test e))
                                                        (comp 'true e))
@@ -496,7 +496,7 @@
                        (list (@impl make-enumerator (comp object e))
                              (-> (lambda '()
                                    (-> (lambda-case
-                                        `((() #f #f #f () () #f)
+                                        `((() #f #f #f () ())
                                           (-> (if (@impl ->boolean
                                                          (@impl pget
                                                                 (-> (lexical '%enum %enum))

module/language/tree-il.scm

@@ -40,7 +40,7 @@
             <lambda-case> lambda-case? make-lambda-case lambda-case-src
                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
                           lambda-case-inits lambda-case-vars
-                          lambda-case-predicate lambda-case-body lambda-case-else
+                          lambda-case-body lambda-case-else
             <let> let? make-let let-src let-names let-vars let-vals let-body
             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
             <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
@@ -70,7 +70,7 @@
   (<application> proc args)
   (<sequence> exps)
   (<lambda> meta body)
-  (<lambda-case> req opt rest kw inits vars predicate body else)
+  (<lambda-case> req opt rest kw inits vars body else)
   (<let> names vars vals body)
   (<letrec> names vars vals body)
   (<fix> names vars vals body)
@@ -135,17 +135,15 @@
      ((lambda ,meta ,body)
       (make-lambda loc meta (retrans body)))
 
-     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body) ,else)
+     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,else)
       (make-lambda-case loc req opt rest kw 
                         (map retrans inits) vars
-                        (and=> predicate retrans)
                         (retrans body)
                         (and=> else retrans)))
 
-     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body))
+     ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
       (make-lambda-case loc req opt rest kw
                         (map retrans inits) vars
-                        (and=> predicate retrans)
                         (retrans body)
                         #f))
 
@@ -208,9 +206,8 @@
     ((<lambda> meta body)
      `(lambda ,meta ,(unparse-tree-il body)))
 
-    ((<lambda-case> req opt rest kw inits vars predicate body else)
-     `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars
-                     ,(and=> predicate unparse-tree-il))
+    ((<lambda-case> req opt rest kw inits vars body else)
+     `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
                     ,(unparse-tree-il body))
                    . ,(if else (list (unparse-tree-il else)) '())))
 
@@ -276,7 +273,7 @@
          `(lambda ,@(car (tree-il->scheme body)))
          `(case-lambda ,@(tree-il->scheme body))))
     
-    ((<lambda-case> req opt rest kw inits vars predicate body else)
+    ((<lambda-case> req opt rest kw inits vars body else)
      ;; FIXME! use parse-lambda-case?
      `((,(if rest (apply cons* vars) vars)
         ,(tree-il->scheme body))
@@ -300,7 +297,7 @@
      ;; not a typo, we really do translate back to letrec
      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 
-    ((<let-values> vars exp body)
+    ((<let-values> exp body)
      `(call-with-values (lambda () ,(tree-il->scheme exp))
         ,(tree-il->scheme (make-lambda #f '() body))))))
 
@@ -336,15 +333,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (up tree (loop exps (down tree result))))
           ((<lambda> body)
            (up tree (loop body (down tree result))))
-          ((<lambda-case> inits predicate body else)
+          ((<lambda-case> inits body else)
            (up tree (if else
                         (loop else
-                              (if predicate
-                                  (loop body (loop predicate (loop inits (down tree result))))
-                                  (loop body (loop inits (down tree result)))))
-                        (if predicate
-                            (loop body (loop predicate (loop inits (down tree result))))
-                            (loop body (loop inits (down tree result)))))))
+                              (loop body (loop inits (down tree result))))
+                        (loop body (loop inits (down tree result))))))
           ((<let> vals body)
            (up tree (loop body
                           (loop vals
@@ -396,19 +389,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
                   (fold-values foldts exps seed ...))
                  ((<lambda> body)
                   (foldts body seed ...))
-                 ((<lambda-case> inits predicate body else)
+                 ((<lambda-case> inits body else)
                   (let-values (((seed ...) (fold-values foldts inits seed ...)))
-                    (if predicate
-                        (if else
-                            (let*-values (((seed ...) (foldts predicate seed ...))
-                                          ((seed ...) (foldts body seed ...)))
-                              (foldts else seed ...))
-                            (let-values (((seed ...) (foldts predicate seed ...)))
-                              (foldts body seed ...)))
-                        (if else
-                            (let-values (((seed ...) (foldts body seed ...)))
-                              (foldts else seed ...))
-                            (foldts body seed ...)))))
+                    (if else
+                        (let-values (((seed ...) (foldts body seed ...)))
+                          (foldts else seed ...))
+                        (foldts body seed ...))))
                  ((<let> vals body)
                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
                     (foldts body seed ...)))
@@ -452,10 +438,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
       ((<lambda> body)
        (set! (lambda-body x) (lp body)))
       
-      ((<lambda-case> inits predicate body else)
+      ((<lambda-case> inits body else)
        (set! inits (map lp inits))
-       (if predicate
-           (set! (lambda-case-predicate x) (lp predicate)))
        (set! (lambda-case-body x) (lp body))
        (if else
            (set! (lambda-case-else x) (lp else))))
@@ -511,9 +495,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
         ((<lambda> body)
          (set! (lambda-body x) (lp body)))
 
-        ((<lambda-case> inits predicate body else)
+        ((<lambda-case> inits body else)
          (set! inits (map lp inits))
-         (if predicate (set! (lambda-case-predicate x) (lp predicate)))
          (set! (lambda-case-body x) (lp body))
          (if else (set! (lambda-case-else x) (lp else))))
 

module/language/tree-il/analyze.scm

@@ -190,8 +190,7 @@
                                             (length tail-call-args))
                                          (not (lambda-case-opt c))
                                          (not (lambda-case-kw c))
-                                         (not (lambda-case-rest c))
-                                         (not (lambda-case-predicate c)))
+                                         (not (lambda-case-rest c)))
                                     (lp (lambda-case-else c)))))))))
            (hashq-set! labels gensym #f))
        (list gensym))
@@ -226,7 +225,7 @@
          (hashq-set! free-vars x free)
          free))
       
-      ((<lambda-case> opt kw inits vars predicate body else)
+      ((<lambda-case> opt kw inits vars body else)
        (hashq-set! bound-vars proc
                    (append (reverse vars) (hashq-ref bound-vars proc)))
        (lset-union
@@ -234,7 +233,6 @@
         (lset-difference eq?
                          (lset-union eq?
                                      (apply lset-union eq? (map step inits))
-                                     (if predicate (step predicate) '())
                                      (step-tail body))
                          vars)
         (if else (step-tail else) '())))
@@ -381,13 +379,12 @@
          (hashq-set! allocation x (cons labels free-addresses)))
        n)
 
-      ((<lambda-case> opt kw inits vars predicate body else)
+      ((<lambda-case> opt kw inits vars body else)
        (max
         (let lp ((vars vars) (n n))
           (if (null? vars)
               (let ((nlocs (apply
                             max
-                            (if predicate (allocate! predicate body n) n)
                             (allocate! body proc n)
                             ;; inits not logically at the end, but they
                             ;; are the list...

module/language/tree-il/compile-glil.scm

@@ -60,7 +60,7 @@
     (analyze-tree analyses x e))
 
   (let* ((x (make-lambda (tree-il-src x) '()
-                         (make-lambda-case #f '() #f #f #f '() '() #f x #f)))
+                         (make-lambda-case #f '() #f #f #f '() '() x #f)))
          (x (optimize! x e opts))
          (allocation (analyze-lexicals x)))
 
@@ -603,14 +603,13 @@
                   (emit-code #f (make-glil-call 'make-closure 2)))))))
        (maybe-emit-return))
       
-      ((<lambda-case> src req opt rest kw inits vars predicate else body)
+      ((<lambda-case> src req opt rest kw inits vars else body)
        ;; o/~ feature on top of feature o/~
        ;; req := (name ...)
        ;; opt := (name ...) | #f
        ;; rest := name | #f
        ;; kw: (allow-other-keys? (keyword name var) ...) | #f
        ;; vars: (sym ...)
-       ;; predicate: tree-il in context of vars
        ;; init: tree-il in context of vars
        ;; vars map to named arguments in the following order:
        ;;  required, optional (positional), rest, keyword.
@@ -691,15 +690,6 @@
                (#t (error "what" inits))))))
          ;; post-prelude case label for label calls
          (emit-label (car (hashq-ref allocation x)))
-         (if predicate
-             (begin
-               (comp-push predicate)
-               (if else-label
-                   ;; fixme: debox if necessary
-                   (emit-branch src 'br-if-not else-label)
-                   (comp-push (make-application
-                               src (make-primitive-ref #f 'error)
-                               (list (make-const #f "precondition not met")))))))
          (comp-tail body)
          (if (not (null? vars))
              (emit-code #f (make-glil-unbind)))
@@ -828,8 +818,8 @@
 
       ((<let-values> src exp body)
        (record-case body
-         ((<lambda-case> req opt kw rest vars predicate body else)
-          (if (or opt kw predicate else)
+         ((<lambda-case> req opt kw rest vars body else)
+          (if (or opt kw else)
               (error "unexpected lambda-case in let-values" x))
           (let ((MV (make-label)))
             (comp-vals exp MV)

module/language/tree-il/inline.scm

@@ -44,9 +44,8 @@
           (let lp ((lcase body))
             (and lcase
                  (record-case lcase
-                   ((<lambda-case> req opt rest kw inits vars predicate body else)
-                    (if (and (= (length vars) (length req) (length args))
-                             (not predicate))
+                   ((<lambda-case> req opt rest kw inits vars body else)
+                    (if (and (= (length vars) (length req) (length args)))
                         (let ((x (make-let src req vars args body)))
                           (or (inline1 x) x))
                         (lp else)))))))
@@ -65,7 +64,6 @@
                          (lambda-case? (lambda-body consumer))
                          (not (lambda-case-opt (lambda-body consumer)))
                          (not (lambda-case-kw (lambda-body consumer)))
-                         (not (lambda-case-predicate (lambda-body consumer)))
                          (not (lambda-case-else (lambda-body consumer))))
                   (make-let-values
                    src

test-suite/tests/tree-il.test

@@ -322,7 +322,7 @@
 (with-test-prefix "lambda"
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x) #f #f #f () (y) #f) (const 2)) #f))
+     (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
    (program ()  (std-prelude 0 0 #f) (label _)
             (program () (std-prelude 1 1 #f)
                      (bind (x #f 0)) (label _)
@@ -331,7 +331,7 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x y) #f #f #f () (x1 y1) #f)
+     (lambda-case (((x y) #f #f #f () (x1 y1))
                    (const 2))
                   #f))
    (program () (std-prelude 0 0 #f) (label _)
@@ -343,7 +343,7 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case ((() #f x #f () (y) #f) (const 2))
+     (lambda-case ((() #f x #f () (y)) (const 2))
                   #f))
    (program () (std-prelude 0 0 #f) (label _)
             (program () (opt-prelude 0 0 0 1 #f) 
@@ -354,7 +354,7 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x) #f x1 #f () (y y1) #f) (const 2))
+     (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
                   #f))
    (program () (std-prelude 0 0 #f) (label _)
             (program () (opt-prelude 1 0 1 2 #f)
@@ -365,7 +365,7 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x y))
+     (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
                   #f))
    (program () (std-prelude 0 0 #f) (label _)
             (program () (opt-prelude 1 0 1 2 #f)
@@ -376,7 +376,7 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x1 y1))
+     (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
                   #f))
    (program () (std-prelude 0 0 #f) (label _)
             (program () (opt-prelude 1 0 1 2 #f)
@@ -387,9 +387,9 @@
 
   (assert-tree-il->glil
    (lambda ()
-     (lambda-case (((x) #f #f #f () (x1) #f)
+     (lambda-case (((x) #f #f #f () (x1))
                    (lambda ()
-                     (lambda-case (((y) #f #f #f () (y1) #f)
+                     (lambda-case (((y) #f #f #f () (y1))
                                    (lexical x x1))
                                   #f)))
                   #f))
@@ -523,7 +523,7 @@
                                  (parse-tree-il
                                   '(lambda ()
                                      (lambda-case
-                                      (((x y) #f #f #f () (x1 y1) #f)
+                                      (((x y) #f #f #f () (x1 y1))
                                        (apply (toplevel +)
                                               (lexical x x1)
                                               (lexical y y1)))