summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm53
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)))))
;;;