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

implement #:predicate

Browse source 
will be useful for making e.g. typecase-lambda. Tough to tell though.

* module/ice-9/psyntax.scm (lambda-formals, lambda*-formals): Parse out
  a #:predicate, which goes right before the rest args. The vanilla
  lambda doesn't parse it out of course, but it does return another
  value.
  (chi-lambda-case, lambda*, lambda): Expand and pass the predicate on
  to build-lambda-case.

* module/ice-9/psyntax-pp.scm: Regenerate.

* module/language/tree-il/compile-glil.scm (flatten): Compile a failing
  predicate without an else clause into a call to `error'. Also, fix
  something the compile warnings caught.
This commit is contained in:
Andy Wingo 2009-10-26 21:20:23 +01:00
parent b1f6293e98
commit 24bf130fd1
3 changed files with 4783 additions and 4531 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -1585,7 +1585,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)) (values req #f rest #f #f))
(else (else
(syntax-violation 'lambda "duplicate identifier in argument list" (syntax-violation 'lambda "duplicate identifier in argument list"
orig-args)))) orig-args))))
@ -1610,40 +1610,44 @@
(define (req args rreq) (define (req args rreq)
(syntax-case args () (syntax-case args ()
(() (()
(check (reverse rreq) '() #f '())) (check (reverse rreq) '() #f '() #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) '() '())) (rest #'b (reverse rreq) '() '() #f))
(r (id? #'r) (r (id? #'r)
(rest #'r (reverse rreq) '() '())) (rest #'r (reverse rreq) '() '() #f))
(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 '())) (check req (reverse ropt) #f '() #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) '())) (rest #'b req (reverse ropt) '() #f))
(r (id? #'r) (r (id? #'r)
(rest #'r req (reverse ropt) '())) (rest #'r req (reverse ropt) '() #f))
(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)))) (check req opt #f (cons #f (reverse rkey)) #f))
((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))))
@ -1654,33 +1658,48 @@
(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)))) (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))))
((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)))) (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)))) (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)))) (rest #'b req opt (cons #f (reverse rkey)) #f))
(r (id? #'r) (r (id? #'r)
(rest #'r req opt (cons #f (reverse rkey)))) (rest #'r req opt (cons #f (reverse rkey)) #f))
(else (else
(syntax-violation 'lambda* "invalid keyword argument list" (syntax-violation 'lambda* "invalid keyword argument list"
orig-args args)))) orig-args args))))
(define (rest args req opt kw) (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 #f kw #'x))
((x . b) (id? #'b)
(rest #'b req opt #f kw #'x))
(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)) (check req opt #'r kw pred))
(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) (define (check req opt rest kw pred)
(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)) (values req opt rest kw pred))
(else (else
(syntax-violation 'lambda* "duplicate identifier in argument list" (syntax-violation 'lambda* "duplicate identifier in argument list"
orig-args)))) orig-args))))
@ -1688,14 +1707,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 body) (define (expand-req req opt rest kw pred 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 body (reverse vars) r* w* '() '())))) opt rest kw pred body (reverse vars) r* w* '() '()))))
(define (expand-opt req opt rest kw body vars r* w* out inits) (define (expand-opt req opt rest kw pred body vars r* w* out inits)
(cond (cond
((pair? opt) ((pair? opt)
(syntax-case (car opt) () (syntax-case (car opt) ()
@ -1704,7 +1723,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 body (cons v vars) (expand-opt req (cdr opt) rest kw pred 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
@ -1715,16 +1734,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)
body (cons v vars) r* w* pred 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)
body vars r* w* pred 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 body vars r* w* aok out inits) (define (expand-kw req opt rest kw pred body vars r* w* aok out inits)
(cond (cond
((pair? kw) ((pair? kw)
(syntax-case (car kw) () (syntax-case (car kw) ()
@ -1733,7 +1752,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) body (cons v vars) (expand-kw req opt rest (cdr kw) pred 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)
@ -1741,17 +1760,20 @@
out) out)
(cons (chi #'i r* w* mod) inits)))))) (cons (chi #'i r* w* mod) inits))))))
(else (else
(expand-body req opt rest (expand-pred req opt rest
(if (or aok (pair? out)) (cons aok (reverse out)) #f) (if (or aok (pair? out)) (cons aok (reverse out)) #f)
body (reverse vars) r* w* (reverse inits))))) pred body (reverse vars) r* w* (reverse inits)))))
(define (expand-body req opt rest kw body vars r* w* 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)
(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 #f (values (syntax->datum #'docstring) req opt rest kw inits vars pred
(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 #f (values #f req opt rest kw inits vars pred
(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)))))
@ -1759,9 +1781,9 @@
(() (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) (lambda (req opt rest kw pred)
(call-with-values (lambda () (call-with-values (lambda ()
(expand-req req opt rest kw #'(e1 e2 ...))) (expand-req req opt rest kw pred #'(e1 e2 ...)))
(lambda (docstring req opt rest kw inits vars pred body) (lambda (docstring req opt rest kw inits vars pred body)
(call-with-values (call-with-values
(lambda () (lambda ()
@ -2033,12 +2055,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) (lambda (req opt rest kw pred)
(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) (lambda (req opt rest kw pred)
(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)))))

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

@ -418,7 +418,7 @@
(else (else
;; no cases left; shuffle args down and jump before the prelude. ;; no cases left; shuffle args down and jump before the prelude.
(for-each (lambda (i) (for-each (lambda (i)
(emit-code #f (make-glil-lexical #t #f 'set index))) (emit-code #f (make-glil-lexical #t #f 'set i)))
(reverse (iota (length args)))) (reverse (iota (length args))))
(emit-branch src 'br self-label))))) (emit-branch src 'br self-label)))))
@ -693,8 +693,9 @@
(if else-label (if else-label
;; fixme: debox if necessary ;; fixme: debox if necessary
(emit-branch src 'br-if-not else-label) (emit-branch src 'br-if-not else-label)
;; fixme: better error (comp-push (make-application
(emit-code src (make-glil-call 'assert-true 0))))) 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)))