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

eliminated some uses of rest-args and list unpacking

Browse Source
This commit is contained in:
Ryan Culpepper 2010-08-31 18:36:32 -06:00
parent bfb1eed2e9
commit be3ca941bb
4 changed files with 71 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/syntax/parse/private/parse.rkt
View File

@ -239,38 +239,38 @@ Conventions:
k)] k)]
[#s(pat:any _attrs) [#s(pat:any _attrs)
#'k] #'k]
[#s(pat:var _attrs name #f _ () _) [#s(pat:var _attrs name #f _ () _ _)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)] k)]
[#s(pat:var _attrs name parser argu (nested-a ...) commit?) [#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit?)
(with-syntax ([(name-attr ...) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
#'([#s(attr name 0 #t) (datum->syntax cx x cx)]) #'([#s(attr name 0 #t) (datum->syntax cx x cx)])
#'())]) #'())])
(if (not (syntax-e #'commit?)) (if (not (syntax-e #'commit?))
;; The normal protocol ;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt #'(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result) (lambda (fh cp av ...)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result) (let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh] (with ([fail-handler fh]
[cut-prompt cp]) [cut-prompt cp])
k)))) k))))
argu) argu)
;; The commit protocol ;; The commit protocol
;; (Avoids putting k in procedure) ;; (Avoids putting k in procedure)
#'(let ([result #'(let-values ([(fs av ...)
(with ([fail-handler (lambda (fs) (cons 'fail fs))]) (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt (app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result) (cons 'ok result)) (lambda (fh cp av ...) (values #f av ...))
argu)))]) argu)))])
(case (car result) (if fs
((fail) (fail (cdr result))) (fail fs)
((ok) (let-attributes (name-attr ...)
(let-attributes (name-attr ...) (let-attributes* ((nested-a ...) (av ...))
(let/unpack ((nested-a ...) (cdr result)) k))))))]
k)))))))]
[#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...)) [#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
@ -496,8 +496,9 @@ Conventions:
[#s(hpat:describe _ description transparent? pattern) [#s(hpat:describe _ description transparent? pattern)
#`(let ([es (cons (cons (expect:thing description transparent?) x) es)]) #`(let ([es (cons (cons (expect:thing description transparent?) x) es)])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
[#s(hpat:var _attrs name parser argu (nested-a ...) commit?) [#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?)
(with-syntax ([(name-attr ...) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)
#'([#s(attr name 0 #t) #'([#s(attr name 0 #t)
(stx-list-take x (ps-difference pr rest-pr))]) (stx-list-take x (ps-difference pr rest-pr))])
@ -505,34 +506,27 @@ Conventions:
(if (not (syntax-e #'commit?)) (if (not (syntax-e #'commit?))
;; The normal protocol ;; The normal protocol
#`(app-argu parser x cx pr es fail-handler cut-prompt #`(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr . result) (lambda (fh cp rest-x rest-cx rest-pr av ...)
(let-attributes (name-attr ...) (let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result) (let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh] (with ([fail-handler fh]
[cut-prompt cp]) [cut-prompt cp])
k)))) k))))
argu) argu)
;; The commit protocol ;; The commit protocol
;; (Avoids putting k in procedure) ;; (Avoids putting k in procedure)
#'(let ([result #'(let-values ([(fs rest-x rest-cx rest-pr av ...)
(with ([fail-handler (lambda (fs) (cons 'fail fs))]) (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler]) (with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt (app-argu parser x cx pr es fail-handler cut-prompt
(lambda result (cons 'ok result)) (lambda (fh cp rest-x rest-cx rest-pr av ...)
argu)))]) (values #f rest-x rest-cx rest-pr av ...))
(case (car result) argu)))])
((fail) (fail (cdr result))) (if fs
((ok) (fail fs)
(let ([_fh (car result)] (let-attributes (name-attr ...)
[_cp (cadr result)] (let-attributes* ((nested-a ...) (av ...))
[result (cddr result)]) k))))))]
(let ([rest-x (cadr result)]
[rest-cx (caddr result)]
[rest-pr (cadddr result)]
[result (cddddr result)])
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
k)))))))))]
[#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...)) [#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...) (with-syntax ([(name-attr ...)
(if (identifier? #'name) (if (identifier? #'name)

16
collects/syntax/parse/private/rep-patterns.rkt
View File

@ -21,7 +21,7 @@ A Base is (listof IAttr)
#| #|
A SinglePattern is one of A SinglePattern is one of
(pat:any Base) (pat:any Base)
(pat:var Base id id Arguments (listof IAttr) bool) (pat:var Base id id Arguments (listof IAttr) nat/#f bool)
(pat:literal Base identifier ct-phase ct-phase) (pat:literal Base identifier ct-phase ct-phase)
(pat:datum Base datum) (pat:datum Base datum)
(pat:action Base ActionPattern SinglePattern) (pat:action Base ActionPattern SinglePattern)
@ -50,7 +50,7 @@ A ListPattern is a subtype of SinglePattern; one of
|# |#
(define-struct pat:any (attrs) #:prefab) (define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser argu nested-attrs commit?) #:prefab) (define-struct pat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab) (define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:action (attrs action inner) #:prefab) (define-struct pat:action (attrs action inner) #:prefab)
@ -93,7 +93,7 @@ action:and is desugared below in create-* procedures
#| #|
A HeadPattern is one of A HeadPattern is one of
(hpat:var Base id id Arguments (listof IAttr) bool) (hpat:var Base id id Arguments (listof IAttr) nat/#f bool)
(hpat:seq Base ListPattern) (hpat:seq Base ListPattern)
(hpat:action Base ActionPattern HeadPattern) (hpat:action Base ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern) (hpat:and Base HeadPattern SinglePattern)
@ -106,7 +106,7 @@ A HeadPattern is one of
(hpat:post Base HeadPattern) (hpat:post Base HeadPattern)
|# |#
(define-struct hpat:var (attrs name parser argu nested-attrs commit?) #:prefab) (define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit?) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:action (attrs action inner) #:prefab) (define-struct hpat:action (attrs action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab) (define-struct hpat:and (attrs head single) #:prefab)
@ -231,10 +231,10 @@ A SideClause is one of
(define (create-pat:any) (define (create-pat:any)
(make pat:any null)) (make pat:any null))
(define (create-pat:var name parser argu nested-attrs commit?) (define (create-pat:var name parser argu nested-attrs attr-count commit?)
(let ([attrs (let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser argu nested-attrs commit?))) (make pat:var attrs name parser argu nested-attrs attr-count commit?)))
(define (create-pat:reflect obj argu attr-decls name nested-attrs) (define (create-pat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs (let ([attrs
@ -328,10 +328,10 @@ A SideClause is one of
;; ---- ;; ----
(define (create-hpat:var name parser argu nested-attrs commit?) (define (create-hpat:var name parser argu nested-attrs attr-count commit?)
(let ([attrs (let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser argu nested-attrs commit?))) (make hpat:var attrs name parser argu nested-attrs attr-count commit?)))
(define (create-hpat:reflect obj argu attr-decls name nested-attrs) (define (create-hpat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs (let ([attrs

13
collects/syntax/parse/private/rep.rkt
View File

@ -600,9 +600,10 @@ A syntax class is integrable if
(define prefix (name->prefix #'name ".")) (define prefix (name->prefix #'name "."))
(define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id)) (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id))
(for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))]) (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))])
(let ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]) (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)])
(list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt)) (list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt))
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs #f) (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f)
(eh-alternative-repc alt)) (eh-alternative-repc alt))
(replace-eh-alternative-attrs (replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))] alt (iattrs->sattrs iattrs))))))]
@ -692,7 +693,7 @@ A syntax class is integrable if
(let-values ([(name sc) (split-id/get-stxclass id decls)]) (let-values ([(name sc) (split-id/get-stxclass id decls)])
(if sc (if sc
(parse-pat:var* id allow-head? name sc no-arguments) (parse-pat:var* id allow-head? name sc no-arguments)
(create-pat:var name #f no-arguments null #t)))])) (create-pat:var name #f no-arguments null #f #t)))]))
(define (parse-pat:var stx decls allow-head?) (define (parse-pat:var stx decls allow-head?)
(define name0 (define name0
@ -737,7 +738,7 @@ A syntax class is integrable if
(arguments-kws argu))]) (arguments-kws argu))])
(parse-pat:var* stx allow-head? name0 sc argu pfx))] (parse-pat:var* stx allow-head? name0 sc argu pfx))]
[else ;; Just proper name [else ;; Just proper name
(create-pat:var name0 #f (arguments null null null) null #t)])) (create-pat:var name0 #f (arguments null null null) null #f #t)]))
(define (parse-pat:var* stx allow-head? name sc argu [pfx "."]) (define (parse-pat:var* stx allow-head? name sc argu [pfx "."])
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc)) (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
@ -763,7 +764,7 @@ A syntax class is integrable if
(define (parse-pat:id/s name parser argu attrs commit? [pfx "."]) (define (parse-pat:id/s name parser argu attrs commit? [pfx "."])
(define prefix (name->prefix name pfx)) (define prefix (name->prefix name pfx))
(define bind (name->bind name)) (define bind (name->bind name))
(create-pat:var bind parser argu (id-pattern-attrs attrs prefix) commit?)) (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?))
(define (parse-pat:id/s/integrate name integrate argu) (define (parse-pat:id/s/integrate name integrate argu)
(define bind (name->bind name)) (define bind (name->bind name))
@ -774,7 +775,7 @@ A syntax class is integrable if
(define (parse-pat:id/h name parser argu attrs commit? [pfx "."]) (define (parse-pat:id/h name parser argu attrs commit? [pfx "."])
(define prefix (name->prefix name pfx)) (define prefix (name->prefix name pfx))
(define bind (name->bind name)) (define bind (name->bind name))
(create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) commit?)) (create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit?))
(define (name->prefix id pfx) (define (name->prefix id pfx)
(cond [(wildcard? id) #f] (cond [(wildcard? id) #f]

34
collects/syntax/parse/private/runtime.rkt
View File

@ -26,8 +26,9 @@
stx-list-drop/cx stx-list-drop/cx
let-attributes let-attributes
attribute let-attributes*
let/unpack let/unpack
attribute
attribute-binding attribute-binding
check-list^depth) check-list^depth)
@ -164,6 +165,26 @@
() ()
. body))))])) . body))))]))
;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
;; Special case: empty attrs need not match number of value exprs.
(define-syntax let-attributes*
(syntax-rules ()
[(la* (() _) . body)
(let () . body)]
[(la* ((a ...) (val ...)) . body)
(let-attributes ([a val] ...) . body)]))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
(define-syntax (attribute stx) (define-syntax (attribute stx)
(parameterize ((current-syntax-context stx)) (parameterize ((current-syntax-context stx))
(syntax-case stx () (syntax-case stx ()
@ -180,17 +201,6 @@
'disappeared-use 'disappeared-use
#'name))))]))) #'name))))])))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
;; (attribute-binding id) ;; (attribute-binding id)
;; mostly for debugging/testing ;; mostly for debugging/testing
(define-syntax (attribute-binding stx) (define-syntax (attribute-binding stx)