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

scrutinizer.scm

@@ -1087 +1087 @@
                     (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 (or (null? (cddr t1)) (not (caddr t1)))
+                       (or (null? (cddr t2)) (not (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 +1296 @@
                        `(list ,@(map simplify (cdr t)))))
                   ((vector)
                    `(vector ,@(map simplify (cdr t))))
+                  ((struct)
+                   (cond
+                    ((= 2 (length t)) t)
+                    ((not (caddr t)) `(struct ,(cadr t)))
+                    (else
+                     (let ((params (map simplify (caddr t))))
+                       (if (every (cut eq? <> '*) params)
+                           `(struct ,(cadr t))
+                           `(struct ,(cadr t) ,params))))))
                   ((procedure)
                    (let* ((name (and (named? t) (cadr t)))
                           (rtypes (if name (cdddr t) (cddr t))))
@@ -1715 +1728 @@
               ((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)))
+                   (cons* 'struct (cadr t) (map (cut resolve <> done) (cddr t)))
+                   t))
               ((procedure)
                (let* ((name (procedure-name t))
                       (argtypes (procedure-arguments t))
@@ -2014 +2032 @@
                                 (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 (list? (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

@@ -2611 +2611 @@
                           (((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-keys (forall (k) (#(procedure #:clean #:enforce) hash-table-keys ((struct hash-table (k *))) (list-of k))))
 (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 +2622 @@
 
 (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-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-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-set! (forall (k v) (#(procedure #:clean #:enforce) hash-table-set! ((struct hash-table (k v)) k v) 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-weak-keys (#(procedure #:clean #:enforce) hash-table-weak-keys ((struct hash-table)) boolean)
                       (((struct hash-table)) (##sys#slot #(1) '7)))