diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6ecf7ba..27093f5 100644
a
|
b
|
|
913 | 913 | ;; (vector x y z) => (vector * * *) |
914 | 914 | (change! (cons 'vector (map (constantly '*) (cdr t)))) |
915 | 915 | (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)) |
916 | 923 | ((list-of list) |
917 | 924 | (dd " smashing `~s' in ~a" (caar lst) where) |
918 | 925 | (change! '(or pair null)) |
… |
… |
|
1087 | 1094 | (results2 (procedure-results t2))) |
1088 | 1095 | (and (match-args args1 args2) |
1089 | 1096 | (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)))))) |
1091 | 1107 | ((pair) (every match1 (cdr t1) (cdr t2))) |
1092 | 1108 | ((list-of vector-of) (match1 (second t1) (second t2))) |
1093 | 1109 | ((list vector) |
… |
… |
|
1292 | 1308 | `(list ,@(map simplify (cdr t))))) |
1293 | 1309 | ((vector) |
1294 | 1310 | `(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)))))) |
1295 | 1317 | ((procedure) |
1296 | 1318 | (let* ((name (and (named? t) (cadr t))) |
1297 | 1319 | (rtypes (if name (cdddr t) (cddr t)))) |
… |
… |
|
1715 | 1737 | ((forall) `(forall ,(second t) ,(resolve (third t) done))) |
1716 | 1738 | ((pair list vector vector-of list-of) |
1717 | 1739 | (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)) |
1718 | 1745 | ((procedure) |
1719 | 1746 | (let* ((name (procedure-name t)) |
1720 | 1747 | (argtypes (procedure-arguments t)) |
… |
… |
|
2014 | 2041 | (second t)) |
2015 | 2042 | constraints)) |
2016 | 2043 | (validate (third t) rec))))) |
2017 | | ((eq? 'or (car t)) |
| 2044 | ((eq? 'or (car t)) |
2018 | 2045 | (and (list? t) |
2019 | 2046 | (let ((ts (map validate (cdr t)))) |
2020 | 2047 | (and (every identity ts) |
2021 | 2048 | `(or ,@ts))))) |
2022 | 2049 | ((eq? 'struct (car t)) |
2023 | | (and (= 2 (length t)) |
| 2050 | (and (<= 2 (length t) 3) |
2024 | 2051 | (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))) |
2026 | 2062 | ((eq? 'deprecated (car t)) |
2027 | 2063 | (and (= 2 (length t)) (symbol? (second t)) t)) |
2028 | 2064 | ((or (memq* '--> t) (memq* '-> t)) => |
diff --git a/types.db b/types.db
index d142e64..53a3429 100644
a
|
b
|
|
2597 | 2597 | (hash-by-identity (#(procedure #:pure #:enforce) hash-by-identity (* #!optional fixnum fixnum) fixnum)) |
2598 | 2598 | (hash-table->alist (#(procedure #:clean #:enforce) hash-table->alist ((struct hash-table)) (list-of pair))) |
2599 | 2599 | (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)) |
2602 | 2600 | (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)) |
2604 | 2601 | (hash-table-fold (#(procedure #:enforce) hash-table-fold ((struct hash-table) (procedure (* * *) *) *) *)) |
2605 | 2602 | (hash-table-for-each (#(procedure #:enforce) hash-table-for-each ((struct hash-table) (procedure (* *) . *)) undefined)) |
2606 | 2603 | |
… |
… |
|
2611 | 2608 | (((struct hash-table)) (##sys#slot #(1) '4))) |
2612 | 2609 | |
2613 | 2610 | (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)) |
2615 | 2611 | (hash-table-map (#(procedure #:clean #:enforce) hash-table-map ((struct hash-table) (procedure (* *) *)) list)) |
2616 | 2612 | |
2617 | 2613 | (hash-table-max-load (#(procedure #:clean #:enforce) hash-table-max-load ((struct hash-table)) fixnum) |
… |
… |
|
2622 | 2618 | |
2623 | 2619 | (hash-table-min-load (#(procedure #:clean #:enforce) hash-table-min-load ((struct hash-table)) fixnum) |
2624 | 2620 | (((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) * *) *)) |
2628 | 2621 | (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 | | |
2631 | 2622 | (hash-table-size (#(procedure #:clean #:enforce) hash-table-size ((struct hash-table)) fixnum) |
2632 | 2623 | (((struct hash-table)) (##sys#slot #(1) '2))) |
2633 | 2624 | |
2634 | 2625 | (hash-table-update! (#(procedure #:enforce) hash-table-update! ((struct hash-table) * (procedure (*) *) #!optional (procedure () *)) *)) |
2635 | 2626 | (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))) |
2638 | 2637 | |
2639 | 2638 | (hash-table-weak-keys (#(procedure #:clean #:enforce) hash-table-weak-keys ((struct hash-table)) boolean) |
2640 | 2639 | (((struct hash-table)) (##sys#slot #(1) '7))) |