Ticket #1445: parameterized-struct-type-style-2.patch

File parameterized-struct-type-style-2.patch, 5.7 KB (added by megane, 4 years ago)
  • scrutinizer.scm

    diff --git a/scrutinizer.scm b/scrutinizer.scm
    index 6ecf7ba..a825266 100644
    a b  
    10871087                    (results2 (procedure-results t2)))
    10881088                (and (match-args args1 args2)
    10891089                     (match-results results1 results2))))
    1090              ((struct) (equal? t1 t2))
     1090             ((struct)
     1091              (and (equal? (cadr t1) (cadr t2))
     1092                   (or (or (null? (cddr t1)) (not (caddr t1)))
     1093                       (or (null? (cddr t2)) (not (caddr t2)))
     1094                       (every match1 (caddr t1) (caddr t2)))))
    10911095             ((pair) (every match1 (cdr t1) (cdr t2)))
    10921096             ((list-of vector-of) (match1 (second t1) (second t2)))
    10931097             ((list vector)
     
    12921296                       `(list ,@(map simplify (cdr t)))))
    12931297                  ((vector)
    12941298                   `(vector ,@(map simplify (cdr t))))
     1299                  ((struct)
     1300                   (cond
     1301                    ((= 2 (length t)) t)
     1302                    ((not (caddr t)) `(struct ,(cadr t)))
     1303                    (else
     1304                     (let ((params (map simplify (caddr t))))
     1305                       (if (every (cut eq? <> '*) params)
     1306                           `(struct ,(cadr t))
     1307                           `(struct ,(cadr t) ,params))))))
    12951308                  ((procedure)
    12961309                   (let* ((name (and (named? t) (cadr t)))
    12971310                          (rtypes (if name (cdddr t) (cddr t))))
     
    17151728              ((forall) `(forall ,(second t) ,(resolve (third t) done)))
    17161729              ((pair list vector vector-of list-of)
    17171730               (cons (car t) (map (cut resolve <> done) (cdr t))))
     1731              ((struct)
     1732               (if (and (= 3 (length t))
     1733                        (list? (caddr t)))
     1734                   (cons* 'struct (cadr t) (map (cut resolve <> done) (cddr t)))
     1735                   t))
    17181736              ((procedure)
    17191737               (let* ((name (procedure-name t))
    17201738                      (argtypes (procedure-arguments t))
     
    20142032                                (second t))
    20152033                               constraints))
    20162034                     (validate (third t) rec)))))
    2017             ((eq? 'or (car t)) 
     2035            ((eq? 'or (car t))
    20182036             (and (list? t)
    20192037                  (let ((ts (map validate (cdr t))))
    20202038                    (and (every identity ts)
    20212039                         `(or ,@ts)))))
    20222040            ((eq? 'struct (car t))
    2023              (and (= 2 (length t))
     2041             (and (<= 2 (length t) 3)
    20242042                  (symbol? (cadr t))
    2025                   t))
     2043                  (if (not (null? (cddr t)))
     2044                      ;; copy of vector/list case
     2045                      (or (and (not (caddr t)) `(struct ,(cadr t)))
     2046                          (and (list? (caddr t))
     2047                               (let loop ((ts (caddr t)) (ts2 '()))
     2048                                 (cond ((null? ts) `(struct ,(cadr t) ,@(reverse ts2)))
     2049                                       ((validate (car ts)) =>
     2050                                        (lambda (t2) (loop (cdr ts) (cons t2 ts2))))
     2051                                       (else #f)))))
     2052                      t)))
    20262053            ((eq? 'deprecated (car t))
    20272054             (and (= 2 (length t)) (symbol? (second t)) t))
    20282055            ((or (memq* '--> t) (memq* '-> t)) =>
  • types.db

    diff --git a/types.db b/types.db
    index d142e64..468afe8 100644
    a b  
    26112611                          (((struct hash-table)) (##sys#slot #(1) '4)))
    26122612
    26132613(hash-table-initial (#(procedure #:clean #:enforce) hash-table-initial ((struct hash-table)) *))
    2614 (hash-table-keys (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table)) list))
     2614(hash-table-keys (forall (k) (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table (k *))) (list-of k))))
    26152615(hash-table-map (#(procedure #:clean #:enforce) hash-table-map ((struct hash-table) (procedure (* *) *)) list))
    26162616
    26172617(hash-table-max-load (#(procedure #:clean #:enforce) hash-table-max-load ((struct hash-table)) fixnum)
     
    26222622
    26232623(hash-table-min-load (#(procedure #:clean #:enforce) hash-table-min-load ((struct hash-table)) fixnum)
    26242624                     (((struct hash-table)) (##sys#slot #(1) '5)))
    2625 
    2626 (hash-table-ref (#(procedure #:clean #:enforce) hash-table-ref ((struct hash-table) * #!optional (procedure () *)) *))
    2627 (hash-table-ref/default (#(procedure #:clean #:enforce) hash-table-ref/default ((struct hash-table) * *) *))
     2625(hash-table-ref (forall (k v) (#(procedure #:clean #:enforce) hash-table-ref ((struct hash-table (k v)) k #!optional (procedure () *)) v)))
     2626(hash-table-ref/default (forall (k v d) (#(procedure #:clean #:enforce) hash-table-ref/default ((struct hash-table (k v)) k d) (or v d))))
    26282627(hash-table-remove! (#(procedure #:clean #:enforce) hash-table-remove! ((struct hash-table) (procedure (* *) *)) undefined))
    2629 (hash-table-set! (#(procedure #:clean #:enforce) hash-table-set! ((struct hash-table) * *) undefined))
     2628(hash-table-set! (forall (k v) (#(procedure #:clean #:enforce) hash-table-set! ((struct hash-table (k v)) k v) undefined)))
    26302629
    26312630(hash-table-size (#(procedure #:clean #:enforce) hash-table-size ((struct hash-table)) fixnum)
    26322631                 (((struct hash-table)) (##sys#slot #(1) '2)))
    26332632
    26342633(hash-table-update! (#(procedure #:enforce) hash-table-update! ((struct hash-table) * (procedure (*) *) #!optional (procedure () *)) *))
    26352634(hash-table-update!/default (#(procedure #:clean #:enforce) hash-table-update!/default ((struct hash-table) * (procedure (*) *) *) *))
    2636 (hash-table-values (#(procedure #:clean #:enforce) hash-table-values ((struct hash-table)) list))
    2637 (hash-table-walk (#(procedure #:enforce) hash-table-walk ((struct hash-table) (procedure (* *) . *)) undefined))
     2635(hash-table-values (forall (v) (#(procedure #:clean #:enforce) hash-table-values ((struct hash-table (* v))) (list-of v))))
     2636(hash-table-walk (forall (k v) (#(procedure #:enforce) hash-table-walk ((struct hash-table (k v)) (procedure (k v) . *)) undefined)))
    26382637
    26392638(hash-table-weak-keys (#(procedure #:clean #:enforce) hash-table-weak-keys ((struct hash-table)) boolean)
    26402639                      (((struct hash-table)) (##sys#slot #(1) '7)))