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

More cleanup

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-06 06:55:29 +01:00
parent 72261decc4
commit 9814513b47
5 changed files with 49 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
flexible-with-utils.hl.rkt
View File

@ -38,21 +38,20 @@
@defproc[(to-bits [n exact-nonnegative-integer?]) (listof boolean?)]{} @defproc[(to-bits [n exact-nonnegative-integer?]) (listof boolean?)]{}
@CHUNK[<to-bits> @CHUNK[<to-bits>
; 1 => 1 ;; 1 => 1
; 2 3 => 10 11 ;; 2 3 => 10 11
;4 5 6 7 => 100 101 110 111 ;; 4 5 6 7 => 100 101 110 111
;89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111 ;; 89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111
; 1 => "" ;; 1 => ε
; 2 3 => 0 1 ;; 2 3 => 0 1
;4 5 6 7 => 00 01 10 11 ;; 4 5 6 7 => 00 01 10 11
;89 ab cd ef => 000 001 010 011 100 101 110 111 ;; 89 ab cd ef => 000 001 010 011 100 101 110 111
; 0 => 0
; 1 2 => 1 10
;3 4 5 6 => 11 100 101 110
;78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110
;; 0 => 0
;; 1 2 => 1 10
;; 3 4 5 6 => 11 100 101 110
;; 78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110
(define-for-syntax (to-bits n) (define-for-syntax (to-bits n)
(reverse (reverse

3
flexible-with.hl.rkt
View File

@ -317,7 +317,8 @@ interesting subparts of the trees (those where there are fields).
#`(begin #`(begin
(define-type-expander bt-fields-id (define-type-expander bt-fields-id
(bt-fields-type #'#,(syntax-local-introduce #'(field …)))) (bt-fields-type #'#,(syntax-local-introduce #'(field …))))
#,@(map #λ(define-replace-in-tree low-names names rm-names ∀-types % (floor-log2 %)) #,@(map #λ(define-replace-in-tree low-names
names rm-names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions))) (range 1 (add1 total-nb-functions)))
#;#,@(map #λ(define-remove-in-tree rm-names ∀-types % (floor-log2 %)) #;#,@(map #λ(define-remove-in-tree rm-names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions))) (range 1 (add1 total-nb-functions)))

16
free-identifier-tree-equal.rkt
View File

@ -32,12 +32,13 @@
(vectorof isyntax #:immutable #t) (vectorof isyntax #:immutable #t)
(syntax/c isyntax) (syntax/c isyntax)
(and/c immutable-struct? (and/c immutable-struct?
prefab-struct-key
(λ (v) (λ (v)
(andmap isyntax/c (struct->list v))))))) (andmap isyntax/c (struct->list v)))))))
(define/contract (free-id-tree=? a b [r equal?]) (define/contract (free-id-tree=? a b [r equal?])
(-> isyntax/c isyntax/c boolean?) (->* {isyntax/c isyntax/c}
{(-> isyntax/c isyntax/c boolean?)}
boolean?)
(define (rec=? a b) (free-id-tree=? a b r)) (define (rec=? a b) (free-id-tree=? a b r))
(cond (cond
[(identifier? a) (and (identifier? b) [(identifier? a) (and (identifier? b)
@ -60,23 +61,28 @@
(and (equal? a-key b-key) (and (equal? a-key b-key)
(rec=? (struct->list a) (rec=? (struct->list a)
(struct->list b)))))] (struct->list b)))))]
[(struct? a)
(rec=? (vector->immutable-vector (struct->vector a)))]
[(null? a) (null? b)] [(null? a) (null? b)]
[else (equal? a b)])) [else (equal? a b)]))
(define/contract ((free-id-tree-hash hc) a) (define/contract ((free-id-tree-hash default-hc) a [hc default-hc])
(-> (-> any/c fixnum?) (-> isyntax/c fixnum?)) (-> (-> any/c fixnum?) (-> isyntax/c (-> isyntax/c fixnum?) fixnum?))
(define rec-hash (free-id-tree-hash hc)) (define rec-hash (free-id-tree-hash hc))
(cond (cond
[(identifier? a) (hc (syntax-e #'a))] [(identifier? a) (hc (syntax-e #'a))]
[(syntax? a) (rec-hash (syntax-e a))] [(syntax? a) (rec-hash (syntax-e a))]
[(pair? a) (hc (cons (rec-hash (car a)) [(pair? a) (hc (cons (rec-hash (car a))
(rec-hash (cdr a))))] (rec-hash (cdr a))))]
[(vector? a) (hc (list->vector (map rec-hash (vector->list a))))] [(vector? a) (hc (vector->immutable-vector
(list->vector (map rec-hash (vector->list a)))))]
[(box? a) (hc (box (rec-hash (unbox a))))] [(box? a) (hc (box (rec-hash (unbox a))))]
[(prefab-struct-key a) [(prefab-struct-key a)
=> (λ (a-key) => (λ (a-key)
(hc (apply make-prefab-struct a-key (hc (apply make-prefab-struct a-key
(rec-hash (struct->list a)))))] (rec-hash (struct->list a)))))]
[(struct? a)
(rec-hash (vector->immutable-vector (struct->vector a)))]
[else (hc a)])) [else (hc a)]))
(define free-id-tree-hash-code (define free-id-tree-hash-code

34
graph-info.hl.rkt
View File

@ -178,15 +178,15 @@ A field has a type.
[(define write-proc (struct-printer 'invariant-info))] [(define write-proc (struct-printer 'invariant-info))]
#:property prop:custom-print-quotable 'never #:property prop:custom-print-quotable 'never
#:methods gen:equal+hash #:methods gen:equal+hash
[(define (equal-proc a b r) |<gen:equal+hash free-id-tree=?>|)]
(free-id-tree=? (vector->immutable-vector (struct->vector a))
(vector->immutable-vector (struct->vector b)))) Instances of @racket[invariant-info] are compared pointwise with
(define (hash-proc a r) @racket[free-id-tree=?]:
(free-id-tree-hash-code
(vector->immutable-vector (struct->vector a)))) @chunk[|<gen:equal+hash free-id-tree=?>|
(define (hash2-proc a r) [(define equal-proc free-id-tree=?)
(free-id-tree-secondary-hash-code (define hash-proc free-id-tree-hash-code)
(vector->immutable-vector (struct->vector a))))])] (define hash2-proc free-id-tree-secondary-hash-code)]]
@section{Dependent invariant information} @section{Dependent invariant information}
@ -203,15 +203,10 @@ which relate the old and the new graph in a graph transformation.
[(define write-proc (struct-printer 'dependent-invariant-info))] [(define write-proc (struct-printer 'dependent-invariant-info))]
#:property prop:custom-print-quotable 'never #:property prop:custom-print-quotable 'never
#:methods gen:equal+hash #:methods gen:equal+hash
[(define (equal-proc a b r) |<gen:equal+hash free-id-tree=?>|)]
(free-id-tree=? (vector->immutable-vector (struct->vector a))
(vector->immutable-vector (struct->vector b)))) Instances of @racket[dependent-invariant-info] are compared pointwise with
(define (hash-proc a r) @racket[free-id-tree=?], like @racket[invariant-info].
(free-id-tree-hash-code
(vector->immutable-vector (struct->vector a))))
(define (hash2-proc a r)
(free-id-tree-secondary-hash-code
(vector->immutable-vector (struct->vector a))))])]
@section{Mapping information} @section{Mapping information}
@ -314,8 +309,6 @@ data.
{~seq #:property _ _}) {~seq #:property _ _})
...))) ...)))
#:with name/c (format-id #'name "~a/c" #'name) #:with name/c (format-id #'name "~a/c" #'name)
;(quasisyntax/loc (stx-car this-syntax)
; #,
(template (template
(begin (begin
(struct name (?? parent) (field ...) (struct name (?? parent) (field ...)
@ -335,7 +328,6 @@ data.
[field contract] [field contract]
...))))))) ...)))))))
;<hash-set/c>
<printer> <printer>
<field-info> <field-info>

17
traversal.hl.rkt
View File

@ -310,14 +310,19 @@ not expressed syntactically using the @racket[Foo] identifier.
@CHUNK[<f-cases> @CHUNK[<f-cases>
[(List X Y …) [(List X Y …)
#'(let*-values ([(result-x acc-x) ((!replace-in-instance X . rec-args) #'(let*-values ([(result-x acc-x) <f-list-car>]
(car v) [(result-y* acc-y*) <f-list-cdr>])
acc)]
[(result-y* acc-y*) ((!replace-in-instance (List Y …) . rec-args)
(cdr v)
acc-x)])
(values (cons result-x result-y*) acc-y*))]] (values (cons result-x result-y*) acc-y*))]]
where the replacement is applied to the @racket[car], and to the @racket[cdr]
as a whole (i.e. by recursion on the whole remaining list of types):
@chunk[<f-list-car>
((!replace-in-instance X . rec-args) (car v) acc)]
@chunk[<f-list-cdr>
((!replace-in-instance (List Y …) . rec-args) (cdr v) acc-x)]
@CHUNK[<type-cases> @CHUNK[<type-cases>
[(U _Xⱼ …) [(U _Xⱼ …)
#'(U (!replace-in-type _Xⱼ . rec-args) …)]] #'(U (!replace-in-type _Xⱼ . rec-args) …)]]