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

95
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,39 +77,38 @@
;(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 (for/list ([n (in-syntax all-fields)]
(for/list ([n (in-syntax all-fields)] [i (in-naturals)])
[i (in-naturals)]) (cons n (+ i offset)))))
(cons n (+ i offset))))) (define fields+indices
(define fields+indices (sort (stx-map #λ(cons % (free-id-table-ref lookup %))
(sort (stx-map #λ(cons % (free-id-table-ref lookup %)) #'(fl …))
#'(fl …)) <
< #:key cdr))
#:key cdr))
(define up (* offset 2)) (define up (* offset 2))
;; Like in convert-fields, but with Pairof ;; Like in convert-fields, but with Pairof
(define (f i) (define (f i)
;(displayln (list i '/ up (syntax->datum #`#,fields+indices))) ;(displayln (list i '/ up (syntax->datum #`#,fields+indices)))
(if (and (pair? fields+indices) (= i (cdar fields+indices))) (if (and (pair? fields+indices) (= i (cdar fields+indices)))
(begin0 (begin0
(caar fields+indices) (caar fields+indices)
(set! fields+indices (cdr fields+indices))) (set! fields+indices (cdr fields+indices)))
(if (>= (* i 2) up) ;; DEPTH (if (>= (* i 2) up) ;; DEPTH
''MISSING ''MISSING
(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)] (append (map (λ (i) (format-id #'here "-with-~a" i))
[i*-above (range 1 (expt 2 depth-above))] i*-above)
[names (list->vector (stx-map (λ (f) (format-id f "with-~a" f))
(append (map (λ (i) (format-id #'here "-with-~a" i)) #'(field …)))))
i*-above) (define τ* (map #λ(format-id #'here "τ~a" %) (range (add1 depth-above))))]
(stx-map (λ (f) (format-id f "with-~a" f))
#'(field …))))]
[τ* (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 ()