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

stxclass: added more contracts

Browse Source 
svn: r13371
This commit is contained in:
Ryan Culpepper 2009-02-03 01:03:08 +00:00
parent ebd77ba75b
commit e092884415
3 changed files with 75 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -36,13 +36,44 @@
[(rhs:basic? rhs)
(rhs:basic-parser rhs)]))
;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce)
(with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fce)])
#`(let ([failcontext fc-expr])
#;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
(k x p 'reason failcontext))))
;; parse:clauses : stx identifier identifier -> stx
(define (parse:clauses stx var failid)
(define clauses-kw-table
(list (list '#:literals check-literals-list)))
(define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table))
(define literals
(cond [(assq '#:literals chunks) => caddr]
[else null]))
(define (clause->pk clause)
(syntax-case clause ()
[(p . rest)
(let-values ([(rest decls _ sides)
(parse-pattern-directives #'rest
#:sc? #f
#:literals literals)])
(syntax-case rest ()
[(b)
(let* ([pattern (parse-pattern #'p decls 0)])
(make-pk (list pattern)
(expr:convert-sides sides
(pattern-attrs pattern)
var
(lambda (iattrs)
(wrap-pattern-body/attrs iattrs
0
#'b)))))]
[_
(wrong-syntax clause "expected single body expression")]))]))
(unless (stx-list? clauses-stx)
(wrong-syntax clauses-stx "expected sequence of clauses"))
(let ([pks (map clause->pk (stx->list clauses-stx))])
(if (pair? pks)
(parse:pks (list var)
(list (empty-frontier var))
pks
failid)
(fail failid var #:fce (empty-frontier var)))))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
(define (rhs->pks rhs relsattrs main-var)
@ -65,7 +96,7 @@
remap
main-var)))))]))
;; expr:convert-sides : (listof SideClause) (listof IAttr) id stx -> stx
(define (expr:convert-sides sides iattrs main-var k)
(match sides
['() (k iattrs)]
@ -107,44 +138,16 @@
(wrong-syntax id "expected identifier")))
(syntax->list stx))
;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce)
(with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fce)])
#`(let ([failcontext fc-expr])
#;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
(k x p 'reason failcontext))))
;; parse:clauses : stx identifier identifier -> stx
(define (parse:clauses stx var failid)
(define clauses-kw-table
(list (list '#:literals check-literals-list)))
(define-values (chunks clauses-stx) (chunk-kw-seq/no-dups stx clauses-kw-table))
(define literals
(cond [(assq '#:literals chunks) => caddr]
[else null]))
(define (clause->pk clause)
(syntax-case clause ()
[(p . rest)
(let-values ([(rest decls _ sides)
(parse-pattern-directives #'rest
#:sc? #f
#:literals literals)])
(syntax-case rest ()
[(b)
(let* ([pattern (parse-pattern #'p decls 0)])
(make-pk (list pattern)
(expr:convert-sides sides
(pattern-attrs pattern)
var
(lambda (iattrs)
(wrap-pattern-body/attrs iattrs
0
#'b)))))]
[_
(wrong-syntax clause "expected single body expression")]))]))
(unless (stx-list? clauses-stx)
(wrong-syntax clauses-stx "expected sequence of clauses"))
(let ([pks (map clause->pk (stx->list clauses-stx))])
(if (pair? pks)
(parse:pks (list var)
(list (empty-frontier var))
pks
failid)
(fail failid var #:fce (empty-frontier var)))))
;; Parsing
;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx
;; Each PK has a list of |vars| patterns.

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

@ -100,7 +100,25 @@
(define (sattr? a)
(and (attr? a) (symbol? (attr-name a))))
;; Contracts
;; DeclEnv = [id -> (list* id id (listof stx)) or #t or #f
;; #t means literal, #f means undeclared, list means stxclass (w/ args)
(define DeclEnv/c
(-> identifier?
(or/c boolean? (cons/c identifier? (cons/c identifier? (listof syntax?))))))
(define RemapEnv/c
(-> identifier? symbol?))
(define SideClause/c (or/c clause:with? clause:when?))
(provide/contract
[DeclEnv/c contract?]
[RemapEnv/c contract?]
[SideClause/c contract?]
[make-empty-sc (-> identifier? sc?)]
[allow-unbound-stxclasses (parameter/c boolean?)]
[iattr? (any/c . -> . boolean?)]
@ -324,5 +342,3 @@
(cond [(null? iattrs) #f]
[(bound-identifier=? name (attr-name (car iattrs))) (car iattrs)]
[else (lookup-iattr name (cdr iattrs))]))

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

@ -1,4 +1,3 @@
#lang scheme
(require (for-template "kws.ss")
(for-template scheme/base)
@ -7,9 +6,15 @@
syntax/stx
"../util.ss"
"rep-data.ss")
(provide parse-pattern
parse-pattern-directives)
(provide/contract
[parse-pattern
(->* [any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?]
[boolean?]
pattern?)]
[parse-pattern-directives
(->* [stx-list?]
[#:sc? boolean? #:literals (listof identifier?)]
(values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))]
[parse-rhs (syntax? boolean? syntax? . -> . rhs?)]
[parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)])
@ -282,8 +287,7 @@
;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id)
;; -> stx DeclEnv env (listof SideClause)
;; DeclEnv = bound-id-mapping[id => (list* id id (listof stx)) or #t]
;; if decls maps a name to #f, it indicates literal
;; if decls maps a name to #t, it indicates literal
(define (parse-pattern-directives stx
#:sc? [sc? #f]
#:literals [literals null])