mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

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

Browse source 
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.
This commit is contained in:
Andy Wingo 2009-11-05 10:22:01 +01:00
parent e161c9f85c
commit 1e2a8edb8b
11 changed files with 4598 additions and 4925 deletions
Download patch file Download diff file Expand all files Collapse all files

19
doc/ref/api-procedures.texi
View file

@ -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 required arguments, but are not too many for the optional and/or rest
arguments. 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 Keyword arguments are possible with @code{case-lambda*}, but they do
not contribute to the ``matching'' behavior. That is to say, not contribute to the ``matching'' behavior. That is to say,
@code{case-lambda*} matches only on required, optional, and rest @code{case-lambda*} matches only on required, optional, and rest

17
module/ice-9/optargs.scm
View file

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

9255
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

112
module/ice-9/psyntax.scm
View file

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

2
module/language/brainfuck/compile-tree-il.scm
View file

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

14
module/language/ecmascript/compile-tree-il.scm
View file

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

53
module/language/tree-il.scm
View file

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

9
module/language/tree-il/analyze.scm
View file

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

18
module/language/tree-il/compile-glil.scm
View file

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

6
module/language/tree-il/inline.scm
View file

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

18
test-suite/tests/tree-il.test
View file

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