Import to github.

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