From 03e4be13fb2c5f728b30da50704171ff2d51a5b9 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 24 Feb 2023 08:49:17 -0500 Subject: Map names to a single type in type environments. --- chickadee/graphics/seagull.scm | 80 +++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 47 deletions(-) diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index b2058d0..7a22355 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -1710,11 +1710,9 @@ types)) (define (apply-substitution-to-env env from to) - (env-fold (lambda (name types env*) + (env-fold (lambda (name type env*) (extend-env name - (map (lambda (type) - (apply-substitution-to-type type from to)) - types) + (apply-substitution-to-type type from to) env*)) (empty-env) env)) @@ -1789,12 +1787,6 @@ a)) (append a* b*)) -(define (lookup-type name env) - (let ((type (lookup name env))) - (if (type-scheme? type) - (instantiate type) - type))) - (define (compose-predicates a b) (cond ((and (eq? a #t) (eq? b #t)) @@ -2139,15 +2131,10 @@ subs) #t))) -(define (maybe-instantiate types) - (define types+preds - (map (lambda (type) - (if (type-scheme? type) - (call-with-values (lambda () (instantiate type)) list) - (list type #t))) - types)) - (values (map first types+preds) - (reduce compose-predicates #t (map second types+preds)))) +(define (maybe-instantiate type) + (if (type-scheme? type) + (instantiate type) + (values type #t))) (define (unify:primitives a b) (if (equal? a b) @@ -2221,9 +2208,9 @@ #t)) (define (infer:variable name env) - (define-values (types pred) - (maybe-instantiate (lookup-type name env))) - (values (texp types name) + (define-values (type pred) + (maybe-instantiate (lookup name env))) + (values (texp (list type) name) '() pred)) @@ -2291,7 +2278,7 @@ ;; The type environment is extended with the function parameters. (define env* (fold (lambda (param type env*) - (extend-env param (list type) env*)) + (extend-env param type env*)) env params param-types)) (define-values (body* body-subs body-pred) (infer-exp body env*)) @@ -2309,11 +2296,8 @@ (define primitive (lookup-seagull-primitive operator)) ;; Primitive functions may be overloaded and need to be instantiated ;; with fresh type variables. - (define-values (types operator-pred) - (maybe-instantiate (list (seagull-primitive-type primitive)))) - (define operator-type - (match types - ((type) type))) + (define-values (operator-type operator-pred) + (maybe-instantiate (seagull-primitive-type primitive))) ;; Infer the arguments. (define-values (args* arg-subs arg-pred) (infer:list args env)) @@ -2422,7 +2406,7 @@ (define (infer:let names exps body env) (define-values (exps* exp-subs exp-pred) (infer:list exps env)) - (define exp-types (map texp-types exps*)) + (define exp-types (map single-type exps*)) (define env* (fold extend-env (apply-substitutions-to-env env exp-subs) @@ -2455,7 +2439,7 @@ (define exp-types (map texp-types exps*)) (define env* (fold (lambda (names types env) - (fold extend-env env names (map list types))) + (fold extend-env env names types)) (apply-substitutions-to-env env exp-subs) names exp-types)) @@ -2495,9 +2479,8 @@ (define (infer:outputs names exps env) (define-values (exps* exp-subs exp-pred) (infer:list exps env)) - (define exp-types (map texp-types exps*)) (define unify-subs - (unify (map texp-types exps*) + (unify (map single-type exps*) (map (lambda (name) (lookup name env)) names))) @@ -2525,7 +2508,7 @@ (eval-predicate* (compose-predicates pred pred*) (compose-substitutions subs subs*))) (define env* - (apply-substitutions-to-env (extend-env name (texp-types texp) env) + (apply-substitutions-to-env (extend-env name (single-type texp) env) combined-subs)) (infer-bindings rest (cons texp texps) @@ -2533,12 +2516,12 @@ new-pred env*)) (((_ desc name) . rest) - (define types (list (type-descriptor->type desc))) + (define type (type-descriptor->type desc)) (infer-bindings rest - (cons types texps) + (cons (list type) texps) subs pred - (extend-env name types env))))) + (extend-env name type env))))) (define qualifiers (map first bindings)) (define names (map (match-lambda @@ -2627,12 +2610,12 @@ (define (top-level-type-env stage) (case stage ((vertex) - `((vertex:position ,type:vec4) - (vertex:point-size ,type:float) - (vertex:clip-distance ,type:float))) + `((vertex:position . ,type:vec4) + (vertex:point-size . ,type:float) + (vertex:clip-distance . ,type:float))) ((fragment) - `((fragment:depth ,type:float) - (fragment:coord ,type:vec4))))) + `((fragment:depth . ,type:float) + (fragment:coord . ,type:vec4))))) ;; TODO: Add some kind of context object that is threaded through the ;; inference process so that when a type error occurs we can show the @@ -2694,9 +2677,9 @@ (define (vars->subs exp env) (match exp (('t ((? variable-type? tvar)) (? symbol? name)) - (let ((types (lookup* name env))) - (if types - (list (cons tvar (first types))) + (let ((type (lookup* name env))) + (if type + (list (cons tvar type)) '()))) ((head . rest) (delete-duplicates @@ -2737,8 +2720,11 @@ (('lambda (params ...) _) params))) (define env - (compose-envs (fold extend-env (empty-env) params - (map list (function-type-parameters type*))) + (compose-envs (fold extend-env + (empty-env) + params + (function-type-parameters + type*)) globals)) (match func (('lambda _ body) @@ -2760,7 +2746,7 @@ (cons (list qualifier type name) (loop rest (extend-env name - (list (type-descriptor->type type)) + (type-descriptor->type type) globals))))))) `(t ,types (top-level ,bindings* ,body))))) -- cgit v1.2.3