Hi everyone,
What do you think about this idea?
I had this idea yesterday that you could add parameters to the struct
type annotation. For example:
(struct hash-table fixnum symbol)
With this new syntax you could tweak the types.db a bit with entries like:
(hash-table-ref (forall (k v) (#(procedure #:clean #:enforce)
hash-table-ref ((struct hash-table k v) k #!optional (procedure () *))
v)))
(hash-table-set! (forall (k v) (#(procedure #:clean #:enforce)
hash-table-set! ((struct hash-table k v) k v) undefined)))
Now if you tried to compile code like this:
(: make-int-to-symbol (-> (struct hash-table fixnum symbol)))
(define (make-int-to-symbol)
(make-hash-table))
(hash-table-set! (make-int-to-symbol) 'foo 2)
You could get warnings like this:
Warning: at toplevel:
(example.scm:5) in procedure call to `hash-table-set!', expected argument #2
of type `fixnum' but was given an argument of type `symbol'
Warning: at toplevel:
(example.scm:5) in procedure call to `hash-table-set!', expected argument #3
of type `symbol' but was given an argument of type `fixnum'
Seems handy, doesn't it?
Now, what's missing is of course the implementation. This seems very
close to the (list T ...) and (vector T ...) case. That's why I thought
this could be possible at all. I made a quick proof-of-concept patch,
which you'll find attached. It's indeed mostly copy paste of the vector
and list cases.
There's at least the smashing missing.
The patch is for the 4.13.0 tarball.
(: make-int-to-symbol (-> (struct hash-table fixnum symbol)))
(define (make-int-to-symbol)
(make-hash-table))
(hash-table-set! (make-int-to-symbol) 'foo 2)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6ecf7ba..6f19b05 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1087,7 +1087,9 @@
(results2 (procedure-results t2)))
(and (match-args args1 args2)
(match-results results1 results2))))
- ((struct) (equal? t1 t2))
+ ((struct)
+ (and (equal? (cadr t1) (cadr t2))
+ (every match1 (cddr t1) (cddr t2))))
((pair) (every match1 (cdr t1) (cdr t2)))
((list-of vector-of) (match1 (second t1) (second t2)))
((list vector)
@@ -1292,6 +1294,8 @@
`(list ,@(map simplify (cdr t)))))
((vector)
`(vector ,@(map simplify (cdr t))))
+ ((struct)
+ `(struct ,(cadr t) ,@(map simplify (cddr t))))
((procedure)
(let* ((name (and (named? t) (cadr t)))
(rtypes (if name (cdddr t) (cddr t))))
@@ -1715,6 +1719,8 @@
((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)
+ (cons* 'struct (cadr t) (map (cut resolve <> done) (cddr t))))
((procedure)
(let* ((name (procedure-name t))
(argtypes (procedure-arguments t))
@@ -2014,15 +2020,23 @@
(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))
(symbol? (cadr t))
- t))
+ (if (not (null? (cddr t)))
+ ;; copy of vector/list case
+ (and (list? (cddr t))
+ (let loop ((ts (cddr 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)) =>
diff --git a/types.db b/types.db
index d142e64..fec7f96 100644
--- a/types.db
+++ b/types.db
@@ -2611,7 +2611,7 @@
(((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,19 +2622,18 @@
(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)))
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
