1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
#lang racket/base
(require (for-syntax racket/base
syntax/parse
racket/lazy-require
"../private/kws.rkt")
syntax/parse/private/residual) ;; keep abs. path
(provide define-primitive-splicing-syntax-class)
(begin-for-syntax
(lazy-require
[syntax/parse/private/rep-attrs
(sort-sattrs)]))
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path (for-meta 2 '#%kernel))
(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs)
(define-syntax (define-primitive-splicing-syntax-class stx)
(define-syntax-class attr
#:commit
(pattern name:id
#:with depth #'0)
(pattern [name:id depth:nat]))
(syntax-parse stx
[(dssp (name:id param:id ...)
(~or (~once (~seq #:attributes (a:attr ...))
#:name "attributes declaration")
(~once (~seq #:description description)
#:name "description declaration")) ...
proc:expr)
#'(begin
(define (get-description param ...)
description)
(define parser
(let ([permute (mk-permute '(a.name ...))])
(lambda (x cx pr es undos fh _cp rl 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 undos fh)
(cdr result))))
((error)
(let ([es
(es-add-message (cadr result)
(es-add-thing pr (get-description param ...) #f rl es))])
(fh undos (failure pr es))))))))))
(define-syntax name
(stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
(quote-syntax parser)
#t
(scopts (length '(a.name ...)) #t #t #f)
#f)))]))
(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 undos fh)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
(let ([rlength (length result)])
(unless (= rlength (+ 1 attr-count))
(error name "parser returned list of wrong length; expected length ~s, got ~e"
(+ 1 attr-count)
result))
(let ([skip (car result)])
;; Compute rest-x & rest-cx from skip
(unless (exact-nonnegative-integer? skip)
(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 undos rest-x rest-cx (ps-add-cdr pr skip)
(permute (cdr result))))))))
|
