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

stxclass: consolidated runtime modules into runtime.ss

Browse Source 
svn: r13470
This commit is contained in:
Ryan Culpepper 2009-02-06 20:55:37 +00:00
parent 4f952a65d2
commit 6a41a09fb6
7 changed files with 123 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/stxclass/private/codegen-data.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/match (require scheme/match
(for-template scheme/base "kws.ss")) (for-template scheme/base "runtime.ss"))
(provide (all-defined-out)) (provide (all-defined-out))
;; A PK is (make-pk (listof Pattern) stx) ;; A PK is (make-pk (listof Pattern) stx)

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

@ -2,8 +2,7 @@
(require (for-template scheme/base (require (for-template scheme/base
syntax/stx syntax/stx
scheme/stxparam scheme/stxparam
"kws.ss" "runtime.ss")
"messages.ss")
scheme/match scheme/match
scheme/contract scheme/contract
scheme/private/sc scheme/private/sc

100
collects/stxclass/private/kws.ss
View File

@ -1,100 +0,0 @@
#lang scheme/base
(require scheme/stxparam
(for-syntax scheme/base))
(provide pattern
...*
with-enclosing-fail
enclosing-fail
ok?
(struct-out failed)
current-expression
current-macro-name)
;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
;; A SCDirective is one of
;; #:description String
;; #:transparent
;; A SyntaxClassRHS is
;; (pattern Pattern PatternDirective ...)
;; A Pattern is one of
;; name:syntaxclass
;; (Pattern . Pattern)
;; (Pattern ... . Pattern)
;; (((Pattern*) HeadDirective* *) ...* . Pattern)
;; datum, including ()
;; A PatternDirective is one of
;; #:declare name SyntaxClassName
;; #:declare name (SyntaxClassName expr ...)
;; #:rename internal-id external-id
;; #:with pattern expr
;; #:with clauses are let*-scoped
;; #:when expr
;; A HeadDirective is one of
;; #:min nat/#f
;; #:max nat/#f
;; #:opt
;; #:mand
;; -- For optional heads only:
;; #:occurs id
;; 'id' is bound to #t is the pattern occurs, #f otherwise
;; #:default form
;; Preceding head must have a single pvar
;; If the head is not present, the pvar is bound to 'form' instead
(define-syntax-rule (define-keyword name)
(define-syntax name
(lambda (stx)
(raise-syntax-error #f "keyword used out of context" stx))))
(define-keyword pattern)
(define-keyword basic-syntax-class)
(define-keyword ...*)
(define-keyword ...**)
(define-syntax-parameter enclosing-fail
(lambda (stx)
(raise-syntax-error #f
"used out of context: not parsing pattern"
stx)))
(define-syntax-parameter pattern-source
(lambda (stx)
(raise-syntax-error #f "used out of context: not in syntax-class parser" stx)))
(define current-expression (make-parameter #f))
(define (current-macro-name)
(let ([expr (current-expression)])
(and expr
(syntax-case expr (set!)
[(set! kw . _)
#'kw]
[(kw . _)
(identifier? #'kw)
#'kw]
[kw
(identifier? #'kw)
#'kw]
[_ #f]))))
;; A PatternParseResult is one of
;; - (listof value)
;; - (make-failed stx expectation/c frontier/#f)
(define (ok? x) (or (pair? x) (null? x)))
(define-struct failed (stx expectation frontier)
#:transparent)
(define-syntax-rule (with-enclosing-fail failvar expr)
(syntax-parameterize ((enclosing-fail
(make-rename-transformer (quote-syntax failvar))))
expr))

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

@ -1,10 +1,6 @@
#lang scheme/base #lang scheme/base
(require (for-template "kws.ss") (require scheme/contract
(for-template scheme/base)
scheme/contract
scheme/match scheme/match
syntax/boundmap
syntax/stx syntax/stx
"../util.ss") "../util.ss")
(provide (struct-out sc) (provide (struct-out sc)

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

@ -1,5 +1,5 @@
#lang scheme/base #lang scheme/base
(require (for-template "kws.ss") (require (for-template "runtime.ss")
(for-template scheme/base) (for-template scheme/base)
scheme/contract scheme/contract
scheme/match scheme/match

87
collects/stxclass/private/messages.ss → collects/stxclass/private/runtime.ss
View File

@ -1,21 +1,95 @@
#lang scheme/base #lang scheme/base
(require (for-syntax scheme/base syntax/stx "rep-data.ss") (require scheme/contract
scheme/contract scheme/match
scheme/match) scheme/stxparam
(provide (for-syntax expectation-of-stxclass (for-syntax scheme/base)
(for-syntax syntax/stx)
(for-syntax "rep-data.ss")
(for-syntax "../util/error.ss"))
(provide pattern
...*
with-enclosing-fail
enclosing-fail
ok?
(struct-out failed)
current-expression
current-macro-name
(for-syntax expectation-of-stxclass
expectation-of-constants expectation-of-constants
expectation-of/message) expectation-of/message)
try try
expectation/c expectation/c
expectation-of-null? expectation-of-null?
expectation->string) expectation->string)
(define-struct scdyn (name desc) ;; Keywords
(define-syntax-rule (define-keyword name)
(define-syntax name
(lambda (stx)
(raise-syntax-error #f "keyword used out of context" stx))))
(define-keyword pattern)
(define-keyword ...*)
(define-keyword ...**)
;; Parameters & Syntax Parameters
(define-syntax-parameter enclosing-fail
(lambda (stx)
(wrong-syntax stx "used out of context: not parsing pattern")))
(define-syntax-rule (with-enclosing-fail failvar expr)
(syntax-parameterize ((enclosing-fail
(make-rename-transformer (quote-syntax failvar))))
expr))
(define-syntax-parameter pattern-source
(lambda (stx)
(wrong-syntax stx "used out of context: not parsing pattern")))
(define current-expression (make-parameter #f))
(define (current-macro-name)
(let ([expr (current-expression)])
(and expr
(syntax-case expr (set!)
[(set! kw . _)
#'kw]
[(kw . _)
(identifier? #'kw)
#'kw]
[kw
(identifier? #'kw)
#'kw]
[_ #f]))))
;; Runtime: syntax-class parser results
;; A PatternParseResult is one of
;; - (listof value)
;; - (make-failed stx expectation/c frontier/#f)
(define (ok? x) (or (pair? x) (null? x)))
(define-struct failed (stx expectation frontier)
#:transparent) #:transparent)
;; Runtime: parsing failures/expectations
;; An Expectation is
;; (make-expc (listof scdyn) bool (listof atom) (listof id))
(define-struct expc (stxclasses pairs? data literals) (define-struct expc (stxclasses pairs? data literals)
#:transparent) #:transparent)
(define-struct scdyn (name desc)
#:transparent)
(define expectation/c (or/c expc?)) (define expectation/c (or/c expc?))
(define (make-stxclass-expc scdyn) (define (make-stxclass-expc scdyn)
@ -36,7 +110,8 @@
[(literal ...) literals] [(literal ...) literals]
[pairs? pairs?]) [pairs? pairs?])
(certify (certify
#'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...))))) #'(make-expc null 'pairs? (list 'datum ...)
(list (quote-syntax literal) ...)))))
(define (expectation-of/message msg) (define (expectation-of/message msg)
(with-syntax ([msg msg]) (with-syntax ([msg msg])

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

@ -9,8 +9,7 @@
"../util.ss") "../util.ss")
scheme/match scheme/match
syntax/stx syntax/stx
"kws.ss" "runtime.ss")
"messages.ss")
(provide define-syntax-class (provide define-syntax-class
define-basic-syntax-class define-basic-syntax-class
@ -33,6 +32,43 @@
current-expression current-expression
current-macro-name) current-macro-name)
;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
;; A SCDirective is one of
;; #:description String
;; #:transparent
;; A SyntaxClassRHS is
;; (pattern Pattern PatternDirective ...)
;; A Pattern is one of
;; name:syntaxclass
;; (Pattern . Pattern)
;; (Pattern ... . Pattern)
;; (((Pattern*) HeadDirective* *) ...* . Pattern)
;; datum, including ()
;; A PatternDirective is one of
;; #:declare name SyntaxClassName
;; #:declare name (SyntaxClassName expr ...)
;; #:rename internal-id external-id
;; #:with pattern expr
;; #:with clauses are let*-scoped
;; #:when expr
;; A HeadDirective is one of
;; #:min nat/#f
;; #:max nat/#f
;; #:opt
;; #:mand
;; -- For optional heads only:
;; #:occurs id
;; 'id' is bound to #t is the pattern occurs, #f otherwise
;; #:default form
;; Preceding head must have a single pvar
;; If the head is not present, the pvar is bound to 'form' instead
(define-syntax (define-syntax-class stx) (define-syntax (define-syntax-class stx)
(syntax-case stx () (syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss) [(define-syntax-class (name arg ...) . rhss)