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

scrutinizer.scm

@@ -913 +913 @@
            ;; (vector x y z) => (vector * * *)
            (change! (cons 'vector (map (constantly '*) (cdr t))))
            (car t))
+          ((struct)
+           (dd "  smashing `~s' in ~a" (caar lst) where)
+           ;; (vector x y z) => (vector * * *)
+           (when (and (= 3 (length t))
+                      (caddr t))
+             (change! `(struct ,(cadr t) ,(map (constantly '*) (caddr t)))))
+           (car t))
           ((list-of list)
            (dd "  smashing `~s' in ~a" (caar lst) where)
            (change! '(or pair null))
@@ -1087 +1094 @@
                     (results2 (procedure-results t2)))
                 (and (match-args args1 args2)
                      (match-results results1 results2))))
-             ((struct) (equal? t1 t2))
+             ((struct)
+              (and (equal? (cadr t1) (cadr t2))
+                   (or (null? (cddr t1))
+                       (null? (cddr t2))
+                       (not (caddr t1))
+                       (not (caddr t2))
+                       (and (pair? (caddr t1))
+                            (pair? (caddr t2))
+                            (= (length (caddr t1)) (length (caddr t2)))
+                            (every match1 (caddr t1) (caddr t2))))))
              ((pair) (every match1 (cdr t1) (cdr t2)))
              ((list-of vector-of) (match1 (second t1) (second t2)))
              ((list vector)
@@ -1292 +1308 @@
                        `(list ,@(map simplify (cdr t)))))
                   ((vector)
                    `(vector ,@(map simplify (cdr t))))
+                  ((struct)
+                   (cond
+                    ((= 2 (length t)) t)
+                    ((not (caddr t)) `(struct ,(cadr t)))
+                    (else
+                     `(struct ,(cadr t) ,(map simplify (caddr t))))))
                   ((procedure)
                    (let* ((name (and (named? t) (cadr t)))
                           (rtypes (if name (cdddr t) (cddr t))))
@@ -1715 +1737 @@
               ((forall) `(forall ,(second t) ,(resolve (third t) done)))
               ((pair list vector vector-of list-of) 
                (cons (car t) (map (cut resolve <> done) (cdr t))))
+              ((struct)
+               (if (and (= 3 (length t))
+                        (list? (caddr t)))
+                   `(struct ,(cadr t) ,(map (cut resolve <> done) (caddr t)))
+                   t))
               ((procedure)
                (let* ((name (procedure-name t))
                       (argtypes (procedure-arguments t))
@@ -2014 +2041 @@
                                 (second t))
                                constraints))
                      (validate (third t) rec)))))
-            ((eq? 'or (car t)) 
+            ((eq? 'or (car t))
              (and (list? t)
                   (let ((ts (map validate (cdr t))))
                     (and (every identity ts)
                          `(or ,@ts)))))
             ((eq? 'struct (car t))
-             (and (= 2 (length t))
+             (and (<= 2 (length t) 3)
                   (symbol? (cadr t))
-                  t))
+                  (if (not (null? (cddr t)))
+                      ;; copy of vector/list case
+                      (or (and (not (caddr t)) `(struct ,(cadr t)))
+                          (and (pair? (caddr t))
+                               (let loop ((ts (caddr t)) (ts2 '()))
+                                 (cond ((null? ts) `(struct ,(cadr t) ,(reverse ts2)))
+                                       ((validate (car ts)) =>
+                                        (lambda (t2) (loop (cdr ts) (cons t2 ts2))))
+                                       (else #f)))))
+                      t)))
             ((eq? 'deprecated (car t))
              (and (= 2 (length t)) (symbol? (second t)) t))
             ((or (memq* '--> t) (memq* '-> t)) =>

types.db

@@ -2597 +2597 @@
 (hash-by-identity (#(procedure #:pure #:enforce) hash-by-identity (* #!optional fixnum fixnum) fixnum))
 (hash-table->alist (#(procedure #:clean #:enforce) hash-table->alist ((struct hash-table)) (list-of pair)))
 (hash-table-clear! (#(procedure #:clean #:enforce) hash-table-clear! ((struct hash-table)) undefined))
-(hash-table-copy (#(procedure #:clean #:enforce) hash-table-copy ((struct hash-table)) (struct hash-table)))
-(hash-table-delete! (#(procedure #:clean #:enforce) hash-table-delete! ((struct hash-table) *) boolean))
 (hash-table-equivalence-function (#(procedure #:clean #:enforce) hash-table-equivalence-function ((struct hash-table)) (procedure (* *) *)))
-(hash-table-exists? (#(procedure #:clean #:enforce) hash-table-exists? ((struct hash-table) *) boolean))
 (hash-table-fold (#(procedure #:enforce) hash-table-fold ((struct hash-table) (procedure (* * *) *) *) *))
 (hash-table-for-each (#(procedure #:enforce) hash-table-for-each ((struct hash-table) (procedure (* *) . *)) undefined))
 
@@ -2611 +2608 @@
                           (((struct hash-table)) (##sys#slot #(1) '4)))
 
 (hash-table-initial (#(procedure #:clean #:enforce) hash-table-initial ((struct hash-table)) *))
-(hash-table-keys (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table)) list))
 (hash-table-map (#(procedure #:clean #:enforce) hash-table-map ((struct hash-table) (procedure (* *) *)) list))
 
 (hash-table-max-load (#(procedure #:clean #:enforce) hash-table-max-load ((struct hash-table)) fixnum)
@@ -2622 +2618 @@
 
 (hash-table-min-load (#(procedure #:clean #:enforce) hash-table-min-load ((struct hash-table)) fixnum)
                      (((struct hash-table)) (##sys#slot #(1) '5)))
-
-(hash-table-ref (#(procedure #:clean #:enforce) hash-table-ref ((struct hash-table) * #!optional (procedure () *)) *))
-(hash-table-ref/default (#(procedure #:clean #:enforce) hash-table-ref/default ((struct hash-table) * *) *))
 (hash-table-remove! (#(procedure #:clean #:enforce) hash-table-remove! ((struct hash-table) (procedure (* *) *)) undefined))
-(hash-table-set! (#(procedure #:clean #:enforce) hash-table-set! ((struct hash-table) * *) undefined))
-
 (hash-table-size (#(procedure #:clean #:enforce) hash-table-size ((struct hash-table)) fixnum)
                  (((struct hash-table)) (##sys#slot #(1) '2)))
 
 (hash-table-update! (#(procedure #:enforce) hash-table-update! ((struct hash-table) * (procedure (*) *) #!optional (procedure () *)) *))
 (hash-table-update!/default (#(procedure #:clean #:enforce) hash-table-update!/default ((struct hash-table) * (procedure (*) *) *) *))
-(hash-table-values (#(procedure #:clean #:enforce) hash-table-values ((struct hash-table)) list))
-(hash-table-walk (#(procedure #:enforce) hash-table-walk ((struct hash-table) (procedure (* *) . *)) undefined))
+
+(hash-table-values (forall (v) (#(procedure #:clean #:enforce) hash-table-values ((struct hash-table (* v))) (list-of v))))
+(hash-table-walk (forall (k v) (#(procedure #:enforce) hash-table-walk ((struct hash-table (k v)) (procedure (k v) . *)) undefined)))
+(hash-table-set! (#(procedure #:enforce) hash-table-set! ((struct hash-table) * *) undefined))
+(hash-table-ref (forall (k v) (#(procedure #:clean #:enforce) hash-table-ref ((struct hash-table (k v)) k #!optional (procedure () *)) v)))
+(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))))
+(hash-table-keys (forall (k) (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table (k *))) (list-of k))))
+(hash-table-delete! (forall (k) (#(procedure #:clean #:enforce) hash-table-delete! ((struct hash-table (k *)) k) boolean)))
+(hash-table-copy (forall (k v) (#(procedure #:clean #:enforce) hash-table-copy ((struct hash-table (k v))) (struct hash-table (k v)))))
+(hash-table-exists? (forall (k) (#(procedure #:clean #:enforce) hash-table-exists? ((struct hash-table (k *)) k) boolean)))
 
 (hash-table-weak-keys (#(procedure #:clean #:enforce) hash-table-weak-keys ((struct hash-table)) boolean)
                       (((struct hash-table)) (##sys#slot #(1) '7)))