Ticket #1445: parameterized-struct-type-version3-with-smashing.patch

File parameterized-struct-type-version3-with-smashing.patch, 7.6 KB (added by megane, 5 years ago)
  • scrutinizer.scm

    diff --git a/scrutinizer.scm b/scrutinizer.scm
    index 6ecf7ba..27093f5 100644
    a b  
    913913           ;; (vector x y z) => (vector * * *)
    914914           (change! (cons 'vector (map (constantly '*) (cdr t))))
    915915           (car t))
     916          ((struct)
     917           (dd "  smashing `~s' in ~a" (caar lst) where)
     918           ;; (vector x y z) => (vector * * *)
     919           (when (and (= 3 (length t))
     920                      (caddr t))
     921             (change! `(struct ,(cadr t) ,(map (constantly '*) (caddr t)))))
     922           (car t))
    916923          ((list-of list)
    917924           (dd "  smashing `~s' in ~a" (caar lst) where)
    918925           (change! '(or pair null))
     
    10871094                    (results2 (procedure-results t2)))
    10881095                (and (match-args args1 args2)
    10891096                     (match-results results1 results2))))
    1090              ((struct) (equal? t1 t2))
     1097             ((struct)
     1098              (and (equal? (cadr t1) (cadr t2))
     1099                   (or (null? (cddr t1))
     1100                       (null? (cddr t2))
     1101                       (not (caddr t1))
     1102                       (not (caddr t2))
     1103                       (and (pair? (caddr t1))
     1104                            (pair? (caddr t2))
     1105                            (= (length (caddr t1)) (length (caddr t2)))
     1106                            (every match1 (caddr t1) (caddr t2))))))
    10911107             ((pair) (every match1 (cdr t1) (cdr t2)))
    10921108             ((list-of vector-of) (match1 (second t1) (second t2)))
    10931109             ((list vector)
     
    12921308                       `(list ,@(map simplify (cdr t)))))
    12931309                  ((vector)
    12941310                   `(vector ,@(map simplify (cdr t))))
     1311                  ((struct)
     1312                   (cond
     1313                    ((= 2 (length t)) t)
     1314                    ((not (caddr t)) `(struct ,(cadr t)))
     1315                    (else
     1316                     `(struct ,(cadr t) ,(map simplify (caddr t))))))
    12951317                  ((procedure)
    12961318                   (let* ((name (and (named? t) (cadr t)))
    12971319                          (rtypes (if name (cdddr t) (cddr t))))
     
    17151737              ((forall) `(forall ,(second t) ,(resolve (third t) done)))
    17161738              ((pair list vector vector-of list-of)
    17171739               (cons (car t) (map (cut resolve <> done) (cdr t))))
     1740              ((struct)
     1741               (if (and (= 3 (length t))
     1742                        (list? (caddr t)))
     1743                   `(struct ,(cadr t) ,(map (cut resolve <> done) (caddr t)))
     1744                   t))
    17181745              ((procedure)
    17191746               (let* ((name (procedure-name t))
    17201747                      (argtypes (procedure-arguments t))
     
    20142041                                (second t))
    20152042                               constraints))
    20162043                     (validate (third t) rec)))))
    2017             ((eq? 'or (car t)) 
     2044            ((eq? 'or (car t))
    20182045             (and (list? t)
    20192046                  (let ((ts (map validate (cdr t))))
    20202047                    (and (every identity ts)
    20212048                         `(or ,@ts)))))
    20222049            ((eq? 'struct (car t))
    2023              (and (= 2 (length t))
     2050             (and (<= 2 (length t) 3)
    20242051                  (symbol? (cadr t))
    2025                   t))
     2052                  (if (not (null? (cddr t)))
     2053                      ;; copy of vector/list case
     2054                      (or (and (not (caddr t)) `(struct ,(cadr t)))
     2055                          (and (pair? (caddr t))
     2056                               (let loop ((ts (caddr t)) (ts2 '()))
     2057                                 (cond ((null? ts) `(struct ,(cadr t) ,(reverse ts2)))
     2058                                       ((validate (car ts)) =>
     2059                                        (lambda (t2) (loop (cdr ts) (cons t2 ts2))))
     2060                                       (else #f)))))
     2061                      t)))
    20262062            ((eq? 'deprecated (car t))
    20272063             (and (= 2 (length t)) (symbol? (second t)) t))
    20282064            ((or (memq* '--> t) (memq* '-> t)) =>
  • types.db

    diff --git a/types.db b/types.db
    index d142e64..53a3429 100644
    a b  
    25972597(hash-by-identity (#(procedure #:pure #:enforce) hash-by-identity (* #!optional fixnum fixnum) fixnum))
    25982598(hash-table->alist (#(procedure #:clean #:enforce) hash-table->alist ((struct hash-table)) (list-of pair)))
    25992599(hash-table-clear! (#(procedure #:clean #:enforce) hash-table-clear! ((struct hash-table)) undefined))
    2600 (hash-table-copy (#(procedure #:clean #:enforce) hash-table-copy ((struct hash-table)) (struct hash-table)))
    2601 (hash-table-delete! (#(procedure #:clean #:enforce) hash-table-delete! ((struct hash-table) *) boolean))
    26022600(hash-table-equivalence-function (#(procedure #:clean #:enforce) hash-table-equivalence-function ((struct hash-table)) (procedure (* *) *)))
    2603 (hash-table-exists? (#(procedure #:clean #:enforce) hash-table-exists? ((struct hash-table) *) boolean))
    26042601(hash-table-fold (#(procedure #:enforce) hash-table-fold ((struct hash-table) (procedure (* * *) *) *) *))
    26052602(hash-table-for-each (#(procedure #:enforce) hash-table-for-each ((struct hash-table) (procedure (* *) . *)) undefined))
    26062603
     
    26112608                          (((struct hash-table)) (##sys#slot #(1) '4)))
    26122609
    26132610(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))
    26152611(hash-table-map (#(procedure #:clean #:enforce) hash-table-map ((struct hash-table) (procedure (* *) *)) list))
    26162612
    26172613(hash-table-max-load (#(procedure #:clean #:enforce) hash-table-max-load ((struct hash-table)) fixnum)
     
    26222618
    26232619(hash-table-min-load (#(procedure #:clean #:enforce) hash-table-min-load ((struct hash-table)) fixnum)
    26242620                     (((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) * *) *))
    26282621(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))
    2630 
    26312622(hash-table-size (#(procedure #:clean #:enforce) hash-table-size ((struct hash-table)) fixnum)
    26322623                 (((struct hash-table)) (##sys#slot #(1) '2)))
    26332624
    26342625(hash-table-update! (#(procedure #:enforce) hash-table-update! ((struct hash-table) * (procedure (*) *) #!optional (procedure () *)) *))
    26352626(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))
     2627
     2628(hash-table-values (forall (v) (#(procedure #:clean #:enforce) hash-table-values ((struct hash-table (* v))) (list-of v))))
     2629(hash-table-walk (forall (k v) (#(procedure #:enforce) hash-table-walk ((struct hash-table (k v)) (procedure (k v) . *)) undefined)))
     2630(hash-table-set! (#(procedure #:enforce) hash-table-set! ((struct hash-table) * *) undefined))
     2631(hash-table-ref (forall (k v) (#(procedure #:clean #:enforce) hash-table-ref ((struct hash-table (k v)) k #!optional (procedure () *)) v)))
     2632(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))))
     2633(hash-table-keys (forall (k) (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table (k *))) (list-of k))))
     2634(hash-table-delete! (forall (k) (#(procedure #:clean #:enforce) hash-table-delete! ((struct hash-table (k *)) k) boolean)))
     2635(hash-table-copy (forall (k v) (#(procedure #:clean #:enforce) hash-table-copy ((struct hash-table (k v))) (struct hash-table (k v)))))
     2636(hash-table-exists? (forall (k) (#(procedure #:clean #:enforce) hash-table-exists? ((struct hash-table (k *)) k) boolean)))
    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)))