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

specialize code for body and no keywords (and no optionals)

Browse Source 
svn: r4440
This commit is contained in:
Eli Barzilay 2006-09-26 15:28:05 +00:00
parent 13b9ef2d9d
commit d1e22794f4
1 changed files with 22 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/mzlib/kw.ss
View File

@ -283,7 +283,7 @@
[clauses '()]) [clauses '()])
(if (null? opts) (if (null? opts)
;; fast order: first the all-variable section, then from vars up ;; fast order: first the all-variable section, then from vars up
(cons (with-syntax ([vars (append! (reverse vars) rest)] (cons (with-syntax ([vars (append (reverse vars) rest)]
[expr expr]) [expr expr])
#'[vars expr]) #'[vars expr])
(reverse clauses)) (reverse clauses))
@ -423,11 +423,11 @@
(when (null? keys) (when (null? keys)
(let ([r (or all-keys other-keys other-keys+body body rest)]) (let ([r (or all-keys other-keys other-keys+body body rest)])
(if allow-other-keys? (if allow-other-keys?
;; allow-other-keys? ;; allow-other-keys? ==>
(unless r (unless r
(serror #f "cannout allow other keys ~a" (serror #f "cannout allow other keys ~a"
"without using them in some way")) "without using them in some way"))
;; (not allow-other-keys?) ;; (not allow-other-keys?) ==>
(begin (begin
;; can use #:body with no keys to forbid all keywords ;; can use #:body with no keys to forbid all keywords
(when (and r (not (eq? r body))) (when (and r (not (eq? r body)))
@ -439,24 +439,36 @@
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; body generation starts here ;; body generation starts here
(cond (cond
;; no optionals or keys (or body or other-keys) => plain lambda ;; no optionals or keys (or other-keys) => plain lambda
[(and (null? opts) (null? keys) (not (or body allow-other-keys?))) [(and (null? opts) (null? keys) (not allow-other-keys?))
(with-syntax ([vars (append! vars (or rest '()))] [expr expr]) (if (not body)
(syntax/loc stx (lambda vars expr)))] ;; really just a plain lambda
(with-syntax ([vars (append vars (or rest '()))] [expr expr])
(syntax/loc stx (lambda vars expr)))
;; has body => forbid keywords
(with-syntax ([vars (append vars body)] [expr expr] [body body])
(syntax/loc stx
(lambda vars
(if (and (pair? body) (keyword? (car body)))
(error* 'name "unknown keyword: ~e" (car body))
expr)))))]
;; no keys => make a case-lambda for optionals ;; no keys => make a case-lambda for optionals
[(and (null? keys) (not (or body allow-other-keys?))) [(and (null? keys) (not (or body allow-other-keys?)))
;; cannot write a special case for having `body' here, because it
;; requires the special pop-non-keywords-for-optionals that is done
;; below, and generalizing that is a hassle with little benefit
(let ([clauses (make-opt-clauses expr (or rest '()))]) (let ([clauses (make-opt-clauses expr (or rest '()))])
(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))))]
;; no opts => normal processing of keywords etc ;; no opts => normal processing of keywords etc
[(null? opts) [(null? opts)
(with-syntax ([vars (append! vars rest*)] (with-syntax ([vars (append vars rest*)]
[body (make-keys-body expr)]) [body (make-keys-body expr)])
(syntax/loc stx (lambda vars body)))] (syntax/loc stx (lambda vars body)))]
;; both opts and keys => combine the above two ;; both opts and keys => combine the above two
;; (the problem with this is that things that follow the required ;; (the problem with this is that things that follow the required
;; arguments are always taken as optionals, even if they're keywords, so ;; arguments are always taken as optionals, even if they're keywords, so
;; the following piece of code is used.) ;; the next piece of code is used.)
#; #;
[else [else
(let ([clauses (make-opt-clauses (make-keys-body expr) rest*)]) (let ([clauses (make-opt-clauses (make-keys-body expr) rest*)])
@ -466,7 +478,7 @@
[else [else
(with-syntax (with-syntax
([rest rest*] ([rest rest*]
[vars (append! vars rest*)] [vars (append vars rest*)]
[body (make-keys-body expr)] [body (make-keys-body expr)]
[((optvar optexpr) ...) [((optvar optexpr) ...)
(apply append (apply append