diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 53 |
1 files changed, 36 insertions, 17 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 677e02d..078e4aa 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -21,6 +21,7 @@ ;; typed, Scheme-like language that can be compiled to GLSL code. ;; ;; Notable features and restrictions: +;; - Purely functional ;; - Vertex and fragment shader output ;; - Targets multiple GLSL versions ;; - Type inference @@ -43,6 +44,10 @@ ;; in a program that is one step closer to being directly emitted to ;; GLSL code. +;; TODO: +;; - Loops +;; - Shader stage linking + ;;; ;;; Compiler helpers @@ -708,9 +713,10 @@ (define (hoist:outputs names exps) (define-values (exps* exp-env) (hoist:list exps)) - (values `(outputs ,@(map (lambda (name exp) - (list name exp)) - names exps*)) + (values `(outputs + ,@(map (lambda (name exp) + (list name exp)) + names exps*)) exp-env)) (define (hoist-functions exp) @@ -1254,7 +1260,7 @@ ;; (lambda (x) x) can truly be applied to any type. (texp (list (generalize (single-type x) env)) (texp-exp x)))) - (define env* (extend-env name (single-type exp*) env)) + (define env* (extend-env name (texp-types exp*) env)) (define result* (cons `(function ,name ,exp*) result)) (annotate:top-level rest body env* result*)) ((((? top-level-qualifier? qualifier) type-name name) . rest) @@ -1311,6 +1317,21 @@ ;; thanks to type inference the user doesn't have to specify any types ;; expect for shader inputs, outputs, and uniforms. +(define &seagull-type-error + (make-exception-type '&seagull-type-error &error '())) + +(define make-seagull-type-error + (record-constructor &seagull-type-error)) + +(define (seagull-type-error msg args origin) + (raise-exception + (make-exception + (make-seagull-type-error) + (make-exception-with-origin origin) + (make-exception-with-message + (format #f "seagull type error: ~a" msg)) + (make-exception-with-irritants args)))) + (define (occurs? a b) (cond ((and (type-variable? a) (type-variable? b)) @@ -1477,6 +1498,16 @@ args sub0 (lambda (sub1) + ;; Check if function call has the proper number of + ;; arguments. + (let* ((k (length args)) + (l (length (function-type-parameters + (single-type operator))))) + (unless (= k l) + (seagull-type-error + (format #f "expected ~a arguments, got ~a" l k) + '() + infer:call))) (unify (apply-substitutions-to-type (function-type (map single-type args) types) @@ -1597,12 +1628,6 @@ (resolve:list exps env)) (_ exp))) -(define &seagull-type-error - (make-exception-type '&seagull-type-error &error '())) - -(define make-seagull-type-error - (record-constructor &seagull-type-error)) - ;; 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 ;; expression that caused it. @@ -1616,13 +1641,7 @@ (resolve annotated subs))))) (match-lambda* ((msg . args) - (raise-exception - (make-exception - (make-seagull-type-error) - (make-exception-with-origin infer-types) - (make-exception-with-message - (format #f "seagull type error: ~a" msg)) - (make-exception-with-irritants args))))))) + (seagull-type-error msg args infer-types))))) ;;; |