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

keyword-function repairs

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-08 21:24:54 -06:00
parent 001cb75bac
commit 2d06f4247f
4 changed files with 122 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
collects/racket/private/kw.rkt
View File

@ -364,9 +364,8 @@
(if (simple-args? #'args) (if (simple-args? #'args)
;; Use plain old `lambda': ;; Use plain old `lambda':
(non-kw-k (non-kw-k
(syntax-protect (syntax/loc stx
(syntax/loc stx (lambda args body1 body ...)))
(lambda args body1 body ...))))
;; Handle keyword or optional arguments: ;; Handle keyword or optional arguments:
(with-syntax ([((plain-id ...) (with-syntax ([((plain-id ...)
(opt-id ...) (opt-id ...)
@ -440,7 +439,9 @@
[with-kw-min-args (+ 2 (length plain-ids))] [with-kw-min-args (+ 2 (length plain-ids))]
[with-kw-max-arg (if (null? (syntax-e #'rest)) [with-kw-max-arg (if (null? (syntax-e #'rest))
(+ 2 (length plain-ids) (length opts)) (+ 2 (length plain-ids) (length opts))
#f)]) #f)]
[core (car (generate-temporaries '(core)))]
[unpack (car (generate-temporaries '(unpack)))])
(let ([mk-core (let ([mk-core
(lambda (kw-core?) (lambda (kw-core?)
;; body of procedure, where all keyword and optional ;; body of procedure, where all keyword and optional
@ -510,7 +511,7 @@
() (rest-id . fail-rest) () (rest-id . fail-rest)
()))))] ()))))]
[kw-k* (lambda (impl kwimpl wrap) [kw-k* (lambda (impl kwimpl wrap)
(kw-k impl kwimpl wrap (kw-k impl kwimpl wrap #'core #'unpack
(length plain-ids) (length opts) (length plain-ids) (length opts)
(not (null? (syntax-e #'rest))) (not (null? (syntax-e #'rest)))
needed-kws needed-kws
@ -574,11 +575,11 @@
(parse-lambda (parse-lambda
stx stx
(lambda (e) e) (lambda (e) e)
(lambda (impl kwimpl wrap n-req n-opt rest? req-kws all-kws) (lambda (impl kwimpl wrap core-id unpack-id n-req n-opt rest? req-kws all-kws)
(syntax-protect (syntax-protect
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([core #,impl]) (let ([#,core-id #,impl])
(let ([unpack #,kwimpl]) (let ([#,unpack-id #,kwimpl])
#,wrap)))))) #,wrap))))))
#`(#%expression #,stx)))]) #`(#%expression #,stx)))])
(values new-lambda new-lambda))) (values new-lambda new-lambda)))
@ -796,21 +797,26 @@
(free-identifier=? #'lam-id #'new-λ))) (free-identifier=? #'lam-id #'new-λ)))
(parse-lambda rhs (parse-lambda rhs
plain plain
(lambda (impl kwimpl wrap n-req n-opt rest? req-kws all-kws) (lambda (impl kwimpl wrap
(syntax-protect core-id unpack-id
(quasisyntax/loc stx n-req n-opt rest? req-kws all-kws)
(begin (with-syntax ([proc (car (generate-temporaries (list id)))])
#,(quasisyntax/loc stx (syntax-protect
(define-syntax #,id (quasisyntax/loc stx
(make-keyword-syntax #'core #'proc (begin
#,n-req #,n-opt #,rest? #,(quasisyntax/loc stx
'#,req-kws '#,all-kws))) (define-syntax #,id
#,(quasisyntax/loc stx (make-keyword-syntax (lambda ()
(define core #,impl)) (values (quote-syntax #,core-id)
#,(quasisyntax/loc stx (quote-syntax proc)))
(define unpack #,kwimpl)) #,n-req #,n-opt #,rest?
#,(quasisyntax/loc stx '#,req-kws '#,all-kws)))
(define proc #,wrap)))))))] #,(quasisyntax/loc stx
(define #,core-id #,impl))
#,(quasisyntax/loc stx
(define #,unpack-id #,kwimpl))
#,(quasisyntax/loc stx
(define proc #,wrap))))))))]
[_ (plain rhs)])))) [_ (plain rhs)]))))
;; ---------------------------------------- ;; ----------------------------------------
@ -836,13 +842,13 @@
"missing procedure expression; probably originally (), which is an illegal empty application" "missing procedure expression; probably originally (), which is an illegal empty application"
stx) stx)
(begin (begin
(check-arity (- (length l) 2)) (when l
(check-arity (- (length l) 2)))
(let ([args (cdr (syntax-e stx))]) (let ([args (cdr (syntax-e stx))])
(syntax-protect (generate-direct
(generate-direct (if l (cdr (if (pair? args) args (syntax-e args))) null) null #f
(cdr (if (pair? args) args (syntax-e args))) null (quasisyntax/loc stx
(quasisyntax/loc stx (#%app . #,args)))))))
(#%app . #,args))))))))
;; keyword app (maybe) ;; keyword app (maybe)
(let ([exprs (let ([exprs
(let ([kw-ht (make-hasheq)]) (let ([kw-ht (make-hasheq)])
@ -896,7 +902,7 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(let #,(reverse bind-accum) (let #,(reverse bind-accum)
#,(generate-direct #,(generate-direct
(cdr args) sorted-kws (cdr args) sorted-kws #t
(quasisyntax/loc stx (quasisyntax/loc stx
((checked-procedure-check-and-extract struct:keyword-procedure ((checked-procedure-check-and-extract struct:keyword-procedure
#,(car args) #,(car args)
@ -924,11 +930,12 @@
kw-pairs)]))))))) kw-pairs)])))))))
(define-syntax (new-app stx) (define-syntax (new-app stx)
(parse-app stx void (lambda (args kw-args orig) orig))) (parse-app stx void (lambda (args kw-args lifted? orig) orig)))
(define-for-syntax (make-keyword-syntax impl-id wrap-id n-req n-opt rest? req-kws all-kws) (define-for-syntax (make-keyword-syntax get-ids n-req n-opt rest? req-kws all-kws)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(define-values (impl-id wrap-id) (get-ids))
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! self rhs) [(set! self rhs)
(quasisyntax/loc stx (set! #,wrap-id rhs))] (quasisyntax/loc stx (set! #,wrap-id rhs))]
@ -961,9 +968,17 @@
(n . > . (+ n-req n-opt)))) (n . > . (+ n-req n-opt))))
(printf "~s\n" (list n n-req n-opt)) (printf "~s\n" (list n n-req n-opt))
(warning "wrong number of by-position arguments"))) (warning "wrong number of by-position arguments")))
(lambda (args kw-args orig) (lambda (args kw-args lifted? orig)
(let* ([args (syntax->list (datum->syntax #f args))] (let* ([args (syntax->list (datum->syntax #f args))]
[n (length args)]) [n (length args)]
[lift-args (lambda (k)
(if (not lifted?)
;; caller didn't lift expresions out
(let ([ids (generate-temporaries args)])
#`(let #,(map list ids args)
#,(k ids)))
;; caller already lifted expression:
(k args)))])
(or (or
(and (not (or (n . < . n-req) (and (not (or (n . < . n-req)
(and (not rest?) (and (not rest?)
@ -999,44 +1014,54 @@
#f] #f]
[else [else
(loop (cdr kw-args) req-kws (cdr all-kws))]))])) (loop (cdr kw-args) req-kws (cdr all-kws))]))]))
(quasisyntax/loc stx (syntax-protect
(if (variable-reference-constant? (#%variable-reference #,wrap-id)) (lift-args
(#,impl-id (lambda (args)
;; keyword arguments: (quasisyntax/loc stx
#,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws]) (if (variable-reference-constant? (#%variable-reference #,wrap-id))
(cond (#,impl-id
[(null? all-kws) null] ;; keyword arguments:
[(and (pair? kw-args) #,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws])
(eq? (syntax-e (caar kw-args)) (car all-kws))) (cond
(if (and (pair? req-kws) [(null? all-kws) null]
(eq? (car req-kws) (car all-kws))) [(and (pair? kw-args)
(cons (cdar kw-args) (eq? (syntax-e (caar kw-args)) (car all-kws)))
(loop (cdr kw-args) (cdr req-kws) (cdr all-kws))) (if (and (pair? req-kws)
(list* (cdar kw-args) (eq? (car req-kws) (car all-kws)))
#'#t (cons (cdar kw-args)
(loop (cdr kw-args) req-kws (cdr all-kws))))] (loop (cdr kw-args) (cdr req-kws) (cdr all-kws)))
[else (list* (cdar kw-args)
(list* #'#f #'#t
#'#f (loop (cdr kw-args) req-kws (cdr all-kws))))]
(loop kw-args req-kws (cdr all-kws)))])) [else
;; required arguments: (list* #'#f
#,@(let loop ([i n-req] [args args]) #'#f
(if (zero? i) (loop kw-args req-kws (cdr all-kws)))]))
null ;; required arguments:
(cons (car args) #,@(let loop ([i n-req] [args args])
(loop (sub1 i) (cdr args))))) (if (zero? i)
;; optional arguments: null
#,@(let loop ([i n-opt] [args (list-tail args n-req)]) (cons (car args)
(cond (loop (sub1 i) (cdr args)))))
[(zero? i) null] ;; optional arguments:
[(null? args) (list* #'#f #'#f (loop (sub1 i) null))] #,@(let loop ([i n-opt] [args (list-tail args n-req)])
[else (cond
(list* (car args) #'#t (loop (sub1 i) (cdr args)))])) [(zero? i) null]
;; rest args: [(null? args) (cons #'#f (loop (sub1 i) null))]
#,@(if rest? [else
#`((list #,@(list-tail args (min (length args) (+ n-req n-opt))))) (cons (car args) (loop (sub1 i) (cdr args)))]))
null)) ;; booleans indicating whether optional argument are present:
#,orig))) #,@(let loop ([i n-opt] [args (list-tail args n-req)])
(cond
[(zero? i) null]
[(null? args) (cons #'#f (loop (sub1 i) null))]
[else
(cons #'#t (loop (sub1 i) (cdr args)))]))
;; rest args:
#,@(if rest?
#`((list #,@(list-tail args (min (length args) (+ n-req n-opt)))))
null))
#,(quasisyntax/loc stx (#%app #,wrap-id . #,args))))))))
orig)))) orig))))
(datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))] (datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))]
[_ wrap-id])))) [_ wrap-id]))))

32
collects/tests/racket/modprot.rktl
View File

@ -10,7 +10,7 @@
(define zero (define zero
'(module zero '#%kernel '(module zero '#%kernel
(define-values (prot) 8) (define-values (prot) '(8))
(#%provide (protect prot)))) (#%provide (protect prot))))
@ -21,9 +21,9 @@
(#%require 'zero (#%require 'zero
(for-syntax '#%kernel)) (for-syntax '#%kernel))
(define-values (unexp) 5) (define-values (unexp) '(5))
(define-syntaxes (stx) (define-syntaxes (stx)
(lambda (stx) (quote-syntax 13))) (lambda (stx) (quote-syntax '(13))))
(define-syntaxes (nab) (define-syntaxes (nab)
(lambda (stx) (lambda (stx)
@ -88,7 +88,7 @@
'(module two '#%kernel '(module two '#%kernel
(#%require 'one) (#%require 'one)
(define-values (normal) 10) (define-values (normal) '(10))
(nab nabbed) (nab nabbed)
(pnab pnabbed) (pnab pnabbed)
@ -111,7 +111,7 @@
'(module two '#%kernel '(module two '#%kernel
(#%require 'one) (#%require 'one)
(define-values (normal) 10) (define-values (normal) '(10))
(nab nabbed) (nab nabbed)
(pnab pnabbed) (pnab pnabbed)
@ -244,17 +244,17 @@
(test #t regexp-match? (test #t regexp-match?
(if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v)))) (if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v))))
(get-output-bytes p))))]) (get-output-bytes p))))])
(try two/no-protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one 5") fail-three?) (try two/no-protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?)
(try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"two 5") fail-three?) (try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") fail-three?)
(try two/no-protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero 8") fail-three?) (try two/no-protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?)
(try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"two 8") (or fail-three? fail-three-comp?)) (try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"two .8.") (or fail-three? fail-three-comp?))
(try two/no-protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one 13") fail-three?) (try two/no-protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?)
(try two/no-protect three/nfsnabbed #rx#"two 13" fail-three?) (try two/no-protect three/nfsnabbed #rx#"two .13." fail-three?)
(try two/no-protect three/normal #rx#"two 10" fail-three?) (try two/no-protect three/normal #rx#"two .10." fail-three?)
(try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one 5") fail-three?) (try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?)
(try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero 8") fail-three?) (try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?)
(try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one 13") fail-three?) (try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?)
(try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two 10") fail-three?))) (try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two .10.") fail-three?)))
;; - - - - - - - - - - - - - - - - - - - - ;; - - - - - - - - - - - - - - - - - - - -

2
collects/tests/racket/portlib.rktl
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.rktl") (load-relative "loadtest.rktl")
(Section 'port) (Section 'portlib)
(define SLEEP-TIME 0.1) (define SLEEP-TIME 0.1)

8
collects/tests/racket/procs.rktl
View File

@ -270,6 +270,14 @@
(err/rt-test (procedure-reduce-keyword-arity void 1 null '(#:b #:a)) (err/rt-test (procedure-reduce-keyword-arity void 1 null '(#:b #:a))
(lambda (exn) (regexp-match #rx"4th argument" (exn-message exn)))) (lambda (exn) (regexp-match #rx"4th argument" (exn-message exn))))
;; ----------------------------------------
;; Check mutation of direct-called keyword procedure
(let ()
(define (f #:x x) (list x))
(set! f (lambda (#:y y) (box y)))
(test (box 8) (lambda () (f #:y 8))))
;; ---------------------------------------- ;; ----------------------------------------
(report-errs) (report-errs)