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

updated syntax/parse/exp./splicing, updated honu use

Browse Source 
fixed stress.rkt
This commit is contained in:
Ryan Culpepper 2010-08-31 14:14:04 -06:00
parent 675cdfda58
commit 712a8f60e9
5 changed files with 65 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/honu/private/parse.rkt
View File

@ -4,7 +4,7 @@
"util.ss"
(for-template "literals.ss")
syntax/parse
syntax/parse/experimental
syntax/parse/experimental/splicing
scheme/splicing
syntax/stx
(for-syntax "util.ss")
@ -34,7 +34,7 @@
[else (loop (stx-cdr start) (add1 count))]))))
(define-primitive-splicing-syntax-class (honu-expr context)
#:attrs (result)
#:attributes (result)
#:description "honu-expr"
(lambda (stx fail)
(cond
@ -42,11 +42,11 @@
[(get-transformer stx) => (lambda (transformer)
(let-values ([(used rest)
(transformer stx context)])
(list rest (syntax-object-position stx rest)
(list (syntax-object-position stx rest)
used)))]
[else (syntax-case stx ()
[(f . rest) (list #'rest 1 #'f)])])))
[(f . rest) (list 1 #'f)])])))
#;
(define-splicing-syntax-class expr

3
collects/syntax/parse/experimental.rkt
View File

@ -1,3 +0,0 @@
#lang racket/base
(require "experimental/splicing.rkt")
(provide (all-from-out "experimental/splicing.rkt"))

83
collects/syntax/parse/experimental/splicing.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base
"../../parse.ss"
"../private/rep-attrs.rkt"
"../private/rep-data.rkt"
"../private/kws.rkt")
"../private/runtime-progress.rkt"
@ -16,7 +17,7 @@
(syntax-parse stx
[(dssp (name:id param:id ...)
(~or (~once (~seq #:attrs (a:attr ...))
(~or (~once (~seq #:attributes (a:attr ...))
#:name "attributes declaration")
(~once (~seq #:description description)
#:name "description declaration")) ...
@ -25,47 +26,63 @@
(define (get-description param ...)
description)
(define parser
(lambda (x cx pr es fh cp success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
(cons 'ok
(proc stx
(lambda ([msg #f] [stx #f])
(escape (list 'error msg stx))))))])
(case (car result)
((ok)
(apply success
((mk-check-result pr 'name '(a.name ...) x cx fh cp) (cdr result))))
((error)
(let ([es
(list* (cons (expect:thing (get-description param ...) #f) stx)
(cons (expect:message (cadr result)) (caddr result))
es)])
(fh (failure pr es)))))))))
(let ([permute (mk-permute '(a.name ...))])
(lambda (x cx pr es fh cp success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
(cons 'ok
(proc stx
(lambda ([msg #f] [stx #f])
(escape (list 'error msg stx))))))])
(case (car result)
((ok)
(apply success
((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh cp)
(cdr result))))
((error)
(let ([es
(list* (cons (expect:thing (get-description param ...) #f) stx)
(cons (expect:message (cadr result)) (caddr result))
es)])
(fh (failure pr es))))))))))
(define-syntax name
(make-stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
'(#s(attr a.name a.depth #f) ...)
(quote-syntax parser)
#t
#s(options #t #t)
#f)))]))
(stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
(quote-syntax parser)
#t
#s(options #t #t)
#f)))]))
(define (mk-check-result pr name attr-names x cx fh cp)
(define (mk-permute unsorted-attrs)
(let ([sorted-attrs
(sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)])
(if (equal? unsorted-attrs sorted-attrs)
values
(let* ([pos-table
(for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)])
(values a i))]
[indexes
(for/vector ([a (in-list sorted-attrs)])
(hash-ref pos-table a))])
(lambda (result)
(for/list ([index (in-vector indexes)])
(list-ref result index)))))))
(define (mk-check-result pr name attr-count permute x cx fh cp)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
(let ([rlength (length result)])
(unless (= rlength (+ 2 (length attr-names)))
(unless (= rlength (+ 1 attr-count))
(error name "parser returned list of wrong length; expected length ~s, got ~e"
(+ 2 (length attr-names))
(+ 1 attr-count)
result))
;; Ignore (car result), supposed to be rest-x
;; Easier to recompute it and get rest-cx right, too.
(let ([skip (cadr result)])
(let ([skip (car result)])
;; Compute rest-x & rest-cx from skip
(unless (exact-nonnegative-integer? skip)
(error name "expected exact nonnegative integer for second element of result list, got ~e"
(error name "expected exact nonnegative integer for first element of result list, got ~e"
skip))
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
(list* fh cp rest-x rest-cx (ps-add-cdr pr skip)
(cddr result)))))))
(permute (cdr result))))))))

9
collects/syntax/scribblings/parse/experimental.scrbl
View File

@ -176,17 +176,16 @@ Like @scheme[~reflect] but for reified splicing syntax classes.
parser-expr)
#:contracts ([parser (-> syntax?
(->* () ((or/c string? #f) -> any))
(list syntax? exact-positive-integer? any/c ...))])]{
(cons/c exact-positive-integer? list?))])]{
Defines a splicing syntax via a procedural parser.
The parser procedure is given two arguments, the syntax to parse and a
failure procedure. To signal a successful parse, the parser procedure
returns a list of 2+@scheme[N] elements, where @scheme[N] is the
returns a list of @scheme[N]+1 elements, where @scheme[N] is the
number of attributes declared by the splicing syntax class. The first
two elements are the unconsumed part of the syntax and the size of the
prefix consumed. The rest of the list contains the values of the
attributes.
element is the size of the prefix consumed. The rest of the list
contains the values of the attributes.
To indicate failure, the parser calls the failure procedure with an
optional message argument.

8
collects/tests/stxparse/stress.rkt
View File

@ -1,3 +1,5 @@
#lang racket
(begin
(require syntax/parse)
(define (mkstx n) (datum->syntax #f (for/list ([i (in-range n)]) #'hello)))
@ -96,10 +98,11 @@ cpu time: 2908 real time: 2901 gc time: 12
|#
#|
given pattern (E ...) where E = A _ | A
the sequence (A A B A A B A A B ...)
causes each E to backtrack
|#
(begin
(define-syntax-class id/nat
@ -132,6 +135,8 @@ causes each E to backtrack
;; (solve 35 _) and (solve 36 _) seem manageable
#|
#| before markparams |#
> (time (parse/trip tripstx3 100))
@ -246,3 +251,4 @@ cpu time: 588 real time: 588 gc time: 76
cpu time: 580 real time: 584 gc time: 68
> (time (solve 36 20))
cpu time: 580 real time: 586 gc time: 56
|#