suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source
This commit is contained in:
Georges Dupéron 2016-12-22 19:16:09 +01:00
parent cf790f6600
commit de81a122d3
1 changed files with 42 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
flexible-with.rkt
View File

@ -13,10 +13,9 @@
<→τ> <→τ>
<define-replace-in-tree> <define-replace-in-tree>
<convert-fields> <convert-fields>
<τ-with-fields> <τ-tree-with-fields>
<convert-from-struct> <convert-from-struct>
<mk> <mk>
<utils>
<example>] <example>]
@CHUNK[<→τ> @CHUNK[<→τ>
@ -78,12 +77,11 @@
;(displayln (syntax->datum #`#,(f 1))) ;(displayln (syntax->datum #`#,(f 1)))
(f 1))] (f 1))]
@CHUNK[<τ-with-fields> @CHUNK[<τ-tree-with-fields>
(define-for-syntax (τ-tree-with-fields fields all-fields) (define-for-syntax (τ-tree-with-fields fields all-fields2)
(define/with-syntax (fl …) fields) (define/with-syntax (fl …) fields)
(define/with-syntax (field …) all-fields) (define/with-syntax (field …) all-fields2)
(let-values ([(all-fields depth-above offset i*-above names τ*) <utils>
(utils #'(field …))])
;; Like in convert-from-struct ;; Like in convert-from-struct
(define lookup (define lookup
(make-free-id-table (make-free-id-table
@ -110,7 +108,7 @@
(begin (begin
`(Pairof ,(f (* i 2)) `(Pairof ,(f (* i 2))
,(f (add1 (* i 2)))))))) ,(f (add1 (* i 2))))))))
(f 1)))] (f 1))]
@CHUNK[<convert-from-struct> @CHUNK[<convert-from-struct>
(define-for-syntax (convert-from-struct (define-for-syntax (convert-from-struct
@ -141,8 +139,8 @@
(define-for-syntax (mk stx) (define-for-syntax (mk stx)
(syntax-case stx () (syntax-case stx ()
[(bt-fields-id (field …) [struct struct-field …] …) [(bt-fields-id (field …) [struct struct-field …] …)
(let-values ([(all-fields depth-above offset i*-above names τ*) (let ()
(utils #'(field …))]) <utils>
(define total-nb-functions (vector-length names)) (define total-nb-functions (vector-length names))
#`(begin #`(begin
(define-type-expander (bt-fields-id stx) (define-type-expander (bt-fields-id stx)
@ -158,25 +156,16 @@
(syntax->list #'([struct-field …] …)))))]))] (syntax->list #'([struct-field …] …)))))]))]
@CHUNK[<utils> @CHUNK[<utils>
(define-for-syntax (utils stx) (define all-fields #'(field …))
(syntax-case stx () (define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
[(field …) (define offset (expt 2 depth-above))
(let* ([all-fields #'(field …)] (define i*-above (range 1 (expt 2 depth-above)))
[depth-above (ceiling-log2 (length (syntax->list #'(field …))))] (define names (list->vector
[offset (expt 2 depth-above)]
[i*-above (range 1 (expt 2 depth-above))]
[names (list->vector
(append (map (λ (i) (format-id #'here "-with-~a" i)) (append (map (λ (i) (format-id #'here "-with-~a" i))
i*-above) i*-above)
(stx-map (λ (f) (format-id f "with-~a" f)) (stx-map (λ (f) (format-id f "with-~a" f))
#'(field …))))] #'(field …)))))
[τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above)))]) (define τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above))))]
(values all-fields
depth-above
offset
i*-above
names
τ*))]))]
@CHUNK[<example> @CHUNK[<example>
(define-syntax (gs stx) (define-syntax (gs stx)
(syntax-case stx () (syntax-case stx ()