summaryrefslogtreecommitdiff
path: root/flic
diff options
context:
space:
mode:
Diffstat (limited to 'flic')
-rw-r--r--flic/README2
-rw-r--r--flic/ast-to-flic.scm277
-rw-r--r--flic/copy-flic.scm146
-rw-r--r--flic/flic-structs.scm89
-rw-r--r--flic/flic-td.scm21
-rw-r--r--flic/flic-walker.scm21
-rw-r--r--flic/flic.scm29
-rw-r--r--flic/invariant.scm88
-rw-r--r--flic/print-flic.scm130
9 files changed, 803 insertions, 0 deletions
diff --git a/flic/README b/flic/README
new file mode 100644
index 0000000..51af8a5
--- /dev/null
+++ b/flic/README
@@ -0,0 +1,2 @@
+This directory contains code to define FLIC structures and associated
+pretty-printers, and the traversal to convert AST to FLIC structures.
diff --git a/flic/ast-to-flic.scm b/flic/ast-to-flic.scm
new file mode 100644
index 0000000..d756723
--- /dev/null
+++ b/flic/ast-to-flic.scm
@@ -0,0 +1,277 @@
+;;; ast-to-flic.scm -- convert AST to flic structures.
+;;;
+;;; author : Sandra Loosemore
+;;; date : 3 Apr 1992
+;;;
+;;;
+
+
+;;; ====================================================================
+;;; Support
+;;; ====================================================================
+
+
+(define-walker ast-to-flic ast-td-ast-to-flic-walker)
+
+(define-local-syntax (define-ast-to-flic ast-type lambda-list . body)
+ `(define-walker-method ast-to-flic ,ast-type ,lambda-list ,@body))
+
+(define (ast-to-flic big-let)
+ (ast-to-flic-let-aux (let-decls big-let) (make-flic-void) '#t))
+
+(define (ast-to-flic-1 ast-node)
+ (call-walker ast-to-flic ast-node))
+
+(define (ast-to-flic/list l)
+ (map (function ast-to-flic-1) l))
+
+(define (init-flic-var var value toplevel?)
+ (setf (var-value var) value)
+ (setf (var-toplevel? var) toplevel?)
+ (setf (var-simple? var)
+ (and value
+ (or (is-type? 'flic-const value)
+ (is-type? 'flic-pack value))))
+ (setf (var-strict? var) '#f)
+ ;; Remember the strictness annotation.
+ (let ((strictness-ann (lookup-annotation var '|Strictness|)))
+ (setf (var-strictness var)
+ (if strictness-ann
+ (adjust-annotated-strictness var
+ (parse-strictness (car (annotation-value-args strictness-ann))))
+ '#f)))
+ ;; If the variable has an inline annotation, rewrite its value
+ ;; from var = value
+ ;; to var = let temp = value in temp
+ ;; (Necessary for inlining recursive definitions.)
+ (let ((inline-ann (lookup-annotation var '|Inline|)))
+ (when inline-ann
+ (setf (var-force-inline? var) '#t)
+ (setf (var-value var) (wrap-with-let var value))))
+ var)
+
+(define (wrap-with-let var value)
+ (let ((temp (copy-temp-var (def-name var))))
+ (init-flic-var temp (copy-flic value (list (cons var temp))) '#f)
+ (make-flic-let (list temp) (make-flic-ref temp) '#t)))
+
+
+;;; ====================================================================
+;;; ast expression structs
+;;; ====================================================================
+
+
+(define-ast-to-flic lambda (object)
+ (make-flic-lambda
+ (map (lambda (pat)
+ (init-flic-var
+ (cond ((var-pat? pat)
+ (var-ref-var (var-pat-var pat)))
+ (else
+ (error "Bad lambda pattern: ~s." pat)))
+ '#f
+ '#f))
+ (lambda-pats object))
+ (ast-to-flic-1 (lambda-body object))))
+
+
+;;; For LET, the CFN has turned all of the definitions into
+;;; simple assignments to a variable. The dependency analyzer
+;;; adds recursive-decl-groups for things which need to be bound
+;;; with LETREC.
+
+(define-ast-to-flic let (object)
+ (ast-to-flic-let-aux
+ (let-decls object)
+ (ast-to-flic-1 (let-body object))
+ '#f))
+
+(define (ast-to-flic-let-aux decls body toplevel?)
+ (multiple-value-bind (bindings newbody)
+ (ast-to-flic-bindings decls body toplevel?)
+ (if (null? bindings)
+ newbody
+ (make-flic-let bindings newbody toplevel?))))
+
+(define (ast-to-flic-bindings decls body toplevel?)
+ (if (null? decls)
+ (values '() body)
+ (multiple-value-bind (bindings newbody)
+ (ast-to-flic-bindings (cdr decls) body toplevel?)
+ (cond ((is-type? 'valdef (car decls))
+ ;; Continue collecting bindings.
+ (let* ((decl (car decls))
+ (pat (valdef-lhs decl))
+ (exp (single-definition-rhs decl)))
+ (values
+ (cond ((var-pat? pat)
+ (cons
+ (init-flic-var
+ (var-ref-var (var-pat-var pat))
+ (ast-to-flic-1 exp)
+ toplevel?)
+ bindings))
+ (else
+ (error "Definition has invalid pattern: ~s." decl)))
+ newbody)))
+ ((not (is-type? 'recursive-decl-group (car decls)))
+ (error "Decl has weird value: ~s." (car decls)))
+ (toplevel?
+ ;; We don't do any of this mess with top level bindings.
+ ;; Turn it into one big letrec.
+ (multiple-value-bind (more-bindings newerbody)
+ (ast-to-flic-bindings
+ (recursive-decl-group-decls (car decls))
+ newbody
+ toplevel?)
+ (values (nconc more-bindings bindings)
+ newerbody)))
+ (else
+ ;; Otherwise, turn remaining bindings into a nested
+ ;; let or letrec, and put that in the body of a new
+ ;; letrec.
+ (multiple-value-bind (more-bindings newerbody)
+ (ast-to-flic-bindings
+ (recursive-decl-group-decls (car decls))
+ (if (null? bindings)
+ newbody
+ (make-flic-let bindings newbody '#f))
+ toplevel?)
+ (values
+ '()
+ (if (null? more-bindings)
+ newerbody
+ (make-flic-let more-bindings newerbody '#t)))))
+ ))))
+
+
+(define (single-definition-rhs decl)
+ (let* ((def-list (valdef-definitions decl))
+ (def (car def-list))
+ (rhs-list (single-fun-def-rhs-list def))
+ (rhs (car rhs-list)))
+ ;; All of this error checking could be omitted for efficiency, since
+ ;; none of these conditions are supposed to happen anyway.
+ (cond ((not (null? (cdr def-list)))
+ (error "Decl has multiple definitions: ~s." decl))
+ ((not (null? (single-fun-def-where-decls def)))
+ (error "Definition has non-null where-decls list: ~s." decl))
+ ((not (null? (cdr rhs-list)))
+ (error "Definition has multiple right-hand-sides: ~s." decl))
+ ((not (is-type? 'omitted-guard (guarded-rhs-guard rhs)))
+ (error "Definition has a guard: ~s." decl)))
+ (guarded-rhs-rhs rhs)))
+
+
+
+;;; These are all straightforward translations.
+
+(define-ast-to-flic if (object)
+ (make-flic-if
+ (ast-to-flic-1 (if-test-exp object))
+ (ast-to-flic-1 (if-then-exp object))
+ (ast-to-flic-1 (if-else-exp object))))
+
+(define-ast-to-flic case-block (object)
+ (make-flic-case-block
+ (case-block-block-name object)
+ (ast-to-flic/list (case-block-exps object))))
+
+(define-ast-to-flic return-from (object)
+ (make-flic-return-from
+ (return-from-block-name object)
+ (ast-to-flic-1 (return-from-exp object))))
+
+(define-ast-to-flic and-exp (object)
+ (make-flic-and (ast-to-flic/list (and-exp-exps object))))
+
+
+;;; Applications. Uncurry here. It's more convenient to do the
+;;; optimizer on fully uncurried applications. After the optimizer
+;;; has run, all applications are adjusted based on observed arity
+;;; of the functions and the saturated? flag is set correctly.
+
+(define-ast-to-flic app (object)
+ (ast-to-flic-app-aux object '()))
+
+(define (ast-to-flic-app-aux object args)
+ (if (is-type? 'app object)
+ (ast-to-flic-app-aux
+ (app-fn object)
+ (cons (ast-to-flic-1 (app-arg object)) args))
+ (make-flic-app (ast-to-flic-1 object) args '#f)))
+
+
+;;; References
+
+(define-ast-to-flic var-ref (object)
+ (make-flic-ref (var-ref-var object)))
+
+(define-ast-to-flic con-ref (object)
+ (make-flic-pack (con-ref-con object)))
+
+
+;;; Constants
+
+(define-ast-to-flic integer-const (object)
+ (make-flic-const (integer-const-value object)))
+
+
+;;; We should probably add a type field to flic-const but at the moment
+;;; I'll force the value to be a list of numerator, denominator.
+
+(define-ast-to-flic float-const (object)
+ (let ((e (float-const-exponent object))
+ (n (float-const-numerator object))
+ (d (float-const-denominator object)))
+ (make-flic-const
+ (if (> e 0)
+ (list (* n (expt 10 e)) d)
+ (list n (* d (expt 10 (- e))))))))
+
+(define-ast-to-flic char-const (object)
+ (make-flic-const (char-const-value object)))
+
+
+(define-ast-to-flic string-const (object)
+ (let ((value (string-const-value object)))
+ (if (equal? value "")
+ (make-flic-pack (core-symbol "Nil"))
+ (make-flic-const value))))
+
+
+
+;;; Random stuff
+
+(define-ast-to-flic con-number (object)
+ (make-flic-con-number
+ (con-number-type object)
+ (ast-to-flic-1 (con-number-value object))))
+
+(define-ast-to-flic sel (object)
+ (make-flic-sel
+ (sel-constructor object)
+ (sel-slot object)
+ (ast-to-flic-1 (sel-value object))))
+
+(define-ast-to-flic is-constructor (object)
+ (make-flic-is-constructor
+ (is-constructor-constructor object)
+ (ast-to-flic-1 (is-constructor-value object))))
+
+(define-ast-to-flic void (object)
+ (declare (ignore object))
+ (make-flic-void))
+
+
+;;; This hack make strictness annotations work. It adds #t's which correspond
+;;; to the strictness of the dict params.
+
+(define (adjust-annotated-strictness v s)
+ (let* ((ty (var-type v))
+ (c (gtype-context ty)))
+ (dolist (c1 c)
+ (dolist (c2 c1)
+ (declare (ignorable c2))
+ (push '#t s)))
+ s))
diff --git a/flic/copy-flic.scm b/flic/copy-flic.scm
new file mode 100644
index 0000000..373fbd4
--- /dev/null
+++ b/flic/copy-flic.scm
@@ -0,0 +1,146 @@
+;;; copy-flic.scm -- general copy functions for flic structures
+;;;
+;;; author : Sandra Loosemore
+;;; date : 23 Feb 1993
+;;;
+;;;
+
+
+;;; The var-renamings argument is an a-list. It's used to map local vars
+;;; in the input expression to new, gensymed vars.
+
+(define-flic-walker copy-flic (object var-renamings))
+
+(define (copy-flic-list objects var-renamings)
+ (let ((result '()))
+ (dolist (o objects)
+ (push (copy-flic o var-renamings) result))
+ (nreverse result)))
+
+
+(define (copy-flic-top object)
+ (copy-flic object '()))
+
+
+(define-copy-flic flic-lambda (object var-renamings)
+ (let ((new-vars (map (lambda (v)
+ (let ((new (copy-temp-var (def-name v))))
+ (push (cons v new) var-renamings)
+ (when (var-force-strict? v)
+ (setf (var-force-strict? new) '#t))
+ (init-flic-var new '#f '#f)))
+ (flic-lambda-vars object))))
+ (make-flic-lambda
+ new-vars
+ (copy-flic (flic-lambda-body object) var-renamings))))
+
+
+;;; Hack to avoid concatenating multiple gensym suffixes.
+
+(define (copy-temp-var sym)
+ (if (gensym? sym)
+ (let* ((string (symbol->string sym))
+ (n (string-length string))
+ (root (find-string-prefix string 0 n)))
+ (create-temp-var root))
+ (create-temp-var sym)))
+
+(define (find-string-prefix string i n)
+ (declare (type string string) (type fixnum i n))
+ (cond ((eqv? i n)
+ string)
+ ((char-numeric? (string-ref string i))
+ (substring string 0 i))
+ (else
+ (find-string-prefix string (+ i 1) n))))
+
+
+(define-copy-flic flic-let (object var-renamings)
+ (let ((new-vars (map (lambda (v)
+ (let ((new (copy-temp-var (def-name v))))
+ (when (var-force-inline? v)
+ (setf (var-force-inline? new) '#t))
+ (push (cons v new) var-renamings)
+ new))
+ (flic-let-bindings object))))
+ (for-each
+ (lambda (new old)
+ (init-flic-var new (copy-flic (var-value old) var-renamings) '#f))
+ new-vars
+ (flic-let-bindings object))
+ (make-flic-let
+ new-vars
+ (copy-flic (flic-let-body object) var-renamings)
+ (flic-let-recursive? object))))
+
+(define-copy-flic flic-app (object var-renamings)
+ (make-flic-app
+ (copy-flic (flic-app-fn object) var-renamings)
+ (copy-flic-list (flic-app-args object) var-renamings)
+ (flic-app-saturated? object)))
+
+(define-copy-flic flic-ref (object var-renamings)
+ (let* ((var (flic-ref-var object))
+ (entry (assq var var-renamings)))
+ (if entry
+ (make-flic-ref (cdr entry))
+ (make-flic-ref var)))) ; don't share structure
+
+
+(define-copy-flic flic-const (object var-renamings)
+ (declare (ignore var-renamings))
+ (make-flic-const (flic-const-value object))) ; don't share structure
+
+(define-copy-flic flic-pack (object var-renamings)
+ (declare (ignore var-renamings))
+ (make-flic-pack (flic-pack-con object))) ; don't share structure
+
+
+;;; Don't have to gensym new block names; these constructs always
+;;; happen in pairs.
+
+(define-copy-flic flic-case-block (object var-renamings)
+ (make-flic-case-block
+ (flic-case-block-block-name object)
+ (copy-flic-list (flic-case-block-exps object) var-renamings)))
+
+(define-copy-flic flic-return-from (object var-renamings)
+ (make-flic-return-from
+ (flic-return-from-block-name object)
+ (copy-flic (flic-return-from-exp object) var-renamings)))
+
+(define-copy-flic flic-and (object var-renamings)
+ (make-flic-and
+ (copy-flic-list (flic-and-exps object) var-renamings)))
+
+(define-copy-flic flic-if (object var-renamings)
+ (make-flic-if
+ (copy-flic (flic-if-test-exp object) var-renamings)
+ (copy-flic (flic-if-then-exp object) var-renamings)
+ (copy-flic (flic-if-else-exp object) var-renamings)))
+
+(define-copy-flic flic-sel (object var-renamings)
+ (make-flic-sel
+ (flic-sel-con object)
+ (flic-sel-i object)
+ (copy-flic (flic-sel-exp object) var-renamings)))
+
+(define-copy-flic flic-is-constructor (object var-renamings)
+ (make-flic-is-constructor
+ (flic-is-constructor-con object)
+ (copy-flic (flic-is-constructor-exp object) var-renamings)))
+
+(define-copy-flic flic-con-number (object var-renamings)
+ (make-flic-con-number
+ (flic-con-number-type object)
+ (copy-flic (flic-con-number-exp object) var-renamings)))
+
+(define-copy-flic flic-void (object var-renamings)
+ (declare (ignore object var-renamings))
+ (make-flic-void)) ; don't share structure
+
+
+
+
+
+
diff --git a/flic/flic-structs.scm b/flic/flic-structs.scm
new file mode 100644
index 0000000..2aab75c
--- /dev/null
+++ b/flic/flic-structs.scm
@@ -0,0 +1,89 @@
+;;; flic-structs.scm -- structures to define FLIC intermediate language
+;;;
+;;; author : Sandra Loosemore
+;;; date : 24 Mar 1992
+
+
+
+(define-struct flic-exp
+ (type-template flic-td)
+ (slots
+ (unboxed? (type bool) (default '#f) (bit #t))
+ (cheap? (type bool) (default '#f) (bit #t))))
+
+
+;;; Use a macro to define each subtype and a BOA constructor.
+;;; Maybe eventually the constructors will need to do additional
+;;; initialization and have to be defined by hand.
+
+(define-local-syntax (define-flic name . slots)
+ (let* ((maker (symbol-append 'make- name))
+ (pred (symbol-append name '?))
+ (args (map (function car) slots))
+ (inits (map (lambda (x) (list x x)) args)))
+ `(begin
+ (define-struct ,name
+ (include flic-exp)
+ (predicate ,pred)
+ (slots ,@slots))
+ (define (,maker ,@args) (make ,name ,@inits))
+ ',name)))
+
+(define-flic flic-lambda
+ (vars (type (list var)))
+ (body (type flic-exp)))
+
+(define-flic flic-let
+ ;; value exp is stored in var-value slot
+ (bindings (type (list var)))
+ (body (type flic-exp))
+ (recursive? (type bool) (bit #t)))
+
+(define-flic flic-app
+ (fn (type flic-exp))
+ (args (type (list flic-exp)))
+ ;; true if number of args exactly matches arity of fn
+ (saturated? (type bool) (bit #t)))
+
+(define-flic flic-ref
+ (var (type var)))
+
+(define-flic flic-const
+ (value (type t)))
+
+(define-flic flic-pack
+ (con (type con)))
+
+(define-flic flic-case-block
+ (block-name (type symbol))
+ (exps (type (list flic-exp))))
+
+(define-flic flic-return-from
+ (block-name (type symbol))
+ (exp (type flic-exp)))
+
+(define-flic flic-and
+ (exps (type (list flic-exp))))
+
+(define-flic flic-if
+ (test-exp (type flic-exp))
+ (then-exp (type flic-exp))
+ (else-exp (type flic-exp)))
+
+(define-flic flic-sel
+ (con (type con))
+ (i (type int))
+ (exp (type flic-exp)))
+
+(define-flic flic-is-constructor
+ (con (type con))
+ (exp (type flic-exp)))
+
+(define-flic flic-con-number
+ (type (type algdata))
+ (exp (type flic-exp)))
+
+(define-flic flic-void
+ )
+
+
diff --git a/flic/flic-td.scm b/flic/flic-td.scm
new file mode 100644
index 0000000..01253b0
--- /dev/null
+++ b/flic/flic-td.scm
@@ -0,0 +1,21 @@
+;;; flic-td.scm -- define type descriptor for flic structs
+;;;
+;;; author : Sandra Loosemore
+;;; date : 6 Oct 1992
+;;;
+
+(define-struct flic-td
+ (include type-descriptor)
+ (slots
+ (codegen-walker (type (maybe procedure)) (default '#f))
+ (optimize-walker (type (maybe procedure)) (default '#f))
+ (postoptimize-walker (type (maybe procedure)) (default '#f))
+ (fun-strictness-walk-walker (type (maybe procedure)) (default '#f))
+ (var-strictness-walk-walker (type (maybe procedure)) (default '#f))
+ (compute-strictness-walk-walker (type (maybe procedure)) (default '#f))
+ (print-strictness-walker (type (maybe procedure)) (default '#f))
+ (box-analysis-walker (type (maybe procedure)) (default '#f))
+ (copy-flic-walker (type (maybe procedure)) (default '#f))
+ (dump-flic-walker (type (maybe procedure)) (default '#f))
+ (flic-invariant?-walker (type (maybe procedure)) (default '#f))
+ ))
diff --git a/flic/flic-walker.scm b/flic/flic-walker.scm
new file mode 100644
index 0000000..846d89f
--- /dev/null
+++ b/flic/flic-walker.scm
@@ -0,0 +1,21 @@
+;;; flic-walker.scm -- macros for defining code walkers for flic
+;;;
+;;; author : Sandra Loosemore
+;;; date : 7 May 1992
+;;;
+
+
+;;; (define-flic-walker foo (object))
+;;; creates a macro (define-foo type (object) . body)
+;;; and a function (foo object) that dispatches on the type of object.
+
+(define-syntax (define-flic-walker name args)
+ (let ((accessor-name (symbol-append 'flic-td- name '-walker))
+ (definer-name (symbol-append 'define- name)))
+ `(begin
+ (define-walker ,name ,accessor-name)
+ (define-local-syntax (,definer-name type args . body)
+ `(define-walker-method ,',name ,type ,args ,@body))
+ (define (,name ,@args)
+ (call-walker ,name ,@args)))))
+
diff --git a/flic/flic.scm b/flic/flic.scm
new file mode 100644
index 0000000..8aa389a
--- /dev/null
+++ b/flic/flic.scm
@@ -0,0 +1,29 @@
+;;; flic.scm -- compilation unit for flic stuff
+;;;
+;;; author : Sandra Loosemore
+;;; date : 7 Apr 1992
+;;;
+
+
+(define-compilation-unit flic
+ (source-filename "$Y2/flic/")
+ (unit flic-td
+ (source-filename "flic-td.scm"))
+ (unit flic-structs
+ (source-filename "flic-structs.scm")
+ (require flic-td))
+ (unit print-flic
+ (source-filename "print-flic.scm")
+ (require flic-structs printer-support))
+ (unit ast-to-flic
+ (source-filename "ast-to-flic.scm")
+ (require flic-structs ast haskell-utils))
+ (unit flic-walker
+ (source-filename "flic-walker.scm"))
+ (unit copy-flic
+ (source-filename "copy-flic.scm")
+ (require flic-walker flic-structs))
+ (unit invariant
+ (source-filename "invariant.scm")
+ (require flic-walker flic-structs))
+ )
diff --git a/flic/invariant.scm b/flic/invariant.scm
new file mode 100644
index 0000000..c6c0486
--- /dev/null
+++ b/flic/invariant.scm
@@ -0,0 +1,88 @@
+;;; invariant.scm -- look for invariant expressions
+;;;
+;;; author : Sandra Loosemore
+;;; date : 12 Mar 1993
+;;;
+;;;
+;;; The function flic-invariant? returns true if the expression is
+;;; invariant with respect to a set of local variable bindings.
+
+(define-flic-walker flic-invariant? (object local-bindings))
+
+(define (flic-invariant-list? objects local-bindings)
+ (if (null objects)
+ '#t
+ (and (flic-invariant? (car objects) local-bindings)
+ (flic-invariant-list? (cdr objects) local-bindings))))
+
+(define-flic-invariant? flic-lambda (object local-bindings)
+ (flic-invariant? (flic-lambda-body object)
+ (cons (flic-lambda-vars object) local-bindings)))
+
+(define-flic-invariant? flic-let (object local-bindings)
+ (let* ((bindings (flic-let-bindings object))
+ (body (flic-let-body object))
+ (recursive? (flic-let-recursive? object))
+ (inner-stuff (cons bindings local-bindings)))
+ (and (flic-invariant-list? (map (function var-value) bindings)
+ (if recursive? inner-stuff local-bindings))
+ (flic-invariant? body inner-stuff))))
+
+(define-flic-invariant? flic-app (object local-bindings)
+ (and (flic-invariant? (flic-app-fn object) local-bindings)
+ (flic-invariant-list? (flic-app-args object) local-bindings)))
+
+(define-flic-invariant? flic-ref (object local-bindings)
+ (let ((var (flic-ref-var object)))
+ (or (var-toplevel? var)
+ (flic-local-var? var local-bindings))))
+
+(define (flic-local-var? var local-bindings)
+ (cond ((null? local-bindings)
+ '#f)
+ ((memq var (car local-bindings))
+ '#t)
+ (else
+ (flic-local-var? var (cdr local-bindings)))))
+
+(define-flic-invariant? flic-const (object local-bindings)
+ (declare (ignore object local-bindings))
+ '#t)
+
+(define-flic-invariant? flic-pack (object local-bindings)
+ (declare (ignore object local-bindings))
+ '#t)
+
+(define-flic-invariant? flic-case-block (object local-bindings)
+ (flic-invariant-list? (flic-case-block-exps object) local-bindings))
+
+(define-flic-invariant? flic-return-from (object local-bindings)
+ (flic-invariant? (flic-return-from-exp object) local-bindings))
+
+(define-flic-invariant? flic-and (object local-bindings)
+ (flic-invariant-list? (flic-and-exps object) local-bindings))
+
+(define-flic-invariant? flic-if (object local-bindings)
+ (and (flic-invariant? (flic-if-test-exp object) local-bindings)
+ (flic-invariant? (flic-if-then-exp object) local-bindings)
+ (flic-invariant? (flic-if-else-exp object) local-bindings)))
+
+(define-flic-invariant? flic-sel (object local-bindings)
+ (flic-invariant? (flic-sel-exp object) local-bindings))
+
+(define-flic-invariant? flic-is-constructor (object local-bindings)
+ (flic-invariant? (flic-is-constructor-exp object) local-bindings))
+
+(define-flic-invariant? flic-con-number (object local-bindings)
+ (flic-invariant? (flic-con-number-exp object) local-bindings))
+
+(define-flic-invariant? flic-void (object local-bindings)
+ (declare (ignore object local-bindings))
+ '#t)
+
+
+
+
+
+
+
diff --git a/flic/print-flic.scm b/flic/print-flic.scm
new file mode 100644
index 0000000..6077f57
--- /dev/null
+++ b/flic/print-flic.scm
@@ -0,0 +1,130 @@
+;;; print-flic.scm -- printers for FLIC structures
+;;;
+;;; author : Sandra Loosemore
+;;; date : 30 Mar 1992
+;;;
+;;;
+
+
+;;; For now, printing of FLIC structures is controlled by the same
+;;; *print-ast-syntax* variable as for AST structures.
+;;; Maybe eventually this should use its own variable.
+
+(define-syntax (define-flic-printer type lambda-list . body)
+ `(define-ast-printer ,type ,lambda-list ,@body))
+
+(define-flic-printer flic-lambda (object xp)
+ (with-ast-block (xp)
+ (write-string "\\ " xp)
+ (write-ordinary-list (flic-lambda-vars object) xp)
+ (write-string " ->" xp)
+ (write-whitespace xp)
+ (write (flic-lambda-body object) xp)))
+
+(define-flic-printer flic-let (object xp)
+ (pprint-logical-block (xp '() "" "") ; no extra indentation
+ (write-string "let " xp)
+ (write-layout-rule (flic-let-bindings object) xp
+ (lambda (v xp)
+ (with-ast-block (xp)
+ (write v xp)
+ (write-string " =" xp)
+ (write-whitespace xp)
+ (write (var-value v) xp))))
+ (write-whitespace xp)
+ (write-string "in " xp)
+ (write (flic-let-body object) xp)))
+
+(define-flic-printer flic-app (object xp)
+ (with-ast-block (xp)
+ (maybe-paren-flic-object (flic-app-fn object) xp)
+ (write-whitespace xp)
+ (write-flic-list (flic-app-args object) xp)))
+
+(define (maybe-paren-flic-object object xp)
+ (cond ((or (flic-ref? object)
+ (flic-const? object)
+ (flic-pack? object))
+ (write object xp))
+ (else
+ (write-char #\( xp)
+ (write object xp)
+ (write-char #\) xp))))
+
+(define (write-flic-list objects xp)
+ (write-delimited-list objects xp (function maybe-paren-flic-object) "" "" ""))
+
+(define-flic-printer flic-ref (object xp)
+ (write (flic-ref-var object) xp))
+
+(define-flic-printer flic-const (object xp)
+ (write (flic-const-value object) xp))
+
+(define-flic-printer flic-pack (object xp)
+ (write-string "pack/" xp)
+ (write (flic-pack-con object) xp))
+
+(define-flic-printer flic-case-block (object xp)
+ (with-ast-block (xp)
+ (write-string "case-block " xp)
+ (write (flic-case-block-block-name object) xp)
+ (write-whitespace xp)
+ (write-layout-rule (flic-case-block-exps object) xp (function write))))
+
+(define-flic-printer flic-return-from (object xp)
+ (with-ast-block (xp)
+ (write-string "return-from " xp)
+ (write (flic-return-from-block-name object) xp)
+ (write-whitespace xp)
+ (write (flic-return-from-exp object) xp)))
+
+(define-flic-printer flic-and (object xp)
+ (with-ast-block (xp)
+ (write-string "and " xp)
+ (write-layout-rule (flic-and-exps object) xp (function write))))
+
+(define-flic-printer flic-if (object xp)
+ (with-ast-block (xp)
+ (write-string "if " xp)
+ (write (flic-if-test-exp object) xp)
+ (write-whitespace xp)
+ (with-ast-block (xp)
+ (write-string "then" xp)
+ (write-whitespace xp)
+ (write (flic-if-then-exp object) xp))
+ (write-whitespace xp)
+ (with-ast-block (xp)
+ (write-string "else" xp)
+ (write-whitespace xp)
+ (write (flic-if-else-exp object) xp))
+ ))
+
+
+(define-flic-printer flic-sel (object xp)
+ (with-ast-block (xp)
+ (write-string "sel/" xp)
+ (write (flic-sel-con object) xp)
+ (write-char #\/ xp)
+ (write (flic-sel-i object) xp)
+ (write-whitespace xp)
+ (write (flic-sel-exp object) xp)))
+
+(define-flic-printer flic-is-constructor (object xp)
+ (with-ast-block (xp)
+ (write-string "is-constructor/" xp)
+ (write (flic-is-constructor-con object) xp)
+ (write-whitespace xp)
+ (write (flic-is-constructor-exp object) xp)))
+
+(define-flic-printer flic-con-number (object xp)
+ (with-ast-block (xp)
+ (write-string "con/" xp)
+ (write (flic-con-number-type object) xp)
+ (write-whitespace xp)
+ (write (flic-con-number-exp object) xp)))
+
+(define-flic-printer flic-void (object xp)
+ (declare (ignore object))
+ (write-string "Void" xp))
+
+ \ No newline at end of file
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 01:00:39 +0000