suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Properly check a body specification

Browse Source 
svn: r1110
This commit is contained in:
Eli Barzilay 2005-10-19 22:09:11 +00:00
parent 04d36492b5
commit b5835267dd
2 changed files with 66 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
collects/mzlib/kw.ss
View File

@ -21,6 +21,12 @@
(raise-syntax-error #f (apply format fmt args) stx sub)) (raise-syntax-error #f (apply format fmt args) stx sub))
;; contents of syntax ;; contents of syntax
(define (syntax-e* x) (if (syntax? x) (syntax-e x) x)) (define (syntax-e* x) (if (syntax? x) (syntax-e x) x))
;; turns formals into a syntax list
(define (formals->list formals)
(syntax-case formals ()
[(formal ... . rest) ; dot is exactly like #:rest
(formals->list #'(formal ... #:rest rest))]
[(formal ...) (syntax->list formals)]))
;; is an expression simple? (=> evaluating cannot have side effects) ;; is an expression simple? (=> evaluating cannot have side effects)
(define (simple-expr? expr) (define (simple-expr? expr)
(let ([expr (local-expand expr 'expression null)]) ; expand id macros (let ([expr (local-expand expr 'expression null)]) ; expand id macros
@ -32,7 +38,7 @@
;; split a list of syntax objects based on syntax keywords: ;; split a list of syntax objects based on syntax keywords:
;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...) ;; (x ... #:k1 ... #:k2 ... ...) --> ((x ...) (#:k1 ...) (#:k2 ...) ...)
(define (split-by-keywords xs) (define (split-by-keywords xs)
(let loop ([xs xs] [cur '()] [r '()]) (let loop ([xs (if (syntax? xs) (formals->list xs) xs)] [cur '()] [r '()])
(if (null? xs) (if (null? xs)
(reverse! (cons (reverse! cur) r)) (reverse! (cons (reverse! cur) r))
(let ([x (car xs)]) (let ([x (car xs)])
@ -77,9 +83,13 @@
(ormap (lambda (k) (and (assq k rests) #t)) enablers))) (ormap (lambda (k) (and (assq k rests) #t)) enablers)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; test variables ;; test variables
(define (process-vars vars opts keys0 rests other-keys-mode body-mode) (define (process-vars vars opts keys0 rests other-keys-mode body-mode
. only-vars?)
(define (gensym x)
(car (generate-temporaries (list x))))
(let*-values (let*-values
([(opts keys0) (values (map process-opt opts) (map process-key keys0))] ([(only-vars?) (and (pair? only-vars?) (car only-vars?))]
[(opts keys0) (values (map process-opt opts) (map process-key keys0))]
[(other-keys-mode body-mode) [(other-keys-mode body-mode)
(values (process-mode other-keys-mode (values (process-mode other-keys-mode
rests #:allow-other-keys other-keys-accessing) rests #:allow-other-keys other-keys-accessing)
@ -90,35 +100,43 @@
(map (lambda (k) (cond [(assq k rests) => cdr] [else #f])) (map (lambda (k) (cond [(assq k rests) => cdr] [else #f]))
'(#:rest #:body #:rest-keys #:all-keys #:other-keys)))] '(#:rest #:body #:rest-keys #:all-keys #:other-keys)))]
[(body-spec body) [(body-spec body)
(if (identifier? body) (values #f body) (values body #'body))] (if (identifier? body)
[(rest* body* other-keys*) (values (or rest #'rest) (or body #'body) (values #f body)
(or other-keys #'other-keys))] (values body (gensym #'body)))]
[(rest* body* other-keys*)
(values (or rest (gensym #'rest))
(or body (gensym #'body))
(or other-keys (gensym #'other-keys)))]
;; turn (<id> <key> <default>) keys to (<id> <default>) ;; turn (<id> <key> <default>) keys to (<id> <default>)
[(keys) (with-syntax ([r rest*]) [(keys)
(map (lambda (k) (with-syntax ([r rest*])
(list (car k) (map (lambda (k)
(if (simple-expr? (caddr k)) (list (car k)
;; simple case => no closure (if (simple-expr? (caddr k))
#`(getarg* r #,(cadr k) #,(caddr k)) ;; simple case => no closure
#`(getarg r #,(cadr k) #`(getarg* r #,(cadr k) #,(caddr k))
(lambda () #,(caddr k)))))) #`(getarg r #,(cadr k) (lambda () #,(caddr k))))))
keys0))]) keys0))]
(let (; use identifiers from here if none given, so the tests work [(all-ids)
[ids `(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body* `(,@vars ,@(map car opts) ,@(map car keys) ,rest* ,body*
,(or rest-keys #'rest-keys) ;; make up names if not specified, to make checking easy
,(or all-keys #'all-keys) ,(or other-keys #'other-keys))]) ,(or rest-keys (gensym #'rest-keys))
(cond [(ormap (lambda (x) (and (not (identifier? x)) x)) ids) ,(or all-keys (gensym #'all-keys))
=> (lambda (d) (serror d "not an identifier"))] ,(or other-keys (gensym #'other-keys))
[(check-duplicate-identifier ids) ,@(if body-spec (parse-formals body-spec #t) '()))])
=> (lambda (d) (serror d "duplicate argument name"))])) (cond [only-vars? all-ids]
(values vars opts keys rest rest* body body* body-spec [(ormap (lambda (x) (and (not (identifier? x)) x)) all-ids)
rest-keys all-keys other-keys other-keys* => (lambda (d) (serror d "not an identifier"))]
other-keys-mode body-mode (map cadr keys0)))) [(check-duplicate-identifier all-ids)
=> (lambda (d) (serror d "duplicate argument name"))]
[else (values vars opts keys rest rest* body body* body-spec
rest-keys all-keys other-keys other-keys*
other-keys-mode body-mode (map cadr keys0))])))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; parses formals, returns list of normal vars, optional var specs, key var ;; parses formals, returns list of normal vars, optional var specs, key var
;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys ;; specs, an alist of rest-like kw+vars, and a mode for allowing other keys
;; or not; no duplicate names ;; or not; no duplicate names
(define (parse-formals formals) (define (parse-formals formals . only-vars?)
(let* ([formals (split-by-keywords formals)] (let* ([formals (split-by-keywords formals)]
[vars (car formals)] [vars (car formals)]
[formals (cdr formals)] [formals (cdr formals)]
@ -135,7 +153,8 @@
[other-keys-mode #f] [other-keys-mode #f]
[body-mode #f]) [body-mode #f])
(if (null? formals) (if (null? formals)
(process-vars vars opts keys rests other-keys-mode body-mode) (apply process-vars vars opts keys rests other-keys-mode body-mode
only-vars?)
(let* ([k-stx (caar formals)] (let* ([k-stx (caar formals)]
[k (syntax-e* k-stx)]) [k (syntax-e* k-stx)])
(cond [(memq k '(#:optional #:key)) (cond [(memq k '(#:optional #:key))
@ -263,7 +282,15 @@
(error* 'name "keyword list not balanced: ~e" rest*)) (error* 'name "keyword list not balanced: ~e" rest*))
#,(if allow-body? #,(if allow-body?
(if body-spec (if body-spec
#`(apply (lambda/kw #,body-spec expr) body*) (with-syntax ([name (string->symbol
(format "~a~~body"
(syntax-e* #'name)))])
(with-syntax ([subcall
(quasisyntax/loc stx
(let ([name (lambda/kw #,body-spec
expr)])
name))])
#'(apply subcall body*)))
#'expr) #'expr)
#'(if (null? body*) #'(if (null? body*)
expr expr
@ -297,10 +324,8 @@
(with-syntax ([name name] [clauses clauses]) (with-syntax ([name name] [clauses clauses])
(syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))])) (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))
(syntax-case stx () (syntax-case stx ()
[(_ (formal ... . rest) expr0 expr ...) ; dot is exactly like #:rest [(_ formals expr0 expr ...)
#'(_ (formal ... #:rest rest) expr0 expr ...)] (generate-body #'formals #'(begin expr0 expr ...))]))
[(_ (formal ...) expr0 expr ...)
(generate-body (syntax->list #'(formal ...)) #'(begin expr0 expr ...))]))
(provide define/kw) (provide define/kw)
(define-syntax (define/kw stx) (define-syntax (define/kw stx)

15
collects/tests/mzscheme/kw.ss
View File

@ -238,10 +238,11 @@
(st #'(lambda/kw (x #:body x #:allow-other-keys) 1)) (st #'(lambda/kw (x #:body x #:allow-other-keys) 1))
(st #'(lambda/kw (x #:optional ()) 1)) (st #'(lambda/kw (x #:optional ()) 1))
(st #'(lambda/kw (x #:optional (x y z)) 1)) (st #'(lambda/kw (x #:optional (x y z)) 1))
(lambda/kw (x #:other-keys z) 1) (st #'(lambda/kw (x #:other-keys z) 1))
(lambda/kw (x #:rest-keys z) 1) (st #'(lambda/kw (x #:rest-keys z) 1))
(lambda/kw (x #:all-keys z) 1) (st #'(lambda/kw (x #:all-keys z) 1))
(lambda/kw (x #:key y #:allow-other-keys z) 1) (st #'(lambda/kw (x #:key y #:allow-other-keys z) 1))
(lambda/kw (x #:key y #:forbid-body z) 1) (st #'(lambda/kw (x #:key y #:forbid-body z) 1))
(lambda/kw (x #:key y #:allow-body #:rest r #:forbid-body) 1) (st #'(lambda/kw (x #:key y #:allow-body #:rest r #:forbid-body) 1))
(lambda/kw (x #:key y #:forbid-other-keys #:rest r #:allow-other-keys) 1)) (st #'(lambda/kw (x #:key y #:forbid-other-keys #:rest r #:allow-other-keys) 1))
(st #'((lambda/kw (x #:key y z #:body (x)) x) 1)))