Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 22:29:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding type inference from assertions

Browse source
This commit is contained in:
Alex Shinn 2011-11-10 22:11:12 +09:00
parent 58ac066820
commit 372a7b37b3
1 changed files with 70 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

114
lib/chibi/type-inference.scm
View file

@ -42,6 +42,11 @@
(member b (cdr a))) (member b (cdr a)))
(and (union-type? b) (member a (cdr b)))))) (and (union-type? b) (member a (cdr b))))))
(define (type-not a)
(match a
(('not b) b)
(else (list 'not a))))
;; XXXX check for type hierarchies ;; XXXX check for type hierarchies
(define (type-union a b) (define (type-union a b)
(cond (cond
@ -88,6 +93,20 @@
(cond ((lambda-param-type-memq f x) (cond ((lambda-param-type-memq f x)
=> (lambda (cell) (set-car! cell y))))) => (lambda (cell) (set-car! cell y)))))
(define (type-assert x true?)
(match x
(((? opcode? f) ($ Ref name (_ . (? lambda? g))))
(cond
((eq? (opcode-class f) (opcode-class pair?))
(let ((t (type-intersection
(lambda-param-type-ref g name)
(if true? (opcode-data f) (type-not (opcode-data f))))))
(lambda-param-type-set! g name t)))))
((($ Ref _ ('not . (? procedure? f))) expr)
(if (eq? f not)
(type-assert expr (not true?))))
(else #f)))
(define (type-analyze-expr x) (define (type-analyze-expr x)
(match x (match x
(($ Lam name params body defs) (($ Lam name params body defs)
@ -101,7 +120,7 @@
(($ Set ref value) (($ Set ref value)
(type-analyze-expr value) (type-analyze-expr value)
(if #f #f)) (if #f #f))
(($ Ref name (value . loc) source) (($ Ref name (value . loc))
(cond (cond
((lambda? loc) (lambda-param-type-ref loc name)) ((lambda? loc) (lambda-param-type-ref loc name))
((procedure? loc) ((procedure? loc)
@ -114,7 +133,15 @@
(let ((test-type (type-analyze-expr test)) (let ((test-type (type-analyze-expr test))
(pass-type (type-analyze-expr pass)) (pass-type (type-analyze-expr pass))
(fail-type (type-analyze-expr fail))) (fail-type (type-analyze-expr fail)))
(type-union pass-type fail-type))) (cond
((equal? '(error) pass-type)
(type-assert test #f)
fail-type)
((equal? '(error) fail-type)
(type-assert test #t)
pass-type)
(else
(type-union pass-type fail-type)))))
(($ Seq ls) (($ Seq ls)
(let lp ((ls ls)) (let lp ((ls ls))
(cond ((null? (cdr ls)) (cond ((null? (cdr ls))
@ -122,50 +149,49 @@
(else (else
(type-analyze-expr (car ls)) (type-analyze-expr (car ls))
(lp (cdr ls)))))) (lp (cdr ls))))))
((f args ...) (((? opcode? f) args ...)
(cond (let lp ((p (opcode-param-types f))
((opcode? f) (a args))
(let lp ((p (opcode-param-types f)) (cond
(a args)) ((pair? a)
(cond (cond
((pair? a) ((or (pair? p) (opcode-variadic? f))
(cond ((or (pair? p) (opcode-variadic? f)) (let ((p-type
(let ((p-type (if (pair? p)
(if (pair? p) (car p)
(car p) (opcode-param-type f (opcode-num-params f)))))
(opcode-param-type f (opcode-num-params f))))) (match (car a)
(match (car a) (($ Ref name (_ . (and g ($ Lam))))
(($ Ref name (_ . (and g ($ Lam)))) (let ((t (type-intersection (lambda-param-type-ref g name)
(let ((t (type-intersection (lambda-param-type-ref g name) p-type)))
p-type))) (lambda-param-type-set! g name t)))
(lambda-param-type-set! g name t))) (else
(else (let ((t (type-analyze-expr (car a))))
(let ((t (type-analyze-expr (car a)))) (cond
(cond ((and t p-type
((and t p-type (finalized-type? t)
(finalized-type? t) (finalized-type? p-type)
(finalized-type? p-type) (not (type-subset? t p-type)))
(not (type-subset? t p-type))) (display "WARNING: incompatible type: "
(display "WARNING: incompatible type: " (current-error-port))
(current-error-port)) (write/ss (list x t p-type) (current-error-port))
(write/ss (list x t p-type) (current-error-port)) (newline (current-error-port))))
(newline (current-error-port)))) t))))
t)))) (lp (and (pair? p) (cdr p)) (cdr a)))
(lp (and (pair? p) (cdr p)) (cdr a)))
(else
(for-each type-analyze-expr a))))))
(opcode-return-type f))
(else
(let ((f-type (type-analyze-expr f)))
;; XXXX apply f-type to params
(for-each type-analyze-expr args)
(cond
((and (pair? f-type) (eq? (car f-type) 'lambda))
(cadr f-type))
((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
f-type)
(else (else
Object)))))) (for-each type-analyze-expr a))))))
(opcode-return-type f))
((f args ...)
(let ((f-type (type-analyze-expr f)))
;; XXXX apply f-type to params
(for-each type-analyze-expr args)
(cond
((and (pair? f-type) (eq? (car f-type) 'lambda))
(cadr f-type))
((and (pair? f-type) (memq (car f-type) '(return-type param-type)))
f-type)
(else
Object))))
(($ Lit value) (($ Lit value)
(type-of value)) (type-of value))
(else (else