From e0928844156b715ee438830149928c53795f39e4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 3 Feb 2009 01:03:08 +0000 Subject: [PATCH] stxclass: added more contracts svn: r13371 --- collects/stxclass/private/codegen.ss | 93 ++++++++++++++------------- collects/stxclass/private/rep-data.ss | 20 +++++- collects/stxclass/private/rep.ss | 14 ++-- 3 files changed, 75 insertions(+), 52 deletions(-) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 4181e78d0a..8eb5f858a6 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -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. diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index e4b7825f16..eb4a7af172 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -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))])) - - diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 466bd97747..6821bc4608 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -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])