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)]
[#s(pat:any _attrs)
#'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)])
k)]
[#s(pat:var _attrs name parser argu (nested-a ...) commit?)
(with-syntax ([(name-attr ...)
[#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit?)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t) (datum->syntax cx x cx)])
#'())])
(if (not (syntax-e #'commit?))
;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result)
(lambda (fh cp av ...)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
#'(let ([result
(with ([fail-handler (lambda (fs) (cons 'fail fs))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result) (cons 'ok result))
argu)))])
(case (car result)
((fail) (fail (cdr result)))
((ok)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) (cdr result))
k)))))))]
#'(let-values ([(fs av ...)
(with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp av ...) (values #f av ...))
argu)))])
(if fs
(fail fs)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
k))))))]
[#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(if (identifier? #'name)
@ -496,8 +496,9 @@ Conventions:
[#s(hpat:describe _ description transparent? pattern)
#`(let ([es (cons (cons (expect:thing description transparent?) x) es)])
(parse:H x cx rest-x rest-cx rest-pr pattern pr es k))]
[#s(hpat:var _attrs name parser argu (nested-a ...) commit?)
(with-syntax ([(name-attr ...)
[#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit?)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
#'([#s(attr name 0 #t)
(stx-list-take x (ps-difference pr rest-pr))])
@ -505,34 +506,27 @@ Conventions:
(if (not (syntax-e #'commit?))
;; The normal protocol
#`(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/unpack ((nested-a ...) result)
(let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]
[cut-prompt cp])
k))))
argu)
;; The commit protocol
;; (Avoids putting k in procedure)
#'(let ([result
(with ([fail-handler (lambda (fs) (cons 'fail fs))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda result (cons 'ok result))
argu)))])
(case (car result)
((fail) (fail (cdr result)))
((ok)
(let ([_fh (car result)]
[_cp (cadr result)]
[result (cddr result)])
(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)))))))))]
#'(let-values ([(fs rest-x rest-cx rest-pr av ...)
(with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr av ...)
(values #f rest-x rest-cx rest-pr av ...))
argu)))])
(if fs
(fail fs)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
k))))))]
[#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...))
(with-syntax ([(name-attr ...)
(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
(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:datum Base datum)
(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: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:datum (attrs datum) #: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
(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:action Base ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern)
@ -106,7 +106,7 @@ A HeadPattern is one of
(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:action (attrs action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
@ -231,10 +231,10 @@ A SideClause is one of
(define (create-pat:any)
(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
(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)
(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
(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)
(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 eh-alt-set (get-eh-alternative-set #'eh-alt-set-id))
(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))
(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))
(replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))]
@ -692,7 +693,7 @@ A syntax class is integrable if
(let-values ([(name sc) (split-id/get-stxclass id decls)])
(if sc
(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 name0
@ -737,7 +738,7 @@ A syntax class is integrable if
(arguments-kws argu))])
(parse-pat:var* stx allow-head? name0 sc argu pfx))]
[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 "."])
(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 prefix (name->prefix name pfx))
(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 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 prefix (name->prefix name pfx))
(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)
(cond [(wildcard? id) #f]

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

@ -26,8 +26,9 @@
stx-list-drop/cx
let-attributes
attribute
let-attributes*
let/unpack
attribute
attribute-binding
check-list^depth)
@ -164,6 +165,26 @@
()
. 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)
(parameterize ((current-syntax-context stx))
(syntax-case stx ()
@ -180,17 +201,6 @@
'disappeared-use
#'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)
;; mostly for debugging/testing
(define-syntax (attribute-binding stx)