From be3ca941bb4a3cdbf6b62cb8d2454a06e3f48aca Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 31 Aug 2010 18:36:32 -0600 Subject: [PATCH] eliminated some uses of rest-args and list unpacking --- collects/syntax/parse/private/parse.rkt | 74 +++++++++---------- .../syntax/parse/private/rep-patterns.rkt | 16 ++-- collects/syntax/parse/private/rep.rkt | 13 ++-- collects/syntax/parse/private/runtime.rkt | 34 ++++++--- 4 files changed, 71 insertions(+), 66 deletions(-) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 5aaf8ac498..71640afb08 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -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) diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt index 4f39ab9289..0089d61998 100644 --- a/collects/syntax/parse/private/rep-patterns.rkt +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -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 diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index e529bd29d4..cb8c96c616 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -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] diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index c9db713ff5..536dc01893 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -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)