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

stxclass: removed basic syntax classes

Browse Source 
svn: r14090
This commit is contained in:
Ryan Culpepper 2009-03-13 20:58:40 +00:00
parent 6ee7b0379c
commit 0458416ec3
6 changed files with 70 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/stxclass/main.ss
View File

@ -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
...*

62
collects/stxclass/private/codegen.ss
View File

@ -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 : <ParseConfig> 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 : <ParseConfig> 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))

46
collects/stxclass/private/rep-data.ss
View File

@ -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 <RHSBase> (listof RHS))
;; (make-rhs:basic <RHSBase> 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 <Pattern> identifier SC/#f (listof stx))
;; (make-pat:datum <Pattern> datum)
@ -59,7 +86,7 @@
;; (make-pat:and <Pattern> string/#f (listof Pattern))
;; (make-pat:compound <Pattern> Kind (listof Pattern))
;; when <Pattern> = 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)

38
collects/stxclass/private/rep.ss
View File

@ -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)

2
collects/stxclass/private/runtime.ss
View File

@ -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 ...*)

36
collects/stxclass/private/sc.ss
View File

@ -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)