From 0458416ec308d4667cac9b9d335cfae3828bc1c5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Mar 2009 20:58:40 +0000 Subject: [PATCH] stxclass: removed basic syntax classes svn: r14090 --- collects/stxclass/main.ss | 4 +- collects/stxclass/private/codegen.ss | 62 +++++++++++++-------------- collects/stxclass/private/rep-data.ss | 46 ++++++++++++++++---- collects/stxclass/private/rep.ss | 38 ++-------------- collects/stxclass/private/runtime.ss | 2 - collects/stxclass/private/sc.ss | 36 ---------------- 6 files changed, 70 insertions(+), 118 deletions(-) diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index f55c6ba21a..ba5bbc094c 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -4,10 +4,8 @@ "private/lib.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* pattern - basic-syntax-class + ~and ~or ...* diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 81727b614f..0798fafc58 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -23,25 +23,22 @@ ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define (parse:rhs rhs relsattrs args) - (cond [(rhs:union? rhs) - (with-syntax ([(arg ...) args]) - #`(lambda (x arg ...) - (define (fail-rhs x expected frontier frontier-stx) - #,(if (rhs-transparent? rhs) - #`(make-failed x expected frontier frontier-stx) - #'#f)) - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (unless (pair? pks) - (wrong-syntax (rhs-orig-stx rhs) - "syntax class has no variants")) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - #'fail-rhs - (list #f) - pks)))))] - [(rhs:basic? rhs) - (rhs:basic-parser rhs)])) + (with-syntax ([(arg ...) args]) + #`(lambda (x arg ...) + (define (fail-rhs x expected frontier frontier-stx) + #,(if (rhs-transparent? rhs) + #`(make-failed x expected frontier frontier-stx) + #'#f)) + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + #,(let ([pks (rhs->pks rhs relsattrs #'x)]) + (unless (pair? pks) + (wrong-syntax (rhs-ostx rhs) + "syntax class has no variants")) + (parse:pks (list #'x) + (list (empty-frontier #'x)) + #'fail-rhs + (list #f) + pks)))))) ;; parse:clauses : stx identifier identifier -> stx (define (parse:clauses stx var phi) @@ -82,15 +79,15 @@ ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) (match rhs - [(struct rhs:union (orig-stx attrs transparent? description patterns)) + [(struct rhs:union (_ attrs transparent? description patterns)) (for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)]) pk)])) ;; rhs-pattern->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs-pattern->pks rhs relsattrs main-var) (match rhs - [(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) - (parameterize ((current-syntax-context orig-stx)) + [(struct rhs:pattern (ostx attrs pattern decls remap sides)) + (parameterize ((current-syntax-context ostx)) (define iattrs (append-attrs (cons (pattern-attrs pattern) @@ -311,7 +308,7 @@ Conventions: ;; parse:gseq:and : pat:and (listof Pattern) stx ;; -> stx (define (parse:group:and vars fcs phi ds and-pattern rest-patterns k) - (match-define (struct pat:and (orig-stx attrs depth description patterns)) + (match-define (struct pat:and (_ _ _ description patterns)) and-pattern) ;; FIXME: handle description (let ([var0-copies (for/list ([p patterns]) (car vars))] @@ -326,7 +323,7 @@ Conventions: ;; parse:compound:gseq : pat:gseq (listof Pattern) stx ;; -> stx (define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k) - (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern) + (match-define (struct pat:gseq (ostx attrs depth heads tail)) gseq-pattern) (define xvar (generate-temporary 'x)) (define head-lengths (for/list ([head heads]) (length (head-ps head)))) (define head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head)))) @@ -348,7 +345,7 @@ Conventions: (map attr-name head-attrs))) (define completed-heads (for/list ([head heads]) - (complete-heads-pattern head xvar (add1 depth) orig-stx))) + (complete-heads-pattern head xvar (add1 depth) ostx))) (define hid-argss (map generate-temporaries head-idss)) (define hid-args (apply append hid-argss)) (define mins (map head-min heads)) @@ -436,12 +433,12 @@ Conventions: [rep 0] ...) (parse-loop var0 hid ... ... rep ... #,phi)))))) -;; complete-heads-patterns : Head identifier number stx -> Pattern -(define (complete-heads-pattern head rest-var depth seq-orig-stx) +;; complete-heads-patterns : Head identifier number -> Pattern +(define (complete-heads-pattern head rest-var depth seq-ostx) (define (loop ps pat) (if (pair? ps) (make pat:compound - (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) + (cons (pattern-ostx (car ps)) (pattern-ostx pat)) (append (pattern-attrs (car ps)) (pattern-attrs pat)) depth pairK @@ -449,7 +446,7 @@ Conventions: pat)) (define base (make pat:id - seq-orig-stx + seq-ostx (list (make-attr rest-var depth null)) depth rest-var #f null)) (loop (head-ps head) base)) @@ -493,8 +490,8 @@ Conventions: (let ([result (not (pattern-intersects? p1 p2))]) (when #f ;; result (printf "commutes!\n ~s\n & ~s\n" - (syntax->datum (pattern-orig-stx p1)) - (syntax->datum (pattern-orig-stx p2)))) + (syntax->datum (pattern-ostx p1)) + (syntax->datum (pattern-ostx p2)))) result)) (define (pattern-intersects? p1 p2) @@ -636,8 +633,7 @@ Conventions: (define (shift-pks:compound pks) (define (shift-pk pk0) (match pk0 - [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns)) - rest-ps) + [(struct pk ((cons (struct pat:compound (_ _ _ _ patterns)) rest-ps) k)) (make-pk (append patterns rest-ps) k)])) (map shift-pk pks)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 6de85b445f..7e06a6e34a 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -8,7 +8,6 @@ (struct-out attr) (struct-out rhs) (struct-out rhs:union) - (struct-out rhs:basic) (struct-out rhs:pattern) (struct-out pattern) (struct-out pat:id) @@ -34,22 +33,50 @@ #:transparent) ;; RHSBase is stx (listof SAttr) boolean stx/#f -(define-struct rhs (orig-stx attrs transparent? description) +(define-struct rhs (ostx attrs transparent? description) #:transparent) ;; A RHS is one of ;; (make-rhs:union (listof RHS)) -;; (make-rhs:basic stx) (define-struct (rhs:union rhs) (patterns) #:transparent) -(define-struct (rhs:basic rhs) (parser) - #:transparent) ;; An RHSPattern is ;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause)) -(define-struct rhs:pattern (stx attrs pattern decls remap whens) +(define-struct rhs:pattern (stx attrs pattern decls remap sides) #:transparent) +#| + +NOT YET ... + +;; A Pattern is +;; (make-pattern (listof IAttr) PCtx (listof id) string/#f Descriminator) +(define-struct pattern (attrs ctx names description descrim) #:transparent) + +;; A PatternContext (PCtx) is +;; (make-pctx stx nat (listof IAttr) (listof IAttr)) +(define-struct pctx (ostx depth env outer-env) #:transparent) + +;; A Descriminator is one of +;; (make-d:any) +;; (make-d:stxclass SC (listof stx)) +;; (make-d:datum datum) +;; (make-d:literal id) +;; (make-d:gseq (listof Head) Pattern) +;; (make-d:and (listof Pattern)) +;; (make-d:orseq (listof Head)) +;; (make-d:compound Kind (listof Pattern)) +(define-struct d:any () #:transparent) +(define-struct d:stxclass (stxclass args) #:transparent) +(define-struct d:datum (datum) #:transparent) +(define-struct d:literal (literal) #:transparent) +(define-struct d:gseq (heads tail) #:transparent) +(define-struct d:and (subpatterns) #:transparent) +(define-struct d:orseq (heads) #:transparent) +(define-struct d:compound (kind patterns) #:transparent) +|# + ;; A Pattern is one of ;; (make-pat:id identifier SC/#f (listof stx)) ;; (make-pat:datum datum) @@ -59,7 +86,7 @@ ;; (make-pat:and string/#f (listof Pattern)) ;; (make-pat:compound Kind (listof Pattern)) ;; when = stx (listof IAttr) number -(define-struct pattern (orig-stx attrs depth) #:transparent) +(define-struct pattern (ostx attrs depth) #:transparent) (define-struct (pat:id pattern) (name stxclass args) #:transparent) (define-struct (pat:datum pattern) (datum) #:transparent) (define-struct (pat:literal pattern) (literal) #:transparent) @@ -72,8 +99,9 @@ (define-struct kind (predicate selectors frontier-procs) #:transparent) ;; A Head is -;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f) -(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent) +;; (make-head stx (listof IAttr) nat (listof Pattern) +;; nat/f nat/f boolean id/#f stx/#f) +(define-struct head (ostx attrs depth ps min max as-list?) #:transparent) ;; A SideClause is one of ;; (make-clause:with pattern stx) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index dd96ade8d5..d604bae802 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -102,30 +102,6 @@ (define transparent? (and trans0 #t)) (define attributes (and attrs0 (caddr attrs0))) - (define (parse-rhs*-basic rhss) - (syntax-case rhss (basic-syntax-class) - [((basic-syntax-class . rest)) - (let-values ([(basic-chunks rest) - (chunk-kw-seq/no-dups #'rest basic-rhs-directive-table - #:context (stx-car rhss))]) - (syntax-case rest () - [(parser-expr) - (make rhs:basic ctx - (or attributes null) - transparent? - description - (if (assq '#:transforming basic-chunks) - #'parser-expr - #`(let ([parser parser-expr]) - (lambda (x . args) - (let ([result (apply parser x args)]) - (if (ok? result) - (cons x result) - result))))))] - [_ - (wrong-syntax (stx-car rhss) - "expected parser expression")]))])) - (define (parse-rhs*-patterns rest) (define (gather-patterns stx) (syntax-case stx (pattern) @@ -145,11 +121,7 @@ description patterns))) - (syntax-case rest (pattern basic-syntax-class) - [((basic-syntax-class . _)) - (parse-rhs*-basic rest)] - [_ - (parse-rhs*-patterns rest)])) + (parse-rhs*-patterns rest)) ;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS (define (parse-rhs-pattern stx allow-unbound? literals) @@ -278,8 +250,8 @@ (define (pattern->head p) (match p - [(struct pattern (orig-stx iattrs depth)) - (make head orig-stx iattrs depth (list p) #f #f #t)])) + [(struct pattern (ostx iattrs depth)) + (make head ostx iattrs depth (list p) #f #f #t)])) (define (parse-heads stx decls enclosing-depth) (syntax-case stx () @@ -468,10 +440,6 @@ (list '#:transparent) (list '#:attributes check-attr-arity-list))) -;; basic-rhs-directive-table -(define basic-rhs-directive-table - (list (list '#:transforming))) - ;; pattern-directive-table (define pattern-directive-table (list (list '#:declare check-id values) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index 22a3bdaaad..ba9ecebdee 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -8,7 +8,6 @@ (for-syntax "rep-data.ss") (for-syntax "../util/error.ss")) (provide pattern - basic-syntax-class ~and ~or ...* @@ -44,7 +43,6 @@ (raise-syntax-error #f "keyword used out of context" stx)))) (define-keyword pattern) -(define-keyword basic-syntax-class) (define-keyword ~and) (define-keyword ~or) (define-keyword ...*) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 1f9e10b039..453d8e63fb 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -12,8 +12,6 @@ "runtime.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* parse-sc attrs-of @@ -22,7 +20,6 @@ with-patterns pattern - basic-syntax-class ~and ~or ...* @@ -92,39 +89,6 @@ (syntax/loc stx (define-syntax-class (name) . rhss))])) -(define-syntax define-basic-syntax-class - (syntax-rules () - [(define-basic-syntax-class (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - (let ([name parser-expr]) - (let ([name - (lambda (x arg ...) - (let ([r (name x arg ...)]) - (if (ok? r) - (cons x r) - r)))]) - name)))] - [(define-basic-syntax-class name - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class (name) - ([attr-name attr-depth] ...) - parser-expr)])) - -(define-syntax define-basic-syntax-class* - (syntax-rules () - [(define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-syntax-class (name arg ...) - #:attributes ([attr-name attr-depth] ...) - (basic-syntax-class - #:transforming - (let ([name parser-expr]) name)))])) - (define-syntax (rhs->parser+description stx) (syntax-case stx () [(rhs->parser+description name rhss (arg ...) ctx)