Misc. tweaks.

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)))))
 
 
 ;;;