summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-01-08 15:44:01 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commit4ec4fd75dc2a61f734490f03d78785662fc93f05 (patch)
treef0c8c94662e4eeef0c277ca1e3a7e82add036239
parent0251a3319532a30b3f7583a8fbde0f4591762c02 (diff)
Add macro expansion and free variable annotation.
-rw-r--r--chickadee/graphics/seagull.scm253
1 files changed, 239 insertions, 14 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 505c4b4..72500fc 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -17,8 +17,8 @@
;;; Commentary:
;;
-;; Seagull is a purely functional, statically typed, Scheme-like
-;; language that can be compiled to GLSL code.
+;; The Seagull shading language is a purely functional, statically
+;; typed, Scheme-like language that can be compiled to GLSL code.
;;
;; Notable features and restrictions:
;; - Vertex and fragment shader output
@@ -31,9 +31,10 @@
;;
;;; Code:
(define-module (chickadee graphics seagull)
+ #:use-module (ice-9 exceptions)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-1)
#:export (compile-seagull))
;; The Seagull compiler is designed as a series of source-to-source
@@ -43,23 +44,191 @@
;;;
-;;; Alpha conversion
+;;; Compiler helpers
;;;
+;; This is where we keep miscellaneous code that is useful for many
+;; stages of the compiler.
+
+(define (float? x)
+ (and (number? x) (inexact? x)))
+
+;; Immediate types are fundamental data types that need no
+;; compilation.
+(define (immediate? x)
+ (or (exact-integer? x)
+ (float? x)
+ (char? x)
+ (boolean? x)))
+
+(define (primitive-call? x)
+ (memq x '(+ - * / = < <= > >=)))
+
+
+;;;
+;;; Lexical environments
+;;;
+
+;; Environments keep track of the variables that are in scope of an
+;; expression.
+
+(define (empty-env)
+ '())
+
+(define &seagull-unbound-variable-error
+ (make-exception-type '&seagull-unbound-variable-error &error '(name)))
+
+(define make-seagull-unbound-variable-error
+ (record-constructor &seagull-unbound-variable-error))
+
+(define seagull-unbound-variable-name
+ (exception-accessor &seagull-unbound-variable-error
+ (record-accessor &seagull-unbound-variable-error 'name)))
+
+(define (lookup name env)
+ (or (assq-ref env name)
+ (raise-exception
+ (make-exception
+ (make-seagull-unbound-variable-error name)
+ (make-exception-with-origin lookup)
+ (make-exception-with-message "seagull: unbound variable")
+ (make-exception-with-irritants (list name env))))))
+
+(define (lookup-all names env)
+ (map (lambda (name) (lookup name env)) names))
+
+(define (extend-env name value env)
+ (alist-cons name value env))
+
+(define (compose-envs . envs)
+ (concatenate envs))
+
+(define (top-level-env)
+ (empty-env))
+
+
+;;;
+;;; Macro expansion and alpha conversion
+;;;
+
+;; Macro expansion converts convenient but non-primitive syntax forms
+;; (such as let*) into primitive syntax. Seagull does not currently
+;; support user defined macros, just a set of built-ins.
+;;
;; Alpha conversion is the process of converting all the user defined
;; identifiers in a program to uniquely named identifiers. This
;; process frees the compiler from having to worry about things like
;; '+' being a user defined variable that shadows the primitive
;; addition operation.
+(define unique-identifier-counter (make-parameter 0))
+
+(define (unique-identifier-number)
+ (let ((n (unique-identifier-counter)))
+ (unique-identifier-counter (+ n 1))
+ n))
+
+(define (unique-identifier)
+ (string->symbol
+ (format #f "V~a" (unique-identifier-number))))
+
+(define (alpha-convert names)
+ (define names* (map (lambda (_name) (unique-identifier)) names))
+ (fold extend-env (empty-env) names names*))
+
+(define (expand-list exps env)
+ (map (lambda (exp) (expand exp env)) exps))
+
+(define (expand-variable exp env)
+ ;; Replace original variable with alpha-converted name, but keep
+ ;; track of the original for showing the user error messages that
+ ;; make sense later.
+ `(var ,(lookup exp env) ,exp))
+
+(define (expand-if predicate consequent alternate env)
+ `(if ,(expand predicate env)
+ ,(expand consequent env)
+ ,(expand alternate env)))
+
+(define (expand-let names exps body env)
+ (if (null? names)
+ (expand body env)
+ (let* ((env* (compose-envs (alpha-convert names) env))
+ (bindings* (map list (lookup-all names env*) exps)))
+ `(let ,bindings* ,(expand body env*)))))
+
+(define (expand-let* bindings body env)
+ (match bindings
+ (() (expand body env))
+ ((binding . rest)
+ (expand `(let (,binding)
+ (let* ,rest ,body))
+ env))))
+
+(define (expand-lambda params body env)
+ (define env* (compose-envs (alpha-convert params) env))
+ (define params* (lookup-all params env*))
+ `(lambda ,params* ,(expand body env*)))
+
+(define (expand-primitive-call operator operands env)
+ `(primcall ,operator ,@(expand-list operands env)))
+
+(define (expand-call operator operands env)
+ `(call ,(expand operator env) ,@(expand-list operands env)))
+
+(define &seagull-syntax-error
+ (make-exception-type '&seagull-syntax-error &error '(form)))
+
+(define make-seagull-syntax-error
+ (record-constructor &seagull-syntax-error))
+
+(define seagull-syntax-form
+ (exception-accessor &seagull-syntax-error
+ (record-accessor &seagull-syntax-error 'form)))
+
+(define (expand exp env)
+ (match exp
+ ;; Immediates and variables:
+ ((? immediate?)
+ exp)
+ ((? symbol?)
+ (expand-variable exp env))
+ ;; Primitive syntax forms:
+ (('if predicate consequent alternate)
+ (expand-if predicate consequent alternate env))
+ (('let (((? symbol? names) exps) ...) body)
+ (expand-let names exps body env))
+ (('lambda ((? symbol? params) ...) body)
+ (expand-lambda params body env))
+ ;; Macros:
+ (('let* (bindings ...) body)
+ (expand-let* bindings body env))
+ ;; Primitive calls:
+ (((? primitive-call? operator) args ...)
+ (expand-primitive-call operator args env))
+ ;; Function calls:
+ ((operator args ...)
+ (expand-call operator args env))
+ ;; Syntax error:
+ (_
+ (raise-exception
+ (make-exception
+ (make-seagull-syntax-error exp)
+ (make-exception-with-origin expand)
+ (make-exception-with-message "seagull: invalid syntax")
+ (make-exception-with-irritants (list exp)))))))
+
+(define (expand* exp)
+ (parameterize ((unique-identifier-counter 0))
+ (expand exp (top-level-env))))
+
;;;
-;;; Macro expansion
+;;; Function hoisting
;;;
-;; Macro expansion converts convenient but non-primitive syntax forms
-;; (such as let*) into primitive syntax. Seagull does not currently
-;; support user defined macros, just a set of built-ins.
+;; Move all lambda bindings to the top-level. As mentioned earlier,
+;; GLSL does not allow nested functions.
;;;
@@ -72,13 +241,69 @@
;; allow free variable references for top-level variables, such as
;; shader inputs and uniforms.
-
-;;;
-;;; Function hoisting
-;;;
+(define &seagull-scope-error
+ (make-exception-type '&seagull-scope-error &error '(variable)))
+
+(define make-seagull-scope-error
+ (record-constructor &seagull-scope-error))
+
+(define seagull-scope-variable
+ (exception-accessor &seagull-scope-error
+ (record-accessor &seagull-scope-error 'variable)))
+
+(define (free-variables exp bound-vars top-level-vars)
+ (match exp
+ ((? immediate?) '())
+ (('var name original-name)
+ (cond
+ ((memq name bound-vars) ; bound vars are not free
+ '())
+ ((memq name top-level-vars) ; free top-level var
+ (list name))
+ (else
+ ;; Free variables that aren't top-level are not allowed because
+ ;; GLSL doesn't support closures.
+ (raise-exception
+ (make-exception
+ (make-seagull-scope-error original-name)
+ (make-exception-with-origin free-variables)
+ (make-exception-with-message
+ "seagull: free variable is not top-level")
+ (make-exception-with-irritants (list exp)))))))
+ (('if predicate consequent alternate)
+ (append (free-variables predicate bound-vars top-level-vars)
+ (free-variables consequent bound-vars top-level-vars)
+ (free-variables alternate bound-vars top-level-vars)))
+ (('let ((names _) ...) body)
+ (free-variables body (append names bound-vars) top-level-vars))
+ (('lambda (params ...) body)
+ (free-variables body (append params bound-vars) top-level-vars))
+ ((or ('primcall _ args ...)
+ ('call args ...))
+ (append-map (lambda (arg)
+ (free-variables arg bound-vars top-level-vars))
+ args))))
-;; Move all non-top-level lambda bindings to the top-level. As
-;; mentioned earlier, GLSL does not allow nested functions.
+(define (annotate-free-variables exp)
+ (match exp
+ ((or (? immediate?)
+ ('var _ _))
+ exp)
+ (('if predicate consequent alternate)
+ `(if (annotate-free-variables predicate)
+ (annotate-free-variables consequent)
+ (annotate-free-variables alternate)))
+ (('let ((names exps) ...) body)
+ (define exps* (map annotate-free-variables exps))
+ `(let ,(map list names exps*) ,(annotate-free-variables body)))
+ (('lambda (params ...) body)
+ ;; TODO: Actually figure out top-level vars.
+ (define free-vars (free-variables body params '(+ - * /)))
+ `(lambda ,free-vars ,params ,(annotate-free-variables body)))
+ (('primcall operator args ...)
+ `(primcall ,operator ,@(map annotate-free-variables args)))
+ (('call args ...)
+ `(call ,@(map annotate-free-variables args)))))
;;;