diff options
Diffstat (limited to 'chickadee/graphics/seagull/base.scm')
| -rw-r--r-- | chickadee/graphics/seagull/base.scm | 313 |
1 files changed, 313 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/base.scm b/chickadee/graphics/seagull/base.scm new file mode 100644 index 0000000..27f5886 --- /dev/null +++ b/chickadee/graphics/seagull/base.scm @@ -0,0 +1,313 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The base intermediate language for Seagull, before it is converted +;; to continuation-passing style. No static type checking at this +;; level. Analogous to Guile's Tree-IL. +(define-module (chickadee graphics seagull base) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (<constant> + make-constant + constant? + constant-source + constant-value + + <lexical-reference> + make-lexical-reference + lexical-reference? + lexical-reference-source + lexical-reference-source-name + lexical-reference-name + + <struct-reference> + make-struct-reference + struct-reference? + struct-reference-source + struct-reference-value + struct-reference-field + + <array-reference> + make-array-reference + array-reference? + array-reference-source + array-reference-value + array-reference-index + + <assignment> + make-assignment + assignment? + assignment-source + assignment-source-name + assignment-name + assignment-value + + <values> + make-values + values? + values-source + values-expressions + + <sequence> + make-sequence + sequence? + sequence-source + sequence-expressions + + <let> + make-let + let? + let-source + let-source-names + let-names + let-expressions + let-body + + <let-values> + make-let-values + let-values? + let-values-source + let-values-source-names + let-values-names + let-values-expressions + let-values-body + + <conditional> + make-conditional + conditional? + conditional-source + conditional-predicate + conditional-consequent + conditional-alternate + + <function> + make-function + function? + function-source + function-source-names + function-names + function-body + + <primitive-call> + make-primitive-call + primitive-call? + primitive-call-source + primitive-call-name + primitive-call-arguments + + <call> + make-call + call? + call-source + call-function + call-arguments + + <discard> + make-discard + discard? + discard-source + + base->sexp + sexp->base)) + +(define-record-type <constant> + (make-constant source value) + constant? + (source constant-source) + (value constant-value)) + +(define-record-type <lexical-reference> + (make-lexical-reference source source-name name) + lexical-reference? + (source lexical-reference-source) + (source-name lexical-reference-source-name) + (name lexical-reference-name)) + +(define-record-type <struct-reference> + (make-struct-reference source value field) + struct-reference? + (source struct-reference-source) + (value struct-reference-value) + (field struct-reference-field)) + +(define-record-type <array-reference> + (make-array-reference source value index) + array-reference? + (source array-reference-source) + (value array-reference-value) + (index array-reference-index)) + +(define-record-type <assignment> + (make-assignment source source-name name value) + assignment? + (source assignment-source) + (source-name assignment-source-name) + (name assignment-name) + (value assignment-value)) + +(define-record-type <values> + (make-values source expressions) + values? + (source values-source) + (expressions values-expressions)) + +(define-record-type <sequence> + (make-sequence source expressions) + sequence? + (source sequence-source) + (expressions sequence-expressions)) + +(define-record-type <let> + (make-let source source-names names expressions body) + let? + (source let-source) + (source-names let-source-names) + (names let-names) + (expressions let-expressions) + (body let-body)) + +(define-record-type <let-values> + (make-let-values source source-names names expressions body) + let-values? + (source let-values-source) + (source-names let-values-source-names) + (names let-values-names) + (expressions let-values-expressions) + (body let-values-body)) + +(define-record-type <conditional> + (make-conditional source predicate consequent alternate) + conditional? + (source conditional-source) + (predicate conditional-predicate) + (consequent conditional-consequent) + (alternate conditional-alternate)) + +(define-record-type <function> + (make-function source source-names names body) + function? + (source function-source) + (source-names function-source-names) + (names function-names) + (body function-body)) + +(define-record-type <primitive-call> + (make-primitive-call source name arguments) + primitive-call? + (source primitive-call-source) + (name primitive-call-name) + (arguments primitive-call-arguments)) + +(define-record-type <call> + (make-call source function arguments) + call? + (source call-source) + (function call-function) + (arguments call-arguments)) + +(define-record-type <discard> + (make-discard source) + discard? + (source discard-source)) + +(define (base->sexp exp) + (match exp + (($ <constant> _ value) + `(constant ,value)) + (($ <lexical-reference> _ name _) + `(lexical-reference ,name)) + (($ <struct-reference> _ value field) + `(struct-reference ,(base->sexp value) ,field)) + (($ <array-reference> _ value index) + `(array-reference ,(base->sexp value) ,index)) + (($ <assignment> _ name _ value) + `(assignment ,name ,(base->sexp value))) + (($ <values> _ exps) + `(values ,@(map base->sexp exps))) + (($ <sequence> _ exps) + `(sequence ,@(map base->sexp exps))) + (($ <let> _ names _ exps body) + `(let ,(zip names (map base->sexp exps)) ,(base->sexp body))) + (($ <let-values> _ names _ exps body) + `(let-values ,(zip names (map base->sexp exps)) ,(base->sexp body))) + (($ <conditional> _ predicate consequent alternate) + `(conditional ,(base->sexp predicate) + ,(base->sexp consequent) + ,(base->sexp alternate))) + (($ <function> _ names _ body) + `(function ,names ,(base->sexp body))) + (($ <primitive-call> _ op args) + `(primitive-call ,op ,@(map base->sexp args))) + (($ <call> _ function args) + `(call ,(base->sexp function) ,@(map base->sexp args))) + (($ <discard> _) + '(discard)))) + +;; Useful for tests. +(define (sexp->base exp) + (match exp + (('constant value) + (make-constant #f value)) + (('lexical-reference (? symbol? name)) + (make-lexical-reference #f name name)) + (('struct-reference value (? symbol? field)) + (make-struct-reference #f (sexp->base value) field)) + (('array-reference value index) + (make-array-reference #f (sexp->base value) (sexp->base index))) + (('assignment (? symbol? name) value) + (make-assignment #f name name (sexp->base value))) + (('values exps ...) + (make-values #f (map sexp->base exps))) + (('sequence exps ...) + (make-sequence #f (map sexp->base exps))) + (('let ((names exps) ...) body) + (make-let #f names names (map sexp->base exps) (sexp->base body))) + (('let-values (((names ...) exps) ...) body) + (make-let-values #f names names (map sexp->base exps) (sexp->base body))) + (('conditional predicate consequent alternate) + (make-conditional #f + (sexp->base predicate) + (sexp->base consequent) + (sexp->base alternate))) + (('function (names ...) body) + (make-function #f names names (sexp->base body))) + (('primitive-call (? symbol? op) args ...) + (make-primitive-call #f op (map sexp->base args))) + (('call function args ...) + (make-call #f (sexp->base function) (map sexp->base args))) + (('discard) + (make-discard #f)))) + +(define (print-base exp port) + (format port "#<base ~a>" (base->sexp exp))) + +(set-record-type-printer! <constant> print-base) +(set-record-type-printer! <lexical-reference> print-base) +(set-record-type-printer! <struct-reference> print-base) +(set-record-type-printer! <array-reference> print-base) +(set-record-type-printer! <assignment> print-base) +(set-record-type-printer! <values> print-base) +(set-record-type-printer! <sequence> print-base) +(set-record-type-printer! <let> print-base) +(set-record-type-printer! <let-values> print-base) +(set-record-type-printer! <conditional> print-base) +(set-record-type-printer! <function> print-base) +(set-record-type-printer! <primitive-call> print-base) +(set-record-type-printer! <call> print-base) +(set-record-type-printer! <discard> print-base) |