Import to github.
authorYale AI Dept <ai@nebula.cs.yale.edu>
Wed, 14 Jul 1993 18:08:00 +0000 (13:08 -0500)
committerDuncan McGreggor <duncan.mcgreggor@rackspace.com>
Wed, 14 Jul 1993 18:08:00 +0000 (13:08 -0500)
390 files changed:
Copyright [new file with mode: 0644]
README [new file with mode: 0644]
ast/README [new file with mode: 0644]
ast/ast-td.scm [new file with mode: 0644]
ast/ast.scm [new file with mode: 0644]
ast/definitions.scm [new file with mode: 0644]
ast/exp-structs.scm [new file with mode: 0644]
ast/modules.scm [new file with mode: 0644]
ast/predicates.scm [new file with mode: 0644]
ast/tc-structs.scm [new file with mode: 0644]
ast/type-structs.scm [new file with mode: 0644]
ast/valdef-structs.scm [new file with mode: 0644]
backend/README [new file with mode: 0644]
backend/backend.scm [new file with mode: 0644]
backend/box.scm [new file with mode: 0644]
backend/codegen.scm [new file with mode: 0644]
backend/interface-codegen.scm [new file with mode: 0644]
backend/optimize.scm [new file with mode: 0644]
backend/strictness.scm [new file with mode: 0644]
bin/cmu-clx-haskell [new file with mode: 0755]
bin/cmu-haskell [new file with mode: 0755]
bin/magic.scm [new file with mode: 0644]
cfn/README [new file with mode: 0644]
cfn/cfn.scm [new file with mode: 0644]
cfn/main.scm [new file with mode: 0644]
cfn/misc.scm [new file with mode: 0644]
cfn/pattern.scm [new file with mode: 0644]
cl-support/PORTING [new file with mode: 0644]
cl-support/README [new file with mode: 0644]
cl-support/cl-definitions.lisp [new file with mode: 0644]
cl-support/cl-init.lisp [new file with mode: 0644]
cl-support/cl-setup.lisp [new file with mode: 0644]
cl-support/cl-structs.lisp [new file with mode: 0644]
cl-support/cl-support.lisp [new file with mode: 0644]
cl-support/cl-types.lisp [new file with mode: 0644]
cl-support/wcl-patches.lisp [new file with mode: 0644]
com/README [new file with mode: 0644]
com/akcl/README [new file with mode: 0644]
com/akcl/build-prelude [new file with mode: 0755]
com/akcl/clean [new file with mode: 0755]
com/akcl/compile [new file with mode: 0755]
com/akcl/savesys [new file with mode: 0755]
com/allegro/README [new file with mode: 0644]
com/allegro/build-prelude [new file with mode: 0755]
com/allegro/build-xlib [new file with mode: 0755]
com/allegro/clean [new file with mode: 0755]
com/allegro/compile [new file with mode: 0755]
com/allegro/next-patches/patch0149.fasl [new file with mode: 0644]
com/allegro/next-patches/patch0151.fasl [new file with mode: 0644]
com/allegro/savesys [new file with mode: 0755]
com/allegro/savesys-xlib [new file with mode: 0755]
com/allegro/sparc-patches/patch0151.fasl [new file with mode: 0644]
com/clean [new file with mode: 0755]
com/cmu/README [new file with mode: 0644]
com/cmu/build-prelude [new file with mode: 0755]
com/cmu/build-xlib [new file with mode: 0755]
com/cmu/clean [new file with mode: 0755]
com/cmu/compile [new file with mode: 0755]
com/cmu/savesys [new file with mode: 0755]
com/cmu/savesys-xlib [new file with mode: 0755]
com/lispworks/README [new file with mode: 0644]
com/lispworks/build-prelude [new file with mode: 0755]
com/lispworks/build-xlib [new file with mode: 0755]
com/lispworks/clean [new file with mode: 0755]
com/lispworks/compile [new file with mode: 0755]
com/lispworks/patches/safe-fo-closure.wfasl [new file with mode: 0644]
com/lispworks/savesys [new file with mode: 0755]
com/lispworks/savesys-xlib [new file with mode: 0755]
com/locked [new file with mode: 0755]
com/lookfor [new file with mode: 0755]
com/lucid/README [new file with mode: 0644]
com/lucid/build-prelude [new file with mode: 0755]
com/lucid/build-xlib [new file with mode: 0755]
com/lucid/clean [new file with mode: 0755]
com/lucid/compile [new file with mode: 0755]
com/lucid/savesys [new file with mode: 0755]
com/lucid/savesys-xlib [new file with mode: 0755]
com/unchecked [new file with mode: 0755]
command-interface-help [new file with mode: 0644]
command-interface/README [new file with mode: 0644]
command-interface/command-interface.scm [new file with mode: 0644]
command-interface/command-utils.scm [new file with mode: 0644]
command-interface/command.scm [new file with mode: 0644]
command-interface/incremental-compiler.scm [new file with mode: 0644]
csys/README [new file with mode: 0644]
csys/cache-structs.scm [new file with mode: 0644]
csys/compiler-driver.scm [new file with mode: 0644]
csys/csys.scm [new file with mode: 0644]
csys/dump-cse.scm [new file with mode: 0644]
csys/dump-flic.scm [new file with mode: 0644]
csys/dump-interface.scm [new file with mode: 0644]
csys/dump-macros.scm [new file with mode: 0644]
csys/dump-params.scm [new file with mode: 0644]
csys/magic.scm [new file with mode: 0644]
depend/README [new file with mode: 0644]
depend/depend.scm [new file with mode: 0644]
depend/dependency-analysis.scm [new file with mode: 0644]
derived/README [new file with mode: 0644]
derived/ast-builders.scm [new file with mode: 0644]
derived/derived-instances.scm [new file with mode: 0644]
derived/derived.scm [new file with mode: 0644]
derived/eq-ord.scm [new file with mode: 0644]
derived/ix-enum.scm [new file with mode: 0644]
derived/text-binary.scm [new file with mode: 0644]
doc/announcement [new file with mode: 0644]
doc/comparison [new file with mode: 0644]
doc/lisp-interface/lisp-interface.dvi [new file with mode: 0644]
doc/manual/haskell.dvi [new file with mode: 0644]
doc/optimizer/optimizer.dvi [new file with mode: 0644]
doc/tutorial/tutorial.ps [new file with mode: 0644]
doc/xinterface/xman.dvi [new file with mode: 0644]
emacs-tools/README [new file with mode: 0644]
emacs-tools/comint.el [new file with mode: 0644]
emacs-tools/comint.elc [new file with mode: 0644]
emacs-tools/haskell.el [new file with mode: 0644]
emacs-tools/haskell.elc [new file with mode: 0644]
emacs-tools/optimizer-help.txt [new file with mode: 0644]
emacs-tools/printer-help.txt [new file with mode: 0644]
flic/README [new file with mode: 0644]
flic/ast-to-flic.scm [new file with mode: 0644]
flic/copy-flic.scm [new file with mode: 0644]
flic/flic-structs.scm [new file with mode: 0644]
flic/flic-td.scm [new file with mode: 0644]
flic/flic-walker.scm [new file with mode: 0644]
flic/flic.scm [new file with mode: 0644]
flic/invariant.scm [new file with mode: 0644]
flic/print-flic.scm [new file with mode: 0644]
haskell-development [new file with mode: 0755]
haskell-setup [new file with mode: 0755]
import-export/README [new file with mode: 0644]
import-export/ie-errors.scm [new file with mode: 0644]
import-export/ie-utils.scm [new file with mode: 0644]
import-export/ie.scm [new file with mode: 0644]
import-export/import-export.scm [new file with mode: 0644]
import-export/init-modules.scm [new file with mode: 0644]
import-export/locate-entity.scm [new file with mode: 0644]
import-export/top-definitions.scm [new file with mode: 0644]
parser/README [new file with mode: 0644]
parser/annotation-parser.scm [new file with mode: 0644]
parser/decl-parser.scm [new file with mode: 0644]
parser/exp-parser.scm [new file with mode: 0644]
parser/interface-parser.scm [new file with mode: 0644]
parser/lexer.scm [new file with mode: 0644]
parser/module-parser.scm [new file with mode: 0644]
parser/parser-debugger.scm [new file with mode: 0644]
parser/parser-driver.scm [new file with mode: 0644]
parser/parser-errors.scm [new file with mode: 0644]
parser/parser-globals.scm [new file with mode: 0644]
parser/parser-macros.scm [new file with mode: 0644]
parser/parser.scm [new file with mode: 0644]
parser/pattern-parser.scm [new file with mode: 0644]
parser/token.scm [new file with mode: 0644]
parser/type-parser.scm [new file with mode: 0644]
parser/typedecl-parser.scm [new file with mode: 0644]
prec/README [new file with mode: 0644]
prec/prec-parse.scm [new file with mode: 0644]
prec/prec.scm [new file with mode: 0644]
prec/scope.scm [new file with mode: 0644]
printers/README [new file with mode: 0644]
printers/print-exps.scm [new file with mode: 0644]
printers/print-modules.scm [new file with mode: 0644]
printers/print-ntypes.scm [new file with mode: 0644]
printers/print-types.scm [new file with mode: 0644]
printers/print-valdefs.scm [new file with mode: 0644]
printers/printers.scm [new file with mode: 0644]
printers/util.scm [new file with mode: 0644]
progs/README [new file with mode: 0644]
progs/demo/Calendar.hs [new file with mode: 0644]
progs/demo/README [new file with mode: 0644]
progs/demo/X11/animation/README [new file with mode: 0644]
progs/demo/X11/animation/animation.hs [new file with mode: 0644]
progs/demo/X11/animation/animation.hu [new file with mode: 0644]
progs/demo/X11/animation/birds.hs [new file with mode: 0644]
progs/demo/X11/animation/birds.hu [new file with mode: 0644]
progs/demo/X11/animation/doc.tex [new file with mode: 0644]
progs/demo/X11/animation/palm.hs [new file with mode: 0644]
progs/demo/X11/animation/palm.hu [new file with mode: 0644]
progs/demo/X11/animation/planets.hs [new file with mode: 0644]
progs/demo/X11/animation/planets.hu [new file with mode: 0644]
progs/demo/X11/animation/r_behaviour.hs [new file with mode: 0644]
progs/demo/X11/animation/r_behaviour.hu [new file with mode: 0644]
progs/demo/X11/animation/r_constants.hs [new file with mode: 0644]
progs/demo/X11/animation/r_constants.hu [new file with mode: 0644]
progs/demo/X11/animation/r_curve.hs [new file with mode: 0644]
progs/demo/X11/animation/r_curve.hu [new file with mode: 0644]
progs/demo/X11/animation/r_defaults.hs [new file with mode: 0644]
progs/demo/X11/animation/r_defaults.hu [new file with mode: 0644]
progs/demo/X11/animation/r_display.hs [new file with mode: 0644]
progs/demo/X11/animation/r_display.hu [new file with mode: 0644]
progs/demo/X11/animation/r_inbetween.hs [new file with mode: 0644]
progs/demo/X11/animation/r_inbetween.hu [new file with mode: 0644]
progs/demo/X11/animation/r_movie.hs [new file with mode: 0644]
progs/demo/X11/animation/r_movie.hu [new file with mode: 0644]
progs/demo/X11/animation/r_picture.hs [new file with mode: 0644]
progs/demo/X11/animation/r_picture.hu [new file with mode: 0644]
progs/demo/X11/animation/r_ptypes.hs [new file with mode: 0644]
progs/demo/X11/animation/r_ptypes.hu [new file with mode: 0644]
progs/demo/X11/animation/r_shapes.hs [new file with mode: 0644]
progs/demo/X11/animation/r_shapes.hu [new file with mode: 0644]
progs/demo/X11/animation/r_utility.hs [new file with mode: 0644]
progs/demo/X11/animation/r_utility.hu [new file with mode: 0644]
progs/demo/X11/animation/seafigs.hs [new file with mode: 0644]
progs/demo/X11/animation/seafigs.hu [new file with mode: 0644]
progs/demo/X11/animation/seaside.hs [new file with mode: 0644]
progs/demo/X11/animation/seaside.hu [new file with mode: 0644]
progs/demo/X11/draw/README [new file with mode: 0644]
progs/demo/X11/draw/draw.hs [new file with mode: 0644]
progs/demo/X11/draw/draw.hu [new file with mode: 0644]
progs/demo/X11/gobang/README [new file with mode: 0644]
progs/demo/X11/gobang/gobang.hs [new file with mode: 0644]
progs/demo/X11/gobang/gobang.hu [new file with mode: 0644]
progs/demo/X11/gobang/misc.hi [new file with mode: 0644]
progs/demo/X11/gobang/misc.hu [new file with mode: 0644]
progs/demo/X11/gobang/redraw.hs [new file with mode: 0644]
progs/demo/X11/gobang/redraw.hu [new file with mode: 0644]
progs/demo/X11/gobang/utilities.hs [new file with mode: 0644]
progs/demo/X11/gobang/utilities.hu [new file with mode: 0644]
progs/demo/X11/gobang/weights.hs [new file with mode: 0644]
progs/demo/X11/gobang/weights.hu [new file with mode: 0644]
progs/demo/X11/graphics/README [new file with mode: 0644]
progs/demo/X11/graphics/henderson.hs [new file with mode: 0644]
progs/demo/X11/graphics/henderson.hu [new file with mode: 0644]
progs/demo/X11/graphics/manual [new file with mode: 0644]
progs/demo/X11/graphics/p.pic [new file with mode: 0644]
progs/demo/X11/graphics/q.pic [new file with mode: 0644]
progs/demo/X11/graphics/r.pic [new file with mode: 0644]
progs/demo/X11/graphics/s.pic [new file with mode: 0644]
progs/demo/X11/graphics/sqrlmt.hs [new file with mode: 0644]
progs/demo/X11/graphics/sqrlmt.hu [new file with mode: 0644]
progs/demo/X11/graphics/stop.pic [new file with mode: 0644]
progs/demo/X11/graphics/strange.pic [new file with mode: 0644]
progs/demo/X11/graphics/text.pic [new file with mode: 0644]
progs/demo/X11/logo/EXAMPLES.LOGO [new file with mode: 0644]
progs/demo/X11/logo/README [new file with mode: 0644]
progs/demo/X11/logo/logo.hs [new file with mode: 0644]
progs/demo/X11/logo/logo.hu [new file with mode: 0644]
progs/demo/X11/mdraw/README [new file with mode: 0644]
progs/demo/X11/mdraw/mdraw.hs [new file with mode: 0644]
progs/demo/X11/mdraw/mdraw.hu [new file with mode: 0644]
progs/demo/X11/mdraw/t.hs [new file with mode: 0644]
progs/demo/X11/mdraw/t.hu [new file with mode: 0644]
progs/demo/add.hs [new file with mode: 0644]
progs/demo/eliza.hs [new file with mode: 0644]
progs/demo/fact.hs [new file with mode: 0755]
progs/demo/improved-add.hs [new file with mode: 0644]
progs/demo/merge.hs [new file with mode: 0755]
progs/demo/pascal.hs [new file with mode: 0644]
progs/demo/pfac.hs [new file with mode: 0644]
progs/demo/primes.hs [new file with mode: 0755]
progs/demo/prolog/Engine.hs [new file with mode: 0644]
progs/demo/prolog/Engine.hu [new file with mode: 0644]
progs/demo/prolog/Interact.hs [new file with mode: 0644]
progs/demo/prolog/Interact.hu [new file with mode: 0644]
progs/demo/prolog/Main.hs [new file with mode: 0644]
progs/demo/prolog/Main.hu [new file with mode: 0644]
progs/demo/prolog/Parse.hs [new file with mode: 0644]
progs/demo/prolog/Parse.hu [new file with mode: 0644]
progs/demo/prolog/PrologData.hs [new file with mode: 0644]
progs/demo/prolog/PrologData.hu [new file with mode: 0644]
progs/demo/prolog/README [new file with mode: 0644]
progs/demo/prolog/Subst.hs [new file with mode: 0644]
progs/demo/prolog/Subst.hu [new file with mode: 0644]
progs/demo/prolog/Version.hs [new file with mode: 0644]
progs/demo/prolog/Version.hu [new file with mode: 0644]
progs/demo/prolog/stdlib [new file with mode: 0644]
progs/demo/queens.hs [new file with mode: 0755]
progs/demo/quicksort.hs [new file with mode: 0644]
progs/lib/README [new file with mode: 0644]
progs/lib/X11/README [new file with mode: 0644]
progs/lib/X11/clx-patch.lisp [new file with mode: 0644]
progs/lib/X11/xlib.hs [new file with mode: 0644]
progs/lib/X11/xlib.hu [new file with mode: 0644]
progs/lib/X11/xlibclx.scm [new file with mode: 0644]
progs/lib/X11/xlibprims.hi [new file with mode: 0644]
progs/lib/X11/xlibprims.hu [new file with mode: 0644]
progs/lib/cl/README [new file with mode: 0644]
progs/lib/cl/logop-prims.hi [new file with mode: 0644]
progs/lib/cl/logop-prims.scm [new file with mode: 0644]
progs/lib/cl/logop.hs [new file with mode: 0644]
progs/lib/cl/logop.hu [new file with mode: 0644]
progs/lib/cl/maybe.hs [new file with mode: 0644]
progs/lib/cl/maybe.hu [new file with mode: 0644]
progs/lib/cl/random-prims.hi [new file with mode: 0644]
progs/lib/cl/random.hs [new file with mode: 0644]
progs/lib/cl/random.hu [new file with mode: 0644]
progs/lib/hbc/Either.hs [new file with mode: 0644]
progs/lib/hbc/Either.hu [new file with mode: 0644]
progs/lib/hbc/Hash.hs [new file with mode: 0644]
progs/lib/hbc/Hash.hu [new file with mode: 0644]
progs/lib/hbc/ListUtil.hs [new file with mode: 0644]
progs/lib/hbc/ListUtil.hu [new file with mode: 0644]
progs/lib/hbc/Maybe.hs [new file with mode: 0644]
progs/lib/hbc/Maybe.hu [new file with mode: 0644]
progs/lib/hbc/Miranda.hs [new file with mode: 0644]
progs/lib/hbc/Miranda.hu [new file with mode: 0644]
progs/lib/hbc/Option.hs [new file with mode: 0644]
progs/lib/hbc/Option.hu [new file with mode: 0644]
progs/lib/hbc/Pretty.hs [new file with mode: 0644]
progs/lib/hbc/Printf.hs [new file with mode: 0644]
progs/lib/hbc/Printf.hu [new file with mode: 0644]
progs/lib/hbc/QSort.hs [new file with mode: 0644]
progs/lib/hbc/QSort.hu [new file with mode: 0644]
progs/lib/hbc/README [new file with mode: 0644]
progs/lib/hbc/Random.hs [new file with mode: 0644]
progs/lib/hbc/Random.hu [new file with mode: 0644]
progs/lib/hbc/Time.hs [new file with mode: 0644]
progs/lib/hbc/Time.hu [new file with mode: 0644]
progs/prelude/Prelude.hs [new file with mode: 0644]
progs/prelude/Prelude.hu [new file with mode: 0644]
progs/prelude/PreludeArray.hs [new file with mode: 0644]
progs/prelude/PreludeArrayPrims.hi [new file with mode: 0644]
progs/prelude/PreludeArrayPrims.hu [new file with mode: 0644]
progs/prelude/PreludeComplex.hs [new file with mode: 0644]
progs/prelude/PreludeCore.hs [new file with mode: 0644]
progs/prelude/PreludeIO.hs [new file with mode: 0644]
progs/prelude/PreludeIOMonad.hs [new file with mode: 0644]
progs/prelude/PreludeIOPrims.hi [new file with mode: 0644]
progs/prelude/PreludeIOPrims.hu [new file with mode: 0644]
progs/prelude/PreludeList.hs [new file with mode: 0644]
progs/prelude/PreludeLocal.hs [new file with mode: 0644]
progs/prelude/PreludeLocalIO.hs [new file with mode: 0644]
progs/prelude/PreludePrims.hi [new file with mode: 0644]
progs/prelude/PreludePrims.hu [new file with mode: 0644]
progs/prelude/PreludeRatio.hs [new file with mode: 0644]
progs/prelude/PreludeText.hs [new file with mode: 0644]
progs/prelude/PreludeTuple.hs [new file with mode: 0644]
progs/prelude/PreludeTuplePrims.hi [new file with mode: 0644]
progs/prelude/PreludeTuplePrims.hu [new file with mode: 0644]
progs/prelude/README [new file with mode: 0644]
progs/tutorial/README [new file with mode: 0644]
progs/tutorial/tutorial.hs [new file with mode: 0644]
runtime/README [new file with mode: 0644]
runtime/array-prims.scm [new file with mode: 0644]
runtime/debug-utils.scm [new file with mode: 0644]
runtime/io-primitives.scm [new file with mode: 0644]
runtime/prims.scm [new file with mode: 0644]
runtime/runtime-utils.scm [new file with mode: 0644]
runtime/runtime.scm [new file with mode: 0644]
runtime/tuple-prims.scm [new file with mode: 0644]
support/README [new file with mode: 0644]
support/compile.scm [new file with mode: 0644]
support/format.scm [new file with mode: 0644]
support/mumble.txt [new file with mode: 0644]
support/pprint.scm [new file with mode: 0644]
support/support.scm [new file with mode: 0644]
support/system.scm [new file with mode: 0644]
support/utils.scm [new file with mode: 0644]
tdecl/README [new file with mode: 0644]
tdecl/alg-syn.scm [new file with mode: 0644]
tdecl/class.scm [new file with mode: 0644]
tdecl/instance.scm [new file with mode: 0644]
tdecl/tdecl-utils.scm [new file with mode: 0644]
tdecl/tdecl.scm [new file with mode: 0644]
tdecl/type-declaration-analysis.scm [new file with mode: 0644]
top/README [new file with mode: 0644]
top/core-definitions.scm [new file with mode: 0644]
top/core-init.scm [new file with mode: 0644]
top/core-symbols.scm [new file with mode: 0644]
top/errors.scm [new file with mode: 0644]
top/globals.scm [new file with mode: 0644]
top/has-macros.scm [new file with mode: 0644]
top/has-utils.scm [new file with mode: 0644]
top/phases.scm [new file with mode: 0644]
top/prelude-core-syms.scm [new file with mode: 0644]
top/symbol-table.scm [new file with mode: 0644]
top/system-init.scm [new file with mode: 0644]
top/top.scm [new file with mode: 0644]
top/tuple.scm [new file with mode: 0644]
type/README [new file with mode: 0644]
type/default.scm [new file with mode: 0644]
type/dictionary.scm [new file with mode: 0644]
type/expression-typechecking.scm [new file with mode: 0644]
type/pattern-binding.scm [new file with mode: 0644]
type/type-decl.scm [new file with mode: 0644]
type/type-error-handlers.scm [new file with mode: 0644]
type/type-macros.scm [new file with mode: 0644]
type/type-main.scm [new file with mode: 0644]
type/type-vars.scm [new file with mode: 0644]
type/type.scm [new file with mode: 0644]
type/unify.scm [new file with mode: 0644]
util/README [new file with mode: 0644]
util/annotation-utils.scm [new file with mode: 0644]
util/constructors.scm [new file with mode: 0644]
util/haskell-utils.scm [new file with mode: 0644]
util/instance-manager.scm [new file with mode: 0644]
util/pattern-vars.scm [new file with mode: 0644]
util/prec-utils.scm [new file with mode: 0644]
util/signature.scm [new file with mode: 0644]
util/type-utils.scm [new file with mode: 0644]
util/walk-ast.scm [new file with mode: 0644]

diff --git a/Copyright b/Copyright
new file mode 100644 (file)
index 0000000..cb40c96
--- /dev/null
+++ b/Copyright
@@ -0,0 +1,18 @@
+Copyright (c) 1991 Yale University Computer Science Department
+
+Yale Haskell System Version 2.0-beta
+
+Permission to copy this software, to redistribute it, and to use it for any
+purpose is granted, subject to the following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice in full.
+2. All materials developed as a consequence of the use of this software
+   shall duly acknowledge such use, in accordance with the usual standards
+   of acknowledging credit in academic research.
+3. Yale has made no warrantee or representation that the operation of
+   this software will be error-free, and Yale is under no obligation to
+   provide any services, by way of maintenance, update, or otherwise.
+4. In conjunction with products arising from the use of this material,
+   there shall be no use of the name of the Yale University nor of any
+   adaptation thereof in any advertising, promotional, or sales literature
+   without prior written consent from Yale in each case.
diff --git a/README b/README
new file mode 100644 (file)
index 0000000..b3afb11
--- /dev/null
+++ b/README
@@ -0,0 +1,37 @@
+This is the main directory for the 2.x release of Yale Haskell.  This
+file contains some basic information about how the system is organized
+and put together.
+
+You should set the variable $HASKELL and source the haskell-setup
+script in this directory before attempting to use Yale Haskell.
+
+If you are rebuilding from the source release, see the scripts and
+README files in the $HASKELL/com area.  You also need to modify
+the haskell-development script.
+
+Yale-specific information:
+
+Source files in this directory area are under RCS control.  Use the
+`rci' and `rco' aliases (from haskell-development) to check things in
+and out.  By convention, each directory containing source files should
+have subdirectories named RCS (for RCS files), t (for compiled T
+files), lucid (for compiled Lucid CL files), and cmu (for compiled CMU
+CL files).
+
+Each subdirectory containing source files should also have a file that
+defines a compilation unit for that subdirectory.  (See
+support/compile.scm for information about the compilation unit
+utility.)  support/system.scm loads all the compilation unit definitions.
+
+To load the system into Common Lisp, you need to load the file
+support/cl-support/cl-init.lisp.  This will automagically compile any
+outdated or missing files.  However, you need to type in an
+(in-package "MUMBLE-USER") once it finishes.
+
+Don't try to load the system into T.  It's broken!  See
+support/t-support/t-init.t.
+
+All system-dependent code goes in either support/cl-support or
+support/t-support.  For information about the mumble compatibility
+package used as the implementation language for the rest of the
+system, see support/mumble.txt.
diff --git a/ast/README b/ast/README
new file mode 100644 (file)
index 0000000..ed2497d
--- /dev/null
@@ -0,0 +1,29 @@
+This directory defines the primary data structures used in the compiler
+using the `define-struct' macro defined in the struct directory.
+
+Structures are divided into the following catagories:
+
+Basic structures: (basic-structs)
+  References to variables, data constructors, classes, type constructors
+    All references contain the name of the object referred to and a
+    field that will receive the actual definition object when scoping
+    has been resolved.
+  Fixity: (l | n | r, Int)
+
+Module structures: (module-structs)
+  The module ast, import & export related ast's, and fixity definition.
+
+Type system structures: (type-structs)
+  The representation of data types and the type related declarations:
+  type, data, class, and instance.
+
+Value declarations: (valdef-structs)
+  
+Expressions: (expr-structs)
+
+Definitions: (definition-structs)
+
+Flic structures: (flic-structs)
+
+
+
diff --git a/ast/ast-td.scm b/ast/ast-td.scm
new file mode 100644 (file)
index 0000000..cf70016
--- /dev/null
@@ -0,0 +1,20 @@
+;;; ast-td.scm -- define ast type descriptor object
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  6 Oct 1992
+;;;
+
+
+;;; Give the type descriptors for AST nodes extra slots to hold walker
+;;; functions.
+
+(define-struct ast-td
+  (include type-descriptor)
+  (slots
+    (cfn-walker (type (maybe procedure)) (default '#f))
+    (cfn-simple-transform-walker (type (maybe procedure)) (default '#f))
+    (depend-walker (type (maybe procedure)) (default '#f))
+    (ast-to-flic-walker (type (maybe procedure)) (default '#f))
+    (scope-walker (type (maybe procedure)) (default '#f))
+    (type-walker (type (maybe procedure)) (default '#f))
+    (collect-pattern-vars-walker (type (maybe procedure)) (default '#f))))
diff --git a/ast/ast.scm b/ast/ast.scm
new file mode 100644 (file)
index 0000000..9169677
--- /dev/null
@@ -0,0 +1,33 @@
+;;; ast.scm -- compilation unit definition for ast definitions
+;;;
+;;; author :  John
+;;; date   :  10 Dec 1991
+;;;
+
+
+(define-compilation-unit ast
+  (source-filename "$Y2/ast/")
+  (unit ast-td
+    (source-filename "ast-td"))
+  (unit modules
+    (source-filename "modules.scm")
+    (require ast-td))
+  (unit type-structs
+    (source-filename "type-structs.scm")
+    (require ast-td modules))
+  (unit tc-structs
+    (source-filename "tc-structs.scm")
+    (require ast-td modules))
+  (unit valdef-structs
+    (source-filename "valdef-structs.scm")
+    (require ast-td modules))
+  (unit definitions
+    (source-filename "definitions.scm")
+    (require ast-td modules))
+  (unit exp-structs
+    (source-filename "exp-structs.scm")
+    (require ast-td modules))
+  (unit predicates
+    (require ast-td modules type-structs valdef-structs definitions
+            exp-structs tc-structs)
+    (source-filename "predicates.scm")))
diff --git a/ast/definitions.scm b/ast/definitions.scm
new file mode 100644 (file)
index 0000000..9184b13
--- /dev/null
@@ -0,0 +1,209 @@
+;;; File: ast/definitions.scm   Author: John
+
+;;; this file contains definitions for the named entities in the
+;;; system.  These are used in both the front and back ends of the
+;;; compiler.  These are created early in the compilation process
+;;; (import/export) and filled in during compilation.  Binary interface
+;;; files are just tables mapping names to definitions.
+
+;;; All definitions have these fields for managing name spaces.  All
+;;; names are uniquified; this requires adding `;' to the front of data
+;;; constructors to separate them from type constructors.  Module names
+;;; do not have a `definition' data structure - the `module' structure
+;;; serves the same purpose.
+
+;;; Definitions are found in two places: the symbol tables which are part of
+;;; the module structure and the -ref nodes in the ast structure.  The -ref
+;;; nodes have two fields: a name (from the parser) and a field which will
+;;; point to the associated definition after name resolution.  Name resolution
+;;; happens in a number of different places: top level definitions are
+;;; resolved during import-export, type declarations are resolved during
+;;; type declaration analysis, and everything else is resolved during scoping
+;;; (alpha conversion).  The parser generates pre-resolved -ref nodes when
+;;; parsing some constructs.  These refs denote pre-defined language
+;;; constructs, such as lists, tuples, or prelude functions.
+
+;;; A special set of definitions constitutes the `core' of Haskell.  These
+;;; definitions are pre-allocated and are filled in during the compilation
+;;; of the Prelude.  This allows the bootstrap of the system.
+
+
+;;; All defs require name, unit, and module args to make.
+;;; Other slots should all have appropriate defaults.
+
+(define-struct def
+  (slots
+   ;; the uniquified name (from the definition)
+   (name (type symbol))
+   ;; compilation unit defined in
+   (unit (type symbol))
+   ;; name of the defining module
+   (module (type symbol))
+   ;; used by the closure check
+   (exported? (type bool) (default '#f) (bit #t))
+   ;; for symbols in `core' Haskell; special case for IO
+   (core? (type bool) (default '#f) (bit #t))      
+   ;; Always a core sym.  Used to avoid putting in sym table
+   (prelude? (type bool) (default '#f) (bit #t))
+   ))
+
+
+
+;;; Variable information
+
+(define-struct var
+  (include def)
+  (predicate var?)
+  (slots
+   ;; inferred during type inference
+   (type             (type (maybe ntype))     (default '#f))
+   ;; type affixed by sign-decl or class decl
+   (signature        (type (maybe ntype))     (default '#f))
+   (interface-type   (type (maybe ntype))     (default '#f))
+   ;; most variables have no fixity information.
+   (fixity           (type (maybe fixity))    (default '#f))
+   ;; The following attributes are used by the backend
+   (selector-fn?     (type bool)              (default '#f) (bit #t))
+   (force-strict?    (type bool)              (default '#f) (bit #t))
+   (force-inline?    (type bool)              (default '#f) (bit #t))
+   (toplevel?        (type bool)              (default '#f) (bit #t))
+   (simple?          (type bool)              (default '#f) (bit #t))
+   (strict?          (type bool)              (default '#f) (bit #t))
+   (optimized-refs?  (type bool)              (default '#f) (bit #t))
+   (standard-refs?   (type bool)              (default '#f) (bit #t))
+   (single-ref       (type (maybe int))       (default '#f))
+   (arity            (type int)               (default 0))
+   (referenced       (type int)               (default 0))
+   (value            (type (maybe flic-exp))  (default '#f))
+   (fullname         (type (maybe symbol))    (default '#f))
+   (inline-value     (type (maybe flic-exp))  (default '#f))
+   ;; Only function bindings use these slots
+   (strictness       (type (list bool))       (default '()))
+   (complexity       (type (maybe int))       (default '#f))
+   (optimized-entry  (type (maybe symbol))    (default '#f))
+   (annotations      (type (list annotation-value)) (default '()))
+   (fn-referenced    (type int)               (default 0))
+   (arg-invariant-value  (type (maybe flic-exp))  (default '#f))
+   (arg-invariant?   (type bool)              (default '#f) (bit #t))
+   ))
+  
+
+;;; This defines an individual class method
+
+(define-struct method-var
+  (include var)
+  (predicate method-var?)
+  (slots
+   (class (type class) (uninitialized? #t))
+   (default (type (maybe var)) (uninitialized? #t))
+   (method-signature (type signature) (uninitialized? #t))))
+
+
+;;; A data constructor
+
+(define-struct con
+  (include def)
+  (predicate con?)
+  (slots
+   ;; These slots are initialized in the type declaration phase
+   (arity (type int) (uninitialized? #t))
+   (types (type (list type)) (uninitialized? #t))
+   (slot-strict? (type (list bool)) (default '()))
+   (tag (type int) (uninitialized? #t))
+   (alg (type algdata) (uninitialized? #t))
+   (infix? (type bool) (bit #t) (default '#f))
+   (signature (type ntype) (uninitialized? #t))
+   ;; Assigned during import-export phase
+   (fixity (type (maybe fixity)) (default '#f))
+   (lisp-fns (type t) (default '()))
+   ))
+
+
+;;; Definitions used by the type system.
+
+(define-struct tycon-def
+  (include def)
+  (slots
+   (arity (type integer) (default -1))))
+
+(define-struct synonym
+  (include tycon-def)
+  (predicate synonym?)
+  (slots
+   ;; These slots are explicitly initialized in the type declaration phase.
+   (args (type (list symbol)) (uninitialized? #t))
+   (body (type type) (uninitialized? #t))  ; stored in ast form
+   ))
+
+(define-struct algdata
+  (include tycon-def)
+  (predicate algdata?)
+  (slots
+   ;; These slots are initialized explicitly in the type declaration phase
+   ;; number of constructors
+   (n-constr (type int) (uninitialized? #t)) 
+   (constrs (type (list con)) (uninitialized? #t))
+   (context (type (list context)) (uninitialized? #t))
+   ;; arguments to tycon
+   (tyvars (type (list symbol)) (uninitialized? #t))
+   ;; signature for the type as a whole
+   (signature (type (maybe ntype)) (default '#f))
+   ;; classes this algdata is an instance of
+   (classes (type (list class)) (uninitialized? #t))
+   ;; true if all constructors have 0 arity
+   (enum? (type bool) (bit #t) (uninitialized? #t))
+   ;; true when only constructor
+   (tuple? (type bool) (bit #t) (uninitialized? #t))
+   ;; true for `tuple-syntax' tuples.
+   (real-tuple? (type bool) (bit #t) (uninitialized? #t))
+   ;; instances to derive
+   (deriving (type (list class)) (uninitialized? #t))
+   (export-to-lisp? (type bool) (default '#f) (bit #t))
+   (implemented-by-lisp? (type bool) (default '#f) (bit #t))
+   ))
+
+(define-struct class
+  (include def)
+  (predicate class?)
+  (slots
+   ;; These slots are initialized in the import-export phase
+   (method-vars (type (list method-var)) (uninitialized? #t))
+   ;; These slots are explicitly initialized in the type declaration phase
+   ;; immediate superclasses
+   (super (type (list class)) (uninitialized? #t))
+   ;; all superclasses
+   (super* (type (list class)) (uninitialized? #t))
+   ;; name of class type variable
+   (tyvar (type symbol) (uninitialized? #t))
+   (instances (type (list instance)) (uninitialized? #t))
+   (kind (type (enum standard numeric other)) (uninitialized? #t))
+   (n-methods (type int) (uninitialized? #t))
+   (dict-size (type int) (uninitialized? #t))
+   (selectors (type (list (tuple method-var var))) (uninitialized? #t))
+   ))
+
+;;; Since instances are not named there is no need to include def.  
+
+(define-struct instance
+  (include ast-node)
+  (slots
+   ;; These slots always have initializers supplied with MAKE.
+   (algdata (type algdata))
+   (tyvars (type (list symbol)))
+   (class (type class))
+   (context (type (list context)))
+   (gcontext (type (list (list class))))
+   (dictionary (type var))
+
+   ;; Explicitly initialized during the type declaration phase.
+   (methods (type (list (tuple method-var var))) (uninitialized? #t))
+
+   ;; These slots usually default on creation.
+   (decls (type (list decl)) (default '()))
+   ;; used during verification of derived instances
+   (ok? (type bool) (bit #t) (default #f))
+   ;; marks magically generated tuple instances
+   (special? (type bool) (bit #t) (default #f))
+   (suppress-readers? (type bool) (bit #t) (default #f))
+   ))
+
diff --git a/ast/exp-structs.scm b/ast/exp-structs.scm
new file mode 100644 (file)
index 0000000..847723d
--- /dev/null
@@ -0,0 +1,386 @@
+;;; File: ast/exp-structs     Author: John
+
+;;; These ast structures define the expression syntax
+
+
+;;; This is simplified; there are additional rules for associativity and
+;;; precedence.
+;;;
+;;; <exp>  -> <lambda-exp>
+;;;        -> <let-exp>
+;;;        -> <if-exp>
+;;;        -> <case-exp>
+;;;        -> <signature-exp>
+;;;        -> <exp> <op> <exp>           ; treated like <fn-app>
+;;;        -> - <exp>
+;;;        -> <fn-app>
+;;;        -> <aexp>
+;;;
+
+(define-struct exp
+  (include ast-node))
+
+
+;;; <lambda-exp> -> \ <apat> ... <apat> -> <exp>
+
+(define-struct lambda
+  (include exp)
+  (slots
+   (pats (type (list pattern)))
+   (body (type exp))))
+
+;;; <let-exp> -> let { <decls> [;] } in <exp>
+
+(define-struct let
+  (include exp)
+  (slots
+   (decls (type (list decl)))
+   (body (type exp))))
+
+;;; <if-exp> -> if <exp> then <exp> else <exp>
+
+(define-struct if
+  (include exp)
+  (slots
+   (test-exp (type exp))
+   (then-exp (type exp))
+   (else-exp (type exp))))
+
+
+;;; <case-exp> -> case <exp> of { <alts> [;] }
+;;;
+;;; <alts>     -> <alt> ; ... ; <alt>
+;;;
+;;; <alt>      -> <pat> -> exp  [where { <decls> [;] } ]
+;;;            -> <pat> <gdpat> [where { <decls> [;] } ]
+
+(define-struct case
+  (include exp)
+  (slots
+   (exp (type exp))
+   (alts (type (list alt)))))
+
+(define-struct alt
+  (include ast-node)
+  (slots
+   (pat (type pattern))
+   ;; defined in valdef-structs
+   (rhs-list (type (list guarded-rhs)))
+   (where-decls (type (list decl)))
+   ;; used internally by cfn
+   (test (type (maybe exp)) (default '#f))
+   ))
+
+;;; <signature-exp> -> <exp> :: [<context> =>] <atype>
+
+(define-struct exp-sign
+  (include exp)
+  (slots
+   (exp (type exp))
+   (signature (type signature))))
+
+
+;;; <fn-app> -> <exp> <aexp>
+
+(define-struct app
+  (include exp)
+  (predicate app?)
+  (slots
+   (fn (type exp))
+   (arg (type exp))))
+
+;;; <aexp> -> <var>                                var-ref
+;;;        -> <con>                                con-ref
+;;;        -> <literal>                            const
+;;;        -> ()                                   constructor is Unit
+;;;        -> ( <exp> )                            
+;;;        -> ( <exp> , ... , <exp> )              constructor is a tuple
+;;;        -> [ <exp> , ... , <exp> ]              list
+;;;        -> <sequence>
+;;;        -> [exp> | <qual> , ... , <qual>]       list-comp
+;;;        -> ( <exp> <op> )                       section-r
+;;;        -> ( <op> <exp> )                       section-l
+;;;
+
+(define-struct aexp
+  (include exp))
+
+
+(define-struct var-ref
+  (include aexp)
+  (predicate var-ref?)
+  (slots
+   (name (type symbol))
+   (var (type def))
+   (infix? (type bool) (bit #t))))
+
+(define-struct con-ref
+  (include aexp)
+  (predicate con-ref?)
+  (slots
+   (name (type symbol))
+   (con (type def))
+   (infix? (type bool) (bit #t))))
+
+(define-struct const
+  (include aexp)
+  (slots
+   (overloaded? (type bool) (default '#t) (bit #t))))
+
+(define-struct integer-const
+  (include const)
+  (predicate integer-const?)
+  (slots
+   (value (type integer))))
+
+(define-struct float-const
+  (include const)
+  (predicate float-const?)
+  (slots
+   (numerator (type integer))
+   (denominator (type integer))
+   (exponent (type integer))))
+
+(define-struct char-const
+  (include const)
+  (predicate char-const?)
+  (slots
+   (value (type char))))
+
+(define-struct string-const
+  (include const)
+  (predicate string-const?)
+  (slots
+   (value (type string))))
+
+(define-struct list-exp
+  (include aexp)
+  (slots
+   (exps (type (list exp)))))
+
+
+;;; <sequence> -> [ <exp> .. ]                  sequence
+;;;            -> [ <exp>, <exp> .. ]           sequence-then
+;;;            -> [ <exp> .. <exp> ]            sequence-to
+;;;            -> [ <exp>, <exp> .. <exp> ]     sequence-then-to
+
+(define-struct sequence
+  (include aexp)
+  (slots
+   (from (type exp))))
+
+(define-struct sequence-to
+  (include aexp)
+  (slots
+   (from (type exp))
+   (to (type exp))))
+
+
+(define-struct sequence-then
+  (include aexp)
+  (slots
+   (from (type exp))
+   (then (type exp))))
+
+(define-struct sequence-then-to
+  (include aexp)
+  (slots
+   (from (type exp))
+   (then (type exp))
+   (to (type exp))))
+
+(define-struct list-comp
+  (include aexp)
+  (slots
+   (exp (type exp))
+   (quals (type (list qual)))))
+
+;;; Op on left
+(define-struct section-l
+  (include aexp)
+  (slots
+   (exp (type exp))
+   (op (type exp))))  ; either con-ref or var-ref
+
+(define-struct section-r
+  (include aexp)
+  (slots
+   (exp (type exp))
+   (op (type exp))))  ; either con-ref or var-ref
+
+;;; <qual> -> <pat> <- <exp>
+;;;        -> <exp>
+
+(define-struct qual
+  (include ast-node))
+
+(define-struct qual-generator
+  (include qual)
+  (slots
+   (pat (type pattern))
+   (exp (type exp))))
+
+(define-struct qual-filter
+  (include qual)
+  (slots
+   (exp (type exp))))
+
+
+;;; This is used as the guard slot in a guarded-rhs to represent lack of a
+;;; guard.  This is the same as True.
+
+(define-struct omitted-guard ; same as True; should print in the guardless form
+  (include exp))
+
+
+;;; These structures are used by the precedence parser.  
+
+(define-struct pp-exp-list  ; list of expressions & ops for the prec parser
+  (include exp)
+  (slots
+   (exps (type (list exp)))))
+
+;; This is a place holder for unary negation in pp-exp expressions.  It is
+;; changed to call the negate function by the prec parser
+
+(define-struct negate
+  (include exp)
+  (predicate negate?))
+
+;; Note: operators are var / con structures with infix? set to #t
+
+;;; The following ast nodes do not directly correspond to Haskell syntax.
+;;; They are generated during internal code transformations.
+
+;;; This returns a number (an Int) associated with the constructor of a
+;;; value.
+
+(define-struct con-number
+  (include exp)
+  (slots
+    (type (type algdata))
+    (value (type exp))))
+
+;;; This selects a value (denoted by the Int in slot) from a data object
+;;; created by a specified constructor.
+
+(define-struct sel
+  (include exp)
+  (slots
+    (constructor (type con))
+    (slot (type int))
+    (value (type exp))))
+
+;;; This returns True if the data value was built with the designated
+;;; constructor
+
+(define-struct is-constructor
+  (include exp)
+  (slots 
+   (constructor (type con))
+   (value (type exp))))
+
+;;; this is for the type checker only.  It turns off
+;;; type checking for the argument.
+
+(define-struct cast
+  (include exp)     
+  (slots 
+   (exp (type exp))))
+
+;; this is used as the body of the let generated by
+;; dependency analysis
+
+(define-struct void  
+  (include exp)
+  (predicate void?))
+  
+
+;;; These structures are for the type checker.  They serve as a placeholder
+;;; for values which will evaluate to methods or dictionaries.
+
+(define-struct placeholder
+  (include exp)
+  (predicate placeholder?)
+  (slots
+   (exp (type (maybe exp)))
+   (tyvar (type ntype))
+   (overloaded-var (type exp))
+   (enclosing-decls (type (list decl)))))
+
+(define-struct method-placeholder
+  (include placeholder)
+  (predicate method-placeholder?)
+  (slots
+   ;; the method to be dispatched
+   (method (type method-var))
+   ))
+
+(define-struct dict-placeholder
+  (include placeholder)
+  (predicate dict-placeholder?)
+  (slots
+   ;; the class of dictionary needed
+   (class (type class))))
+
+(define-struct recursive-placeholder
+  (include exp)
+  (slots
+   (var (type var))
+   (enclosing-decls (type (list decl)))
+   ;; this holds the code associated with recursive
+   ;; functions or variables.  This code instantiates
+   ;; the recursive context if necessary.
+   (exp (type (maybe exp)))
+   ))
+
+;;; This is used in primitive modules only.  It holds the definition of
+;;; a lisp level primitive.
+
+(define-struct prim-definition
+  (include exp)
+  (slots
+   (lisp-name (type symbol))
+   (atts (type (list (tuple symbol t))))))
+
+;;; This is used by the type checker to hang on to the original
+;;; version of a program for message printing.  This is removed by
+;;; the cfn pass.
+
+(define-struct save-old-exp
+  (include exp)
+  (slots
+   (old-exp (type exp))
+   (new-exp (type exp))))
+
+
+;;; This is used for type checking overloaded methods.
+
+(define-struct overloaded-var-ref
+  (include exp)
+  (slots
+    (var (type var))
+    (sig (type ntype))))
+
+
+
+;;; These are used by the CFN.
+
+
+(define-struct case-block
+  (include exp)
+  (slots
+    (block-name (type symbol))
+    (exps       (type (list exp)))))
+
+(define-struct return-from
+  (include exp)
+  (slots
+    (block-name (type symbol))
+    (exp        (type exp))))
+
+(define-struct and-exp
+  (include exp)
+  (slots
+    (exps       (type (list exp)))))
+
diff --git a/ast/modules.scm b/ast/modules.scm
new file mode 100644 (file)
index 0000000..e445444
--- /dev/null
@@ -0,0 +1,252 @@
+;;;  File: ast/module-structs   Author: John
+
+;;; This contains AST structures which define the basic module structure.
+;;; This is just the skeleton module structure: module, imports, exports,
+;;; fixity, and default decls.
+
+;;; AST nodes defined in the file:
+;;;  module  import-decl  entity  entity-module  entity-var  entity-con
+;;;  entity-class  entity-abbreviated  entity-datatype  fixity-decl
+
+
+
+;;; All AST structs inherit from ast-node.  Not instantiated directly.
+;;; The line-number is a back pointer to the source code.
+
+(define-struct ast-node
+  (type-template ast-td)
+  (slots
+   (line-number (type (maybe source-pointer)) (default '#f))))
+
+(define-struct source-pointer
+  (slots
+   (line (type int))
+   (file (type string))))
+
+;;; <module> -> module <modid> [<exports>] where <body>
+;;;          -> <body>
+;;;
+;;; <exports> -> ( <export>, ... <export> )
+;;;
+;;; <body>   -> { [<impdecls>;] [[<fixdecls>;] <topdecls> [;]] }
+;;;          -> { <impdecls> [;] }
+;;;
+;;; <impdecls> -> <impdecl> ; ... ; <impdecl>
+;;;
+;;; <fixdecls> -> <fix> ; ... ; <fix>
+;;;
+;;; <topdecls> -> <topdecl> ; ... ; <topdecl>
+;;;
+;;; <topdecl> -> <synonym-decl>
+;;;           -> <algdata-decl>
+;;;           -> <class-decl>
+;;;           -> <instance-decl>
+;;;           -> <default-decl>
+;;;           -> <sign-decl>
+;;;           -> <valdef>
+
+;;; The module struct is used to represent the program internally.  Binary
+;;; files containing interface information contain these structures.
+;;; Most compiler passes operate on this structure.  A table maps module
+;;; names to this structure.  Within the module structure, local names are
+;;; mapped to definitions.
+
+;;; Modules are also used to represent interfaces & primitives.
+;;; Some of the module fields may be blank for non-standard modules.
+
+(define-struct module
+  (include ast-node)
+  (slots
+
+    ;; These slots are required.
+
+    (name (type symbol))
+    (type (type (enum standard interface extension)))
+    (prelude? (type bool) (default '#f))  ; True when symbols define the core
+    (interface-module (type (maybe module)) (default '#f))
+        ; link to previously compiled interface
+
+    ;; The unit is filled in by the compilation system
+
+    (unit (type symbol) (default '*undefined*))
+
+    ;; The following slots are defined at parse time.
+    ;; After a module is dumped, these are all empty.
+
+    ;; <exports>, list of exported names
+    (exports (type (list entity)) (default '()))
+    ;; <impdecls>, local import decls
+    (imports (type (list import-decl)) (default '()))
+    ;; <fixdecls>, local fixity decls
+    (fixities (type (list fixity-decl)) (default '()))
+    ;; <synonym-decl>, local type synonym decls
+    (synonyms (type (list synonym-decl)) (default '()))
+    ;; <algdata-decl>, local data decls
+    (algdatas (type (list data-decl)) (default '()))
+    ;; <class-decl>, local class decls
+    (classes (type (list class-decl)) (default '()))
+    ;; <instance-decl>, local instance decls
+    (instances (type (list instance-decl)) (default '()))
+    ;; <default-decl>, default types
+    (annotations (type (list annotation)) (default '()))
+    (default (type (maybe default-decl)) (default '#f))
+    ;; signatures, pattern, function bindings
+    (decls (type (list decl)) (default '()))
+
+    ;; These slots are filled in by the type-declaration-analysis phase
+    ;; after conversion to definition form
+
+    (synonym-defs (type (list synonym)) (default '()))
+    (alg-defs (type (list algdata)) (default '()))
+    (class-defs (type (list class)) (default '()))
+    (instance-defs (type (list instance)) (default '()))
+
+
+    ;; The import-export stage creates a set of tables which are used for
+    ;; imports and exports and local name resolution.  All of these tables
+    ;; are indexed by names.  These tables always deal with definitions.
+    ;; Every variable, type, class, instance, and synonym is converted into
+    ;; a definition.  Blank definitions are created early (in import/export)
+    ;; and different aspects of the definitions are filled in as compilation
+    ;; progresses.  The type-related definitions are filled in during
+    ;; declaration analysis.  Only definitions are saved when a module is
+    ;; written to a file; the ast information is not retained.
+
+    ;; Used to avoid copy of Prelude symbols.
+    (uses-standard-prelude? (type bool) (default '#f))
+    ;; maps symbols in scope to definitions
+    (symbol-table (type (table symbol def)) (default (make-table)))
+    ;; maps names onto groups.
+    (export-table (type (table symbol (list (tuple symbol def))))
+                 (default (make-table)))
+    ;; Note: symbol groups are found in classes and data decls.  An
+    ;; entire group is denoted by the (..) abbreviation in an entity.
+    ;; maps local names onto declared fixities
+    (fixity-table (type (table symbol fixity)) (default (make-table)))
+    ;; maps defs to local names
+    (inverted-symbol-table (type (table symbol symbol)) (default (make-table)))
+    ;; Used internally during import-export
+    (fresh-exports (type (list (list (tuple symbol def)))) (default '()))
+    (exported-modules (type (list module)) (default '()))
+
+    ;; These slots are used to support incremental compilation.
+
+    ;; vars defined in the module
+    (vars (type (list var)) (default '()))
+    ;; for incremental compilation
+    (inherited-env (type (maybe module)) (default '#f))
+    ;; The following slots are for interfaces only
+    ;; These store renaming mappings defined in the import decls of
+    ;; the interface.  Maps local name onto (module, original name).
+    (interface-imports (type (list (tuple symbol (typle symbol symbol))))
+                      (default '()))
+    (interface-codefile (type (list string)) (default '()))
+    ))
+
+
+;;; <impdecl> -> import <modid> [<impspec>] [renaming <renamings>]
+;;;
+;;; <impspec> -> ( <import> , ... , <import> )
+;;;           -> hiding ( <import> , ... , <import> )
+;;;
+;;; <import>  -> <entity>
+;;;
+;;; <renamings> -> ( <renaming>, ... , <renaming> )
+;;;
+;;; <renaming>  -> <varid> to <varid>
+;;;             -> <conid> to <conid>
+
+(define-struct import-decl
+  (include ast-node)
+  (slots
+   ;; <modid>, module imported from
+   (module-name (type symbol))
+   ;; all: import Foo; by-name: import Foo(x) import Foo()
+   (mode (type (enum all by-name)))
+   ;; <impspec>, for mode = all this is the hiding list
+   (specs (type (list entity)))
+   ;; <renamings>, alist maps symbol -> symbol
+   (renamings (type (list renaming)))
+   ;; place to put corresponding module-ast; filled in by import/export.
+   (module (type module) (uninitialized? #t))
+   ))
+
+
+;;; <entity> -> <modid> ..                              entity-module
+;;           -> <varid>                                 entity-var
+;;;          -> <tycon>                                 entity-con
+;;;          -> <tycon> (..)                            entity-abbreviated
+;;;          -> <tycon> ( <conid> , ... , <conid>)      entity-datatype
+;;;          -> <tycls> (..)                            entity-abbreviated
+;;;                note: this is indistinguishable from tycon (..)
+;;;          -> <tycls> ( <varid> , ... , <varid>)      entity-class
+
+(define-struct entity
+  (include ast-node)
+  (slots
+    (name (type symbol))))
+
+(define-struct entity-module
+  (include entity)
+  (predicate entity-module?)
+  (slots
+    ;; a direct pointer to the referenced module added later
+    (module (type module) (uninitialized? #t))
+    ))
+
+(define-struct entity-var
+  (include entity)
+  (predicate entity-var?))
+
+(define-struct entity-con
+  (include entity)
+  (predicate entity-con?))
+
+(define-struct entity-abbreviated
+  (include entity)
+  (predicate entity-abbreviated?))
+
+(define-struct entity-class
+  (include entity)
+  (predicate entity-class?)
+  (slots
+    (methods (type (list symbol)))))
+
+(define-struct entity-datatype
+  (include entity)
+  (predicate entity-datatype?)
+  (slots
+    (constructors (type (list symbol)))))
+
+(define-struct renaming
+  (include ast-node)
+  (slots
+    (from (type symbol))
+    (to (type symbol))
+    (referenced? (type bool))))
+               
+
+;;; <fix> -> infixl [<digit>] <ops>
+;;;       -> infixr [<digit>] <ops>
+;;;       -> infix  [<digit>] <ops>
+;;;
+;;; <ops> -> <op> , ... , <op>
+;;;
+;;; <op>  -> <varop>
+;;;       -> <conop>
+
+;;; Not sure where to put this decl - jcp
+(define-struct fixity
+  (include ast-node)
+  (slots
+    (associativity (type (enum l n r)))
+    (precedence (type int))))
+
+(define-struct fixity-decl
+  (include ast-node)
+  (slots
+    (fixity (type fixity))
+    ;; <ops>
+    (names (type (list symbol)))
+    ))
+
diff --git a/ast/predicates.scm b/ast/predicates.scm
new file mode 100644 (file)
index 0000000..20dfc13
--- /dev/null
@@ -0,0 +1,18 @@
+;;; predicates.scm -- various useful predicates, collected from other places
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  19 Mar 1992
+;;;
+
+
+;;; Some predicates on patterns (used by CFN)
+
+(define-integrable (var-or-wildcard-pat? p)
+  (or (is-type? 'wildcard-pat p)
+      (is-type? 'var-pat p)))
+
+(define-integrable (irrefutable-pat? p)
+  (or (is-type? 'wildcard-pat p)
+      (is-type? 'var-pat p)
+      (is-type? 'irr-pat p)))
+
diff --git a/ast/tc-structs.scm b/ast/tc-structs.scm
new file mode 100644 (file)
index 0000000..1433082
--- /dev/null
@@ -0,0 +1,62 @@
+;;; These structures are used by the type checker for the internal
+;;; representation of type information.  These are referred to in
+;;; general as `ntype' structures.  Conversions are required between
+;;; ast types and ntypes.
+
+(define-struct ntype
+  (include ast-node))
+
+(define-struct ntycon
+  (include ntype)
+  (predicate ntycon?)
+  (slots
+   (tycon (type def))
+   (args (type (list ntype)))))
+
+(define-struct ntyvar
+  (include ntype)
+  (predicate ntyvar?)
+  (slots
+   ;; non-instantiated tyvars use #f for a value.
+   (value (type (maybe ntype)))
+   ;; could be encoded in value.
+   (context (type (list class)) (default ()))
+   (read-only? (type bool) (default #f) (bit #t))
+   (dict-params (type (list (tuple valdef (list (tuple class var))))))
+   ))
+
+;;; This is used only at the top level of a type during letrec type
+;;; checking.
+
+(define-struct recursive-type
+  (include ntype)
+  (predicate recursive-type?)
+  (slots
+   (type (type ntype))
+   (placeholders (type (list exp)))))
+
+;;; Gtypes are generalized types which can be copied quickly & stored in
+;;; interfaces.  They may contain monomorphic type variables which will not
+;;; be copied.
+
+(define-struct gtype
+  (include ntype)
+  (predicate gtype?)
+  (slots
+   (context (type (list (list class))))
+   (type (type ntype))))
+
+;;; These tyvars just index a list of pre-allocated tyvars.
+
+(define-struct gtyvar
+  (include ntype)
+  (predicate gtyvar?)
+  (slots
+   (varnum (type int))))
+
+(define-struct const-type
+  (include ntype)
+  (predicate const-type?)
+  (slots
+   (type (type ntype))))
+
diff --git a/ast/type-structs.scm b/ast/type-structs.scm
new file mode 100644 (file)
index 0000000..0ba4705
--- /dev/null
@@ -0,0 +1,159 @@
+;;;  File: ast/type-structs   Author: John
+
+;;; This contains AST structures for the type-related declarations,
+;;; including `data', `class', `instance', and `type' decls.  Basic type
+;;; syntax is also defined here.
+
+;;; Structures declared here:
+;;;  type  type-var  type-con  context  signature  synonym-decl
+;;;  data-decl  class-decl  instance-decl
+
+
+;;; <type>  -> <atype>
+;;;         -> <type> -> <type>                              ***
+;;;         -> <tycon> <atype> ... <atype>                   tycon
+;;;
+;;; <atype> -> <tyvar>                                       tyvar
+;;;         -> <tycon>                                       tycon
+;;;         -> ()                                            ***
+;;;         -> ( <type> )                                    grouping syntax
+;;;         -> ( <type> , ... , <type>)                      ***
+;;;         -> [ <type> ]                                    ***
+;;; *** Special <tycon> cases
+
+;;; Type with no context - either a tyvar or a constructor
+(define-struct type
+  (include ast-node))
+
+(define-struct tyvar
+  (include type)
+  (predicate tyvar?)
+  (slots
+   (name (type symbol))))
+
+(define-struct tycon
+  (include type)
+  (predicate tycon?)
+  (slots
+   (name (type symbol))
+   (def (type def))
+   (args (type (list type)))))
+
+;;; <signature> -> [<context> =>] <type>
+;;;
+;;; <context> -> <class>
+;;;           -> (<class> , ... , <class>)
+
+;;; A single class, variable pair
+(define-struct context
+  (include ast-node)
+  (slots
+   (class (type class-ref))
+   (tyvar (type symbol))))
+
+
+;;; Type + context
+(define-struct signature
+  (include type)
+  (slots
+   (context (type (list context)))
+   (type (type type))))
+
+
+;;; Major type declarations.  Note: no explicit structures for <simple>
+;;; or <inst> are needed - these are just special cases of type.
+
+;;; <synonym-decl> -> type <simple> = <type>
+;;;
+;;; <simple> -> <tycon> <tyvar> ... <tyvar>
+
+(define-struct synonym-decl
+  (include ast-node)
+  (slots
+   (simple (type type))
+   (body (type type))))
+
+
+;;; <aldata-decl> -> data [<context> => ] <simple> = <constrs> 
+;;;                    [deriving <tycls> | ( <tycls> , ... <tycls>) ]
+;;;
+;;; <constrs>     -> <constr> | ... | <constr>
+;;;
+
+(define-struct data-decl
+  (include ast-node)
+  (slots
+   (context (type (list context)))
+   (simple (type type))
+   (constrs (type (list constr)))  
+   (deriving (type (list class-ref)))
+   (annotations (type (list annotation-value)))))
+
+;;; <constr>      -> <con> <atype> ... <atype>
+;;;               -> <type> <conop> <type>
+
+(define-struct constr
+  (include ast-node)
+  (slots
+   (constructor (type con-ref))  ; this con-ref has an infix? flag.
+   (types (type (list (tuple type (list annotation-value)))))))
+
+
+;;; <class-decl> -> class [<context> => ] <class> [where { <cbody> [;] } ]
+;;;
+;;; <cbody> -> [<csigns> ; ] [ <valdefs> ]
+;;;
+;;; <csigns> -> <signdecl> ; ... ; <signdecl>
+
+(define-struct class-decl
+  (include ast-node)
+  (slots
+   (class (type class-ref))
+   (super-classes (type (list context)))
+   (class-var (type symbol))              ; name of type var for this class in decls
+   (decls (type (list decl)))))           ; <cbody>
+
+
+;;; <instance-decl> -> instance [<context> =>] <tycls> <inst>
+;;;                      [where { <valdefs> [;] } ]
+;;;
+;;; <inst> -> <tycon>
+;;;        -> ( <tycon> <tyvar> ... <tyvar> )
+;;;        -> ( <tyvar> , ... , <tyvar>)
+;;;        -> ()
+;;;        -> [ <tyvar> ]
+;;;        -> ( <tyvar> -> <tyvar>)
+;;;
+
+(define-struct instance-decl
+  (include ast-node)
+  (slots
+   ;; <context>
+   (context (type (list context)))
+   ;; <tycls>
+   (class (type class-ref))
+   ;;
+   (simple (type type))
+   ;; <valdefs>
+   (decls (type (list valdef)))
+   ))
+
+
+
+;;; <default-decl> -> default <type>
+;;;                -> default ( <type> , ... , <type> )
+
+(define-struct default-decl
+  (include ast-node)
+  (slots
+   (types (type (list type)))))
+
+
+;;; <tycls> -> <aconid>
+
+(define-struct class-ref
+  (include ast-node)
+  (slots
+   (name (type symbol))
+   (class (type def))))
+
diff --git a/ast/valdef-structs.scm b/ast/valdef-structs.scm
new file mode 100644 (file)
index 0000000..eb0dc88
--- /dev/null
@@ -0,0 +1,276 @@
+;;; File: ast/valdef-structs    Author: John
+
+;;; Ast structure for local declarations
+
+;;; <decl> -> <signdecl>
+;;;        -> <valdef>
+
+;;; decl contains value declarations and type signatures.(
+;;; type related decls are topdecls and are separated from
+;;; these decls.
+
+(define-struct decl   
+  (include ast-node))
+                      
+
+
+;;; <signdecl> -> <vars> :: [<context> =>] <type>
+;;;
+;;; <vars>     -> <var> , ... , <var>
+;;;
+
+(define-struct signdecl ; this affixes a signature to a list of variables
+  (include decl)
+  (predicate signdecl?)
+  (slots
+   (vars (type (list var-ref)))
+   (signature (type signature))))
+
+;;; This is introduced into decl lists by dependency analysis
+(define-struct recursive-decl-group
+  (include decl)
+  (slots
+   ;; none of these are recursive decl groups
+   (decls (type (list decl)))
+   ))
+
+;;; <valdef>  -> <lhs> = <exp> [where { <decls> [;] }]
+;;;           -> <lhs> <gdrhs> [where { <decls> [;] }]
+;;;
+;;; <lhs>     -> <apat>
+;;;           -> <funlhs>
+;;;
+;;; <funlhs>  -> <afunlhs>
+;;;           -> <pat> <varop> <pat>
+;;;           -> <lpat> <varop> <pat>
+;;;           -> <pat> <varop> <rpat>
+;;;
+;;; <afunlhs> -> <var> <apat>
+;;;           -> ( <funlhs> ) <apat>    (infix operator with more than 2 args)
+;;;           -> <afunlhs> <apat>       (multiple argument pattern)
+
+(define-struct valdef  ; this defines values.
+  (include decl)
+  (predicate valdef?)
+  (slots
+   ;; this pattern contains all new variables defined.
+   ;; For a function definition the pattern will always
+   ;; be a simple variable.
+   (lhs (type pattern))
+   ;; this is a list of right hand sides.
+   ;; for a pattern definition, this list is always a singleton.  For
+   ;; a function definition, there is a member for every successive
+   ;; alternative for the function.
+   (definitions (type (list single-fun-def)))
+   ;; this is used internally by dependency analysis
+   (depend-val (type int) (uninitialized? #t))
+   ;; this is filled in by the type phase
+   (dictionary-args (type (list var)) (uninitialized? #t))
+   ;; used for defaulting
+   (module (type symbol) (default '|Prelude|))
+   ))
+
+(define-struct single-fun-def
+  (include ast-node)
+  (slots
+   ;; this list is always empty for pattern definition
+   ;; and always non-empty for function definition.
+   ;; The length of this list is the arity of the function.
+   ;; All single-fun-defs for a function have the same arity.
+   (args (type (list pattern)))
+   ;; <gdrhs>, this contains a list of guard , expression pairs
+   (rhs-list (type (list guarded-rhs)))
+   ;; this contains declarations local to the
+   ;; single fun def.  It scopes over the args.  The
+   ;; guarded-rhs may refer to these values.
+   (where-decls (type (list decl)))
+   ;; true when declared in infix style.  Used for printing
+   ;; and to check precs in prec parsing.
+   (infix? (type bool) (bit #t))
+   ))
+
+
+
+;;; <gdrhs>   -> <gd> = <exp> [<gdrhs>]
+;;;
+;;; <gd>      -> | <exp>
+
+(define-struct guarded-rhs ; a single guarded expression.  A special expression
+  (include ast-node)
+  (slots
+   ;; node - omitted-guard - is used when no guard given
+   (guard (type exp))
+   (rhs (type exp))))
+
+
+;;; Some examples of the above:
+;;; (a,b) | z>y = (z,y)
+;;;       | otherwise = (1,2)
+;;;   where z = x-2
+;;;
+;;;  valdef:
+;;;    lhs = (a,b)
+;;;    definitions =
+;;;       [single-fun-def:
+;;;         args = []
+;;;         rhs-list = [guarded-rhs: guard = z>y
+;;;                                  rhs = (z,y),
+;;;                     guarded-rhs: guard = otherwise
+;;;                                  rhs = (1,2)]
+;;;         where-decls = [valdef: lhs = z
+;;;                                definitions =
+;;;                                   [single-fun-def:
+;;;                                      args = []
+;;;                                      rhs-list = [guarded-rhs:
+;;;                                                    guard = omitted-guard
+;;;                                                    exp = x-2]
+;;;                                      where-decls = []]]]
+;;;
+;;;  fact 0 = 1
+;;;  fact (n+1) = (n+1)*fact n
+;;;
+;;;  valdef:
+;;;    lhs = fact
+;;;    definitions =
+;;;       [single-fun-def:
+;;;         args = [0]
+;;;         rhs-list = [guarded-rhs: guard = omitted-guard
+;;;                                  rhs = 1]
+;;;         where-decls = [],
+;;;        single-fun-def:
+;;;         args = [n+1]
+;;;         rhs-list = [guarded-rhs: guard = omitted-guard
+;;;                                  rhs = (n+1)*fact n]
+;;;         where-decls = []]
+
+
+
+
+;;; Definitions for patterns
+
+;;; This is a simplification; the real syntax is complicated by
+;;; rules for precedence and associativity.
+;;;
+;;; <pat>   -> <pat> <conop> <pat>           pcon
+;;;         -> <pat> + <integer>             plus-pat
+;;;         -> - <integer-or-float>          *** ???  const-pat?
+;;;         -> <apat>
+;;;         -> <con> <apat> .... <apat>      pcon
+;;;
+;;; <apat>  -> <var>                         var-pat
+;;;         -> <var> @ <apat>                as-pat
+;;;         -> <con>                         *** ??? var-pat?
+;;;         -> <literal>                     const-pat
+;;;         -> _                             wildcard-pat
+;;;         -> ()                            pcon special case
+;;;         -> ( <pat> )                     (grouping syntax)
+;;;         -> ( <pat> , ... , <pat> )       pcon special case
+;;;         -> [ <pat> , ... , <pat> ]       list-pat
+;;;         -> ~ <apat>                      irr-pat
+
+(define-struct pattern
+  (include ast-node))
+
+(define-struct apat
+  (include pattern))
+
+(define-struct as-pat  ;; var@pat
+  (include apat)
+  (slots
+   (var (type var-ref))
+   (pattern (type pattern))))
+
+(define-struct irr-pat ;; ~pat
+  (include apat)
+  (slots
+   (pattern (type pattern))))
+
+(define-struct var-pat  ;; v
+  (include apat)
+  (predicate var-pat?)
+  (slots
+   (var (type var-ref))))
+
+(define-struct wildcard-pat  ;; _
+  (include apat)
+  (predicate wildcard-pat?))
+
+(define-struct const-pat  ;; literal
+  (include apat)
+  (predicate const-pat?)
+  (slots
+   (value (type const))
+   ;; this is the code that actually performs the match.
+   ;; it's filled in by type phase.
+   (match-fn (type exp) (uninitialized? #t))))
+
+(define-struct plus-pat  ;; p+k
+  (include pattern)
+  (slots
+   (pattern (type pattern))
+   (k (type integer))
+   ;; code to check for match, filled in by type phase
+   (match-fn (type exp) (uninitialized? #t))
+   ;; code to bind result, filled in by type phase
+   (bind-fn (type exp) (uninitialized? #t))
+   ))
+
+(define-struct pcon      ;; con pat1 pat2 ...
+  (include pattern)      ;; pat1 con pat2
+  (predicate pcon?)
+  (slots
+   (name (type symbol))
+   (con (type def))
+   (pats (type (list pattern)))
+   (infix? (type bool) (bit #t))))
+
+(define-struct list-pat   ;; [p1,p2,...]
+  (include apat)
+  (slots
+   (pats (type (list pattern)))))
+
+;;; The following structs deal with prec parsing of patterns.
+
+(define-struct pp-pat-list
+  (include pattern)
+  (slots
+   (pats (type (list pattern)))))
+
+(define-struct pp-pat-plus
+  (include pattern)
+  (predicate pp-pat-plus?))
+
+(define-struct pp-pat-negated
+  (include pattern)
+  (predicate pp-pat-negated?))
+
+
+
+;;; Structs for annotations
+
+(define-struct annotation
+  (include decl)
+  (predicate annotation?))
+
+(define-struct annotation-decl
+  (include annotation)
+  (predicate annotation-decl?)
+  (slots
+   (names (type (list symbol)))
+   (annotations (type (list annotation-value)))))
+
+(define-struct annotation-value
+  (include annotation)
+  (predicate annotation-value?)
+  (slots
+   (name (type symbol))
+   (args (type (list t)))))
+
+;;; This is a list of annotations placed in where decls lists in the same
+;;; manner a signdecls.
+
+(define-struct annotation-decls
+  (include annotation)
+  (predicate annotation-decls?)
+  (slots
+    (annotations (type (list annotation)))))
diff --git a/backend/README b/backend/README
new file mode 100644 (file)
index 0000000..f221b1a
--- /dev/null
@@ -0,0 +1,10 @@
+This directory contains the files for the compiler backend.  All of these
+phases operate on FLIC code.
+
+optimize -- performs various tweaks to compact the code and make it faster.
+  also includes a postpass to fill in some additional structure slots.
+
+strictness -- attaches strictness information to functions and decides
+  whether locally-bound variables have a boxed or unboxed representation.
+
+codegen -- generates Lisp code from the optimized FLIC code.
diff --git a/backend/backend.scm b/backend/backend.scm
new file mode 100644 (file)
index 0000000..b370ea7
--- /dev/null
@@ -0,0 +1,21 @@
+;;; backend.scm -- compilation unit for code generator stuff
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  13 May 1992
+;;;
+
+
+(define-compilation-unit backend
+  (source-filename "$Y2/backend/")
+  (require flic)
+  (unit optimize
+       (source-filename "optimize.scm"))
+  (unit strictness
+       (source-filename "strictness.scm"))
+  (unit box
+       (source-filename "box.scm"))
+  (unit codegen
+       (source-filename "codegen.scm"))
+  (unit interface-codegen
+       (source-filename "interface-codegen.scm")))
+
diff --git a/backend/box.scm b/backend/box.scm
new file mode 100644 (file)
index 0000000..c47848a
--- /dev/null
@@ -0,0 +1,417 @@
+;;; box.scm -- determine which expressions need to be boxed
+;;;
+;;; author  :  Sandra Loosemore
+;;; date    :  03 Apr 1993
+;;;
+;;; 
+;;; This phase determines whether expressions need to be boxed or unboxed.
+;;;
+;;; In the case of an expression that needs to be boxed, it determines 
+;;; whether it can be evaluated eagerly and boxed or whether a delay
+;;; must be constructed.
+;;;
+;;; In the case of an expression that needs to be unboxed, it determines
+;;; whether it is already known to have been evaluated and can simply
+;;; be unboxed instead of checking for a delay that must be forced.
+;;;
+;;; This phase may mark previously non-strict variables as strict if their
+;;; initializers can be evaluated eagerly.  However, doing this evaluation
+;;; eagerly never causes any other non-strict variables to be forced,
+;;; so there is no need to propagate this strictness information backwards
+;;; (as happens in the var-strictness-walk pass).
+
+
+;;;======================================================================
+;;; Top-level function
+;;;======================================================================
+
+
+;;; Complexity computation
+
+(define-integrable delay-complexity 10)
+(define-integrable unbox-complexity 1)
+(define-integrable box-complexity 2)
+(define-integrable sel-complexity 1)
+(define-integrable is-constructor-complexity 1)
+(define-integrable pack-complexity 2)
+(define-integrable con-number-complexity 1)
+
+(define (add-complexity c1 c2)
+  (cond ((not c1)
+        '#f)
+       ((not c2)
+        '#f)
+       (else
+        ;; *** We might want to establish an arbitrary cutoff here.
+        ;; *** e.g., if complexity > N then set it to '#f.
+        (the fixnum (+ (the fixnum c1) (the fixnum c2))))))
+
+
+
+;;; The second argument to the walker is a list of things
+;;; that are known to have been forced already.
+;;; The third argument is a list of variables that have not yet
+;;; been initialized.
+;;; Walkers return two values:  a new value for already-forced and
+;;; the complexity of the expression.
+
+;;; This helper function sets the unboxed? and cheap? bits for the
+;;; code generator, and adjusts the basic complexity to account for
+;;; forces, boxes, and delays.
+;;;
+;;; The basic decision tree for the code generator should be:
+;;; if unboxed?
+;;;    then if strict-result?
+;;;            then generate x                                   (1)
+;;;            else if cheap?
+;;;                    then generate (unbox x)                   (2)
+;;;                    else generate (force x)                   (3)
+;;;    else if strict-result?
+;;;            then if cheap?
+;;;                    then generate (box x)                     (4)
+;;;                    else generate (delay x)                   (5)
+;;;            else if cheap?
+;;;                    then generate x                           (6)
+;;;                    then generate (delay (force x))           (7)
+;;; See function do-codegen in codegen.scm.
+
+
+(define (do-box-analysis object already-forced uninitialized unboxed?)
+  (setf (flic-exp-unboxed? object) unboxed?)
+  (multiple-value-bind (result complexity)
+      (box-analysis object already-forced uninitialized)
+    (setf complexity
+         (if unboxed?
+             ;; If the expression returns a boxed value and we want
+             ;; an unboxed one, we may need to do a force.
+             (if (flic-exp-strict-result? object)
+                 (begin                                       ; case (1)
+                   ;; this flic-exp-cheap? bit is used only by
+                   ;; exp-would-be-cheap? below -- not by codegen
+                   (setf (flic-exp-cheap? object)
+                         (if complexity '#t '#f))
+                   complexity)      
+                 (if (already-forced? object already-forced)
+                     (begin                                   ; case (2)
+                       (setf (flic-exp-cheap? object) '#t)
+                       (add-complexity complexity unbox-complexity))
+                     (begin                                   ; case (3)
+                       (setf (flic-exp-cheap? object) '#f)
+                       '#f)))
+             ;; We want a boxed value.  If the expression already
+             ;; returns a boxed value, return its complexity directly;
+             ;; otherwise return the cost of either boxing or delaying it.
+             (if (flic-exp-strict-result? object)
+                 (if complexity
+                     (begin                                   ; case (4)
+                       (setf (flic-exp-cheap? object) '#t)
+                       (add-complexity complexity box-complexity))
+                     (begin                                   ; case (5)
+                       (setf (flic-exp-cheap? object) '#f)
+                       delay-complexity))
+                 (if complexity
+                     (begin
+                       (setf (flic-exp-cheap? object) '#t)    ; case (6)
+                       complexity)
+                     (begin                                   ; case (7)
+                       (setf (flic-exp-cheap? object) '#f)
+                       delay-complexity)))
+           ))
+    (values
+      (if unboxed?
+         (note-already-forced object result)
+         result)
+      complexity)))
+
+
+
+
+;;;======================================================================
+;;; Code walk
+;;;======================================================================
+
+
+(define *local-function-calls* '())
+
+(define-flic-walker box-analysis (object already-forced uninitialized))
+
+(define-box-analysis flic-lambda (object already-forced uninitialized)
+  (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t)
+  (values already-forced 0))
+
+(define-box-analysis flic-let (object already-forced uninitialized)
+  (let ((bindings    (flic-let-bindings object)))
+    (dynamic-let ((*local-function-calls*  (dynamic *local-function-calls*)))
+      (dolist (var bindings)
+       ;; Note local functions
+       (when (and (not (var-toplevel? var))
+                  (is-type? 'flic-lambda (var-value var))
+                  (not (var-standard-refs? var)))
+         (push (cons var '()) (dynamic *local-function-calls*))))
+      (multiple-value-bind (already-forced complexity)
+         (box-analysis-let-aux object already-forced uninitialized)
+       (dolist (var bindings)
+         ;; Go back and reexamine local functions to see whether
+         ;; we can make more arguments strict, based on the values
+         ;; the function is actually called with.
+         (let ((stuff  (assq var (dynamic *local-function-calls*))))
+           (when stuff
+             (maybe-make-more-arguments-strict var (cdr stuff)))))
+       (values already-forced complexity)))))
+
+(define (box-analysis-let-aux object already-forced uninitialized)
+  (let ((recursive?  (flic-let-recursive? object))
+       (bindings    (flic-let-bindings object))
+       (body        (flic-let-body object)))
+    (when recursive? (setf uninitialized (append bindings uninitialized)))
+    (dolist (var bindings)
+      (let* ((value   (var-value var))
+            (strict? (var-strict? var))
+            (result  (do-box-analysis value already-forced uninitialized
+                                      strict?)))
+       (cond (strict?
+              ;; Propagate information about things forced.
+              (setf already-forced result))
+             ((and (flic-exp-cheap? value)
+                   (flic-exp-strict-result? value))
+              ;; The value expression is cheap unboxed value, so mark
+              ;; the variable as strict.
+              (setf (var-strict? var) '#t)
+              (setf (flic-exp-unboxed? value) '#t))))
+      (when recursive? (pop uninitialized)))
+    ;; *** Could be smarter about computing complexity.
+    (values
+      (do-box-analysis body already-forced uninitialized '#t)
+      '#f)))
+
+(define (maybe-make-more-arguments-strict var calls)
+  (setf (var-strictness var)
+       (maybe-make-more-arguments-strict-aux
+         (flic-lambda-vars (var-value var))
+         calls)))
+
+(define (maybe-make-more-arguments-strict-aux vars calls)
+  (if (null? vars)
+      '()
+      (let ((var  (car vars)))
+       ;; If the variable is not already strict, check to see
+       ;; whether it's always called with "cheap" arguments.
+       (when (and (not (var-strict? var))
+                  (every-1 (lambda (call)
+                             (exp-would-be-cheap? (car call) var))
+                           calls))
+         (setf (var-strict? var) '#t)
+         (dolist (call calls)
+           (setf (flic-exp-unboxed? (car call)) '#t)))
+       (cons (var-strict? var)
+             (maybe-make-more-arguments-strict-aux
+              (cdr vars)
+              (map (function cdr) calls))))
+    ))
+
+
+;;; Look for one special fixed-point case: argument used as counter-type
+;;; variable.  Otherwise ignore fixed points.
+
+(define (exp-would-be-cheap? exp var)
+  (or (and (flic-exp-cheap? exp)
+          (flic-exp-strict-result? exp))
+      (and (is-type? 'flic-ref exp)
+          (eq? (flic-ref-var exp) var))
+      (and (is-type? 'flic-app exp)
+          (is-type? 'flic-ref (flic-app-fn exp))
+          (var-complexity (flic-ref-var (flic-app-fn exp)))
+          (every-1 (lambda (a) (exp-would-be-cheap? a var))
+                   (flic-app-args exp)))
+      ))
+
+
+
+(define-box-analysis flic-app (object already-forced uninitialized)
+  (let ((fn         (flic-app-fn object))
+       (args       (flic-app-args object))
+       (saturated? (flic-app-saturated? object)))
+    (cond ((and saturated? (is-type? 'flic-ref fn))
+          (let* ((var    (flic-ref-var fn))
+                 (stuff  (assq var (dynamic *local-function-calls*))))
+            (when stuff
+              (push args (cdr stuff)))
+            (box-analysis-app-aux
+              (var-strictness var) (var-complexity var)
+              args already-forced uninitialized)))
+         ((and saturated? (is-type? 'flic-pack fn))
+          (box-analysis-app-aux
+            (con-slot-strict? (flic-pack-con fn)) pack-complexity
+            args already-forced uninitialized))
+         (else
+          ;; The function is going to be forced but all the arguments
+          ;; are non-strict.
+          (dolist (a args)
+            (do-box-analysis a already-forced uninitialized '#f))
+          (values 
+            (do-box-analysis fn already-forced uninitialized '#t)
+            '#f))
+         )))
+         
+
+
+;;; Propagation of already-forced information depends on whether or
+;;; not the implementation evaluates function arguments in left-to-right
+;;; order.  If not, we can still propagate this information upwards.
+
+(define (box-analysis-app-aux
+          strictness complexity args already-forced uninitialized)
+  (let ((result   already-forced))
+    (dolist (a args)
+      (let ((strict?  (pop strictness)))
+       (multiple-value-bind (new-result new-complexity)
+           (do-box-analysis a already-forced uninitialized strict?)
+         (when strict?
+           (setf result
+                 (if left-to-right-evaluation
+                     (setf already-forced new-result)
+                     (union-already-forced
+                       new-result already-forced result))))
+         (setf complexity (add-complexity complexity new-complexity)))))
+    (values result complexity)))
+
+
+(define-box-analysis flic-ref (object already-forced uninitialized)
+  (values
+    already-forced
+    (if (memq (flic-ref-var object) uninitialized)
+       '#f
+       0)))
+
+(define-box-analysis flic-const (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+(define-box-analysis flic-pack (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+
+;;; For case-block and and, already-forced information can be propagated 
+;;; sequentially in the clauses.  But only the first expression is 
+;;; guaranteed to be evaluated, so only it can propagate the information
+;;; outwards.
+
+(define-box-analysis flic-case-block (object already-forced uninitialized)
+  (values
+    (box-analysis-sequence
+      (flic-case-block-exps object) already-forced uninitialized)
+    '#f))
+
+(define-box-analysis flic-and (object already-forced uninitialized)
+  (values
+    (box-analysis-sequence
+      (flic-and-exps object) already-forced uninitialized)
+    '#f))
+
+(define (box-analysis-sequence exps already-forced uninitialized)
+  (let ((result
+         (setf already-forced
+               (do-box-analysis
+                 (car exps) already-forced uninitialized '#t))))
+    (dolist (e (cdr exps))
+      (setf already-forced
+           (do-box-analysis e already-forced uninitialized '#t)))
+    (values result already-forced)))
+
+
+(define-box-analysis flic-return-from (object already-forced uninitialized)
+  (values
+    (do-box-analysis
+      (flic-return-from-exp object) already-forced uninitialized '#t)
+    '#f))
+
+
+;;; For if, the test propagates to both branches and the result.
+;;; Look for an important optimization:
+;;; in (if (and e1 e2 ...) e-then e-else),
+;;; e-then can inherit already-forced information from all of the ei
+;;; rather than only from e1.
+;;; *** Could be smarter about the complexity, I suppose....
+;;; *** Also could intersect already-forced results from both
+;;; *** branches.
+
+(define-box-analysis flic-if (object already-forced uninitialized)
+  (if (is-type? 'flic-and (flic-if-test-exp object))
+      (box-analysis-if-and-aux object already-forced uninitialized)
+      (box-analysis-if-other-aux object already-forced uninitialized)))
+
+(define (box-analysis-if-other-aux object already-forced uninitialized)
+  (setf already-forced
+       (do-box-analysis
+         (flic-if-test-exp object) already-forced uninitialized '#t))
+  (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t)
+  (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t)
+  (values already-forced '#f))
+
+(define (box-analysis-if-and-aux object already-forced uninitialized)
+  (let* ((test-exp  (flic-if-test-exp object))
+        (subexps   (flic-and-exps test-exp))
+        (then-exp  (flic-if-then-exp object))
+        (else-exp  (flic-if-else-exp object)))
+    (setf (flic-exp-unboxed? test-exp) '#t)
+    (multiple-value-bind (result1 resultn)
+       (box-analysis-sequence subexps already-forced uninitialized)
+      (do-box-analysis then-exp resultn uninitialized '#t)
+      (do-box-analysis else-exp result1 uninitialized '#t)
+      (values result1 '#f))))
+
+
+(define-box-analysis flic-sel (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-sel-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity sel-complexity complexity))))
+
+(define-box-analysis flic-is-constructor (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-is-constructor-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity is-constructor-complexity complexity))))
+
+(define-box-analysis flic-con-number (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-con-number-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity con-number-complexity complexity))))
+
+(define-box-analysis flic-void (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+
+
+
+;;;======================================================================
+;;; Already-forced bookkeeping
+;;;======================================================================
+
+
+;;; For now, we only keep track of variables that have been forced,
+;;; and not data structure accesses.
+
+(define (already-forced? object already-forced)
+  (and (is-type? 'flic-ref object)
+       (memq (flic-ref-var object) already-forced)))
+
+(define (note-already-forced object already-forced)
+  (if (is-type? 'flic-ref object)
+      (cons (flic-ref-var object) already-forced)
+      already-forced))
+
+(define (union-already-forced new tail result)
+  (cond ((eq? new tail)
+        result)
+       ((memq (car new) result)
+        (union-already-forced (cdr new) tail result))
+       (else
+        (union-already-forced (cdr new) tail (cons (car new) result)))
+       ))
+
+                                     
+
diff --git a/backend/codegen.scm b/backend/codegen.scm
new file mode 100644 (file)
index 0000000..283594f
--- /dev/null
@@ -0,0 +1,600 @@
+;;; codegen.scm -- compile flic code to Lisp
+;;;
+;;; Author :  Sandra Loosemore
+;;; Date   :  29 Apr 1992
+;;;
+;;; to do:  check completeness of special cases for constructors
+;;;         constants still need work
+;;;         optimized entry points
+;;;
+;;; The code generated here uses the following helper functions:
+;;; (make-curried-fn opt-fn strictness)
+;;;   make a curried function that calls opt-fn after collecting the
+;;;   arguments and processing them according to strictness.  Both
+;;;   the arguments are evaluated.
+;;; (make-tuple-constructor arity)
+;;;   return a function that makes an untagged data structure with "arity" 
+;;;   slots.  "arity" is a constant.
+;;; (make-tuple . args)
+;;;   uncurried version of the above
+;;; (make-tagged-data-constructor n arity)
+;;;   return a function that makes a data structure with tag "n" and
+;;;   "arity" slots.
+;;; (make-tagged-data n . args)
+;;;   uncurried version of the above
+;;; (tuple-select arity i object)
+;;;   extract component "i" from untagged "object"
+;;; (tagged-data-select arity i object)
+;;;   extract component "i" from tagged "object"
+;;; (constructor-number object)
+;;;   return the tag from "object"
+;;; (delay form)
+;;;   returns a delay object with unevaluated "form".
+;;; (box form)
+;;;   returns a delay object with evaluated "form".
+;;; (force delay)
+;;;   return the value of the delay object.
+;;; (make-haskell-string string)
+;;;   Converts a Lisp string lazily to a haskell string (using a magic
+;;;   delay function).  Returns an unboxed result.
+
+
+
+;;;======================================================================
+;;; Code walker
+;;;======================================================================
+
+
+;;; Here is the main entry point.
+
+(define (codegen-top big-let)
+  (do ((bindings (flic-let-bindings big-let) (cdr bindings))
+       (result   '())
+       (decls    '()))
+      ((null? bindings) `(begin ,@(nreverse decls) ,@(nreverse result)))
+    (let ((var  (car bindings)))
+      (push `(predefine ,(fullname var)) decls)
+      (push (codegen-definition var (var-value var)) result))))
+
+
+;;; See box.scm for more information about this...
+
+(define (do-codegen object)
+  (let ((x               (codegen object))
+       (unboxed?        (flic-exp-unboxed? object))
+       (strict-result?  (flic-exp-strict-result? object))
+       (cheap?          (flic-exp-cheap? object)))
+    (if unboxed?
+       (if strict-result?
+           x
+           (if cheap?
+               `(unbox ,x)
+               `(force ,x)))
+       (if strict-result?
+           (if cheap?
+               `(box ,x)
+               `(delay ,x))
+           (if cheap?
+               x
+               `(delay (force ,x)))))))
+    
+
+(define (do-codegen-list list)
+  (map (function do-codegen) list))
+
+
+(define-flic-walker codegen (object))
+
+
+;;; For top-level definitions bound to lambda expressions, make both
+;;; a standard entry point (with possibly unboxed arguments) and
+;;; a standard entry point.
+
+(define (codegen-definition var exp)
+  (let ((fullname  (fullname var)))
+    (when (or (memq 'codegen (dynamic *printers*))
+             (memq 'codegen-flic (dynamic *printers*)))
+;       (format '#t "~%Codegen of ~A [~A]  " (def-name var) (struct-hash var))
+       (format '#t "~%Codegen of ~A  " (def-name var))
+       (when (not (var-strict? var))
+          (format '#t "Nonstrict  "))
+       (when (not (eq? (var-strictness var) '()))
+          (format '#t "Strictness: ")
+          (dolist (s (var-strictness var))
+              (format '#t (if s "S " "N "))))
+       (when (var-simple? var)
+          (format '#t " Inline "))
+       (format '#t "~%")
+       (when (memq 'codegen-flic (dynamic *printers*))
+          (pprint* exp)))
+    (let ((lisp-code
+          (if (not (flic-lambda? exp))
+              `(define ,fullname ,(do-codegen exp))
+              (let* ((optname  (optname var))
+                     (lambda   (codegen-lambda-aux exp))
+                     (def      `(define (,optname ,@(cadr lambda))
+                                                  ,@(cddr lambda))))
+                (if (var-selector-fn? var)
+                    ;; Standard entry point for selectors is never used.
+                    def
+                    `(begin
+                       ,def
+                       (define ,fullname
+                         ,(maybe-make-box-value
+                           (codegen-curried-fn
+                            `(function ,optname) (var-strictness var))
+                           (var-strict? var)))))))))
+      (when (or (memq 'codegen (dynamic *printers*))
+               (memq 'codegen-flic (dynamic *printers*)))
+           (pprint* lisp-code))
+      lisp-code)))
+
+(define (codegen-lambda-list vars)
+  (map (function fullname) vars))
+
+(define (codegen-curried-fn opt-fn strictness)
+  (if (null? (cdr strictness))
+      ;; one-argument special cases
+      (if (car strictness)
+         `(make-curried-fn-1-strict ,opt-fn)
+         `(make-curried-fn-1-nonstrict ,opt-fn))
+      ;; general case
+      `(make-curried-fn ,opt-fn ',strictness)))
+
+
+;;; Curry lambdas.  Functions always return an unboxed value.
+
+(define-codegen flic-lambda (object)
+  (codegen-curried-fn
+    (codegen-lambda-aux object)
+    (map (lambda (x) (var-strict? x)) (flic-lambda-vars object))))
+
+(define (codegen-lambda-aux object)
+  (let* ((vars    (flic-lambda-vars object))
+        (ignore  '())
+        (args    (codegen-lambda-list vars)))
+    (dolist (v vars)
+      (if (eqv? (var-referenced v) 0)
+         (push (fullname v) ignore)))
+    `(lambda ,args
+       ,@(if (not (null? ignore))
+            `((declare (ignore ,@ignore)))
+            '())
+       ,(do-codegen (flic-lambda-body object)))))
+
+
+;;; This is only for non-top-level lets.
+;;; The boxing of the value of each of the bindings is controlled by its
+;;; strict? property.
+
+(define-codegen flic-let (object)
+  (let ((bindings   (flic-let-bindings object))
+       (body       (flic-let-body object))
+       (recursive? (flic-let-recursive? object)))
+    (if recursive?
+       (codegen-letrec bindings body)
+       (codegen-let*   bindings body))))
+
+
+;;; For efficiency reasons, we want to make all the function bindings
+;;; in the function namespace (some implementations do not do tail-recursion
+;;; or other optimizations correctly otherwise).  This means we have
+;;; to sort out the variable bindings from the function bindings here.
+
+(define (codegen-letrec bindings body)
+  (let ((let-bindings     '())
+       (labels-bindings  '()))
+    (dolist (var bindings)
+      (let ((value    (var-value var))
+           (fullname (fullname var))
+           (strict?  (var-strict? var)))
+       (if (flic-lambda? value)
+           ;; Some functions may need only the optimized or standard
+           ;; entry points, but not both.
+           (let ((optname     (optname var))
+                 (lambda      (codegen-lambda-aux value))
+                 (optimized?  (var-optimized-refs? var))
+                 (standard?   (var-standard-refs? var)))
+             (when standard?
+               (push (list fullname
+                           (maybe-make-box-value
+                             (codegen-curried-fn
+                               (if optimized? `(function ,optname) lambda)
+                               (var-strictness var))
+                             strict?))
+                     let-bindings))
+             (when optimized?
+               (push (cons optname (cdr lambda)) labels-bindings)))
+           (push (list fullname (do-codegen value)) let-bindings))))
+    (setf let-bindings (nreverse let-bindings))
+    (setf labels-bindings (nreverse labels-bindings))
+    (cond ((null? let-bindings)
+          `(labels ,labels-bindings ,(do-codegen body)))
+         ((null? labels-bindings)
+          `(letrec ,let-bindings ,(do-codegen body)))
+         (t
+          `(let ,(map (lambda (b) `(,(car b) '#f)) let-bindings)
+             (labels ,labels-bindings
+                     ,@(map (lambda (b) `(setf ,@b)) let-bindings)
+                     ,(do-codegen body))))
+         )))
+
+(define (codegen-let* bindings body)
+  (if (null? bindings)
+      (do-codegen body)
+      (let* ((var       (car bindings))
+            (value     (var-value var))
+            (fullname  (fullname var))
+            (strict?   (var-strict? var))
+            (body      (codegen-let* (cdr bindings) body)))
+       (if (flic-lambda? value)
+           ;; Some functions may need only the optimized or standard
+           ;; entry points, but not both.
+           (let ((optname     (optname var))
+                 (lambda      (codegen-lambda-aux value))
+                 (optimized?  (var-optimized-refs? var))
+                 (standard?   (var-standard-refs? var)))
+             (when standard?
+               (setf body
+                     (add-let-binding
+                       (list fullname
+                             (maybe-make-box-value
+                               (codegen-curried-fn
+                                 (if optimized? `(function ,optname) lambda)
+                                 (var-strictness var))
+                               strict?))
+                       body)))
+             (when optimized?
+               (setf body `(flet ((,optname ,@(cdr lambda))) ,body)))
+             body)
+           (add-let-binding (list fullname (do-codegen value)) body)))))
+
+(define (add-let-binding binding body)
+  (if (and (pair? body) (eq? (car body) 'let*))
+      `(let* (,binding ,@(cadr body)) ,@(cddr body))
+      `(let* (,binding) ,body)))
+
+
+(define-codegen flic-app (object)
+  (let ((fn         (flic-app-fn object))
+       (args       (flic-app-args object))
+       (saturated? (flic-app-saturated? object)))
+    (cond ((and saturated? (flic-pack? fn))
+          ;; Saturated call to constructor
+          (codegen-constructor-app-aux
+            (flic-pack-con fn)
+            (do-codegen-list args)))
+         ((and saturated? (flic-ref? fn))
+          ;; Saturated call to named function
+          (let* ((var     (flic-ref-var fn))
+                 (optname (optname var))
+                 (argcode (do-codegen-list args)))
+            `(,optname ,@argcode)))
+         (else
+          ;; Have to make a curried call to standard entry point.
+          (let ((fncode   (do-codegen fn))
+                (argcode  (do-codegen-list args)))
+            (if (and (pair? fncode)
+                     (eq? (car fncode) 'force))
+                `(funcall-force ,(cadr fncode) ,@argcode)
+                `(funcall ,fncode ,@argcode))))
+         )))
+
+(define (codegen-constructor-app-aux con argcode)
+  (let ((alg  (con-alg con)))
+    (cond ((eq? con (core-symbol ":"))
+          `(cons ,@argcode))
+         ((algdata-implemented-by-lisp? alg)
+          (apply-maybe-lambda (cadr (con-lisp-fns con)) argcode))
+         ((algdata-tuple? alg)
+          `(make-tuple ,@argcode))
+         (else
+          `(make-tagged-data ,(con-tag con) ,@argcode)))))
+
+
+(define-codegen flic-ref (object)
+  (fullname (flic-ref-var object)))
+
+
+(define-codegen flic-const (object)
+  (let ((value   (flic-const-value object)))
+    (cond ((string? value)
+          `(make-haskell-string ,value))
+         ((char? value)
+          ;; *** I think the parser ought to convert characters to their
+          ;; *** ASCII codes instead of doing it here.  There are problems
+          ;; *** with valid Haskell characters that can't be represented
+          ;; *** portably as Lisp characters.
+          (char->integer value))
+         ((number? value)
+          value)
+         (else
+          ;; It must be a ratio.  This is a bit of a hack - this depends on
+          ;; the fact that 2 tuples are represented in the same manner as
+          ;; rationals.  Hacked for strict rationals - jcp
+          `(make-tuple ,(car value) ,(cadr value)))
+         )))
+
+
+;;; Returns a function or constant, so doesn't need to delay result.
+;;; See flic-app for handling of saturated constructor calls.
+
+(define-codegen flic-pack (object)
+  (let* ((con        (flic-pack-con object))
+        (arity      (con-arity con))
+        (alg        (con-alg con))
+        (tuple?     (algdata-tuple? alg))
+        (strictness (con-slot-strict? con))
+        (index      (con-tag con)))
+    (cond ((eq? con (core-symbol "Nil"))
+          ''())
+         ((eq? con (core-symbol "True"))
+          ''#t)
+         ((eq? con (core-symbol "False"))
+          ''#f)
+         ((eq? con (core-symbol ":"))
+          '(function make-cons-constructor))
+         ((algdata-implemented-by-lisp? alg)
+          (let ((fn (cadr (con-lisp-fns con))))
+            (if (eqv? (con-arity con) 0)
+                fn
+                (codegen-curried-fn
+                 (if (and (pair? fn) (eq? (car fn) 'lambda))
+                     fn
+                     `(function ,fn))
+                 strictness))))
+         ((algdata-enum? alg)
+          ;; All constructors have 0 arity; represent them just
+          ;; by numbers.
+          index)
+         (tuple?
+          ;; Only a single constructor for this type.
+          (codegen-curried-fn
+            `(make-tuple-constructor ,arity)
+            strictness))
+         ((eqv? arity 0)
+          ;; No arguments to this constructor.
+          `(make-tagged-data ,index))
+         (else
+          ;; General case.
+          (codegen-curried-fn
+           `(make-tagged-data-constructor ,index ,arity)
+           strictness))
+         )))
+
+
+
+;;; These expressions translate directly into their Lisp equivalents.
+
+(define-codegen flic-case-block (object)
+  `(block ,(flic-case-block-block-name object)
+     ,@(do-codegen-list (flic-case-block-exps object))))
+
+(define-codegen flic-return-from (object)
+  `(return-from ,(flic-return-from-block-name object)
+               ,(do-codegen (flic-return-from-exp object))))
+
+(define-codegen flic-and (object)
+  `(and ,@(do-codegen-list (flic-and-exps object))))
+
+(define-codegen flic-if (object)
+  `(if ,(do-codegen (flic-if-test-exp object))
+       ,(do-codegen (flic-if-then-exp object))
+       ,(do-codegen (flic-if-else-exp object))))
+
+(define-codegen flic-sel (object)
+  (codegen-flic-sel-aux
+    (flic-sel-con object)
+    (flic-sel-i object)
+    (do-codegen (flic-sel-exp object))))
+
+(define (codegen-flic-sel-aux con index exp)
+  (let* ((alg      (con-alg con))
+        (tuple?   (algdata-tuple? alg))
+        (arity    (con-arity con)))
+    (cond ((eq? con (core-symbol ":"))
+          (if (eqv? index 0)
+              `(car ,exp)
+              `(cdr ,exp)))
+         ((algdata-implemented-by-lisp? alg)
+          (apply-maybe-lambda (list-ref (cddr (con-lisp-fns con)) index)
+                              (list exp)))
+         (tuple?
+          `(tuple-select ,arity ,index ,exp))
+         (else
+          `(tagged-data-select ,arity ,index ,exp))
+         )))
+
+(define-codegen flic-is-constructor (object)
+  (codegen-flic-is-constructor-aux
+    (flic-is-constructor-con object)
+    (do-codegen (flic-is-constructor-exp object))))
+
+(define (codegen-flic-is-constructor-aux con exp)
+  (let ((type (con-alg con)))
+    (cond ((eq? type (core-symbol "Bool"))
+          (if (eq? con (core-symbol "True"))
+              exp
+              `(not ,exp)))
+         ((eq? type (core-symbol "List"))
+          (if (eq? con (core-symbol ":"))
+              `(pair? ,exp)
+              `(null? ,exp)))
+         ((algdata-implemented-by-lisp? type)
+          (let ((fn (car (con-lisp-fns con))))
+            (apply-maybe-lambda fn (list exp))))
+         ((algdata-tuple? type)
+          ;; This should never happen.
+          ''#t)
+         ((algdata-enum? type)
+          `(eqv? (the fixnum ,exp) (the fixnum ,(con-tag con))))
+         (else
+          `(eqv? (the fixnum (constructor-number ,exp))
+                 (the fixnum ,(con-tag con))))
+         )))
+
+
+(define-codegen flic-con-number (object)
+  (let ((type   (flic-con-number-type object))
+       (exp    (do-codegen (flic-con-number-exp object))))
+    `(the fixnum
+         ,(cond ((eq? type (core-symbol "Bool"))
+                 `(if ,exp 1 0))
+                ((eq? type (core-symbol "List"))
+                 `(if (pair? ,exp) 0 1))
+                ((algdata-tuple? type)
+                 ;; This should never happen.
+                 0)
+                ((algdata-implemented-by-lisp? type)
+                 (let ((var (gensym)))
+                   `(let ((,var ,exp))
+                      (cond ,@(map (lambda (con)
+                                     `(,(apply-maybe-lambda
+                                         (car (con-lisp-fns con))
+                                         (list var))
+                                       ',(con-tag con)))
+                                   (algdata-constrs type))
+                            (else (error "No constructor satisfies ~A.~%"
+                                         ',(def-name type)))))))
+                ((algdata-enum? type)
+                 exp)
+                (else
+                 `(constructor-number ,exp))
+                ))
+    ))
+
+
+
+;;;======================================================================
+;;; Utility functions
+;;;======================================================================
+
+;;; Here are some helper functions for handing boxing and unboxing
+;;; of values.
+;;; maybe-make-box-delay is used to box forms that are "expensive" to
+;;; compute; maybe-make-box-value is used to box forms like constants
+;;; or functions that are "cheap" to compute eagerly.
+;;; Maybe-unbox is used to unbox a form that returns a boxed result.
+
+(define (maybe-make-box-delay form unboxed?)
+  (if unboxed?
+      form
+      `(delay ,form)))
+
+(define (maybe-make-box-value form unboxed?)
+  (if unboxed?
+      form
+      `(box ,form)))
+
+(define (maybe-unbox form unboxed?)
+  (if unboxed?
+      `(force ,form)
+      form))
+
+
+;;; These two var slots are filled in lazily by the code generator,
+;;; since most vars generated don't need them.  You should always
+;;; use these functions instead of accessing the structure slot
+;;; directly.
+
+(define (fullname var)
+  (or (var-fullname var)
+      (setf (var-fullname var)
+           (if (var-toplevel? var)
+               ;; For toplevel names, use module name glued onto base names.
+               ;; These are always interned symbols.
+               (if (def-core? var)
+                   (symbol-append '|*Core:| (def-name var))
+                   (symbol-append (def-module var) '\: (def-name var)))
+               ;; Otherwise, make sure we have a gensym.
+               ;; The uniquification of interned symbols is required
+               ;; because there may be multiple nested bindings of the
+               ;; same name, and we want to be able to distinguish between
+               ;; the different bindings.
+               (let ((name  (def-name var)))
+                 (if (gensym? name)
+                     name
+                     (gensym (symbol->string name))))))
+      ))
+
+(define (optname var)
+  (or (var-optimized-entry var)
+      (let ((name  (string-append (symbol->string (fullname var)) "/OPT")))
+       (setf (var-optimized-entry var)
+             (if (var-toplevel? var)
+                 (string->symbol name)
+                 (gensym name))))))
+
+
+
+;;;======================================================================
+;;; Exported functions
+;;;======================================================================
+
+;;; This handles types exported to lisp from Haskell
+;;; *** Is this really supposed to create variable bindings as
+;;; *** opposed to function bindings???
+;;; *** I assume all of these functions want strict arguments and return
+;;; *** strict results, even if the data structures contain boxed values.
+
+(define (codegen-exported-types mods)
+  (let ((defs '()))
+    (dolist (m mods)
+      (dolist (a (module-alg-defs m))
+        (when (algdata-export-to-lisp? a)
+         (dolist (c (algdata-constrs a))
+           (setf defs (nconc (codegen-constr c) defs))))))
+    `(begin ,@defs)))
+
+(define (codegen-constr c)
+  (let ((lisp-fns (con-lisp-fns c)))
+    (if c
+        (let ((res
+              `(,(codegen-lisp-predicate (car lisp-fns) c)
+                ,(codegen-lisp-constructor (cadr lisp-fns) c)
+                ,@(codegen-lisp-accessors
+                   (cddr lisp-fns) (con-slot-strict? c) c 0))))
+         (when (memq 'codegen (dynamic *printers*))
+           (dolist (d res)
+             (pprint* d)))
+         res)
+       '())))
+
+(define (codegen-lisp-predicate name c)
+  `(define (,name x)
+     ,(codegen-flic-is-constructor-aux c 'x)))
+
+(define (codegen-lisp-constructor name c)
+  (let ((strictness (con-slot-strict? c))
+       (args       '())
+       (exps       '()))
+    (dolist (s strictness)
+      (let ((arg  (gensym)))
+       (push arg args)
+       (push (if s arg `(box ,arg)) exps)))
+    `(define (,name ,@(nreverse args))
+        ,(codegen-constructor-app-aux c (nreverse exps)))))
+
+(define (codegen-lisp-accessors names strictness c i)
+  (declare (type fixnum i))
+  (if (null? names)
+      '()
+      (let ((body  (codegen-flic-sel-aux c i 'x)))
+       (when (not (car strictness))
+         (setf body `(force ,body)))
+       (cons `(define (,(car names) x) ,body)
+             (codegen-lisp-accessors (cdr names) (cdr strictness) c (+ i 1))))
+    ))
+
+
+
+;;; This is a special hack needed due to brain-dead common lisp problems.
+;;; This allows the user to place lambda defined functions in ImportLispType
+;;; *** I'm not convinced this is necessary;  ((lambda ...) args)
+;;; *** is perfectly valid Common Lisp syntax!
+
+(define (apply-maybe-lambda fn args)
+  (if (and (pair? fn)
+          (eq? (car fn) 'lambda))
+      `(funcall ,fn ,@args)
+      `(,fn ,@args)))
diff --git a/backend/interface-codegen.scm b/backend/interface-codegen.scm
new file mode 100644 (file)
index 0000000..50c8630
--- /dev/null
@@ -0,0 +1,200 @@
+
+;;; This generates code for vars defined in an interface.  This looks at
+;;; annotations and fills in the slots of the var definition.
+
+(define (haskell-codegen/interface mods)
+  (codegen/interface (car mods)))
+
+(define (codegen/interface mod)
+ (let ((code '()))
+  (dolist (d (module-decls mod))
+    (when (not (signdecl? d))
+      (error 'bad-decl))
+    (dolist (var (signdecl-vars d))
+     (let ((v (var-ref-var var)))
+      (setf (var-type v) (var-signature v))
+      (setf (var-toplevel? v) '#t)
+      (let ((a (lookup-annotation v '|Complexity|)))
+       (when (not (eq? a '#f))
+         (setf (var-complexity v)
+               (car (annotation-value-args a)))))
+      (let ((a (lookup-annotation v '|LispName|)))
+       (when (not (eq? a '#f))
+          (let ((lisp-entry (generate-lisp-entry v a)))
+            (push lisp-entry code)
+            (when (memq 'codegen (dynamic *printers*))
+               (pprint* lisp-entry))))))))
+  `(begin ,@code)))
+
+(define (generate-lisp-entry v a)
+  (let ((lisp-name (read-lisp-object (car (annotation-value-args a))))
+       (type (maybe-expand-io-type (gtype-type (var-type v)))))
+    (setf (var-optimized-entry v) lisp-name)
+    (if (arrow-type? type)
+       (codegen-lisp-fn v (gather-arg-types type))
+       (codegen-lisp-const v type))))
+
+(define (codegen-lisp-fn var arg-types)
+  (let* ((aux-definition '())
+        (wrapper? (foreign-fn-needs-wrapper? var arg-types))
+        (strictness-annotation (lookup-annotation var '|Strictness|))
+        (strictness (determine-strictness strictness-annotation arg-types))
+        (temps (gen-temp-names strictness)))
+    (setf (var-strict? var) '#t)
+    (setf (var-arity var) (length strictness))
+    (setf (var-strictness var) strictness)
+    (when wrapper?
+         (mlet (((code name)
+                 (make-wrapper-fn var (var-optimized-entry var) arg-types)))
+             (setf (var-optimized-entry var) name)
+             (setf aux-definition (list code))))
+    `(begin ,@aux-definition
+           (define ,(fullname var)
+                   ,(maybe-make-box-value
+                      (codegen-curried-fn
+                       (if wrapper?
+                           `(function ,(var-optimized-entry var))
+                           `(lambda ,temps
+                                 (,(var-optimized-entry var) ,@temps)))
+                        (var-strictness var))
+                      '#t)))))
+
+(define (determine-strictness a args)
+  (if (eq? a '#f)
+      (map (lambda (x) (declare (ignore x)) '#t) (cdr args))
+      (parse-strictness (car (annotation-value-args a)))))
+
+(define (codegen-lisp-const var type)
+  (let ((conversion-fn (output-conversion-fn type)))
+    (setf (var-strict? var) '#f)
+    (setf (var-arity var) 0)
+    (setf (var-strictness var) '())
+    `(define ,(fullname var)
+             (delay
+              ,(if (eq? conversion-fn '#f)
+                   (var-optimized-entry var)
+                   `(,@conversion-fn ,(var-optimized-entry var)))))))
+
+(define (maybe-expand-io-type ty)
+  (cond ((and (ntycon? ty)
+             (eq? (ntycon-tycon ty) (core-symbol "IO")))
+        (**ntycon (core-symbol "Arrow")
+                  (list (**ntycon (core-symbol "SystemState") '())
+                        (**ntycon (core-symbol "IOResult")
+                                  (ntycon-args ty)))))
+       ((arrow-type? ty)
+        (**ntycon (core-symbol "Arrow")
+                  (list (car (ntycon-args ty))
+                        (maybe-expand-io-type (cadr (ntycon-args ty))))))
+       (else ty)))
+
+(define (gather-arg-types type)
+  (if (arrow-type? type)
+      (let ((a (ntycon-args type)))
+       (cons (car a) (gather-arg-types (cadr a))))
+      (list type)))
+          
+(define (input-conversion-fn ty)
+  (if (ntycon? ty)
+      (let ((tycon (ntycon-tycon ty)))
+       (cond ((eq? tycon (core-symbol "String"))
+              (lambda (x) `(haskell-string->string ,x)))
+             ((eq? tycon (core-symbol "List"))  ; needs to convert elements
+              (let ((var (gensym "X"))
+                    (inner-fn (input-conversion-fn (car (ntycon-args ty)))))
+                (lambda (x) `(haskell-list->list
+                              (lambda (,var)
+                                ,(if (eq? inner-fn '#f)
+                                     var
+                                     (funcall inner-fn var)))
+                              ,x))))
+             ((eq? tycon (core-symbol "Char"))
+              (lambda (x) `(integer->char ,x)))
+             (else '#f)))
+      '#f))
+
+(define (output-conversion-fn ty)
+  (if (ntycon? ty)
+      (let ((tycon (ntycon-tycon ty)))
+       (cond ((eq? tycon (core-symbol "String"))
+              (lambda (x) `(make-haskell-string ,x)))
+             ((eq? tycon (core-symbol "List"))
+              (let ((var (gensym "X"))
+                    (inner-fn (output-conversion-fn (car (ntycon-args ty)))))
+                (lambda (x) `(list->haskell-list
+                              (lambda (,var)
+                                ,(if (eq? inner-fn '#f)
+                                     var
+                                     (funcall inner-fn var)))
+                              ,x))))
+             ((eq? tycon (core-symbol "UnitType"))
+              (lambda (x) `(insert-unit-value ,x)))
+             ((eq? tycon (core-symbol "IOResult"))
+              (lambda (x)
+                (let ((c1 (output-conversion-fn (car (ntycon-args ty)))))
+                  `(box ,(apply-conversion c1 x)))))
+             (else '#f)))
+      '#f))
+
+(define (apply-conversion fn x)
+  (if (eq? fn '#f)
+      x
+      (funcall fn x)))
+
+(define (foreign-fn-needs-wrapper? var args)
+ (if (lookup-annotation var '|NoConversion|)
+     '#f
+     (ffnw-1 args)))
+
+(define (ffnw-1 args)
+  (if (null? (cdr args))
+      (not (eq? (output-conversion-fn (car args)) '#f))
+      (or (not (eq? (input-conversion-fn (car args)) '#f))
+         (systemstate? (car args))
+         (ffnw-1 (cdr args)))))
+
+(define (make-wrapper-fn var fn args)
+  (mlet ((new-fn (symbol-append (fullname var) '|/wrapper|))
+        (avars (gen-temp-names (cdr args)))
+        (ignore-state? (systemstate? (cadr (reverse args))))
+        ((arg-conversions res-conversion)
+         (collect-conversion-fns avars args)))
+     (values
+      `(define (,new-fn ,@avars)
+        ,@(if ignore-state? `((declare (ignore ,(car (last avars)))))
+                            '())
+        ,@arg-conversions
+        ,(apply-conversion res-conversion
+                           `(,fn ,@(if ignore-state?
+                                       (butlast avars)
+                                       avars))))
+      new-fn)))
+
+(define (collect-conversion-fns avars args)
+  (if (null? avars)
+      (values '() (output-conversion-fn (car args)))
+      (mlet ((fn (input-conversion-fn (car args)))
+            ((c1 r) (collect-conversion-fns (cdr avars) (cdr args))))
+        (values (if (eq? fn '#f)
+                    c1
+                    `((setf ,(car avars) ,(funcall fn (car avars))) ,@c1))
+                r))))
+
+(define (arrow-type? x)
+  (and (ntycon? x)
+       (eq? (ntycon-tycon x) (core-symbol "Arrow"))))
+
+(define (systemstate? x)
+  (and (ntycon? x)
+       (eq? (ntycon-tycon x) (core-symbol "SystemState"))))
+
+(define (gen-temp-names l)
+  (gen-temp-names-1 l '(A B C D E F G H I J K L M N O P)))
+
+(define (gen-temp-names-1 l1 l2)
+  (if (null? l1)
+      '()
+      (if (null? l2)
+         (gen-temp-names-1 l1 (list (gensym "T")))
+         (cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2))))))
+
diff --git a/backend/optimize.scm b/backend/optimize.scm
new file mode 100644 (file)
index 0000000..1624e35
--- /dev/null
@@ -0,0 +1,1986 @@
+;;; optimize.scm -- flic optimizer
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  7 May 1992
+;;;
+;;;
+;;; The optimizer does these kinds of program transformations:
+;;;
+;;; * remove unreferenced variable bindings.
+;;;
+;;; * constant folding and various other kinds of compile-time
+;;;   evaluation.
+;;;
+;;; * beta reduction (replace references to variables bound to simple
+;;;   expressions with the expression)
+;;; 
+
+
+;;; Since some of the optimizations can make additional transformations
+;;; possible, we want to make multiple iteration passes.  But since each
+;;; pass is likely to have diminishing benefits, we don't want to keep
+;;; iterating indefinitely.  So establish a fairly arbitrary cutoff point.
+;;; The value is based on empirical results from compiling the prelude.
+
+(define *max-optimize-iterations* 5)
+(define *optimize-foldr-iteration* 0)  ; when to inline foldr
+(define *optimize-build-iteration* 0)  ; when to inline build
+(define *current-optimize-iteration* 0)
+
+
+;;; Flags for enabling various optimizations
+
+(define *all-optimizers* '(foldr inline constant lisp))
+(define *optimizers* *all-optimizers*)
+
+
+;;; Used to note whether we are doing the various optimizations
+
+(define-local-syntax (do-optimization? o)
+  `(memq ,o (dynamic *optimizers*)))
+
+(define *do-foldr-optimizations* (do-optimization? 'foldr))
+(define *do-inline-optimizations* (do-optimization? 'inline))
+(define *do-constant-optimizations* (do-optimization? 'constant))
+
+
+;;; If the foldr optimization is enabled, bind the corresponding
+;;; variables to these values instead of the defaults.
+
+(define *foldr-max-optimize-iterations* 15)
+(define *foldr-optimize-foldr-iteration* 8)
+(define *foldr-optimize-build-iteration* 5)
+
+
+;;; Some random other variables
+
+(define *structured-constants* '())
+(define *structured-constants-table* '#f)
+(define *lambda-depth* 0)
+(define *local-bindings* '())
+
+
+;;; This is for doing some crude profiling.  
+;;; Comment out the body of the macro to disable profiling.
+
+;;; Here are current counts from compiling the prelude:
+;;; (LET-REMOVE-UNUSED-BINDING . 5835) 
+;;; (REF-INLINE-SINGLE-REF . 2890) 
+;;; (REF-INLINE . 2692) 
+;;; (LET-EMPTY-BINDINGS . 2192) 
+;;; (APP-LAMBDA-TO-LET . 1537) 
+;;; (APP-MAKE-SATURATED . 416) 
+;;; (LET-HOIST-RETURN-FROM . 310) 
+;;; (CASE-BLOCK-IDENTITY . 273) 
+;;; (CASE-BLOCK-DEAD-CODE . 234) 
+;;; (CASE-BLOCK-TO-IF . 212) 
+;;; (SEL-FOLD-VAR . 211) 
+;;; (APP-HOIST-LET . 190) 
+;;; (LET-HOIST-LAMBDA . 181) 
+;;; (FOLDR-INLINE . 176) 
+;;; (AND-UNARY . 172) 
+;;; (LAMBDA-COMPRESS . 168) 
+;;; (APP-FOLD-SELECTOR . 141) 
+;;; (BUILD-INLINE-LAMBDA . 134) 
+;;; (LET-COMPRESS . 134) 
+;;; (IF-FOLD . 128) 
+;;; (INTEGER-TO-INT-CONSTANT-FOLD . 124) 
+;;; (AND-COMPRESS . 94) 
+;;; (APP-COMPRESS . 93) 
+;;; (FOLDR-CONS-IDENTITY . 69) 
+;;; (IF-COMPRESS-TEST . 65) 
+;;; (IF-HOIST-LAMBDA . 61) 
+;;; (APP-HOIST-STRUCTURED-CONSTANT . 60) 
+;;; (FOLDR-PRIM-APPEND-INLINE . 55) 
+;;; (FOLDR-BUILD-IDENTITY . 40) 
+;;; (CASE-BLOCK-DISCARD-REDUNDANT-TEST . 37) 
+;;; (FOLDR-NIL-IDENTITY . 36) 
+;;; (LET-HOIST-INVARIANT-ARGS . 30) 
+;;; (FOLDR-HOIST-LET . 28) 
+;;; (CON-NUMBER-FOLD-TUPLE . 21) 
+;;; (FOLDR-CONS-NIL-IDENTITY . 15) 
+;;; (AND-CONTAINS-TRUE . 14) 
+;;; (IF-IDENTITY-INVERSE . 8) 
+;;; (IF-HOIST-RETURN-FROM . 7) 
+;;; (CASE-BLOCK-HOIST-LET . 7) 
+;;; (INTEGER-TO-INT-IDENTITY . 7) 
+;;; (APP-PACK-IDENTITY . 2) 
+;;; (CON-NUMBER-FOLD . 2) 
+;;; (IF-IDENTITY . 2) 
+;;; (INT-TO-INTEGER-CONSTANT-FOLD . 2) 
+;;; (LET-HOIST-STRUCTURED-CONSTANT . 1) 
+
+
+(define-local-syntax (record-hack type . args)
+  (declare (ignore args))
+  `',type
+;  `(record-hack-aux ,type ,@args)
+  )
+
+(define *hacks-done* '())
+
+(define (record-hack-aux type . args)
+  ;; *** debug
+  ;; (format '#t "~s ~s~%" type args)
+  (declare (ignore args))
+  (let ((stuff  (assq type (car (dynamic *hacks-done*)))))
+    (if stuff
+       (incf (cdr stuff))
+       (push (cons type 1) (car (dynamic *hacks-done*))))))
+
+(define (total-hacks)
+  (let ((totals  '()))
+    (dolist (alist *hacks-done*)
+      (dolist (entry alist)
+       (let ((stuff  (assq (car entry) totals)))
+         (if stuff
+             (setf (cdr stuff) (+ (cdr stuff) (cdr entry)))
+             (push (cons (car entry) (cdr entry)) totals)))))
+    totals))
+
+
+;;; This is the main entry point.
+
+(define (optimize-top object)
+  (dynamic-let ((*structured-constants*       '())
+               (*structured-constants-table* (make-table))
+               (*lambda-depth*               0)
+               (*local-bindings*             '())
+               (*do-inline-optimizations*
+                 (do-optimization? 'inline))
+               (*do-constant-optimizations*
+                 (do-optimization? 'constant))
+               (*max-optimize-iterations*
+                 (if (do-optimization? 'foldr)
+                     (dynamic *foldr-max-optimize-iterations*)
+                     (dynamic *max-optimize-iterations*)))
+               (*optimize-foldr-iteration*
+                 (if (do-optimization? 'foldr)
+                     (dynamic *foldr-optimize-foldr-iteration*)
+                     (dynamic *optimize-foldr-iteration*)))
+               (*optimize-build-iteration*
+                 (if (do-optimization? 'foldr)
+                     (dynamic *foldr-optimize-build-iteration*)
+                     (dynamic *optimize-build-iteration*))))
+    (setf *hacks-done* '())
+    (dotimes (i (dynamic *max-optimize-iterations*))
+      (dynamic-let ((*current-optimize-iteration*  i))
+;; debug           (*duplicate-object-table*      (make-table)))
+       (when (memq 'optimize-extra (dynamic *printers*))
+         (format '#t "~%Optimize pass ~s:" i)
+         (pprint object))
+        (push '() *hacks-done*)
+       (setf object (optimize-flic-let-aux object '#t))))
+    (setf (flic-let-bindings object)
+         (nconc (nreverse (dynamic *structured-constants*))
+                (flic-let-bindings object))))
+  (install-uninterned-globals (flic-let-bindings object))
+  (postoptimize object)
+  object)
+
+
+(define-flic-walker optimize (object))
+
+;;; debugging stuff
+;;; 
+;;; (define *duplicate-object-table* (make-table))
+;;; 
+;;; (define (new-optimize object)
+;;;   (if (table-entry (dynamic *duplicate-object-table*) object)
+;;;       (error "Duplicate object ~s detected." object)
+;;;       (begin
+;;;    (setf (table-entry (dynamic *duplicate-object-table*) object) '#t)
+;;;    (old-optimize object))))
+;;; 
+;;; (lisp:setf (lisp:symbol-function 'old-optimize)
+;;;       (lisp:symbol-function 'optimize))
+;;; (lisp:setf (lisp:symbol-function 'optimize)
+;;;       (lisp:symbol-function 'new-optimize))
+
+(define (optimize-list objects)
+  (optimize-list-aux objects)
+  objects)
+
+(define (optimize-list-aux objects)
+  (if (null? objects)
+      '()
+      (begin
+        (setf (car objects) (optimize (car objects)))
+       (optimize-list-aux (cdr objects)))))
+
+
+;;; Compress nested lambdas.  This hack is desirable because saturating
+;;; applications within the lambda body effectively adds additional 
+;;; parameters to the function.
+
+;;; *** Maybe this should look for hoistable constant lambdas too.
+
+(define-optimize flic-lambda (object)
+  (let ((vars  (flic-lambda-vars object)))
+    (dynamic-let ((*lambda-depth*   (1+ (dynamic *lambda-depth*)))
+                 (*local-bindings* (cons vars (dynamic *local-bindings*))))
+      (dolist (var vars)
+       (setf (var-referenced var) 0))
+      (let ((new-body  (optimize (flic-lambda-body object))))
+       (setf (flic-lambda-body object) new-body)
+       (cond ((is-type? 'flic-lambda new-body)
+              (record-hack 'lambda-compress)
+              (setf (flic-lambda-vars object)
+                    (nconc (flic-lambda-vars object)
+                           (flic-lambda-vars new-body)))
+              (setf (flic-lambda-body object) (flic-lambda-body new-body)))
+             (else
+              '#f))
+       object))))
+
+
+;;; For let, first mark all variables as unused and check for "simple"
+;;; binding values that permit beta reduction.  Then walk the subexpressions.
+;;; Finally discard any bindings that are still marked as unused.
+;;; *** This fails to detect unused recursive variables.
+
+(define-optimize flic-let (object)
+  (optimize-flic-let-aux object '#f))
+
+(define (optimize-flic-let-aux object toplevel?)
+  (let ((bindings      (flic-let-bindings object))
+       (recursive?    (flic-let-recursive? object)))
+    ;; *** This handling of *local-bindings* isn't quite right since
+    ;; *** it doesn't account for the sequential nature of bindings
+    ;; *** in a non-recursive let, but it's close enough.  We won't
+    ;; *** get any semantic errors, but it might miss a few optimizations.
+    (dynamic-let ((*local-bindings*
+                   (if (and recursive? (not toplevel?))
+                       (cons bindings (dynamic *local-bindings*))
+                       (dynamic *local-bindings*))))
+      (optimize-flic-let-bindings bindings recursive? toplevel?)
+      (dynamic-let ((*local-bindings*
+                     (if (and (not recursive?) (not toplevel?))
+                         (cons bindings (dynamic *local-bindings*))
+                         (dynamic *local-bindings*))))
+       (setf (flic-let-body object) (optimize (flic-let-body object))))
+      ;; Check for unused bindings and other rewrites.
+      ;; Only do this for non-toplevel lets.
+      (if toplevel?
+         object
+         (optimize-flic-let-rewrite object bindings recursive?)))))
+
+(define (optimize-flic-let-bindings bindings recursive? toplevel?)
+  ;; Initialize
+  (dolist (var bindings)
+    (setf (var-referenced var) 0)
+    (setf (var-fn-referenced var) 0)
+    (when (is-type? 'flic-lambda (var-value var))
+      (dolist (v (flic-lambda-vars (var-value var)))
+       (setf (var-arg-invariant? v) '#t)
+       (setf (var-arg-invariant-value v) '#f))))
+  ;; Traverse value subforms
+  (do ((bindings bindings (cdr bindings)))
+      ((null? bindings) '#f)
+      (let* ((var  (car bindings))
+            (val  (var-value var)))
+       (if (and (is-type? 'flic-app val)
+                (dynamic *do-constant-optimizations*)
+                (let ((fn   (flic-app-fn val))
+                      (args (flic-app-args val)))
+                  (if recursive?
+                      (structured-constant-app-recursive?
+                        fn args bindings (list var))
+                      (structured-constant-app? fn args))))
+           ;; Variable is bound to a structured constant.  If this
+           ;; isn't already a top-level binding, replace the value
+           ;; of the constant with a reference to a top-level variable
+           ;; that is in turn bound to the constant expression.
+           ;; binding to top-level if this is a new constant.
+           ;; *** Maybe we should also look for variables bound
+           ;; *** to lambdas, that can also be hoisted to top level.
+           (when (not toplevel?)
+             (multiple-value-bind (con args cvar)
+                 (enter-structured-constant-aux val '#t)
+               (record-hack 'let-hoist-structured-constant)
+               (if cvar
+                   (setf (var-value var) (make-flic-ref cvar))
+                   (add-new-structured-constant var con args))))
+           (begin
+             ;; If this is a function that's a candidate for foldr/build
+             ;; optimization, stash the value away prior to
+             ;; inlining the calls.
+             ;; *** We might try to automagically detect functions
+             ;; *** that are candidates for these optimizations here,
+             ;; *** but have to watch out for infinite loops!
+             (when (and (var-force-inline? var)
+                        (eqv? (the fixnum
+                                   (dynamic *current-optimize-iteration*))
+                              (the fixnum
+                                   (dynamic *optimize-build-iteration*)))
+                        (is-type? 'flic-lambda val)
+                        (or (is-foldr-or-build-app? (flic-lambda-body val))))
+               (setf (var-inline-value var) (copy-flic-top val)))
+             ;; Then walk value normally.
+             (let ((new-val  (optimize val)))
+               (setf (var-value var) new-val)
+               (setf (var-simple? var)
+                     (or (var-force-inline? var)
+                         (and (not (var-selector-fn? var))
+                              (can-inline?
+                                new-val
+                                (if recursive? bindings '())
+                                toplevel?))))))
+         ))))
+
+
+(define (is-foldr-or-build-app? exp)
+  (typecase exp
+    (flic-app
+     (let ((fn  (flic-app-fn exp)))
+       (and (is-type? 'flic-ref fn)
+           (or (eq? (flic-ref-var fn) (core-symbol "foldr"))
+               (eq? (flic-ref-var fn) (core-symbol "build"))))))
+    (flic-let
+     (is-foldr-or-build-app? (flic-let-body exp)))
+    (flic-ref
+     (let ((val  (var-value (flic-ref-var exp))))
+       (and val (is-foldr-or-build-app? val))))
+    (else
+     '#f)))
+
+
+(define (optimize-flic-let-rewrite object bindings recursive?)
+  ;; Delete unused variables from the list.
+  (setf bindings
+       (list-delete-if
+         (lambda (var)
+           (cond ((var-toplevel? var)
+                  ;; This was a structured constant hoisted to top-level.
+                  '#t)
+                 ((eqv? (the fixnum (var-referenced var)) (the fixnum 0))
+                  (record-hack 'let-remove-unused-binding var)
+                  '#t)
+                 ((eqv? (the fixnum (var-referenced var)) (the fixnum 1))
+                  (setf (var-single-ref var) (dynamic *lambda-depth*))
+                  '#f)
+                 (else
+                  (setf (var-single-ref var) '#f)
+                  '#f)))
+         bindings))
+  ;; Add extra bindings for reducing functions with invariant
+  ;; arguments.  Hopefully some of the extra bindings will go
+  ;; away in future passes!
+  (setf (flic-let-bindings object)
+       (setf bindings (add-stuff-for-invariants bindings)))
+  ;; Look for other special cases.
+  (cond ((null? bindings)
+        ;; Simplifying the expression by getting rid of the LET may
+        ;; make it possible to do additional optimizations on the 
+        ;; next pass.
+        (record-hack 'let-empty-bindings)
+        (flic-let-body object))
+       ((is-type? 'flic-return-from (flic-let-body object))
+        ;; Hoist return-from outside of LET.  This may permit
+        ;; further optimizations by an enclosing case-block.
+        (record-hack 'let-hoist-return-from)
+        (let* ((body       (flic-let-body object))
+               (inner-body (flic-return-from-exp body)))
+          (setf (flic-return-from-exp body) object)
+          (setf (flic-let-body object) inner-body)
+          body))
+       ((and (not recursive?)
+             (is-type? 'flic-let (flic-let-body object))
+             (not (flic-let-recursive? (flic-let-body object))))
+        ;; This is purely to produce more compact code.
+        (record-hack 'let-compress)
+        (let ((body  (flic-let-body object)))
+          (setf (flic-let-bindings object)
+                (nconc bindings (flic-let-bindings body)))
+          (setf (flic-let-body object) (flic-let-body body))
+          object))
+       ((is-type? 'flic-lambda (flic-let-body object))
+        ;; Hoist lambda outside of LET.  This may permit
+        ;; merging of nested lambdas on a future pass.
+        (record-hack 'let-hoist-lambda)
+        (let* ((body       (flic-let-body object))
+               (inner-body (flic-lambda-body body)))
+          (setf (flic-lambda-body body) object)
+          (setf (flic-let-body object) inner-body)
+          body))
+       (else
+        object))
+  )
+
+;;; Look for constant-folding and structured constants here.
+
+(define-optimize flic-app (object)
+  (optimize-flic-app-aux object))
+
+(define (optimize-flic-app-aux object)
+  (let ((new-fn   (optimize (flic-app-fn object)))
+       (new-args (optimize-list (flic-app-args object))))
+    (typecase new-fn
+      (flic-ref
+       ;; The function is a variable.
+       (let* ((var    (flic-ref-var new-fn))
+             (val    (var-value var))
+             (n      (length new-args))
+             (arity  (guess-function-arity var)))
+        (cond ((and arity (< (the fixnum n) (the fixnum arity)))
+               ;; This is a first-class call that is not fully saturated.
+               ;; Make it saturated by wrapping a lambda around it.
+               (setf new-fn
+                     (do-app-make-saturated object new-fn new-args arity n))
+               (setf new-args '()))
+              ((var-selector-fn? var)
+               ;; This is a saturated call to a selector.  We might
+               ;; be able to inline the call.
+               (multiple-value-bind (fn args)
+                   (try-to-fold-selector var new-fn new-args)
+                 (setf new-fn fn)
+                 (setf new-args args)))
+              ((and (not (var-toplevel? var))
+                    (is-type? 'flic-lambda val))
+               ;; This is a saturated call to a local function.
+               ;; Increment its reference count and note if any of
+               ;; the arguments are invariant.
+               (incf (var-fn-referenced var))
+               (note-invariant-args new-args (flic-lambda-vars val)))
+              (else
+               (let ((magic  (magic-optimize-function var)))
+                 (when magic
+                   (multiple-value-bind (fn args)
+                       (funcall magic new-fn new-args)
+                     (setf new-fn fn)
+                     (setf new-args args)))))
+              )))
+      (flic-lambda
+       ;; Turn application of lambda into a let.
+       (multiple-value-bind (fn args)
+          (do-lambda-to-let-aux new-fn new-args)
+        (setf new-fn fn)
+        (setf new-args args)))
+      (flic-pack
+       (let ((con  (flic-pack-con new-fn))
+            (temp '#f))
+        (when (eqv? (length new-args) (con-arity con))
+          (cond ((and (dynamic *do-constant-optimizations*)
+                      (every-1 (function structured-constant?) new-args))
+                 ;; This is a structured constant that
+                 ;; can be replaced with a top-level binding.
+                 (setf (flic-app-fn object) new-fn)
+                 (setf (flic-app-args object) new-args)
+                 (record-hack 'app-hoist-structured-constant object)
+                 (setf new-fn (enter-structured-constant object '#t))
+                 (setf new-args '()))
+                ((and (setf temp (is-selector? con 0 (car new-args)))
+                      (is-selector-list? con 1 temp (cdr new-args)))
+                 ;; This is an expression like (cons (car x) (cdr x)).
+                 ;; Replace it with just plain x to avoid reconsing.
+                 (record-hack 'app-pack-identity new-fn)
+                 (setf new-fn (copy-flic-top temp))
+                 (setf new-args '()))
+                ))))
+      (flic-let
+       ;; Hoist let to surround entire application.
+       ;; Simplifying the function being applied may permit further
+       ;; optimizations on next pass.
+       ;; (We might try to hoist lets in the argument expressions, too,
+       ;; but I don't think that would lead to any real simplification
+       ;; of the code.)
+       (record-hack 'app-hoist-let)
+       (setf (flic-app-fn object) (flic-let-body new-fn))
+       (setf (flic-app-args object) new-args)
+       (setf new-args '())
+       (setf (flic-let-body new-fn) object)
+       )
+      (flic-app
+       ;; Try to compress nested applications.
+       ;; This may make the call saturated and permit further optimizations
+       ;; on the next pass.
+       (record-hack 'app-compress)
+       (setf new-args (nconc (flic-app-args new-fn) new-args))
+       (setf new-fn (flic-app-fn new-fn)))
+      )
+    (if (null? new-args)
+       new-fn
+       (begin
+         (setf (flic-app-fn object) new-fn)
+         (setf (flic-app-args object) new-args)
+         object))
+    ))
+
+(define (guess-function-arity var)
+  (or (let ((value  (var-value var)))
+       (and value
+            (is-type? 'flic-lambda value)
+            (length (flic-lambda-vars value))))
+      (var-arity var)))
+
+(define (do-app-make-saturated app fn args arity nargs)
+  (declare (type fixnum arity nargs))
+  (record-hack 'app-make-saturated fn args)
+  (let ((newvars  '())
+       (newargs  '()))
+    (dotimes (i (- arity nargs))
+      (declare (type fixnum i))
+      (let ((v  (init-flic-var (create-temp-var 'arg) '#f '#f)))
+       (push v newvars)
+       (push (make-flic-ref v) newargs)))
+    (setf (flic-app-fn app) fn)
+    (setf (flic-app-args app) (nconc args newargs))
+    (make-flic-lambda newvars app)))
+
+
+
+;;; If the function is a selector applied to a literal dictionary,
+;;; inline it.
+
+(define (try-to-fold-selector var new-fn new-args)
+  (let ((exp  (car new-args)))
+    (if (or (and (is-type? 'flic-ref exp)
+                ;; *** should check that var is top-level?
+                (is-bound-to-constructor-app? (flic-ref-var exp)))
+           (and (is-type? 'flic-app exp)
+                (is-constructor-app-prim? exp)))
+       (begin
+         (record-hack 'app-fold-selector)
+         (setf new-fn (copy-flic-top (var-value var)))
+         (do-lambda-to-let-aux new-fn new-args))
+       (values new-fn new-args))))
+
+
+;;; Various primitive functions have special optimizer functions
+;;; associated with them, that do constant folding and certain
+;;; other identities.  The optimizer function is called with the 
+;;; function expression and list of argument expressions (at least
+;;; as many arguments as the arity of the function) and should return
+;;; the two values.
+
+;;; *** This should really use some kind of hash table, but we'd
+;;; *** have to initialize the table dynamically because core-symbols
+;;; *** aren't defined when this file is loaded.
+
+(define (magic-optimize-function var)
+  (cond ((eq? var (core-symbol "foldr"))
+        (function optimize-foldr-aux))
+       ((eq? var (core-symbol "build"))
+        (function optimize-build))
+       ((eq? var (core-symbol "primIntegerToInt"))
+        (function optimize-integer-to-int))
+       ((eq? var (core-symbol "primIntToInteger"))
+        (function optimize-int-to-integer))
+       ((eq? var (core-symbol "primRationalToFloat"))
+        (function optimize-rational-to-float))
+       ((eq? var (core-symbol "primRationalToDouble"))
+        (function optimize-rational-to-double))
+       ((or (eq? var (core-symbol "primNegInt"))
+            (eq? var (core-symbol "primNegInteger"))
+            (eq? var (core-symbol "primNegFloat"))
+            (eq? var (core-symbol "primNegDouble")))
+        (function optimize-neg))
+       (else
+        '#f)))
+
+
+;;; Foldr identities for deforestation
+
+(define (optimize-foldr fn args)
+  (multiple-value-bind (fn args)
+      (optimize-foldr-aux fn args)
+    (maybe-make-app fn args)))
+
+(define (optimize-foldr-aux fn args)
+  (let ((k     (car args))
+       (z     (cadr args))
+       (l     (caddr args))
+       (tail  (cdddr args)))
+    (cond ((and (is-type? 'flic-pack k)
+               (eq? (flic-pack-con k) (core-symbol ":"))
+               (is-type? 'flic-pack z)
+               (eq? (flic-pack-con z) (core-symbol "Nil")))
+          ;; foldr (:) [] l ==> l
+          ;; (We arrange for build to be inlined before foldr
+          ;; so that this pattern can be detected.)
+          (record-hack 'foldr-cons-nil-identity)
+          (values l tail))
+         ((and (is-type? 'flic-app l)
+               (is-type? 'flic-ref (flic-app-fn l))
+               (eq? (flic-ref-var (flic-app-fn l))
+                    (core-symbol "build"))
+               (null? (cdr (flic-app-args l))))
+          ;; foldr k z (build g) ==> g k z
+          (record-hack 'foldr-build-identity)
+          (values
+            (car (flic-app-args l))
+            (cons k (cons z tail))))
+         ((and (is-type? 'flic-pack l)
+               (eq? (flic-pack-con l) (core-symbol "Nil")))
+          ;; foldr k z [] ==> z
+          (record-hack 'foldr-nil-identity)
+          (values z tail))
+         ((short-string-constant? l)
+          ;; If the list argument is a string constant, expand it inline.
+          ;; Only do this if the string is fairly short, though.
+          (optimize-foldr-aux
+            fn
+            (cons k (cons z (cons (expand-string-constant l) tail)))))
+         ((and (is-type? 'flic-app l)
+               (is-type? 'flic-pack (flic-app-fn l))
+               (eq? (flic-pack-con (flic-app-fn l)) (core-symbol ":"))
+               (eqv? (length (flic-app-args l)) 2))
+          ;; foldr k z x:xs ==> let c = k in c x (foldr c z xs)
+          (record-hack 'foldr-cons-identity)
+          (let ((x     (car (flic-app-args l)))
+                (xs    (cadr (flic-app-args l))))
+            (values 
+              (if (can-inline? k '() '#f)
+                  (do-foldr-cons-identity k z x xs)
+                  (let ((cvar  (init-flic-var (create-temp-var 'c) k '#f)))
+                    (make-flic-let
+                      (list cvar)
+                      (do-foldr-cons-identity (make-flic-ref cvar) z x xs)
+                      '#f)))
+              tail)))
+         ((is-type? 'flic-let l)
+          ;; foldr k z (let bindings in body) ==>
+          ;;   let bindings in foldr k z body
+          (record-hack 'foldr-hoist-let)
+          (setf (flic-let-body l)
+                (optimize-foldr fn (list k z (flic-let-body l))))
+          (values l tail))
+         ((not (eqv? (the fixnum (dynamic *current-optimize-iteration*))
+                     (the fixnum (dynamic *optimize-foldr-iteration*))))
+          ;; Hope for more optimizations later.
+          (values fn args))
+         ((and (is-type? 'flic-pack k)
+               (eq? (flic-pack-con k) (core-symbol ":")))
+          ;; Inline to special case, highly optimized append primitive.
+          ;; Could also look for (++ (++ l1 l2) l3) => (++ l1 (++ l2 l3))
+          ;; here, but I don't think that happens very often.
+           (record-hack 'foldr-prim-append-inline)
+          (values
+            (make-flic-ref (core-symbol "primAppend"))
+            (cons l (cons z tail))))
+         (else
+          ;; Default inline.
+          (record-hack 'foldr-inline k z)
+          (let ((new-fn
+                  (copy-flic-top (var-value (core-symbol "inlineFoldr")))))
+            (if (is-type? 'flic-lambda new-fn)
+                (do-lambda-to-let-aux new-fn args)
+                (values new-fn args))))
+         )))
+
+
+;;; Mess with compile-time expansion of short string constants.
+
+(define-integrable max-short-string-length 3)
+
+(define (short-string-constant? l)
+  (and (is-type? 'flic-const l)
+       (let ((string  (flic-const-value l)))
+        (and (string? string)
+             (<= (the fixnum (string-length string))
+                 (the fixnum max-short-string-length))))))
+
+(define (expand-string-constant l)
+  (let* ((string  (flic-const-value l))
+        (length  (string-length string)))
+    (expand-string-constant-aux string 0 length)))
+
+(define (expand-string-constant-aux string i length)
+  (declare (type fixnum i length))
+  (if (eqv? i length)
+      (make-flic-pack (core-symbol "Nil"))
+      (make-flic-app
+        (make-flic-pack (core-symbol ":"))
+       (list (make-flic-const (string-ref string i))
+             (expand-string-constant-aux string (+ 1 i) length))
+       '#f)))
+
+
+;;; Helper function for the case of expanding foldr applied to cons call.
+
+(define (do-foldr-cons-identity c z x xs)
+  (make-flic-app
+    c
+    (list x
+         (optimize-foldr
+           (make-flic-ref (core-symbol "foldr"))
+           (list (copy-flic-top c) z xs)))
+    '#f))
+
+
+
+;;; Short-circuit build inlining for the usual case where the
+;;; argument is a lambda.  (It would take several optimizer passes
+;;; for this simplification to fall out, otherwise.)
+
+(define (optimize-build fn args)
+  (let ((arg  (car args)))
+    (cond ((not (eqv? (dynamic *current-optimize-iteration*)
+                     (dynamic *optimize-build-iteration*)))
+          (values fn args))
+         ((is-type? 'flic-lambda arg)
+          (record-hack 'build-inline-lambda)
+          (do-lambda-to-let-aux
+            arg
+            (cons (make-flic-pack (core-symbol ":"))
+                  (cons (make-flic-pack (core-symbol "Nil"))
+                        (cdr args)))))
+         (else
+          (record-hack 'build-inline-other)
+          (let ((new-fn
+                  (copy-flic-top (var-value (core-symbol "inlineBuild")))))
+            (if (is-type? 'flic-lambda new-fn)
+                (do-lambda-to-let-aux new-fn args)
+                (values new-fn args))))
+         )))
+
+
+;;; Various simplifications on numeric functions.
+;;; *** Obviously, could get much fancier about this.
+                 
+(define (optimize-integer-to-int fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+          (record-hack 'integer-to-int-constant-fold)
+          (if (is-type? 'integer (flic-const-value arg))
+              (let ((value  (flic-const-value arg)))
+                (when (not (is-type? 'fixnum value))
+                  ;; Overflow is a user error, not an implementation error.
+                  (phase-error 'int-overflow
+                               "Int overflow in primIntegerToInt: ~s"
+                               value))
+                (values arg (cdr args)))
+              (error "Bad argument ~s to primIntegerToInt." arg)))
+         ((and (is-type? 'flic-app arg)
+               (is-type? 'flic-ref (flic-app-fn arg))
+               (eq? (flic-ref-var (flic-app-fn arg))
+                    (core-symbol "primIntToInteger"))
+               (null? (cdr (flic-app-args arg))))
+          (record-hack 'integer-to-int-identity)
+          (values (car (flic-app-args arg)) (cdr args)))
+         (else
+          (values fn args)))))
+
+(define (optimize-int-to-integer fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+          (record-hack 'int-to-integer-constant-fold)
+          (if (is-type? 'integer (flic-const-value arg))
+              (values arg (cdr args))
+              (error "Bad argument ~s to primIntToInteger." arg)))
+         ((and (is-type? 'flic-app arg)
+               (is-type? 'flic-ref (flic-app-fn arg))
+               (eq? (flic-ref-var (flic-app-fn arg))
+                    (core-symbol "primIntegerToInt"))
+               (null? (cdr (flic-app-args arg))))
+          (record-hack 'int-to-integer-identity)
+          (values (car (flic-app-args arg)) (cdr args)))
+         (else
+          (values fn args)))))
+
+(predefine (prim.rational-to-float-aux n d))   ; in prims.scm
+(predefine (prim.rational-to-double-aux n d))  ; in prims.scm
+
+(define (optimize-rational-to-float fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+          (record-hack 'rational-to-float-constant-fold)
+          (if (is-type? 'list (flic-const-value arg))
+              (let ((value  (flic-const-value arg)))
+                (setf (flic-const-value arg)
+                      (prim.rational-to-float-aux (car value) (cadr value)))
+                (values arg (cdr args)))
+              (error "Bad argument ~s to primRationalToFloat." arg)))
+         (else
+          (values fn args)))))
+
+(define (optimize-rational-to-double fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+          (record-hack 'rational-to-double-constant-fold)
+          (if (is-type? 'list (flic-const-value arg))
+              (let ((value  (flic-const-value arg)))
+                (setf (flic-const-value arg)
+                      (prim.rational-to-double-aux (car value) (cadr value)))
+                (values arg (cdr args)))
+              (error "Bad argument ~s to primRationalToDouble." arg)))
+         (else
+          (values fn args)))))
+
+(define (optimize-neg fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+          (record-hack 'neg-constant-fold)
+          (if (is-type? 'number (flic-const-value arg))
+              (begin
+                (setf (flic-const-value arg) (- (flic-const-value arg)))
+                (values arg (cdr args)))
+              (error "Bad argument ~s to ~s." arg fn)))
+         (else
+          (values fn args)))))
+
+
+
+;;; Convert lambda applications to lets.
+;;; If application is not saturated, break it up into two nested
+;;; lambdas before doing the transformation.
+;;; It's better to do this optimization immediately than hoping
+;;; the call will become fully saturated on the next pass.
+;;; Maybe we could also look for a flic-let with a flic-lambda as
+;;; the body to catch the cases where additional arguments can
+;;; be found on a later pass.
+
+(define (do-lambda-to-let new-fn new-args)
+  (multiple-value-bind (fn args)
+      (do-lambda-to-let-aux new-fn new-args)
+    (maybe-make-app fn args)))
+
+(define (maybe-make-app fn args)
+  (if (null? args)
+      fn
+      (make-flic-app fn args '#f)))
+
+(define (do-lambda-to-let-aux new-fn new-args)
+  (let ((vars     (flic-lambda-vars new-fn))
+       (body     (flic-lambda-body new-fn))
+       (matched  '()))
+    (record-hack 'app-lambda-to-let)
+    (do ()
+       ((or (null? new-args) (null? vars)))
+       (let ((var  (pop vars))
+             (arg  (pop new-args)))
+         (setf (var-value var) arg)
+         (setf (var-simple? var) (can-inline? arg '() '#t))
+         (if (eqv? (var-referenced var) 1)
+             (setf (var-single-ref var) (dynamic *lambda-depth*)))
+         (push var matched)))
+    (setf matched (nreverse matched))
+    (if (not (null? vars))
+       (setf body (make-flic-lambda vars body)))
+    (setf new-fn (make-flic-let matched body '#f))
+    (values new-fn new-args)))
+
+
+;;; For references, check to see if we can beta-reduce.
+;;; Don't increment reference count for inlineable vars, but do
+;;; traverse the new value expression.
+
+(define-optimize flic-ref (object)
+  (optimize-flic-ref-aux object))
+
+(define (optimize-flic-ref-aux object)
+  (let ((var     (flic-ref-var object)))
+    (cond ((var-single-ref var)
+          ;; (or (eqv? (var-single-ref var) (dynamic *lambda-depth*)))
+          ;; *** The lambda-depth test is too conservative to handle
+          ;; *** inlining of stuff necessary for foldr/build optimizations.
+          ;; Can substitute value no matter how hairy it is.
+          ;; Note that this is potentially risky; if the single
+          ;; reference detected on the previous pass appeared as 
+          ;; the value of a variable binding that is being inlined
+          ;; on the current pass, it might turn into multiple
+          ;; references again!
+          ;; We copy the value anyway to avoid problems with shared
+          ;; structure in the multiple reference case.
+          (record-hack 'ref-inline-single-ref var)
+          (optimize (copy-flic-top (var-value var))))
+         ((and (var-inline-value var) (dynamic *do-inline-optimizations*))
+          ;; Use the previously saved value in preference to the current
+          ;; value of the variable.
+          (record-hack 'ref-inline-foldr-hack)
+          (optimize (copy-flic-top (var-inline-value var))))
+         ((and (var-simple? var)
+               (or (dynamic *do-inline-optimizations*)
+                   (not (var-toplevel? var))))
+          ;; Can substitute, but must copy.
+          (record-hack 'ref-inline var)
+          (optimize (copy-flic-top (var-value var))))
+         ((eq? var (core-symbol "foldr"))
+          ;; Magic stuff for deforestation
+          (if (> (the fixnum (dynamic *current-optimize-iteration*))
+                 (the fixnum (dynamic *optimize-foldr-iteration*)))
+              (begin
+                (record-hack 'ref-inline-foldr)
+                (optimize (make-flic-ref (core-symbol "inlineFoldr"))))
+              object))
+         ((eq? var (core-symbol "build"))
+          ;; Magic stuff for deforestation
+          (if (> (the fixnum (dynamic *current-optimize-iteration*))
+                 (the fixnum (dynamic *optimize-build-iteration*)))
+              (begin
+                (record-hack 'ref-inline-build)
+                (optimize (make-flic-ref (core-symbol "inlineBuild"))))
+              object))
+         ((var-toplevel? var)
+          object)
+         (else
+          (incf (var-referenced var))
+          object))))
+
+
+;;; Don't do anything exciting with constants.
+
+(define-optimize flic-const (object)
+  object)
+
+(define-optimize flic-pack (object)
+  object)
+
+
+
+;;; Various simplifications on and
+
+(define-optimize flic-and (object)
+  (maybe-simplify-and
+    object
+    (optimize-and-exps (flic-and-exps object) '())))
+
+(define (maybe-simplify-and object exps)
+  (cond ((null? exps)
+        (record-hack 'and-empty)
+        (make-flic-pack (core-symbol "True")))
+       ((null? (cdr exps))
+        (record-hack 'and-unary)
+        (car exps))
+       (else
+        (setf (flic-and-exps object) exps)
+        object)))
+
+(define (optimize-and-exps exps result)
+  (if (null? exps)
+      (nreverse result)
+      (let ((exp  (optimize (car exps))))
+       (typecase exp
+         (flic-pack
+           (cond ((eq? (flic-pack-con exp) (core-symbol "True"))
+                  ;; True appears in subexpressions.
+                  ;; Discard this test only.
+                  (record-hack 'and-contains-true)
+                  (optimize-and-exps (cdr exps) result))
+                 ((eq? (flic-pack-con exp) (core-symbol "False"))
+                  ;; False appears in subexpressions.
+                  ;; Discard remaining tests as dead code.
+                  ;; Can't replace the whole and expression with false because
+                  ;; of possible strictness side-effects.
+                  (record-hack 'and-contains-false)
+                  (nreverse (cons exp result)))
+                 (else
+                  ;; Should never happen.
+                  (error "Non-boolean con ~s in and expression!" exp))))
+         (flic-and
+          ;; Flatten nested ands.
+          (record-hack 'and-compress)
+          (optimize-and-exps
+           (cdr exps)
+           (nconc (nreverse (flic-and-exps exp)) result)))
+         (else
+          ;; No optimization possible.
+          (optimize-and-exps (cdr exps) (cons exp result)))
+         ))))
+
+
+;;; Case-block optimizations.  These optimizations are possible because
+;;; of the restricted way this construct is used;  return-froms are
+;;; never nested, etc.
+
+(define-optimize flic-case-block (object)
+  (let* ((sym  (flic-case-block-block-name object))
+        (exps (optimize-case-block-exps
+                sym (flic-case-block-exps object) '())))
+    (optimize-flic-case-block-aux object sym exps)))
+
+(define (optimize-flic-case-block-aux object sym exps)
+  (cond ((null? exps)
+        ;; This should never happen.  It means all of the tests were
+        ;; optimized away, including the failure case!
+        (error "No exps left in case block ~s!" object))
+       ((and (is-type? 'flic-and (car exps))
+             (is-return-from-block?
+               sym
+               (car (last (flic-and-exps (car exps))))))
+        ;; The first clause is a simple and.  Hoist it out of the
+        ;; case-block and rewrite as if/then/else.
+        (record-hack 'case-block-to-if)
+        (let ((then-exp  (car (last (flic-and-exps (car exps))))))
+          (setf (flic-case-block-exps object) (cdr exps))
+          (make-flic-if
+            (maybe-simplify-and
+              (car exps)
+              (butlast (flic-and-exps (car exps))))
+            (flic-return-from-exp then-exp)
+            (optimize-flic-case-block-aux object sym (cdr exps)))))
+       ((is-return-from-block? sym (car exps))
+        ;; Do an identity reduction.
+        (record-hack 'case-block-identity)
+        (flic-return-from-exp (car exps)))
+       ((is-type? 'flic-let (car exps))
+        ;; The first clause is a let.  Since this clause is going
+        ;; to be executed anyway, hoisting the bindings to surround
+        ;; the entire case-block should not change their strictness
+        ;; properties, and it may permit some further optimizations.
+        (record-hack 'case-block-hoist-let)
+        (let* ((exp  (car exps))
+               (body (flic-let-body exp)))
+          (setf (flic-let-body exp)
+                (optimize-flic-case-block-aux
+                  object sym (cons body (cdr exps))))
+          exp))
+       (else
+        (setf (flic-case-block-exps object) exps)
+        object)
+       ))
+
+
+(define (optimize-case-block-exps sym exps result)
+  (if (null? exps)
+      (nreverse result)
+      (let ((exp  (optimize (car exps))))
+       (cond ((is-return-from-block? sym exp)
+              ;; Any remaining clauses are dead code and should be removed.
+              (if (not (null? (cdr exps)))
+                  (record-hack 'case-block-dead-code))
+              (nreverse (cons exp result)))
+             ((is-type? 'flic-and exp)
+              ;; See if we can remove redundant tests.
+              (push (maybe-simplify-and
+                      exp
+                      (look-for-redundant-tests (flic-and-exps exp) result))
+                    result)
+              (optimize-case-block-exps sym (cdr exps) result))
+             (else
+              ;; No optimization possible.
+              (optimize-case-block-exps sym (cdr exps) (cons exp result)))
+             ))))
+
+
+;;; Look for case-block tests that are known to be either true or false
+;;; because of tests made in previous clauses.
+;;; For now, we only look at is-constructor tests.  Such a test is known
+;;; to be true if previous clauses have eliminated all other possible
+;;; constructors.  And such a test is known to be false if a previous
+;;; clause has already matched this constructor.
+
+(define (look-for-redundant-tests exps previous-clauses)
+  (if (null? exps)
+      '()
+      (let ((exp  (car exps)))
+       (cond ((and (is-type? 'flic-is-constructor exp)
+                   (constructor-test-redundant? exp previous-clauses))
+              ;; Known to be true.
+              (record-hack 'case-block-discard-redundant-test)
+              (cons (make-flic-pack (core-symbol "True"))
+                    (look-for-redundant-tests (cdr exps) previous-clauses)))
+
+              ((and (is-type? 'flic-is-constructor exp)
+                   (constructor-test-duplicated? exp previous-clauses))
+              ;; Known to be false.
+              (record-hack 'case-block-discard-duplicate-test)
+              (list (make-flic-pack (core-symbol "False"))))
+             (else
+              ;; No optimization.
+              (cons exp
+                    (look-for-redundant-tests (cdr exps) previous-clauses)))
+             ))))
+
+
+;;; In looking for redundant/duplicated tests, only worry about
+;;; is-constructor tests that have an argument that is a variable.
+;;; It's too hairy to consider any other cases.
+
+(define (constructor-test-duplicated? exp previous-clauses)
+  (let ((con  (flic-is-constructor-con exp))
+       (arg  (flic-is-constructor-exp exp)))
+    (and (is-type? 'flic-ref arg)
+        (constructor-test-present? con arg previous-clauses))))
+
+(define (constructor-test-redundant? exp previous-clauses)
+  (let ((con     (flic-is-constructor-con exp))
+        (arg     (flic-is-constructor-exp exp)))
+    (and (is-type? 'flic-ref arg)
+        (every-1 (lambda (c)
+                   (or (eq? c con)
+                       (constructor-test-present? c arg previous-clauses)))
+                 (algdata-constrs (con-alg con))))))
+
+(define (constructor-test-present? con arg previous-clauses)
+  (cond ((null? previous-clauses)
+        '#f)
+       ((constructor-test-present-1? con arg (car previous-clauses))
+        '#t)
+       (else
+        (constructor-test-present? con arg (cdr previous-clauses)))))
+
+
+;;; The tricky thing here is that, even if the constructor test is 
+;;; present in the clause, we have to make sure that the entire clause won't
+;;; fail due to the presence of some other test which fails.  So look
+;;; for a very specific pattern here, namely
+;;;  (and (is-constructor con arg) (return-from ....))
+
+(define (constructor-test-present-1? con arg clause)
+  (and (is-type? 'flic-and clause)
+       (let ((exps  (flic-and-exps clause)))
+        (and (is-type? 'flic-is-constructor (car exps))
+             (is-type? 'flic-return-from (cadr exps))
+             (null? (cddr exps))
+             (let* ((inner-exp  (car exps))
+                    (inner-con  (flic-is-constructor-con inner-exp))
+                    (inner-arg  (flic-is-constructor-exp inner-exp)))
+               (and (eq? inner-con con)
+                    (flic-exp-eq? arg inner-arg)))))))
+
+
+
+;;; No fancy optimizations for return-from by itself.
+
+(define-optimize flic-return-from (object)
+  (setf (flic-return-from-exp object)
+       (optimize (flic-return-from-exp object)))
+  object)
+
+
+
+;;; Obvious simplification on if
+
+(define-optimize flic-if (object)
+  (let ((test-exp  (optimize (flic-if-test-exp object)))
+       (then-exp  (optimize (flic-if-then-exp object)))
+       (else-exp  (optimize (flic-if-else-exp object))))
+    (cond ((and (is-type? 'flic-pack test-exp)
+               (eq? (flic-pack-con test-exp) (core-symbol "True")))
+          ;; Fold constant test
+          (record-hack 'if-fold)
+          then-exp)
+         ((and (is-type? 'flic-pack test-exp)
+               (eq? (flic-pack-con test-exp) (core-symbol "False")))
+          ;; Fold constant test
+          (record-hack 'if-fold)
+          else-exp)
+         ((and (is-type? 'flic-is-constructor test-exp)
+               (eq? (flic-is-constructor-con test-exp) (core-symbol "True")))
+          ;; Remove redundant is-constructor test.
+          ;; Doing this as a general is-constructor identity
+          ;; backfires because it prevents some of the important case-block
+          ;; optimizations from being recognized, but it works fine here.
+          (record-hack 'if-compress-test)
+          (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
+          (setf (flic-if-then-exp object) then-exp)
+          (setf (flic-if-else-exp object) else-exp)
+          object)
+         ((and (is-type? 'flic-is-constructor test-exp)
+               (eq? (flic-is-constructor-con test-exp) (core-symbol "False")))
+          ;; Remove redundant is-constructor test, flip branches.
+          (record-hack 'if-compress-test)
+          (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
+          (setf (flic-if-then-exp object) else-exp)
+          (setf (flic-if-else-exp object) then-exp)
+          object)
+         ((and (is-type? 'flic-return-from then-exp)
+               (is-type? 'flic-return-from else-exp)
+               (eq? (flic-return-from-block-name then-exp)
+                    (flic-return-from-block-name else-exp)))
+          ;; Hoist return-from outside of IF.
+          ;; This may permit further case-block optimizations.
+          (record-hack 'if-hoist-return-from)
+          (let ((return-exp  then-exp))
+            (setf (flic-if-test-exp object) test-exp)
+            (setf (flic-if-then-exp object) (flic-return-from-exp then-exp))
+            (setf (flic-if-else-exp object) (flic-return-from-exp else-exp))
+            (setf (flic-return-from-exp return-exp) object)
+            return-exp))
+         ((and (is-type? 'flic-pack then-exp)
+               (is-type? 'flic-pack else-exp)
+               (eq? (flic-pack-con then-exp) (core-symbol "True"))
+               (eq? (flic-pack-con else-exp) (core-symbol "False")))
+          ;; This if does nothing useful at all!
+          (record-hack 'if-identity)
+          test-exp)
+         ((and (is-type? 'flic-pack then-exp)
+               (is-type? 'flic-pack else-exp)
+               (eq? (flic-pack-con then-exp) (core-symbol "False"))
+               (eq? (flic-pack-con else-exp) (core-symbol "True")))
+          ;; Inverse of previous case
+          (record-hack 'if-identity-inverse)
+          (make-flic-is-constructor (core-symbol "False") test-exp))
+         ((or (is-type? 'flic-lambda then-exp)
+              (is-type? 'flic-lambda else-exp))
+          ;; Hoist lambdas to surround entire if.  This allows us to
+          ;; do a better job of saturating them.
+          (record-hack 'if-hoist-lambda)
+          (multiple-value-bind (vars then-exp else-exp)
+              (do-if-hoist-lambda then-exp else-exp)
+            (setf (flic-if-test-exp object) test-exp)
+            (setf (flic-if-then-exp object) then-exp)
+            (setf (flic-if-else-exp object) else-exp)
+            (make-flic-lambda vars object)))
+         (else
+          ;; No optimization possible
+          (setf (flic-if-test-exp object) test-exp)
+          (setf (flic-if-then-exp object) then-exp)
+          (setf (flic-if-else-exp object) else-exp)
+          object)
+         )))
+
+
+
+;;; Try to pull as many variables as possible out to surround the entire
+;;; let.
+
+(define (do-if-hoist-lambda then-exp else-exp)
+  (let ((vars       '())
+       (then-args  '())
+       (else-args  '()))
+    (do ((then-vars  (if (is-type? 'flic-lambda then-exp)
+                        (flic-lambda-vars then-exp)
+                        '())
+                    (cdr then-vars))
+        (else-vars  (if (is-type? 'flic-lambda else-exp)
+                        (flic-lambda-vars else-exp)
+                        '())
+                    (cdr else-vars)))
+       ((and (null? then-vars) (null? else-vars)) '#f)
+       (let ((var  (init-flic-var (create-temp-var 'arg) '#f '#f)))
+         (push var vars)
+         (push (make-flic-ref var) then-args)
+         (push (make-flic-ref var) else-args)))
+    (values
+      vars
+      (if (is-type? 'flic-lambda then-exp)
+         (do-lambda-to-let then-exp then-args)
+         (make-flic-app then-exp then-args '#f))
+      (if (is-type? 'flic-lambda else-exp)
+         (do-lambda-to-let else-exp else-args)
+         (make-flic-app else-exp else-args '#f)))))
+
+    
+
+;;; Look for (sel (pack x)) => x
+
+(define-optimize flic-sel (object)
+  (optimize-flic-sel-aux object))
+
+(define (optimize-flic-sel-aux object)
+  (let ((new-exp  (optimize (flic-sel-exp object))))
+    (setf (flic-sel-exp object) new-exp)
+    (typecase new-exp
+      (flic-ref
+       ;; Check to see whether this is bound to a pack application
+       (let ((val  (is-bound-to-constructor-app? (flic-ref-var new-exp))))
+        (if val
+            ;; Yup, it is.  Now extract the appropriate component,
+            ;; provided it is inlineable.
+            (let* ((i      (flic-sel-i object))
+                   (args   (flic-app-args val))
+                   (newval (list-ref args i)))
+              (if (can-inline? newval '() '#t)
+                  (begin
+                    (record-hack 'sel-fold-var)
+                    (optimize (copy-flic-top newval)))
+                  object))
+            ;; The variable was bound to something else.
+            object)))
+      (flic-app
+       ;; The obvious optimization.
+       (if (is-constructor-app-prim? new-exp)
+          (begin
+            (record-hack 'sel-fold-app)
+            (list-ref (flic-app-args new-exp) (flic-sel-i object)))
+          object))
+      (else
+       object))))
+
+
+
+
+;;; Do similar stuff for is-constructor.
+
+(define-optimize flic-is-constructor (object)
+  (let ((con      (flic-is-constructor-con object))
+       (exp      (optimize (flic-is-constructor-exp object)))
+       (exp-con  '#f))
+    (cond ((algdata-tuple? (con-alg con))
+          ;; Tuples have only one constructor, so this is always true
+          (record-hack 'is-constructor-fold-tuple)
+          (make-flic-pack (core-symbol "True")))
+         ((setf exp-con (is-constructor-app? exp))
+          ;; The expression is a constructor application.
+          (record-hack 'is-constructor-fold)
+          (make-flic-pack
+            (if (eq? exp-con con)
+                (core-symbol "True")
+                (core-symbol "False"))))
+         (else
+          ;; No optimization possible
+          (setf (flic-is-constructor-exp object) exp)
+          object)
+         )))
+
+
+(define-optimize flic-con-number (object)
+  (let ((exp  (flic-con-number-exp object))
+       (type (flic-con-number-type object)))
+    ;; ***Maybe ast-to-flic should look for this one.
+    (if (algdata-tuple? type)
+       (begin
+         (record-hack 'con-number-fold-tuple)
+         (make-flic-const 0))
+       (let* ((new-exp  (optimize exp))
+              (con      (is-constructor-app? new-exp)))
+         (if con
+             (begin
+               (record-hack 'con-number-fold)
+               (make-flic-const (con-tag con)))
+             (begin
+               (setf (flic-con-number-exp object) new-exp)
+               object)))
+      )))
+
+(define-optimize flic-void (object)
+  object)
+
+
+;;;===================================================================
+;;; General helper functions
+;;;===================================================================
+
+
+;;; Lucid's built-in every function seems to do a lot of unnecessary
+;;; consing.  This one is much faster.
+
+(define (every-1 fn list)
+  (cond ((null? list)
+        '#t)
+       ((funcall fn (car list))
+        (every-1 fn (cdr list)))
+       (else
+        '#f)))
+
+
+
+;;; Equality predicate on flic expressions
+
+(define (flic-exp-eq? a1 a2)
+  (typecase a1
+    (flic-const
+     (and (is-type? 'flic-const a2)
+         (equal? (flic-const-value a1) (flic-const-value a2))))
+    (flic-ref
+     (and (is-type? 'flic-ref a2)
+         (eq? (flic-ref-var a1) (flic-ref-var a2))))
+    (flic-pack
+     (and (is-type? 'flic-pack a2)
+         (eq? (flic-pack-con a1) (flic-pack-con a2))))
+    (flic-sel
+     (and (is-type? 'flic-sel a2)
+         (eq? (flic-sel-con a1) (flic-sel-con a2))
+         (eqv? (flic-sel-i a1) (flic-sel-i a2))
+         (flic-exp-eq? (flic-sel-exp a1) (flic-sel-exp a2))))
+    (else
+     '#f)))
+
+
+
+;;; Predicates for testing whether an expression matches a pattern.
+
+(define (is-constructor-app? exp)
+  (typecase exp
+    (flic-app
+     ;; See if we have a saturated call to a constructor.
+     (is-constructor-app-prim? exp))
+    (flic-ref
+     ;; See if we can determine anything about the value the variable
+     ;; is bound to.
+     (let ((value  (var-value (flic-ref-var exp))))
+       (if value
+          (is-constructor-app? value)
+          '#f)))
+    (flic-let
+     ;; See if we can determine anything about the body of the let.
+     (is-constructor-app? (flic-let-body exp)))
+    (flic-pack
+     ;; See if this is a nullary constructor.
+     (let ((con  (flic-pack-con exp)))
+       (if (eqv? (con-arity con) 0)
+          con
+          '#f)))
+    (else
+     '#f)))
+
+(define (is-return-from-block? sym exp)
+  (and (is-type? 'flic-return-from exp)
+       (eq? (flic-return-from-block-name exp) sym)))
+
+(define (is-constructor-app-prim? exp)
+  (let ((fn    (flic-app-fn exp))
+       (args  (flic-app-args exp)))
+    (if (and (is-type? 'flic-pack fn)
+            (eqv? (length args) (con-arity (flic-pack-con fn))))
+       (flic-pack-con fn)
+       '#f)))
+
+(define (is-bound-to-constructor-app? var)
+  (let ((val  (var-value var)))
+    (if (and val
+            (is-type? 'flic-app val)
+            (is-constructor-app-prim? val))
+       val
+       '#f)))
+
+(define (is-selector? con i exp)
+  (or (and (is-type? 'flic-ref exp)
+          (is-selector? con i (var-value (flic-ref-var exp))))
+      (and (is-type? 'flic-sel exp)
+          (eq? (flic-sel-con exp) con)
+          (eqv? (the fixnum i) (the fixnum (flic-sel-i exp)))
+          (flic-sel-exp exp))
+      ))
+
+(define (is-selector-list? con i subexp exps)
+  (declare (type fixnum i))
+  (if (null? exps)
+      subexp
+      (let ((temp  (is-selector? con i (car exps))))
+       (and (flic-exp-eq? subexp temp)
+            (is-selector-list? con (+ 1 i) subexp (cdr exps))))))
+
+
+
+;;;===================================================================
+;;; Inlining criteria
+;;;===================================================================
+
+;;; Expressions that can be inlined unconditionally are constants, variable
+;;; references, and some functions.
+;;; I've made some attempt here to arrange the cases in the order they
+;;; are likely to occur.
+
+(define (can-inline? exp recursive-vars toplevel?)
+  (typecase exp
+    (flic-sel
+     ;; Listed first because it happens more frequently than
+     ;; anything else.
+     ;; *** Inlining these is an experiment.
+     ;; *** This transformation interacts with the strictness
+     ;; *** analyzer; if the variable referenced is not strict, then
+     ;; *** it is probably not a good thing to do since it adds extra
+     ;; *** forces.
+     ;; (let ((subexp  (flic-sel-exp exp)))
+     ;;   (and (is-type? 'flic-ref subexp)
+     ;;        (not (memq (flic-ref-var subexp) recursive-vars))))
+     '#f)
+    (flic-lambda
+     ;; Do not try to inline lambdas if the fancy inline optimization
+     ;; is disabled.
+     ;; Watch for problems with infinite loops with recursive variables.
+     (if (dynamic *do-inline-optimizations*)
+        (simple-function-body? (flic-lambda-body exp)
+                               (flic-lambda-vars exp)
+                               recursive-vars
+                               toplevel?)
+        '#f))
+    (flic-ref
+     ;; We get into infinite loops trying to inline recursive variables.
+     (not (memq (flic-ref-var exp) recursive-vars)))
+    ((or flic-pack flic-const)
+     '#t)
+    (else
+     '#f)))
+
+
+;;; Determining whether to inline a function is difficult.  This is
+;;; very conservative to avoid code bloat.  What we need to do is
+;;; compare the cost (in program size mainly) of the inline call with
+;;; an out of line call.  For an out of line call, we pay for one function
+;;; call and a setup for each arg.  When inlining, we pay for function
+;;; calls in the body and for args referenced more than once.  In terms of
+;;; execution time, we win big when a functional parameter is called
+;;; since this `firstifies' the program.
+
+;;; Here's the criteria:
+;;;  An inline function gets to reference no more that 2 non-parameter
+;;;  values (including constants and repeated parameter references).
+;;; For non-toplevel functions, be slightly more generous since the
+;;; fixed overhead of binding the local function would go away.
+
+(define (simple-function-body? exp lambda-vars recursive-vars toplevel?)
+  (let ((c  (if toplevel? 2 4)))
+    (>= (the fixnum (simple-function-body-1 exp lambda-vars recursive-vars c))
+       0)))
+
+
+;;; I've made some attempt here to order the cases by how frequently
+;;; they appear.
+
+(define (simple-function-body-1 exp lambda-vars recursive-vars c)
+  (declare (type fixnum c))
+  (if (< c 0)
+      (values c '())
+      (typecase exp
+       (flic-ref
+        (let ((var (flic-ref-var exp)))
+          (cond ((memq var lambda-vars)
+                 (values c (list-remove-1 var lambda-vars)))
+                ((memq var recursive-vars)
+                 (values -1 '()))
+                (else
+                 (values (the fixnum (1- c)) lambda-vars)))))
+       (flic-app
+        (simple-function-body-1/l
+          (cons (flic-app-fn exp) (flic-app-args exp))
+          lambda-vars recursive-vars c))
+       (flic-sel
+        (simple-function-body-1
+         (flic-sel-exp exp)
+         lambda-vars recursive-vars (the fixnum (1- c))))
+       (flic-is-constructor
+        (simple-function-body-1
+         (flic-is-constructor-exp exp)
+         lambda-vars recursive-vars (the fixnum (1- c))))
+       ((or flic-const flic-pack)
+        (values (the fixnum (1- c)) lambda-vars))
+       (else
+         ;; case & let & lambda not allowed.
+        (values -1 '())))))
+
+(define (list-remove-1 item list)
+  (cond ((null? list)
+        '())
+       ((eq? item (car list))
+        (cdr list))
+       (else
+        (cons (car list) (list-remove-1 item (cdr list))))
+       ))
+
+(define (simple-function-body-1/l exps lambda-vars recursive-vars c)
+  (declare (type fixnum c))
+  (if (or (null? exps) (< c 0))
+      (values c lambda-vars)
+      (multiple-value-bind (c-1 lambda-vars-1)
+         (simple-function-body-1 (car exps) lambda-vars recursive-vars c)
+       (simple-function-body-1/l
+         (cdr exps) lambda-vars-1 recursive-vars c-1))))
+
+
+
+;;;===================================================================
+;;; Constant structured data detection
+;;;===================================================================
+
+
+;;; Look to determine whether an object is a structured constant,
+;;; recursively examining its components if it's an app.  This is
+;;; necessary in order to detect constants with arbitrary circular
+;;; reference to the vars in recursive-vars.
+
+(define (structured-constant-recursive? object recursive-vars stack)
+  (typecase object
+    (flic-const
+     '#t)
+    (flic-ref
+     (let ((var  (flic-ref-var object)))
+       (or (memq var stack)
+          (var-toplevel? var)
+          (and (memq var recursive-vars)
+               (structured-constant-recursive?
+                (var-value var) recursive-vars (cons var stack))))))
+    (flic-pack
+     '#t)
+    (flic-app
+     (structured-constant-app-recursive?
+       (flic-app-fn object)
+       (flic-app-args object)
+       recursive-vars
+       stack))
+    (flic-lambda
+     (lambda-hoistable? object))
+    (else
+     '#f)))
+
+(define (structured-constant-app-recursive? fn args recursive-vars stack)
+  (and (is-type? 'flic-pack fn)
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
+       (every-1 (lambda (a)
+                 (structured-constant-recursive? a recursive-vars stack))
+               args)))
+
+
+;;; Here's a non-recursive (and more efficient) version of the above.
+;;; Instead of looking at the whole structure, it only looks one level
+;;; deep.  This can't detect circular constants, but is useful in
+;;; contexts where circularities cannot appear.
+
+(define (structured-constant? object)
+  (typecase object
+    (flic-ref
+     (var-toplevel? (flic-ref-var object)))
+    (flic-const
+     '#t)
+    (flic-pack
+     '#t)
+    (flic-lambda
+     (lambda-hoistable? object))
+    (else
+     '#f)))
+
+(define (structured-constant-app? fn args)
+  (and (is-type? 'flic-pack fn)
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
+       (every-1 (function structured-constant?) args)))
+
+
+;;; Determine whether a lambda can be hoisted to top-level.
+;;; The main purpose of this code is to mark structured constants
+;;; containing simple lambdas to permit later folding of sel expressions 
+;;; on those constants.  Since the latter expression is permissible
+;;; only on inlinable functions, stop if we hit an expression that
+;;; would make the function not inlinable.
+
+(define (lambda-hoistable? object)
+  (and (can-inline? object '() '#t)
+       (lambda-hoistable-aux
+        (flic-lambda-body object)
+        (flic-lambda-vars object))))
+
+(define (lambda-hoistable-aux object local-vars)
+  (typecase object
+    (flic-ref
+     (or (var-toplevel? (flic-ref-var object))
+        (memq (flic-ref-var object) local-vars)))
+    ((or flic-const flic-pack)
+     '#t)
+    (flic-sel
+     (lambda-hoistable-aux (flic-sel-exp object) local-vars))
+    (flic-is-constructor
+     (lambda-hoistable-aux (flic-is-constructor-exp object) local-vars))
+    (flic-app
+     (and (lambda-hoistable-aux (flic-app-fn object) local-vars)
+         (every-1 (lambda (x) (lambda-hoistable-aux x local-vars))
+                  (flic-app-args object))))
+    (else
+     '#f)))
+
+
+;;; Having determined that something is a structured constant,
+;;; enter it (and possibly its subcomponents) in the hash table
+;;; and return a var-ref.
+
+(define (enter-structured-constant value recursive?)
+  (multiple-value-bind (con args var)
+      (enter-structured-constant-aux value recursive?)
+    (when (not var)
+      (setf var (create-temp-var 'constant))
+      (add-new-structured-constant var con args))
+    (make-flic-ref var)))
+
+(define (enter-structured-constant-aux value recursive?)
+  (let* ((fn   (flic-app-fn value))
+        (con  (flic-pack-con fn))
+        (args (if recursive?
+                  (map (function enter-structured-constant-arg)
+                       (flic-app-args value))
+                  (flic-app-args value))))
+    (values con args (lookup-structured-constant con args))))
+
+(define (enter-structured-constant-arg a)
+  (if (is-type? 'flic-app a)
+      (enter-structured-constant a '#t)
+      a))
+
+(define (lookup-structured-constant con args)
+  (lookup-structured-constant-aux
+    (table-entry *structured-constants-table* con) args))
+
+(define (lookup-structured-constant-aux alist args)
+  (cond ((null? alist)
+        '#f)
+       ((every (function flic-exp-eq?) (car (car alist)) args)
+        (cdr (car alist)))
+       (else
+        (lookup-structured-constant-aux (cdr alist) args))))
+
+(define (add-new-structured-constant var con args)
+  (push (cons args var) (table-entry *structured-constants-table* con))
+  (setf (var-toplevel? var) '#t)
+  (setf (var-value var) (make-flic-app (make-flic-pack con) args '#t))
+  (push var *structured-constants*)
+  var)
+
+
+
+;;;===================================================================
+;;; Invariant argument stuff
+;;;===================================================================
+
+
+;;; When processing a saturated call to a locally defined function,
+;;; note whether any of the arguments are always passed the same value.
+
+(define (note-invariant-args args vars)
+  (when (and (not (null? args)) (not (null? vars)))
+    (let* ((arg  (car args))
+          (var  (car vars))
+          (val  (var-arg-invariant-value var)))
+      (cond ((not (var-arg-invariant? var))
+            ;; This argument already marked as having more than one
+            ;; value.
+            )
+           ((and (is-type? 'flic-ref arg)
+                 (eq? (flic-ref-var arg) var))
+            ;; This is a recursive call with the same argument.
+            ;; Don't update the arg-invariant-value slot.
+            )
+           ((or (not val)
+                (flic-exp-eq? arg val))
+            ;; Either this is the first call, or a second call with
+            ;; the same argument.
+            (setf (var-arg-invariant-value var) arg))
+           (else
+            ;; Different values for this argument are passed in
+            ;; different places, so we can't mess with it.
+            (setf (var-arg-invariant? var) '#f)))
+      (note-invariant-args (cdr args) (cdr vars)))))
+
+
+;;; After processing a let form, check to see if any of the bindings
+;;; are for local functions with invariant arguments.
+;;; Suppose we have something like
+;;;   let foo = \ x y z -> <fn-body>
+;;;     in <let-body>
+;;; and y is known to be invariant; then we rewrite this as
+;;;   let foo1 = \ x z -> let y = <invariant-value> in <fn-body>
+;;;       foo = \ x1 y1 z1 -> foo1 x1 z1
+;;;     in <let-body>
+;;; The original foo binding is inlined on subsequent passes and 
+;;; should go away.  Likewise, the binding of y should be inlined also.
+;;; *** This is kind of bogus because of the way it depends on the
+;;; *** magic force-inline bit.  It would be better to do a code walk
+;;; *** now on the entire let expression to rewrite all the calls to foo.
+
+(define (add-stuff-for-invariants bindings)
+  (if (null? bindings)
+      '()
+      (let* ((var  (car bindings))
+            (val  (var-value var)))
+       (setf (cdr bindings)
+             (add-stuff-for-invariants (cdr bindings)))
+       (if (and (is-type? 'flic-lambda val)
+                ;; Don't mess with single-reference variable bindings,
+                ;; or things we are going to inline anyway.
+                (not (var-single-ref var))
+                (not (var-simple? var))
+                ;; All references must be in saturated calls to do this.
+                (eqv? (var-referenced var) (var-fn-referenced var))
+                ;; There is at least one argument marked invariant.
+                (some (function var-arg-invariant?) (flic-lambda-vars val))
+                ;; Every argument marked invariant must also be hoistable.
+                (every-1 (function arg-hoistable?) (flic-lambda-vars val)))
+           (hoist-invariant-args
+             var
+             val
+             bindings)
+           bindings))))
+
+(define (arg-hoistable? var)
+  (if (var-arg-invariant? var)
+      (or (not (var-arg-invariant-value var))
+         (flic-invariant? (var-arg-invariant-value var)
+                          (dynamic *local-bindings*)))
+      '#t))
+
+(define (hoist-invariant-args var val bindings)
+  (let ((foo1-var       (copy-temp-var (def-name var)))
+       (foo1-def-vars  '())
+       (foo1-app-args  '())
+       (foo1-let-vars  '())
+       (foo-def-vars   '()))
+    (push foo1-var bindings)
+    (dolist (v (flic-lambda-vars val))
+      (let ((new-v  (copy-temp-var (def-name v))))
+       (push (init-flic-var new-v '#f '#f) foo-def-vars)
+       (if (var-arg-invariant? v)
+           (when (var-arg-invariant-value v)
+             (push (init-flic-var
+                     v (copy-flic-top (var-arg-invariant-value v)) '#f)
+                   foo1-let-vars))
+           (begin
+             (push v foo1-def-vars)
+             (push (make-flic-ref new-v) foo1-app-args))
+         )))
+    (setf foo1-def-vars (nreverse foo1-def-vars))
+    (setf foo1-app-args (nreverse foo1-app-args))
+    (setf foo1-let-vars (nreverse foo1-let-vars))
+    (setf foo-def-vars (nreverse foo-def-vars))
+    (record-hack 'let-hoist-invariant-args var foo1-let-vars)
+    ;; Fix up the value of foo1
+    (init-flic-var
+      foo1-var
+      (let ((body  (make-flic-let foo1-let-vars (flic-lambda-body val) '#f)))
+       (if (null? foo1-def-vars)
+           ;; *All* of the arguments were invariant.
+           body
+           ;; Otherwise, make a new lambda
+           (make-flic-lambda foo1-def-vars body)))
+      '#f)
+    ;; Fix up the value of foo and arrange for it to be inlined.
+    (setf (flic-lambda-vars val) foo-def-vars)
+    (setf (flic-lambda-body val)
+         (if (null? foo1-app-args)
+             (make-flic-ref foo1-var)
+             (make-flic-app (make-flic-ref foo1-var) foo1-app-args '#t)))
+    (setf (var-simple? var) '#t)
+    (setf (var-force-inline? var) '#t)
+    ;; Return modified list of bindings
+    bindings))
+
+
+
+;;;===================================================================
+;;; Install globals
+;;;===================================================================
+
+
+;;; The optimizer, CFN, etc. can introduce new top-level variables that
+;;; are not installed in the symbol table.  This causes problems if
+;;; those variables are referenced in the .hci file (as in the inline
+;;; expansion of some other variables).  So we need to fix up the 
+;;; symbol table before continuing.
+
+(define (install-uninterned-globals vars)
+  (dolist (v vars)
+    (let* ((module  (locate-module (def-module v)))
+          (name    (def-name v))
+          (table   (module-symbol-table module))
+          (def     (table-entry table name)))
+      (cond ((not def)
+            ;; This def was not installed.  Rename it if it's a gensym
+            ;; and install it.
+            (when (gensym? name)
+              (setf name (rename-gensym-var v name table)))
+            (setf (table-entry table name) v))
+           ((eq? def v)
+            ;; Already installed.
+            '#t)
+           (else
+            ;; Ooops!  The symbol installed in the symbol table isn't 
+             ;; this one!
+            (error "Duplicate defs ~s and ~s in symbol table for ~s!"
+                   v def module))
+           ))))
+
+
+(define (rename-gensym-var var name table)
+  (setf name (string->symbol (symbol->string name)))
+  (if (table-entry table name)
+      ;; This name already in use; gensym a new one!
+      (rename-gensym-var var (gensym (symbol->string name)) table)
+      ;; OK, no problem
+      (setf (def-name var) name)))
+
+
+
+;;;===================================================================
+;;; Postoptimizer
+;;;===================================================================
+
+;;; This is another quick traversal of the structure to determine 
+;;; whether references to functions are fully saturated or not.
+;;; Also makes sure that reference counts on variables are correct;
+;;; this is needed so the code generator can generate ignore declarations
+;;; for unused lambda variables.
+
+(define-flic-walker postoptimize (object))
+
+(define-postoptimize flic-lambda (object)
+  (dolist (var (flic-lambda-vars object))
+    (setf (var-referenced var) 0))
+  (postoptimize (flic-lambda-body object)))
+
+(define-postoptimize flic-let (object)
+  (dolist (var (flic-let-bindings object))
+    (setf (var-referenced var) 0)
+    (let ((val  (var-value var)))
+      (setf (var-arity var)
+           (if (is-type? 'flic-lambda val)
+               (length (flic-lambda-vars val))
+               0))))
+  (dolist (var (flic-let-bindings object))
+    (postoptimize (var-value var)))
+  (postoptimize (flic-let-body object)))
+
+(define-postoptimize flic-app (object)
+  (let ((fn    (flic-app-fn object)))
+    (typecase fn
+      (flic-ref
+       (let* ((var     (flic-ref-var fn))
+             (arity   (var-arity var)))
+        (if (not (var-toplevel? var)) (incf (var-referenced var)))
+        (when (not (eqv? arity 0))
+          (postoptimize-app-aux object var arity (flic-app-args object)))))
+      (flic-pack
+       (let* ((con    (flic-pack-con fn))
+             (arity  (con-arity con)))
+        (postoptimize-app-aux object '#f arity (flic-app-args object))))
+      (else
+       (postoptimize fn)))
+    (dolist (a (flic-app-args object))
+      (postoptimize a))))
+
+(define (postoptimize-app-aux object var arity args)
+  (declare (type fixnum arity))
+  (let ((nargs   (length args)))
+    (declare (type fixnum nargs))
+    (cond ((< nargs arity)
+          ;; not enough arguments
+          (when var (setf (var-standard-refs? var) '#t)))
+         ((eqv? nargs arity)
+          ;; exactly the right number of arguments
+          (when var (setf (var-optimized-refs? var) '#t))
+          (setf (flic-app-saturated? object) '#t))
+         (else
+          ;; make the fn a nested flic-app
+          (multiple-value-bind (arghead argtail)
+              (split-list args arity)
+            (setf (flic-app-fn object)
+                  (make-flic-app (flic-app-fn object) arghead '#t))
+            (setf (flic-app-args object) argtail)
+            (when var (setf (var-optimized-refs? var) '#t))
+            (dolist (a arghead)
+              (postoptimize a))))
+         )))
+
+(define-postoptimize flic-ref (object)
+  (let ((var  (flic-ref-var object)))
+    (if (not (var-toplevel? var)) (incf (var-referenced var)))
+    (setf (var-standard-refs? var) '#t)))
+
+(define-postoptimize flic-const (object)
+  object)
+
+(define-postoptimize flic-pack (object)
+  object)
+
+(define-postoptimize flic-and (object)
+  (for-each (function postoptimize) (flic-and-exps object)))
+
+(define-postoptimize flic-case-block (object)
+  (for-each (function postoptimize) (flic-case-block-exps object)))
+
+(define-postoptimize flic-if (object)
+  (postoptimize (flic-if-test-exp object))
+  (postoptimize (flic-if-then-exp object))
+  (postoptimize (flic-if-else-exp object)))
+
+(define-postoptimize flic-return-from (object)
+  (postoptimize (flic-return-from-exp object)))
+
+(define-postoptimize flic-sel (object)
+  (postoptimize (flic-sel-exp object)))
+
+(define-postoptimize flic-is-constructor (object)
+  (postoptimize (flic-is-constructor-exp object)))
+
+(define-postoptimize flic-con-number (object)
+  (postoptimize (flic-con-number-exp object)))
+
+(define-postoptimize flic-void (object)
+  object)
diff --git a/backend/strictness.scm b/backend/strictness.scm
new file mode 100644 (file)
index 0000000..5e03aa6
--- /dev/null
@@ -0,0 +1,845 @@
+;;; strictness.scm -- strictness analyzer
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  28 May 1992
+;;;
+;;; The algorithm used here follows Consel, "Fast Strictness Analysis
+;;; Via Symbolic Fixpoint Interation".
+;;;
+;;; The basic idea is to do a traversal of the flic structure, building
+;;; a boolean term that represents the strictness of each subexpression.
+;;; The boolean terms are composed of ands & ors of the argument variables
+;;; to each function.  After traversing the body of the function, we can
+;;; determine which argument variables are strict by examining the 
+;;; corresponding term, and then we can update the strictness attribute
+;;; of the var that names the function.
+;;;
+;;; Another traversal needs to be done to attach strictness properties
+;;; to locally bound variables.  
+
+
+;;; Here's the main entry point.
+
+(define (strictness-analysis-top big-let)
+  (fun-strictness-walk big-let)
+  (var-strictness-walk big-let '() '())
+  ;; *** This probably belongs somewhere else?
+  (do-box-analysis big-let '() '() '#t)
+  big-let)
+
+
+;;;======================================================================
+;;; Function strictness analyzer code walk
+;;;======================================================================
+
+;;; This actually involves two code walkers.  The first merely traverses
+;;; structure and identifies function definitions.  The second traverses
+;;; the definitions of the functions to compute their strictness.
+
+
+;;; Fun-strictness-walk is the walker to find function definitions.
+;;; This is trivial for everything other than flic-let.
+
+(define-flic-walker fun-strictness-walk (object))
+
+(define-fun-strictness-walk flic-lambda (object)
+  (fun-strictness-walk (flic-lambda-body object)))
+
+(define-fun-strictness-walk flic-let (object)
+  (if (flic-let-recursive? object)
+      (fun-strictness-walk-letrec object)
+      (fun-strictness-walk-let* object))
+  (dolist (v (flic-let-bindings object))
+    (fun-strictness-walk (var-value v)))
+  (fun-strictness-walk (flic-let-body object)))
+
+(define-fun-strictness-walk flic-app (object)
+  (fun-strictness-walk (flic-app-fn object))
+  (for-each (function fun-strictness-walk) (flic-app-args object)))
+
+(define-fun-strictness-walk flic-ref (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-pack (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-const (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-case-block (object)
+  (for-each (function fun-strictness-walk) (flic-case-block-exps object)))
+
+(define-fun-strictness-walk flic-return-from (object)
+  (fun-strictness-walk (flic-return-from-exp object)))
+
+(define-fun-strictness-walk flic-and (object)
+  (for-each (function fun-strictness-walk) (flic-and-exps object)))
+
+(define-fun-strictness-walk flic-if (object)
+  (fun-strictness-walk (flic-if-test-exp object))
+  (fun-strictness-walk (flic-if-then-exp object))
+  (fun-strictness-walk (flic-if-else-exp object)))
+
+(define-fun-strictness-walk flic-sel (object)
+  (fun-strictness-walk (flic-sel-exp object)))
+
+(define-fun-strictness-walk flic-is-constructor (object)
+  (fun-strictness-walk (flic-is-constructor-exp object)))
+
+(define-fun-strictness-walk flic-con-number (object)
+  (fun-strictness-walk (flic-con-number-exp object)))
+
+(define-fun-strictness-walk flic-void (object)
+  (declare (ignore object))
+  '#f)
+
+
+
+;;; Here is the magic for let bindings of function definitions.
+;;; Sequential bindings are easy.  For recursive bindings, we must 
+;;; keep track of mutually recursive functions.
+;;; If a function binding has a strictness annotation attached,
+;;; do not mess with it further.
+
+(define (fun-strictness-walk-let* object)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (when (is-type? 'flic-lambda val)
+       (if (var-strictness var)
+           (mark-argument-strictness
+             (var-strictness var) (flic-lambda-vars val))
+           (compute-function-strictness var val '())))
+      )))
+
+(define (fun-strictness-walk-letrec object)
+  (let ((stack   '()))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+       (if (and (is-type? 'flic-lambda val) (not (var-strictness var)))
+           (setf stack (add-recursive-function-1 var (init-var-env) stack)))))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+       (when (is-type? 'flic-lambda val)
+         (if (var-strictness var)
+             (mark-argument-strictness
+               (var-strictness var) (flic-lambda-vars val))
+             (compute-function-strictness var val stack)))
+       ))))
+
+(define (compute-function-strictness var val stack)
+  (let* ((vars  (flic-lambda-vars val))
+        (env   (add-var-binding-n vars (map (function list) vars)
+                                  (init-var-env)))
+        (term  (compute-strictness-walk (flic-lambda-body val) env stack)))
+    (when (eq? term '#t)
+      (signal-infinite-loop-function var)
+      (setf (flic-lambda-body val)
+           (make-infinite-loop-error
+             (format '#f "Function ~s has an infinite loop." var))))
+    (setf (var-strictness var) (munge-strictness-terms term vars))))
+
+
+(define (signal-infinite-loop-function var)
+  (recoverable-error 'infinite-loop-function
+    "Function ~s has an infinite loop."
+    var))
+
+(define (make-infinite-loop-error msg)
+  (make-flic-app
+    (make-flic-ref (core-symbol "error"))
+    (list (make-flic-const msg))
+    '#t))
+
+  
+;;; compute-strictness-walk is the traversal to compute strictness
+;;; terms.
+;;; The purpose of the env is to map locally bound variables onto 
+;;; strictness terms which are expressed as lists of argument variables
+;;; to the function being analyzed.
+;;; The purpose of the stack is to keep track of recursive function
+;;; walks and recognize when we've reached a fixed point.
+
+(define-flic-walker compute-strictness-walk (object env stack))
+
+
+;;; Making a function never forces anything.
+
+(define-compute-strictness-walk flic-lambda (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; For let, add bindings to environment and get strictness of body.
+
+(define-compute-strictness-walk flic-let (object env stack)
+  (let ((bindings    (flic-let-bindings object))
+       (body        (flic-let-body object))
+       (recursive?  (flic-let-recursive? object)))
+    (if recursive?
+       ;; Must add stuff to env and stack before traversing anything.
+       (begin
+         (dolist (var bindings)
+           (setf env (add-var-binding-1 var '#f env)))
+         (dolist (var bindings)
+           (let ((val  (var-value var)))
+             (when (is-type? 'flic-lambda val)
+               (setf stack (add-recursive-function-1 var env stack)))))
+         (dolist (var bindings)
+           (let ((val  (var-value var)))
+             (set-var-env var env (compute-strictness-walk val env stack)))))
+       ;; Otherwise just do things sequentially.
+       ;; Note that even though there is no possibility of recursion
+       ;; here, we must add stuff to the stack anyway so that we can
+       ;; walk calls in the correct env.
+       (dolist (var bindings)
+         (let ((val  (var-value var)))
+           (when (is-type? 'flic-lambda val)
+             (setf stack (add-recursive-function-1 var env stack)))
+           (setf env
+                 (add-var-binding-1
+                   var (compute-strictness-walk val env stack) env)))))
+    (compute-strictness-walk body env stack)))
+
+
+;;; Treat explicit, saturated calls to named functions specially.
+
+(define-compute-strictness-walk flic-app (object env stack)
+  (let ((fn         (flic-app-fn object))
+       (args       (flic-app-args object))
+       (saturated? (flic-app-saturated? object)))
+    (cond ((and (is-type? 'flic-ref fn) saturated?)
+          ;; Special handling for named functions.
+          (compute-application-strictness
+            (flic-ref-var fn)
+            args env stack))
+         ((and (is-type? 'flic-pack fn) saturated?)
+          ;; Similarly for constructor applications, but we always
+          ;; know which arguments are strict in advance.
+          (compute-application-strictness-aux
+             (con-slot-strict? (flic-pack-con fn))
+             args env stack))
+         (else
+          ;; Otherwise, we know that the function expression is going to
+          ;; be forced, but all of its arguments are lazy.  So ignore the
+          ;; arguments in computing the strictness of the whole expression.
+          (compute-strictness-walk fn env stack)))))
+
+
+(define (compute-application-strictness var args env stack)
+  (let* ((strictness          (var-strictness var))
+        (info                '#f)
+        (arg-strictness-list '#f))
+    (cond ((eq? var (core-symbol "error"))
+          ;; This expression will return bottom no matter what.
+          'error)
+         (strictness
+          ;; We've already completed the walk for this function and
+          ;; determined which of its arguments are strict.
+          ;; The strictness expression for the application is the
+          ;; OR of the strictness of its non-lazy arguments.
+          (compute-application-strictness-aux strictness args env stack))
+         ((get-recursive-function-trace
+            (setf arg-strictness-list
+                  (map (lambda (a) (compute-strictness-walk a env stack))
+                       args))
+            (setf info (get-recursive-function var stack)))
+          ;; We're already tracing this call.  Return true to
+          ;; terminate the fixpoint iteration.
+          '#t)
+         (else
+          ;; Otherwise, begin a new trace instance.
+          ;; Add stuff to the saved var-env to map references to
+          ;; the argument variables to the strictness terms for
+          ;; the actual arguments at this call site.
+          ;; References to closed-over variables within the function
+          ;; use the strictness values that were stored in the env
+          ;; at the point of function definition.
+          (let* ((env      (get-recursive-function-env info))
+                 (lambda   (var-value var))
+                 (body     (flic-lambda-body lambda))
+                 (vars     (flic-lambda-vars lambda))
+                 (result   '#f))
+            (push-recursive-function-trace arg-strictness-list info)
+            (setf result
+                  (compute-strictness-walk
+                    body
+                    (add-var-binding-n vars arg-strictness-list env)
+                    stack))
+            (pop-recursive-function-trace info)
+            result))
+         )))
+
+
+(define (compute-application-strictness-aux strictness args env stack)
+  (make-or-term
+    (map (lambda (strict? arg)
+          (if strict? (compute-strictness-walk arg env stack) '#f))
+        strictness args)))
+
+
+;;; For a reference, look up the term associated with the variable in env.
+;;; If not present in the environment, ignore it; the binding was established
+;;; outside the scope of the function being analyzed.
+
+(define-compute-strictness-walk flic-ref (object env stack)
+  (declare (ignore stack))
+  (get-var-env (flic-ref-var object) env))
+       
+
+;;; References to constants or constructors never fail.
+
+(define-compute-strictness-walk flic-const (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+(define-compute-strictness-walk flic-pack (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; The first clause of a case-block is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-case-block (object env stack)
+  (compute-strictness-walk (car (flic-case-block-exps object)) env stack))
+
+
+;;; Return-from fails if its subexpression fails.
+
+(define-compute-strictness-walk flic-return-from (object env stack)
+  (compute-strictness-walk (flic-return-from-exp object) env stack))
+
+
+;;; For and, the first subexpression is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-and (object env stack)
+  (compute-strictness-walk (car (flic-and-exps object)) env stack))
+
+
+;;; The strictness of an IF is the strictness of the test OR'ed
+;;; with the AND of the strictness of its branches.
+
+(define-compute-strictness-walk flic-if (object env stack)
+  (make-or-term-2
+    (compute-strictness-walk (flic-if-test-exp object) env stack)
+    (make-and-term-2
+      (compute-strictness-walk (flic-if-then-exp object) env stack)
+      (compute-strictness-walk (flic-if-else-exp object) env stack))))
+
+
+;;; Selecting a component of a data structure causes it to be forced,
+;;; so propagate the strictness of the subexpression upwards.
+
+(define-compute-strictness-walk flic-sel (object env stack)
+  (compute-strictness-walk (flic-sel-exp object) env stack))
+
+
+;;; Is-constructor and con-number force their subexpressions.
+
+(define-compute-strictness-walk flic-is-constructor (object env stack)
+  (compute-strictness-walk (flic-is-constructor-exp object) env stack))
+
+(define-compute-strictness-walk flic-con-number (object env stack)
+  (compute-strictness-walk (flic-con-number-exp object) env stack))
+
+(define-compute-strictness-walk flic-void (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Utilities for managing the env
+;;;======================================================================
+
+;;; The env is just an a-list.
+
+(define (init-var-env)
+  '())
+
+(define (add-var-binding-1 var binding env)
+  (cons (cons var binding) env))
+
+(define (add-var-binding-n vars bindings env)
+  (if (null? vars)
+      env
+      (add-var-binding-n (cdr vars) (cdr bindings)
+                        (cons (cons (car vars) (car bindings)) env))))
+
+(define (get-var-env var env)
+  (let ((stuff  (assq var env)))
+    (if stuff
+       (cdr stuff)
+       '#f)))
+
+(define (set-var-env var env new-value)
+  (let ((stuff  (assq var env)))
+    (if stuff
+       (setf (cdr stuff) new-value)
+       (error "Can't find binding for ~s in environment." var))))
+  
+
+
+;;;======================================================================
+;;; Utilities for managing the stack
+;;;======================================================================
+
+;;; For now, the stack is just an a-list too.
+;;; Some sort of hashing scheme could also be used instead of a linear
+;;; search, but if the iteration depth for the fixpoint analysis is
+;;; small, it's probably not worth the trouble.
+
+(define (add-recursive-function-1 var env stack)
+  (cons (list var env '()) stack))
+
+(define (get-recursive-function var stack)
+  (or (assq var stack)
+      (error "Can't find entry for ~s in stack." var)))
+
+(define (get-recursive-function-env entry)
+  (cadr entry))
+
+(define (push-recursive-function-trace new-args entry)
+  (push new-args (caddr entry)))
+
+(define (pop-recursive-function-trace entry)
+  (pop (caddr entry)))
+
+(define (get-recursive-function-trace args entry)
+  (get-recursive-function-trace-aux args (caddr entry)))
+
+(define (get-recursive-function-trace-aux args list)
+  (cond ((null? list)
+        '#f)
+       ((every (function term=) args (car list))
+        '#t)
+       (else
+        (get-recursive-function-trace-aux args (cdr list)))))
+
+
+;;;======================================================================
+;;; Utilities for boolean terms
+;;;======================================================================
+
+
+;;; A term is either #t, #f, the symbol 'error, or a list of variables 
+;;; (which are implicitly or'ed together).
+;;; #t and 'error are treated identically, except that #t indicates
+;;; failure because of infinite recursion and 'error indicates failure
+;;; due to a call to the error function.
+;;; In general, AND terms add nothing to the result, so to reduce
+;;; needless computation we generally reduce (and a b) to #f.
+
+;;; Make an OR term.  First look for some obvious special cases as an
+;;; efficiency hack, otherwise fall through to more general code.
+
+(define (make-or-term terms)
+  (cond ((null? terms)
+        '#f)
+       ((null? (cdr terms))
+        (car terms))
+       ((eq? (car terms) '#t)
+        '#t)
+       ((eq? (car terms) 'error)
+        'error)
+       ((eq? (car terms) '#f)
+        (make-or-term (cdr terms)))
+       (else
+        (make-or-term-2 (car terms) (make-or-term (cdr terms))))))
+
+(define (make-or-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+        '#t)
+       ((eq? term2 'error)
+        'error)
+       ((eq? term2 '#f)
+        term1)
+       ((eq? term1 '#t)
+        '#t)
+       ((eq? term1 'error)
+        'error)
+       ((eq? term1 '#f)
+        term2)
+       ;; At this point we know both terms are variable lists.
+       ((implies? term2 term1)
+        term2)
+       ((implies? term1 term2)
+        term1)
+       (else
+        (merge-list-terms term1 term2))))
+
+
+;;;  Merge the two lists, throwing out duplicate variables.
+
+(define (merge-list-terms list1 list2)
+  (cond ((null? list1)
+        list2)
+       ((null? list2)
+        list1)
+       ((eq? (car list1) (car list2))
+        (cons (car list1) (merge-list-terms (cdr list1) (cdr list2))))
+       ((var< (car list1) (car list2))
+        (cons (car list1) (merge-list-terms (cdr list1) list2)))
+       (else
+        (cons (car list2) (merge-list-terms list1 (cdr list2))))))
+
+
+;;; Helper function: does term1 imply term2?
+;;; True if every subterm of term2 is also included in term1.
+
+(define (implies? term1 term2)
+  (every (lambda (v2) (memq v2 term1)) term2))
+
+
+;;; Make an AND term.  Because we don't want to build up arbitrarily
+;;; complex AND expressions, basically just compute an OR list that 
+;;; represents the intersection of the subterms.
+
+(define (make-and-term terms)
+  (cond ((null? terms)
+        '#f)
+       ((null? (cdr terms))
+        (car terms))
+       ((eq? (car terms) '#t)
+        (make-and-term (cdr terms)))
+       ((eq? (car terms) 'error)
+        (make-and-term (cdr terms)))
+       ((eq? (car terms) '#f)
+        '#f)
+       (else
+        (make-and-term-2 (car terms) (make-and-term (cdr terms))))))
+
+(define (make-and-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+        term1)
+       ((eq? term2 'error)
+        term1)
+       ((eq? term2 '#f)
+        '#f)
+       ((eq? term1 '#t)
+        term2)
+       ((eq? term1 'error)
+        term2)
+       ((eq? term1 '#f)
+        '#f)
+       ;; At this point we know both terms are variable lists.
+       ((implies? term2 term1)
+        term1)
+       ((implies? term1 term2)
+        term2)
+       (else
+        (let ((result  '()))
+          (dolist (v term1)
+            (if (memq v term2)
+                (push v result)))
+          (if (null? result)
+              '#f
+              (nreverse result))))
+       ))
+
+
+;;; Subterms of an and/or term are always sorted, so that to compare
+;;; two terms we can just compare subterms componentwise.
+
+(define (term= term1 term2)
+  (or (eq? term1 term2)
+      (and (pair? term1)
+          (pair? term2)
+          (eq? (car term1) (car term2))
+          (term= (cdr term1) (cdr term2)))))
+
+
+;;; Variables within an OR-list are sorted alphabetically by names.
+
+(define (var< var1 var2)
+  (string<? (symbol->string (def-name var1))
+           (symbol->string (def-name var2))))
+
+
+;;; Determine which of the vars are present in the term.
+
+(define (munge-strictness-terms term vars)
+  (map (lambda (v)
+        (setf (var-strict? v)
+              (cond ((var-force-strict? v)
+                     '#t)
+                    ((eq? term '#t)
+                     '#t)
+                    ((eq? term 'error)
+                     '#t)
+                    ((eq? term '#f)
+                     '#f)
+                    ((memq v term)
+                     '#t)
+                    (else
+                     '#f))))
+       vars))
+
+(define (mark-argument-strictness strictness vars)
+  (map (lambda (s v) (setf (var-strict? v) s)) strictness vars))
+
+
+
+;;;======================================================================
+;;; Variable strictness propagation code walk
+;;;======================================================================
+
+;;; Walk the code, marking any vars found in strict contexts as strict.
+;;; Locally bound variables are consed onto the varlist.  This is
+;;; used to determine which variables can be marked as strict when they
+;;; appear in strict contexts.
+;;; When walking something that does not appear in a strict context
+;;; or that is not always evaluated, reinitialize varlist to the empty
+;;; list.
+;;; The stack is used to keep track of variables that have not been
+;;; initialized yet, so that we can detect some kinds of infinite loops.
+;;; When walking something that is not always evaluated, reset this to 
+;;; the empty list.
+
+(define-flic-walker var-strictness-walk (object varlist stack))
+
+
+
+;;; Since the body of the lambda might not be evaluated, reset
+;;; both varlist and stack.
+
+(define-var-strictness-walk flic-lambda (object varlist stack)
+  (declare (ignore varlist stack))
+  (var-strictness-walk (flic-lambda-body object) '() '()))
+
+
+;;; The basic idea for let is to find the variables that are strict in 
+;;; the body first, and propagate that information backwards to the 
+;;; binding initializers.
+
+(define-var-strictness-walk flic-let (object varlist stack)
+  (let ((bindings  (flic-let-bindings object)))
+    (var-strictness-walk-let-aux
+      bindings
+      (flic-let-body object)
+      (append bindings varlist)
+      (append bindings stack)
+      (flic-let-recursive? object))))
+
+(define (var-strictness-walk-let-aux bindings body varlist stack recursive?)
+  (if (null? bindings)
+      (var-strictness-walk body varlist stack)
+      (begin
+       (var-strictness-walk-let-aux
+         (cdr bindings) body varlist (cdr stack) recursive?)
+       (let* ((var  (car bindings))
+              (val  (var-value var)))
+         (cond ((var-strict? var)
+                ;; Recursive variables have to be set back to unstrict
+                ;; because the value form might contain forward references.
+                ;; The box analyzer will set them to strict again if the
+                ;; value forms are safe.
+                (when recursive? (setf (var-strict? var) '#f))
+                ;; Detect x = 1 + x circularities here
+                (var-strictness-walk val varlist stack))
+               ((flic-exp-strict-result? val)
+                ;; The val is going to be wrapped in a delay.
+                (var-strictness-walk val '() '()))
+               (else
+                ;; Watch out for x = x and x = cdr x circularities.
+                ;; *** I am still a little confused about this.  It
+                ;; *** seems like the stack should be passed through
+                ;; *** when walking already-boxed values that appear as
+                 ;; *** non-strict function arguments as well, but doing
+                ;; *** so generates some apparently bogus complaints
+                ;; *** about infinite loops.  So maybe doing it here
+                ;; *** is incorrect too, and we just haven't run across
+                ;; *** a test case that triggers it???
+                (var-strictness-walk val '() stack))
+               )))))
+
+
+(define (flic-exp-strict-result? val)
+  (cond ((is-type? 'flic-ref val)
+        (var-strict? (flic-ref-var val)))
+       ((is-type? 'flic-sel val)
+        (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val)))
+       (else
+        '#t)))
+
+(define-var-strictness-walk flic-app (object varlist stack)
+  (let ((fn           (flic-app-fn object))
+       (args         (flic-app-args object))
+       (saturated?   (flic-app-saturated? object)))
+    (cond ((and saturated? (is-type? 'flic-ref fn))
+          ;; Strictness of function should be stored on var
+          (do-var-strictness-flic-app-aux
+            (var-strictness (flic-ref-var fn))
+            fn args varlist stack))
+         ((and saturated? (is-type? 'flic-pack fn))
+          ;; Strictness of constructor should be stored on con
+          (do-var-strictness-flic-app-aux
+            (con-slot-strict? (flic-pack-con fn))
+            fn args varlist stack))
+         (else
+          ;; All arguments are non-strict
+          (var-strictness-walk fn varlist stack)
+          (dolist (a args)
+            (var-strictness-walk a '() '()))))))
+
+(define (do-var-strictness-flic-app-aux strictness fn args varlist stack)
+  (when (not strictness)
+    (error "Can't find strictness for function ~s." fn))
+  (dolist (a args)
+    (if (pop strictness)
+       (var-strictness-walk a varlist stack)
+       (var-strictness-walk a '() '()))))
+
+
+(define-var-strictness-walk flic-ref (object varlist stack)
+  (let ((var  (flic-ref-var object)))
+    (cond ((memq var stack)
+          ;; Circular variable definition detected.
+          (signal-infinite-loop-variable var)
+          (setf (var-value var)
+                (make-infinite-loop-error
+                  (format '#f "Variable ~s has an infinite loop." var))))
+         ((memq var varlist)
+          (setf (var-strict? var) '#t))
+         (else
+          '#f))))
+
+(define (signal-infinite-loop-variable var)
+  (recoverable-error 'infinite-loop-variable
+    "Variable ~s has an infinite loop."
+    var))
+
+(define-var-strictness-walk flic-const (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-pack (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-case-block (object varlist stack)
+  (var-strictness-walk (car (flic-case-block-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-case-block-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-return-from (object varlist stack)
+  (var-strictness-walk (flic-return-from-exp object) varlist stack))
+
+(define-var-strictness-walk flic-and (object varlist stack)
+  (var-strictness-walk (car (flic-and-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-and-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-if (object varlist stack)
+  (var-strictness-walk (flic-if-test-exp object) varlist stack)
+  (var-strictness-walk (flic-if-then-exp object) '() '())
+  (var-strictness-walk (flic-if-else-exp object) '() '()))
+
+(define-var-strictness-walk flic-sel (object varlist stack)
+  (var-strictness-walk (flic-sel-exp object) varlist stack))
+
+(define-var-strictness-walk flic-is-constructor (object varlist stack)
+  (var-strictness-walk (flic-is-constructor-exp object) varlist stack))
+
+(define-var-strictness-walk flic-con-number (object varlist stack)
+  (var-strictness-walk (flic-con-number-exp object) varlist stack))
+
+(define-var-strictness-walk flic-void (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Printer support
+;;;======================================================================
+
+(define (strictness-analysis-printer big-let)
+  (print-strictness big-let 0))
+
+(define (print-strictness-list list depth)
+  (dolist (o list)
+    (print-strictness o depth)))
+
+(define (print-strictness-indent depth)
+  (dotimes (i (* 2 depth))
+    (declare (ignorable i))
+    (write-char #\space)))
+
+(define (strictness-string bool)
+  (if bool "#t" "#f"))
+
+(define-flic-walker print-strictness (object depth))
+
+(define-print-strictness flic-lambda (object depth)
+  (print-strictness-indent depth)
+  (format '#t "In anonymous function:~%")
+  (print-strictness (flic-lambda-body object) (1+ depth)))
+
+(define-print-strictness flic-let (object depth)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (if (is-type? 'flic-lambda val)
+         (begin
+           (print-strictness-indent depth)
+           (format '#t "Function ~s has argument strictness ~a.~%"
+                   var
+                   (map (function strictness-string) (var-strictness var)))
+           (print-strictness (flic-lambda-body val) (1+ depth)))
+         (begin
+           (print-strictness-indent depth)
+           (format '#t "Variable ~s has strictness ~a.~%"
+                   var
+                   (strictness-string (var-strict? var)))
+           (print-strictness val depth)))))
+  (print-strictness (flic-let-body object) depth))
+
+(define-print-strictness flic-app (object depth)
+  (print-strictness (flic-app-fn object) depth)
+  (print-strictness-list (flic-app-args object) depth))
+
+(define-print-strictness flic-ref (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-const (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-pack (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-case-block (object depth)
+  (print-strictness-list (flic-case-block-exps object) depth))
+
+(define-print-strictness flic-return-from (object depth)
+  (print-strictness (flic-return-from-exp object) depth))
+
+(define-print-strictness flic-and (object depth)
+  (print-strictness-list (flic-and-exps object) depth))
+
+(define-print-strictness flic-if (object depth)
+  (print-strictness (flic-if-test-exp object) depth)
+  (print-strictness (flic-if-then-exp object) depth)
+  (print-strictness (flic-if-else-exp object) depth))
+
+(define-print-strictness flic-sel (object depth)
+  (print-strictness (flic-sel-exp object) depth))
+
+(define-print-strictness flic-is-constructor (object depth)
+  (print-strictness (flic-is-constructor-exp object) depth))
+
+(define-print-strictness flic-con-number (object depth)
+  (print-strictness (flic-con-number-exp object) depth))
+
+(define-print-strictness flic-void (object depth)
+  (declare (ignore object depth))
+  '#f)
+
diff --git a/bin/cmu-clx-haskell b/bin/cmu-clx-haskell
new file mode 100755 (executable)
index 0000000..dba0998
--- /dev/null
@@ -0,0 +1,9 @@
+#!/bin/csh
+#
+# run cmu clx haskell
+
+if (`arch -k` == "sun4c") then
+  $CMUCLBIN -core $HASKELL/bin/sun4c-clx-haskell.core
+else
+  $CMUCLBIN -core $HASKELL/bin/sun4m-clx-haskell.core
+endif
diff --git a/bin/cmu-haskell b/bin/cmu-haskell
new file mode 100755 (executable)
index 0000000..ff82dfc
--- /dev/null
@@ -0,0 +1,9 @@
+#!/bin/csh
+#
+# run cmu haskell
+
+if (`arch -k` == "sun4c") then
+  $CMUCLBIN -core $HASKELL/bin/sun4c-haskell.core
+else
+  $CMUCLBIN -core $HASKELL/bin/sun4m-haskell.core
+endif
diff --git a/bin/magic.scm b/bin/magic.scm
new file mode 100644 (file)
index 0000000..999e8b0
--- /dev/null
@@ -0,0 +1,10 @@
+;;; magic.scm -- magic support file for dumping compiled code files.
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  8 Jul 1992
+;;;
+;;; This file is used to dump compiled code files.  The macro call below
+;;; expands into the code being dumped.  See dump-interface.scm for more
+;;; details.
+
+(magic-form-to-compile)
diff --git a/cfn/README b/cfn/README
new file mode 100644 (file)
index 0000000..80a25c1
--- /dev/null
@@ -0,0 +1,35 @@
+Whats what in the cfn.
+
+Language generated by cfn contains these ast node types:
+  lambda
+  let
+  if
+  case   -- restriction: all patterns must be either literals or
+                         a constructor with var and wildcard args
+  app
+  var-ref
+  con-ref
+  const
+  con-number
+  sel
+  is-constructor
+
+Transformations to do:
+  Convert lists to explicit calls to cons
+  Simplify patterns
+  Remove sequences
+  Remove list comprehensions
+  Remove sections
+  Reduce patterns on lhs of decls
+  Reduce patterns in function args
+  Convert where decls to let statements
+  Convert guarded-expressions to if - then - else form
+
+Done earlier:
+  signdecls are removed in scoping
+  exp-signs are removed in typechecker
+  prec parser removes `negate' & pp-* nodes
+
+
+
+
diff --git a/cfn/cfn.scm b/cfn/cfn.scm
new file mode 100644 (file)
index 0000000..bf43be0
--- /dev/null
@@ -0,0 +1,21 @@
+;;; cfn.scm -- module definition for CFN phase
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  11 Mar 1992
+;;;
+
+
+(define-compilation-unit cfn
+  (source-filename "$Y2/cfn/")
+  (require ast haskell-utils)
+  (unit main
+       (source-filename "main.scm"))
+  (unit misc
+       (source-filename "misc.scm")
+       (require main))
+  (unit pattern
+       (source-filename "pattern.scm")
+       (require main)))
+
+       
+
diff --git a/cfn/main.scm b/cfn/main.scm
new file mode 100644 (file)
index 0000000..3853b03
--- /dev/null
@@ -0,0 +1,83 @@
+;;; main.scm -- main entry point for CFN pass
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  27 Feb 1992
+;;;
+
+
+;;;===================================================================
+;;; Basic support
+;;;===================================================================
+
+
+;;; Define the basic walker and some helper functions.
+
+(define-walker cfn ast-td-cfn-walker)
+
+(define (cfn-ast-1 x)
+  (call-walker cfn x))
+
+(define (cfn-ast/list l)
+  (map (lambda (x) (cfn-ast-1 x)) l))
+
+
+;;; This is the main entry point.  It is called by the driver on
+;;; each top-level decl in the module.
+
+(define (cfn-ast x)
+  (let ((result  (cfn-ast-1 x)))
+;    (pprint result)  ;*** debug
+    result))
+
+
+
+;;;===================================================================
+;;; Default traversal methods
+;;;===================================================================
+
+
+(define-local-syntax (make-cfn-code slot type)
+  (let ((stype  (sd-type slot))
+        (sname  (sd-name slot)))
+    (cond ((and (symbol? stype)
+                (or (eq? stype 'exp)
+                    (subtype? stype 'exp)))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-ast-1 (struct-slot ',type ',sname object))))
+          ((and (pair? stype)
+                (eq? (car stype) 'list)
+                (symbol? (cadr stype))
+                (or (eq? (cadr stype) 'exp)
+                    (subtype? (cadr stype) 'exp)))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-ast/list (struct-slot ',type ',sname object))))
+          ((and (pair? stype)
+                (eq? (car stype) 'list)
+                (eq? (cadr stype) 'decl))
+           `(setf (struct-slot ',type ',sname object)
+                  (cfn-valdef-list (struct-slot ',type ',sname object))))
+          (else
+;          (format '#t "Cfn: skipping slot ~A in ~A~%"
+;                  (sd-name slot)
+;                  type)
+           '#f))))
+
+(define-modify-walker-methods cfn
+  (let if
+   exp-sign
+   app
+   var-ref con-ref
+   integer-const float-const char-const string-const
+   con-number sel is-constructor
+   void
+   case-block return-from and-exp
+   )
+  (object)
+  make-cfn-code)
+
+
+;;; These have specialized walkers:
+;;; lambda, case, valdef, list-comp  (pattern.scm)
+;;; list-exp, list-comp, section-l, section-r, dict-placeholder,
+;;; recursive-placeholder, save-old-exp (misc.scm)
+
diff --git a/cfn/misc.scm b/cfn/misc.scm
new file mode 100644 (file)
index 0000000..4bcba64
--- /dev/null
@@ -0,0 +1,113 @@
+;;; misc.scm -- random other transformations done during CFN processing
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  27 Feb 1992
+;;;
+;;; This file contains specialized CFN walkers that implement rewrite rules
+;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r.
+
+
+;;; Turn list-exps into cons chains.
+
+(define-walker-method cfn list-exp (object)
+  (do-cfn-list-exp (list-exp-exps object)))
+
+(define (do-cfn-list-exp exps)
+  (if (null? exps)
+      ;; Make a con-ref for []
+      (**con/def (core-symbol "Nil"))
+      ;; Otherwise make an app of :
+      (let ((first  (cfn-ast-1 (car exps)))
+           (rest   (do-cfn-list-exp (cdr exps))))
+       (**app (**con/def (core-symbol ":")) first rest))))
+       
+
+;;; Sections get turned into lambda expressions.
+
+(define-walker-method cfn section-l (object)
+  (let ((def   (create-temp-var 'section-arg)))
+    (**lambda/pat
+      (list (**var-pat/def def))
+      (**app (cfn-ast-1 (section-l-op object))
+             (**var/def def)
+            (cfn-ast-1 (section-l-exp object))))))
+
+(define-walker-method cfn section-r (object)
+  (let ((def   (create-temp-var 'section-arg)))
+    (**lambda/pat
+      (list (**var-pat/def def))
+      (**app (cfn-ast-1 (section-r-op object))
+            (cfn-ast-1 (section-r-exp object))
+             (**var/def def)))))
+
+
+
+;;; Do list comprehensions.
+;;; rewrite in terms of build and foldr so that we can apply
+;;; deforestation techniques later.
+
+(define-walker-method cfn list-comp (object)
+  (let ((c   (create-temp-var 'c))
+       (n   (create-temp-var 'n)))
+    (cfn-ast-1
+      (**app (**var/def (core-symbol "build"))
+            (**lambda/pat
+              (list (**var-pat/def c) (**var-pat/def n))
+              (do-cfn-list-comp
+                (list-comp-exp object) (list-comp-quals object) c n))))))
+
+(define (do-cfn-list-comp exp quals c n)
+  (if (null? quals)
+      (**app (**var/def c) exp (**var/def n))
+      (let ((qual  (car quals)))
+       (if (is-type? 'qual-generator qual)
+           (do-cfn-list-comp-generator exp qual (cdr quals) c n)
+           (do-cfn-list-comp-filter exp qual (cdr quals) c n)))))
+
+(define (do-cfn-list-comp-filter exp qual quals c n)
+  (**if (qual-filter-exp qual)
+       (do-cfn-list-comp exp quals c n)
+       (**var/def n)))
+
+(define (do-cfn-list-comp-generator exp qual quals c n)
+  (let ((gen-pat  (qual-generator-pat qual))
+       (gen-exp  (qual-generator-exp qual))
+       (l        (create-temp-var 'list))
+       (b        (create-temp-var 'rest)))
+    (**app (**var/def (core-symbol "foldr"))
+          (**lambda/pat
+            (list (**var-pat/def l) (**var-pat/def b))
+            (**case (**var/def l)
+                    (list (**alt/simple
+                           gen-pat
+                           (do-cfn-list-comp exp quals c b))
+                          (**alt/simple
+                           (**wildcard-pat)
+                           (**var/def b)))))
+          (**var/def n)
+          gen-exp)))
+
+;;; Placeholders just get eliminated
+
+(define-walker-method cfn dict-placeholder (object)
+  (if (eq? (dict-placeholder-exp object) '#f)
+      (error "Type checker screwed a dict placeholder object ~s." object)
+      (cfn-ast-1 (dict-placeholder-exp object))))
+
+(define-walker-method cfn method-placeholder (object)
+  (if (eq? (method-placeholder-exp object) '#f)
+      (error "Type checker screwed a method placeholder object ~s." object)
+      (cfn-ast-1 (method-placeholder-exp object))))
+
+(define-walker-method cfn recursive-placeholder (object)
+  (if (eq? (recursive-placeholder-exp object) '#f)
+      (error "Type checker screwed a recursive placeholder object ~s." object)
+      (cfn-ast-1 (recursive-placeholder-exp object))))
+
+(define-walker-method cfn cast (object)
+  (cfn-ast-1 (cast-exp object)))
+
+;;; Eliminate saved old expressions
+
+(define-walker-method cfn save-old-exp (object)
+  (cfn-ast-1 (save-old-exp-new-exp object)))
diff --git a/cfn/pattern.scm b/cfn/pattern.scm
new file mode 100644 (file)
index 0000000..64badbf
--- /dev/null
@@ -0,0 +1,654 @@
+;;; pattern.scm -- cfn processing of pattern-related AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  27 Feb 1992
+;;;
+;;; This file contains specialized CFN walkers for lambda, case, and valdef
+;;; structures.
+
+
+
+;;;=====================================================================
+;;; Top-level walkers
+;;;=====================================================================
+
+
+;;; The calls to remember-context are so an appropriate error message
+;;; can be produced for pattern-matching failures.
+
+(define-walker-method cfn lambda (object)
+  (remember-context object
+    (do-cfn-lambda (lambda-pats object) (lambda-body object))))
+
+
+(define-walker-method cfn case (object)
+  (remember-context object
+    (do-cfn-case
+      (case-exp object)
+      (case-alts object))))
+
+
+
+
+;;; Valdefs are always processed as a list.
+
+(define (cfn-valdef-list list-of-valdefs)
+  (if (null? list-of-valdefs)
+      '()
+      (nconc (cfn-valdef (car list-of-valdefs))
+            (cfn-valdef-list (cdr list-of-valdefs)))))
+
+(define (cfn-valdef object)
+  (remember-context object
+    (if (null? (single-fun-def-args (car (valdef-definitions object))))
+       ;; This is a pattern binding.
+       (do-cfn-pattern-def-top object)
+       ;; This is a function binding.
+       ;; Branch on single-headed/multi-headed definition.
+       (list (add-dict-params
+               object
+               (if (null? (cdr (valdef-definitions object)))
+                   (do-cfn-function-def-simple object)
+                   (do-cfn-function-def-general object))))
+      )))
+
+
+;;; This adds the dictionary parameters needed by the type system.  A valdef
+;;; structure has a dictionary-args field which contains the variables to be
+;;; bound to dicationary arguments.
+
+(define (add-dict-params original-valdef generated-valdef)
+  (let ((vars (valdef-dictionary-args original-valdef)))
+    (when (not (null? vars))
+      (let* ((sfd  (car (valdef-definitions generated-valdef)))
+            (rhs  (car (single-fun-def-rhs-list sfd)))
+            (exp  (guarded-rhs-rhs rhs))
+            (pats (map (function **var-pat/def) vars)))
+       (if (is-type? 'lambda exp)
+           (setf (lambda-pats exp)
+                 (nconc pats (lambda-pats exp)))
+           (setf (guarded-rhs-rhs rhs)
+                 (**lambda/pat pats exp))))))
+  generated-valdef)
+
+
+;;;=====================================================================
+;;; Lambda rewriting
+;;;=====================================================================
+
+
+;;; For lambda, make all the argument patterns into var pats.
+;;; Rewrite the body as a CASE to do any more complicated pattern
+;;; matching.
+;;; The CFN output for lambda is a modified lambda expression with
+;;; all var-pats as arguments.
+
+(define (do-cfn-lambda pats body)
+  (let ((new-args  '())
+       (new-vars  '())
+       (new-pats  '()))
+    (dolist (p pats)
+      (typecase p
+       (wildcard-pat
+         (push (**var-pat/def (create-temp-var 'arg)) new-args))
+        (var-pat
+         (push p new-args))
+       (as-pat
+         (let ((var  (var-ref-var (as-pat-var p))))
+           (push (**var-pat/def var) new-args)
+           (push (**var/def var) new-vars)
+           (push (as-pat-pattern p) new-pats)))
+       (else
+         (let ((var  (create-temp-var 'arg)))
+           (push (**var-pat/def var) new-args)
+           (push (**var/def var) new-vars)
+           (push p new-pats)))))
+    (setf new-args (nreverse new-args))
+    (setf new-vars (nreverse new-vars))
+    (setf new-pats (nreverse new-pats))
+    (**lambda/pat
+      new-args
+      (cond ((null? new-vars)
+            ;; No fancy pattern matching necessary.
+            (cfn-ast-1 body))
+           ((null? (cdr new-vars))
+            ;; Exactly one argument to match on.
+            (do-cfn-case (car new-vars)
+                         (list (**alt/simple (car new-pats) body))))
+           (else
+            ;; Multiple arguments to match on.
+            (do-cfn-case-tuple
+              new-vars
+              (list (**alt/simple (**tuple-pat new-pats) body))))
+           ))))
+
+
+;;;=====================================================================
+;;; Function definitions
+;;;=====================================================================
+
+
+;;; The output of the CFN for function definitions is a simple 
+;;; valdef which binds a variable to a lambda expression.
+
+
+;;; The simple case:  there is only one set of arguments.
+
+(define (do-cfn-function-def-simple object)
+  (let* ((pat    (valdef-lhs object))
+        (sfd    (car (valdef-definitions object))))
+    (**valdef/pat
+      pat
+      (do-cfn-lambda
+        (single-fun-def-args sfd)
+       (rewrite-guards-and-where-decls
+         (single-fun-def-where-decls sfd)
+         (single-fun-def-rhs-list sfd)
+         '#f)))))
+
+
+;;; The general case:  generate new variables as the formal parameters 
+;;; to the resulting lambda, then use case to do the pattern matching.
+
+(define (do-cfn-function-def-general object)
+  (let ((pat   (valdef-lhs object))
+       (vars  (map (lambda (p)
+                     (declare (ignore p))
+                     (create-temp-var 'arg))
+                   (single-fun-def-args (car (valdef-definitions object)))))
+       (alts  (map (lambda (sfd)
+                     (**alt (**tuple-pat (single-fun-def-args sfd))
+                            (single-fun-def-rhs-list sfd)
+                            (single-fun-def-where-decls sfd)))
+                   (valdef-definitions object))))
+    (**valdef/pat
+      pat
+      (**lambda/pat
+        (map (function **var-pat/def) vars)
+       (if (null? (cdr vars))
+           ;; one-argument case
+           (do-cfn-case (**var/def (car vars)) alts)
+           ;; multi-argument case
+           (do-cfn-case-tuple (map (function **var/def) vars) alts))))
+    ))
+
+
+;;;=====================================================================
+;;; Case
+;;;=====================================================================
+
+
+;;; For case, add failure alt, then call helper function to generate
+;;; pattern matching tests.
+;;; The CFN output for case is a case-block construct.
+
+(define (do-cfn-case exp alts)
+  (setf alts
+       (append alts
+               (list (**alt/simple (**wildcard-pat) (make-failure-exp)))))
+  (let ((list-of-pats          (map (lambda (a) (list (alt-pat a))) alts)))
+    (if (is-type? 'var-ref exp)
+       (match-pattern-list (list exp) list-of-pats alts)
+       (let ((temp  (create-temp-var 'cfn)))
+         (**let (list (**valdef/def temp (cfn-ast-1 exp)))
+                (match-pattern-list
+                  (list (**var/def temp))
+                  list-of-pats
+                  alts)))
+      )))
+
+
+
+;;; Here's a special case, for when the exp being matched is a tuple
+;;; of var-refs and all the alts also have tuple pats.
+
+(define (do-cfn-case-tuple exps alts)
+  (setf alts
+       (append alts
+               (list
+                 (**alt/simple
+                   (**tuple-pat
+                     (map (lambda (e) (declare (ignore e)) (**wildcard-pat))
+                          exps))
+                   (make-failure-exp)))))
+  (match-pattern-list
+    exps
+    (map (lambda (a) (pcon-pats (alt-pat a))) alts)
+    alts))
+
+
+(define (match-pattern-list exps list-of-pats alts)
+  (let ((block-name  (gensym "PMATCH")))
+    (**case-block
+      block-name
+      (map (lambda (a p) (match-pattern exps p a block-name))
+          alts
+          list-of-pats))))
+
+
+;;; Produce an exp that matches the given alt against the exps.
+;;; If the match succeeds, it will return-from the given block-name.
+
+(define (match-pattern exps pats alt block-name)
+  (if (null pats)
+      ;; No more patterns to match.
+      ;; Return an exp that handles the guards and where-decls.
+      (cfn-ast-1
+        (rewrite-guards-and-where-decls
+         (alt-where-decls alt) (alt-rhs-list alt) block-name))
+      ;; Otherwise dispatch on type of first pattern.
+      (let ((pat  (pop pats))
+           (exp  (pop exps)))
+       (funcall
+         (typecase pat
+           (wildcard-pat (function match-wildcard-pat))
+           (var-pat      (function match-var-pat))
+           (pcon         (function match-pcon))
+           (as-pat       (function match-as-pat))
+           (irr-pat      (function match-irr-pat))
+           (const-pat    (function match-const-pat))
+           (plus-pat     (function match-plus-pat))
+           (list-pat     (function match-list-pat))
+           (else         (error "Unrecognized pattern ~s." pat)))
+         pat
+         exp
+         pats
+         exps
+         alt
+         block-name))))
+
+
+
+
+;;; Wildcard patterns add no pattern matching test.
+;;; Just recurse on the next pattern to be matched.
+
+(define (match-wildcard-pat pat exp pats exps alt block-name)
+  (declare (ignore pat exp))
+  (match-pattern exps pats alt block-name))
+
+
+;;; A variable pattern likewise does not add any test.  However,
+;;; a binding of the variable to the corresponding exp must be added.
+
+(define (match-var-pat pat exp pats exps alt block-name)
+  (push (**valdef/pat pat exp)
+       (alt-where-decls alt))
+  (match-pattern exps pats alt block-name))
+
+
+;;; Pcons are the hairy case because they may have subpatterns that need
+;;; to be matched.
+;;; If there are subpats and the exp is not a var-ref, make a let binding.
+;;; If the con is a tuple type, there is no need to generate a test
+;;; since the test would always succeed anyway.
+;;; Do not generate let bindings here for subexpressions; do this lazily
+;;; if and when necessary.
+
+(define (match-pcon pat exp pats exps alt block-name)
+  (let* ((var?    (is-type? 'var-ref exp))
+        (var     (if var?
+                     (var-ref-var exp)
+                     (create-temp-var 'conexp)))
+        (con     (pcon-con pat))
+        (arity   (con-arity con))
+        (alg     (con-alg con))
+        (tuple?  (algdata-tuple? alg))
+        (subpats (pcon-pats pat))
+        (subexps '()))
+    (dotimes (i arity)
+      (push (**sel con (**var/def var) i) subexps))
+    (setf exps (nconc (nreverse subexps) exps))
+    (setf pats (append subpats pats))
+    (let ((tail  (match-pattern exps pats alt block-name)))
+      (when (not tuple?)
+       (setf tail
+             (**and-exp (**is-constructor (**var/def var) con) tail)))
+      (when (not var?)
+       (setf tail
+             (**let (list (**valdef/def var (cfn-ast-1 exp))) tail)))
+      tail)))
+
+
+;;; For as-pat, add a variable binding.
+;;; If the expression being matched is not already a variable reference,
+;;; take this opportunity to make the let binding.  Otherwise push the
+;;; let-binding onto the where-decls.
+
+(define (match-as-pat pat exp pats exps alt block-name)
+  (let ((var    (var-ref-var (as-pat-var pat)))
+       (subpat (as-pat-pattern pat)))
+    (if (is-type? 'var-ref exp)
+       (begin
+         (push (**valdef/def var (**var/def (var-ref-var exp)))
+               (alt-where-decls alt))
+         (match-pattern
+           (cons exp exps)
+           (cons subpat pats)
+           alt
+           block-name))
+       (**let (list (**valdef/def var (cfn-ast-1 exp)))
+              (match-pattern
+                (cons (**var/def var) exps)
+                (cons subpat pats)
+                alt
+                block-name)))))
+
+
+;;; An irrefutable pattern adds no test to the pattern matching,
+;;; but adds a pattern binding to the where-decls.
+
+(define (match-irr-pat pat exp pats exps alt block-name)
+  (let ((subpat  (irr-pat-pattern pat)))
+    (push (**valdef/pat subpat exp) (alt-where-decls alt))
+    (match-pattern exps pats alt block-name)))
+
+
+;;; A const pat has a little piece of code inserted by the typechecker
+;;; to do the test.
+;;; For matches against string constants, generate an inline test to match 
+;;; on each character of the string.
+
+(define (match-const-pat pat exp pats exps alt block-name)
+  (let ((const  (const-pat-value pat)))
+    (**and-exp 
+      (if (is-type? 'string-const const)
+         (let ((string  (string-const-value const)))
+           (if (string=? string "")
+               (**is-constructor exp (core-symbol "Nil"))
+               (**app (**var/def (core-symbol "primStringEq")) const exp)))
+         (cfn-ast-1 (**app (const-pat-match-fn pat) exp)))
+      (match-pattern exps pats alt block-name))
+    ))
+
+
+;;; Plus pats have both a magic test and a piece of code to
+;;; make a binding in the where-decls.  Make a variable binding
+;;; for the exp if it's not already a variable.
+
+(define (match-plus-pat pat exp pats exps alt block-name)
+  (let* ((var?  (is-type? 'var-ref exp))
+        (var   (if var? (var-ref-var exp) (create-temp-var 'plusexp))))
+    (push (**valdef/pat (plus-pat-pattern pat)
+                       (**app (plus-pat-bind-fn pat) (**var/def var)))
+         (alt-where-decls alt))
+    (let ((tail  (match-pattern exps pats alt block-name)))
+      (setf tail
+           (**and-exp
+             (cfn-ast-1 (**app (plus-pat-match-fn pat) (**var/def var)))
+             tail))
+      (if var?
+         tail
+         (**let (list (**valdef/def var exp)) tail)))))
+
+
+;;; Rewrite list pats as pcons, then process recursively.
+
+(define (match-list-pat pat exp pats exps alt block-name)
+  (let ((newpat  (rewrite-list-pat (list-pat-pats pat))))
+    (match-pattern
+      (cons exp exps)
+      (cons newpat pats)
+      alt
+      block-name)))
+
+(define (rewrite-list-pat subpats)
+  (if (null? subpats)
+      (**pcon/def (core-symbol "Nil") '())
+      (**pcon/def (core-symbol ":")
+                 (list (car subpats)
+                       (rewrite-list-pat (cdr subpats))))))
+
+
+
+
+;;;=====================================================================
+;;; Pattern definitions
+;;;=====================================================================
+
+
+(define (do-cfn-pattern-def-top object)
+  (typecase (valdef-lhs object)
+    (var-pat
+      ;; If the pattern definition is a simple variable assignment, it
+      ;; may have dictionary parameters that need to be messed with.
+      ;; Complicated pattern bindings can't be overloaded in this way.
+      (list (add-dict-params object (do-cfn-pattern-def-simple object))))
+    (irr-pat
+      ;; Irrefutable patterns are redundant here.
+      (setf (valdef-lhs object) (irr-pat-pattern (valdef-lhs object)))
+      (do-cfn-pattern-def-top object))
+    (wildcard-pat
+     ;; Wildcards are no-ops.
+     '())
+    (pcon
+     ;; Special-case because it's frequent and general case creates
+     ;; such lousy code
+     (do-cfn-pattern-def-pcon object))
+    (else
+      (do-cfn-pattern-def-general object))))
+
+
+;;; Do a "simple" pattern definition, e.g. one that already has a
+;;; var-pat on the lhs.
+
+(define (do-cfn-pattern-def-simple object)
+  (let* ((pat  (valdef-lhs object))
+        (sfd  (car (valdef-definitions object)))
+        (exp  (rewrite-guards-and-where-decls
+                (single-fun-def-where-decls sfd)
+                (single-fun-def-rhs-list sfd)
+                '#f)))
+  (**valdef/pat pat (cfn-ast-1 exp))))
+
+
+;;; Destructure a pcon.
+;;; Note that the simplified expansion is only valid if none of
+;;; the subpatterns introduce tests.  Otherwise we must defer to
+;;; the general case.
+
+(define (do-cfn-pattern-def-pcon object)
+  (let* ((pat     (valdef-lhs object))
+        (subpats (pcon-pats pat)))
+    (if (every (function irrefutable-pat?) subpats)
+       (let* ((con     (pcon-con pat))
+              (arity   (con-arity con))
+              (alg     (con-alg con))
+              (tuple?  (algdata-tuple? alg))
+              (temp    (create-temp-var 'pbind))
+              (result  '()))
+         (dotimes (i arity)
+           (setf result
+                 (nconc result
+                        (do-cfn-pattern-def-top 
+                          (**valdef/pat (pop subpats)
+                                        (**sel con (**var/def temp) i))))))
+         (if (null? result)
+             '()
+             (let* ((sfd   (car (valdef-definitions object)))
+                    (exp   (cfn-ast-1
+                             (rewrite-guards-and-where-decls
+                               (single-fun-def-where-decls sfd)
+                               (single-fun-def-rhs-list sfd)
+                               '#f))))
+               (when (not tuple?)
+                 (let ((temp1  (create-temp-var 'cfn)))
+                   (setf exp
+                         (**let (list (**valdef/def temp1 exp))
+                                (**if (**is-constructor (**var/def temp1) con)
+                                      (**var/def temp1)
+                                      (make-failure-exp))))))
+               (cons (**valdef/def temp exp) result))))
+       (do-cfn-pattern-def-general object))))
+
+
+
+;;; Turn a complicated pattern definition into a list of simple ones.
+;;; The idea is to use case to match the pattern and build a tuple of
+;;; all the values which are being destructured into the pattern
+;;; variables.
+
+(define (do-cfn-pattern-def-general object)
+  (multiple-value-bind (new-pat vars new-vars)
+      (copy-pattern-variables (valdef-lhs object))
+    (if (not (null? vars))
+       (let* ((sfd      (car (valdef-definitions object)))
+              (exp      (rewrite-guards-and-where-decls
+                          (single-fun-def-where-decls sfd)
+                          (single-fun-def-rhs-list sfd)
+                          '#f))
+              (arity    (length vars)))
+         (if (eqv? arity 1)
+             (list (**valdef/def
+                     (var-ref-var (car vars))
+                     (do-cfn-case
+                       exp
+                       (list (**alt/simple new-pat (car new-vars))))))
+             (let ((temp     (create-temp-var 'pbind))
+                   (bindings '()))
+               (dotimes (i arity)
+                 (push (**valdef/def (var-ref-var (pop vars))
+                                     (**tuple-sel arity i (**var/def temp)))
+                       bindings))
+               (cons (**valdef/def
+                       temp
+                       (do-cfn-case
+                         exp
+                         (list (**alt/simple new-pat (**tuple/l new-vars)))))
+                     bindings))))
+       '())))
+
+
+
+;;; Helper function for above.
+;;; All the variables in the pattern must be replaced with temporary
+;;; variables.  
+
+(define (copy-pattern-variables pat)
+  (typecase pat
+    (wildcard-pat
+      (values pat '() '()))
+    (var-pat
+      (let ((new  (create-temp-var (var-ref-name (var-pat-var pat)))))
+       (values (**var-pat/def new)
+               (list (var-pat-var pat))
+               (list (**var/def new)))))
+    (pcon
+      (multiple-value-bind (new-pats vars new-vars)
+         (copy-pattern-variables-list (pcon-pats pat))
+       (values (**pcon/def (pcon-con pat) new-pats)
+               vars
+               new-vars)))
+    (as-pat
+      (let ((new  (create-temp-var (var-ref-name (as-pat-var pat)))))
+       (multiple-value-bind (new-pat vars new-vars)
+           (copy-pattern-variables (as-pat-pattern pat))
+         (values
+           (make as-pat
+                 (var (**var/def new))
+                 (pattern new-pat))
+           (cons (as-pat-var pat) vars)
+           (cons (**var/def new) new-vars)))))
+    (irr-pat
+      (multiple-value-bind (new-pat vars new-vars)
+         (copy-pattern-variables (irr-pat-pattern pat))
+       (values
+         (make irr-pat (pattern new-pat))
+         vars
+         new-vars)))
+    (const-pat
+      (values pat '() '()))
+    (plus-pat
+      (multiple-value-bind (new-pat vars new-vars)
+         (copy-pattern-variables (plus-pat-pattern pat))
+       (values
+         (make plus-pat
+               (pattern new-pat)
+               (k (plus-pat-k pat))
+               (match-fn (plus-pat-match-fn pat))
+               (bind-fn (plus-pat-bind-fn pat)))
+         vars
+         new-vars)))
+    (list-pat
+      (multiple-value-bind (new-pats vars new-vars)
+         (copy-pattern-variables-list (list-pat-pats pat))
+       (values (make list-pat (pats new-pats))
+               vars
+               new-vars)))
+    (else
+      (error "Unrecognized pattern ~s." pat))))
+
+(define (copy-pattern-variables-list pats)
+  (let ((new-pats  '())
+       (vars      '())
+       (new-vars  '()))
+    (dolist (p pats)
+      (multiple-value-bind (p v n) (copy-pattern-variables p)
+       (push p new-pats)
+       (setf vars (nconc vars v))
+       (setf new-vars (nconc new-vars n))))
+    (values (nreverse new-pats)
+           vars
+           new-vars)))
+
+
+
+;;;=====================================================================
+;;; Helper functions for processing guards and where-decls
+;;;=====================================================================
+
+;;; Process guards and where-decls into a single expression.
+;;; If block-name is non-nil, wrap the exp with a return-from.
+;;; If block-name is nil, add a failure exp if necessary.
+;;; Note that this does NOT do the CFN traversal on the result or
+;;; any part of it.
+
+(define (rewrite-guards-and-where-decls where-decls rhs-list block-name)
+  (if (null? where-decls)
+      (rewrite-guards rhs-list block-name)
+      (**let where-decls
+            (rewrite-guards rhs-list block-name))))
+
+(define (rewrite-guards rhs-list block-name)
+  (if (null? rhs-list)
+      (if block-name
+         (**con/def (core-symbol "False"))
+         (make-failure-exp))
+      (let* ((rhs     (car rhs-list))
+            (guard   (guarded-rhs-guard rhs))
+            (exp     (guarded-rhs-rhs rhs)))
+       (when block-name
+         (setf exp (**return-from block-name exp)))
+       (cond ((is-type? 'omitted-guard (guarded-rhs-guard (car rhs-list)))
+              exp)
+             ((and block-name (null? (cdr rhs-list)))
+              (**and-exp guard exp))
+             (else
+              (**if guard
+                    exp
+                    (rewrite-guards (cdr rhs-list) block-name)))
+             ))))
+
+
+(define (make-failure-exp)
+  (let ((c  (dynamic *context*)))
+    (**abort
+      (if (not c)
+         "Pattern match failed."
+         (let* ((stuff  (ast-node-line-number c))
+                (line   (source-pointer-line stuff))
+                (file   (source-pointer-file stuff)))
+           (if (and (is-type? 'valdef c)
+                    (is-type? 'var-pat (valdef-lhs c)))
+               (format
+                 '#f
+                 "Pattern match failed in function ~a at line ~s in file ~a."
+                 (valdef-lhs c) line file)
+               (format
+                 '#f
+                 "Pattern match failed at line ~s in file ~a."
+                 line file)))))))
+
+
+
+
diff --git a/cl-support/PORTING b/cl-support/PORTING
new file mode 100644 (file)
index 0000000..2114be5
--- /dev/null
@@ -0,0 +1,105 @@
+Here are the steps involved in porting to a new Common Lisp implementation.
+
+(0) Find the executable you want to use.  If possible, use an image
+    that doesn't have stuff like CLX, CLOS, a snazzy editor, and the
+    like loaded, since we don't use any of that stuff.
+
+    Put an environment variable in the haskell-development script to point 
+    to the lisp you want to run.
+
+(1) You must add appropriate conditionalizations to cl-init.lisp and 
+    cl-definitions.lisp in this directory.  Look for places where there
+    are #+ things for the other dialects.
+
+    As a matter of style, try to make an explicit case for each Lisp
+    instead of using #- to test for it *not* being a particular dialect.
+    This will prevent confusion on future ports.
+
+    You may also need/want to add conditionals to the primitive 
+    implementation files in the runtime directory.
+
+    Do not add #+/#- conditionalizations to any other random .scm
+    files, since we want to keep this implementation-dependent stuff 
+    centralized.
+
+(2) Make subdirectories to hold compiled files in each of the source
+    directories.  The name of the subdirectory must match the constant
+    lisp-implementation-name in cl-definitions.lisp.
+
+(3) Try compiling the Haskell system (by loading cl-init.lisp) and
+    fix any compilation warnings that happen.  (Hopefully there won't
+    be any.)
+
+    You probably want to build a system initially with the default
+    compiler settings and verbose compiler diagnostics.  This will make 
+    any problems that show up later easier to debug.  Also, it is
+    helpful to capture all the messages in a dribble file to make it
+    easier to verify that everything went OK.
+
+(4) Try compiling the prelude using (compile/prelude *prelude-unit*).
+    You need to create a subdirectory in the progs/prelude directory
+    to hold the output files, and define $PRELUDEBIN to point at
+    this directory (see the haskell-setup script).
+
+    The important thing at this point is that the prelude makes it all 
+    the way through the codegen phase and produces Lisp code.  Don't worry
+    too much now if the Lisp compiler has trouble digesting the output.
+
+    Once you get to this stage, it's time to start messing with
+    compiler optimize proclamations.  We generally use (speed 3) and
+    (safety 0).  Also, you should figure out how to suppress any
+    compiler messages (e.g., set *compile-print* and *compile-verbose*
+    to false).  We usually leave *compile-verbose* on during compilation
+    of the Haskell compiler, but turn it off later so that people don't
+    get messages from the Lisp compiler when running Haskell programs.
+
+(5) Make a subdirectory in the com directory and make the following set 
+    of scripts there:
+
+    clean -- remove all binary files.  Also change the main com/clean
+      script to invoke this.
+    compile -- recompile everything with the right compiler flags (see 
+      step 5).
+    build-prelude -- run the prelude through the haskell compiler.
+      This should save the old compiled prelude files as old-prelude.*
+      case something goes wrong.
+    savesys -- load the compiled prelude and save a core file.
+      This should also be careful not to overwrite an existing file.
+
+    Look at the scripts that have already been written for other Lisps
+    for hints.
+
+    At some point you also need to put a README file in this directory.
+
+
+(6) Now it's time to get serious about getting the prelude to compile.
+    Use the clean, compile, and build-prelude scripts you just wrote.
+
+    Some compilers have a hard time dealing with the large pieces of
+    Lisp code produced for the prelude.  You will probably need to do 
+    something to make the heap bigger.  (And, make sure the machine
+    you are using to do the build on has plenty of swap space.)  You 
+    may also need to tweak the chunk-size parameters to force the 
+    output to be split up into smaller pieces.
+
+    It's OK to leave the prelude interface file as a source file, or
+    to compile it with low speed optimizations.  On the other hand,
+    the prelude code file ought to be processed with as many speed
+    optimizations as possible.
+
+(7) Build a new executable using the "savesys" script and take it for
+    a test drive.
+
+(8) You must also hack the emacs interface file, emacs-tools/haskell.el,
+    to recognize when it's gotten into the debugger or break loop.
+    To test your new executable with the emacs stuff, you must
+    define the environment variable HASKELLPROG to point at it, or
+    set the emacs variable haskell-program-name.
+
+(9) If you want to use the Haskell->CLX interface, you'll have to
+    mess with equivalents of the build-xlib and savesys-xlib scripts.
+    There is some system-dependent code in xlibclx.scm to set up an
+    error handler -- make sure you have conditionalized this appropriately
+    for your Lisp system.
+
+
diff --git a/cl-support/README b/cl-support/README
new file mode 100644 (file)
index 0000000..5553e4a
--- /dev/null
@@ -0,0 +1,3 @@
+This directory contains Common-Lisp-syntax files to set up a more
+Scheme-like environment.  Load cl-init.lisp and it will suck in all
+the rest.
diff --git a/cl-support/cl-definitions.lisp b/cl-support/cl-definitions.lisp
new file mode 100644 (file)
index 0000000..8727679
--- /dev/null
@@ -0,0 +1,1351 @@
+;;; cl-definitions.lisp -- mumble compatibility package for Common Lisp
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  11 Oct 1991
+;;;
+;;; You must load cl-setup and cl-support before trying to compile this 
+;;; file.
+
+(in-package "MUMBLE-IMPLEMENTATION")
+
+
+;;;=====================================================================
+;;; Syntax
+;;;=====================================================================
+
+(define-mumble-import quote)
+(define-mumble-import function)
+
+;;; Lambda lists have to have dot syntax converted to &rest.
+
+(define-mumble-macro mumble::lambda (lambda-list &rest body)
+  `(function (lambda ,(mung-lambda-list lambda-list) ,@body)))
+
+(defun mung-lambda-list (lambda-list)
+  (cond ((consp lambda-list)
+        (let ((last  (last lambda-list)))
+          (if (null (cdr last))
+              lambda-list
+              `(,@(ldiff lambda-list last) ,(car last) &rest ,(cdr last)))))
+       ((null lambda-list)
+        '())
+       (t
+        `(&rest ,lambda-list))))
+
+
+;;; We only funcall and apply things that are real functions.
+
+
+;;; Gag.  Lucid needs to see the procedure declaration to avoid putting
+;;; a coerce-to-procedure check in, but there's a compiler bug that causes
+;;; it to barf if the function is a lambda form.
+
+#+lucid
+(define-mumble-macro mumble::funcall (fn . args)
+  (if (and (consp fn) (eq (car fn) 'mumble::lambda))
+      `(funcall ,fn ,@args)
+      `(funcall (the system::procedure ,fn) ,@args)))
+
+#+(or cmu allegro akcl lispworks mcl)
+(define-mumble-macro mumble::funcall (fn . args)
+  `(funcall (the function ,fn) ,@args))
+
+#+wcl
+(define-mumble-macro mumble::funcall (fn . args)
+  `(funcall (the lisp:procedure ,fn) ,@args))
+
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::funcall)
+
+
+;;; Could make this declare its fn argument too
+
+(define-mumble-import apply)
+
+(define-mumble-synonym mumble::map mapcar)
+(define-mumble-synonym mumble::for-each mapc)
+(define-mumble-import some)
+(define-mumble-import every)
+(define-mumble-import notany)
+(define-mumble-import notevery)
+(define-mumble-synonym mumble::procedure? functionp)
+
+
+(define-mumble-import if)
+(define-mumble-import when)
+(define-mumble-import unless)
+
+
+;;; COND and CASE differ from Common Lisp because of using "else" instead 
+;;; of "t" as the fall-through case.
+
+(define-mumble-import mumble::else)
+
+(define-mumble-macro mumble::cond (&rest cases)
+  (let ((last    (car (last cases))))
+    (if (eq (car last) 'mumble::else)
+       `(cond ,@(butlast cases) (t ,@(cdr last)))
+       `(cond ,@cases))))
+
+(define-mumble-macro mumble::case (data &rest cases)
+  (let ((last  (car (last cases))))
+    (if (eq (car last) 'mumble::else)
+       `(case ,data ,@(butlast cases) (t ,@(cdr last)))
+       `(case ,data ,@cases))))
+
+
+(define-mumble-import and)
+(define-mumble-import or)
+(define-mumble-import not)
+
+(define-mumble-macro mumble::set! (variable value)
+  `(setq ,variable ,value))
+(define-mumble-import setf)
+
+
+;;; AKCL's SETF brokenly tries to macroexpand the place
+;;; form before looking for a define-setf-method.  Redefine the
+;;; internal function to do the right thing.
+
+#+akcl
+(defun system::setf-expand-1 (place newvalue env)
+  (multiple-value-bind (vars vals stores store-form access-form)
+      (get-setf-method place env)
+    (declare (ignore access-form))
+    `(let* ,(mapcar #'list
+                    (append vars stores)
+                    (append vals (list newvalue)))
+       ,store-form)))
+
+
+;;; Allegro has renamed this stuff as per ANSI CL.
+
+#+allegro
+(eval-when (eval compile load)
+  (setf (macro-function 'define-setf-method)
+       (macro-function 'define-setf-expander))
+  (setf (symbol-function 'get-setf-method)
+       (symbol-function 'get-setf-expansion))
+  )
+
+(define-mumble-import let)
+(define-mumble-import let*)
+
+(define-mumble-macro mumble::letrec (bindings &rest body)
+  `(let ,(mapcar #'car bindings)
+     ,@(mapcar #'(lambda (b) (cons 'setq b)) bindings)
+     (locally ,@body)))
+
+(define-mumble-import flet)
+(define-mumble-import labels)
+
+(define-mumble-macro mumble::dynamic-let (bindings &rest body)
+  `(let ,bindings
+     (declare (special ,@(mapcar #'car bindings)))
+     ,@body))
+
+(define-mumble-macro mumble::dynamic (name)
+  `(locally (declare (special ,name)) ,name))
+
+(define-setf-method mumble::dynamic (name)
+  (let ((store  (gensym)))
+    (values nil
+           nil
+           (list store)
+           `(locally (declare (special ,name)) (setf ,name ,store))
+           `(locally (declare (special ,name)) ,name))))
+
+
+(define-mumble-macro mumble::begin (&rest body)
+  `(progn ,@body))
+
+(define-mumble-import block)
+(define-mumble-import return-from)
+
+(define-mumble-import do)
+(define-mumble-import dolist)
+(define-mumble-import dotimes)
+
+(define-mumble-import values)
+(define-mumble-import multiple-value-bind)
+
+(define-mumble-macro mumble::let/cc (variable &rest body)
+  (let ((tagvar  (gensym)))
+    `(let* ((,tagvar   (gensym))
+           (,variable (let/cc-aux ,tagvar)))
+       (catch ,tagvar (locally ,@body)))))
+
+(defun let/cc-aux (tag)
+  #'(lambda (&rest values)
+      (throw tag (values-list values))))
+
+
+(define-mumble-import unwind-protect)
+
+(define-mumble-import declare)
+(define-mumble-import ignore)
+
+
+;;; IGNORABLE is part of ANSI CL but not implemented by Lucid yet.
+;;; IGNORE in Lucid seems to behave like what ANSI CL says IGNORABLE 
+;;; should do, but there doesn't seem to be any way to rename it.
+
+#+(or lucid akcl lispworks wcl)
+(progn
+  (proclaim '(declaration mumble::ignorable))
+  (define-mumble-import mumble::ignorable))
+
+#+(or cmu mcl allegro)
+(define-mumble-import cl:ignorable)
+
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::ignorable)
+
+
+(define-mumble-import type)
+
+
+
+;;;=====================================================================
+;;; Definitions
+;;;=====================================================================
+
+
+;;; *** This shouldn't really do a DEFPARAMETER, since that proclaims
+;;; *** the variable SPECIAL and makes any LETs of the variable do
+;;; *** special binding rather than lexical binding.  But if you just
+;;; *** SETF the variable, you'll get a compiler warning about an
+;;; *** undeclared free variable on every reference!!!  Argggh.
+
+(define-mumble-macro mumble::define (pattern &rest value)
+  (if (consp pattern)
+      `(defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value)
+      `(defparameter ,pattern ,(car value))))
+
+(define-mumble-macro mumble::define-integrable (pattern &rest value)
+  (if (consp pattern)
+      `(progn
+        (eval-when (eval compile load)
+          (proclaim '(inline ,(car pattern))))
+        (defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value))
+      `(defconstant ,pattern ,(car value))))
+
+
+(define-mumble-macro mumble::define-syntax (pattern . body)
+  `(defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body))
+
+(define-mumble-macro mumble::define-local-syntax (pattern . body)
+  `(eval-when (eval compile)
+     (defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body)))
+
+
+(define-mumble-macro mumble::define-setf (getter setter)
+  `(define-setf-method ,getter (&rest subforms)
+     (define-setf-aux ',setter ',getter subforms)))
+
+(defun define-setf-aux (setter getter subforms)
+  (let ((temps    nil)
+       (tempvals nil)
+       (args     nil)
+       (store  (gensym)))
+    (dolist (x subforms)
+      (if (constantp x)
+         (push x args)
+         (let ((temp  (gensym)))
+           (push temp temps)
+           (push x tempvals)
+           (push temp args))))
+    (setq temps (nreverse temps))
+    (setq tempvals (nreverse tempvals))
+    (setq args (nreverse args))
+    (values temps
+           tempvals
+           (list store)
+           `(,setter ,store ,@args)
+           `(,getter ,@args))))
+
+
+;;; Declaring variables special will make the compiler not proclaim
+;;; about references to them.
+;;; A proclamation works to disable undefined function warnings in 
+;;; most Lisps.  Harlequin seems to offer no way to shut up these warnings.
+;;; In allegro, we have to work around a bug in the compiler's handling
+;;; of PROCLAIM.
+
+(define-mumble-macro mumble::predefine (pattern)
+  `(eval-when (eval compile)
+     #+allegro (let ((excl::*compiler-environment* nil))
+                (do-predefine ',pattern))
+     #-allegro (do-predefine ',pattern)
+     ))
+
+(eval-when (eval compile load)
+  (defun do-predefine (pattern)
+    (if (consp pattern)
+        (proclaim `(ftype (function ,(mung-decl-lambda-list (cdr pattern)) t)
+                         ,(car pattern)))
+       (proclaim `(special ,pattern))))
+  (defun mung-decl-lambda-list (lambda-list)
+    (cond ((consp lambda-list)
+          (cons 't (mung-decl-lambda-list (cdr lambda-list))))
+         ((null lambda-list)
+          '())
+         (t
+          '(&rest t))))
+  )
+
+
+;;; CMUCL doesn't complain about function redefinitions, but Lucid does.
+
+#+(or cmu akcl mcl lispworks wcl)
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(mumble::define ,pattern ,@value))
+
+#+lucid
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(let ((lcl:*redefinition-action*  nil))
+     (mumble::define ,pattern ,@value)))
+
+#+allegro
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(let ((excl:*redefinition-warnings*  nil))
+     (mumble::define ,pattern ,@value)))
+
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::redefine)
+
+
+#+(or cmu akcl mcl lispworks wcl)
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(mumble::define-syntax ,pattern ,@body))
+
+#+lucid
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(eval-when (eval compile load)
+     (let ((lcl:*redefinition-action*  nil))
+       (mumble::define-syntax ,pattern ,@body))))
+
+#+allegro
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(eval-when (eval compile load)
+     (let ((excl:*redefinition-warnings*  nil))
+       (mumble::define-syntax ,pattern ,@body))))
+  
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::redefine-syntax)
+
+
+
+;;;=====================================================================
+;;; Equivalence
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::eq? (x y)
+  (eq x y))
+(define-mumble-function-inline mumble::eqv? (x y)
+  (eql x y))
+
+(define-mumble-function mumble::equal? (x1 x2)
+  (cond ((eql x1 x2)
+        t)
+       ((consp x1)
+        (and (consp x2)
+             (mumble::equal? (car x1) (car x2))
+             (mumble::equal? (cdr x1) (cdr x2))))
+       ((simple-string-p x1)
+        (and (simple-string-p x2)
+             (string= x1 x2)))
+       ((simple-vector-p x1)
+        (and (simple-vector-p x2)
+             (eql (length (the simple-vector x1))
+                  (length (the simple-vector x2)))
+             (every #'mumble::equal?
+                    (the simple-vector x1)
+                    (the simple-vector x2))))
+       (t nil)))
+
+
+;;;=====================================================================
+;;; Lists
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::pair? (x)
+  (consp x))
+
+(define-mumble-import cons)
+
+
+;;; Can't import this directly because of type problems.
+
+(define-mumble-synonym mumble::list list)
+
+(define-mumble-function-inline mumble::make-list (length &optional (init nil))
+  (the list
+       (make-list length :initial-element init)))
+
+(define-mumble-import car)
+(define-mumble-import cdr)
+(define-mumble-import caar)
+(define-mumble-import cadr)
+(define-mumble-import cadr)
+(define-mumble-import cddr)
+(define-mumble-import caaar)
+(define-mumble-import caadr)
+(define-mumble-import caadr)
+(define-mumble-import caddr)
+(define-mumble-import cdaar)
+(define-mumble-import cdadr)
+(define-mumble-import cdadr)
+(define-mumble-import cdddr)
+(define-mumble-import caaaar)
+(define-mumble-import caaadr)
+(define-mumble-import caaadr)
+(define-mumble-import caaddr)
+(define-mumble-import cadaar)
+(define-mumble-import cadadr)
+(define-mumble-import cadadr)
+(define-mumble-import cadddr)
+(define-mumble-import cdaaar)
+(define-mumble-import cdaadr)
+(define-mumble-import cdaadr)
+(define-mumble-import cdaddr)
+(define-mumble-import cddaar)
+(define-mumble-import cddadr)
+(define-mumble-import cddadr)
+(define-mumble-import cddddr)
+
+(define-mumble-function-inline mumble::null? (x)
+  (null x))
+
+(define-mumble-function mumble::list? (x)
+  (cond ((null x) t)
+       ((consp x) (mumble::list? (cdr x)))
+       (t nil)))
+
+(define-mumble-function-inline mumble::length (x)
+  (the fixnum (length (the list x))))
+
+(define-mumble-import append)
+(define-mumble-import nconc)
+
+(define-mumble-function-inline mumble::reverse (x)
+  (the list (reverse (the list x))))
+(define-mumble-function-inline mumble::nreverse (x)
+  (the list (nreverse (the list x))))
+
+(define-mumble-function-inline mumble::list-tail (list n)
+  (nthcdr n list))
+(define-mumble-function-inline mumble::list-ref (list n)
+  (nth n list))
+
+(define-mumble-import last)
+(define-mumble-import butlast)
+
+(define-setf-method mumble::list-ref (list n)
+  (get-setf-method `(nth ,n ,list)))
+
+(define-mumble-function-inline mumble::memq (object list)
+  (member object list :test #'eq))
+(define-mumble-function-inline mumble::memv (object list)
+  (member object list))
+(define-mumble-function-inline mumble::member (object list)
+  (member object list :test #'mumble::equal?))
+
+;;; *** The Lucid compiler is not doing anything inline for assq so
+;;; *** I'm rewriting this  -- jcp
+(define-mumble-function mumble::assq (object list)
+  (if (null list)
+      nil
+      (if (eq object (caar list))
+          (car list)
+         (mumble::assq object (cdr list)))))
+       
+(define-mumble-function-inline mumble::assv (object list)
+  (assoc object list))
+(define-mumble-function-inline mumble::assoc (object list)
+  (assoc object list :test #'mumble::equal?))
+
+(define-mumble-import push)
+(define-mumble-import pop)
+
+(define-mumble-synonym mumble::list-copy copy-list)
+
+
+;;;=====================================================================
+;;; Symbols
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::symbol? (x)
+  (symbolp x))
+(define-mumble-synonym mumble::symbol->string symbol-name)
+
+(define-mumble-function-inline mumble::string->symbol (x)
+  (intern x))
+
+
+;;; We want a gensym that follows the new ANSI CL gensym-name-stickiness
+;;; decision.
+
+#+(or lucid akcl wcl)
+(define-mumble-function mumble::gensym (&optional (prefix "G"))
+  (gensym prefix))
+
+#+(or cmu allegro mcl lispworks)
+(define-mumble-import gensym)
+
+#-(or lucid akcl wcl cmu allegro mcl lispworks)
+(missing-mumble-definition mumble::gensym)
+
+(define-mumble-function mumble::gensym? (x)
+  (and (symbolp x)
+       (not (symbol-package x))))
+
+(defun symbol-append (&rest symbols)
+  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+(define-mumble-import symbol-append)
+
+
+;;;=====================================================================
+;;; Characters
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::char? (x)
+  (characterp x))
+
+(define-mumble-synonym mumble::char=? char=)
+(define-mumble-synonym mumble::char<? char<)
+(define-mumble-synonym mumble::char>? char>)
+(define-mumble-synonym mumble::char>=? char>=)
+(define-mumble-synonym mumble::char<=? char<=)
+
+(define-mumble-synonym mumble::char-ci=? char-equal)
+(define-mumble-synonym mumble::char-ci<? char-lessp)
+(define-mumble-synonym mumble::char-ci>? char-greaterp)
+(define-mumble-synonym mumble::char-ci>=? char-not-lessp)
+(define-mumble-synonym mumble::char-ci<=? char-not-greaterp)
+
+(define-mumble-synonym mumble::char-alphabetic? alpha-char-p)
+(define-mumble-synonym mumble::char-numeric? digit-char-p)
+
+(define-mumble-function mumble::char-whitespace? (c)
+  (member c '(#\space #\tab #\newline #\linefeed #\page #\return)))
+
+(define-mumble-synonym mumble::char-upper-case? upper-case-p)
+(define-mumble-synonym mumble::char-lower-case? lower-case-p)
+
+(define-mumble-synonym mumble::char->integer char-code)
+(define-mumble-synonym mumble::integer->char code-char)
+
+(define-mumble-import char-upcase)
+(define-mumble-import char-downcase)
+(define-mumble-import char-name)
+
+(define-mumble-synonym mumble::char->digit digit-char-p)
+
+
+;;;=====================================================================
+;;; Strings
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::string? (x)
+  (simple-string-p x))
+
+(define-mumble-function-inline mumble::make-string
+      (length &optional (init nil init-p))
+  (the simple-string
+       (if init-p
+          (make-string length :initial-element init)
+          (make-string length))))
+
+(define-mumble-function-inline mumble::string (char &rest more-chars)
+  (the simple-string (coerce (cons char more-chars) 'string)))
+
+(define-mumble-function-inline mumble::string-length (string)
+  (the fixnum (length (the simple-string string))))
+
+(define-mumble-function-inline mumble::string-ref (x n)
+  (the character (schar (the simple-string x) (the fixnum n))))
+
+(define-setf-method mumble::string-ref (string n)
+  (get-setf-method `(schar ,string ,n)))
+
+(define-mumble-synonym mumble::string=? string=)
+(define-mumble-synonym mumble::string<? string<)
+(define-mumble-synonym mumble::string>? string>)
+(define-mumble-synonym mumble::string<=? string<=)
+(define-mumble-synonym mumble::string>=? string>=)
+
+(define-mumble-synonym mumble::string-ci=? string-equal)
+(define-mumble-synonym mumble::string-ci<? string-lessp)
+(define-mumble-synonym mumble::string-ci>? string-greaterp)
+(define-mumble-synonym mumble::string-ci<=? string-not-greaterp)
+(define-mumble-synonym mumble::string-ci>=? string-not-lessp)
+
+(define-mumble-function-inline mumble::substring (string start end)
+  (the simple-string (subseq (the simple-string string) start end)))
+
+(define-mumble-function-inline mumble::string-append
+      (string &rest more-strings)
+  (declare (type simple-string string))
+  (the simple-string (apply #'concatenate 'string string more-strings)))
+
+(define-mumble-function-inline mumble::string->list (string)
+  (the list (coerce (the simple-string string) 'list)))
+
+(define-mumble-function-inline mumble::list->string (list)
+  (the simple-string (coerce (the list list) 'string)))
+
+(define-mumble-function-inline mumble::string-copy (string)
+  (the simple-string (copy-seq (the simple-string string))))
+
+(define-mumble-import string-upcase)
+(define-mumble-import string-downcase)
+
+
+;;;=====================================================================
+;;; Vectors
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::vector? (x)
+  (simple-vector-p x))
+
+(define-mumble-function-inline mumble::make-vector
+      (length &optional (init nil init-p))
+  (declare (type fixnum length))
+  (the simple-vector
+       (if init-p
+          (make-array length :initial-element init)
+          (make-array length))))
+
+
+;;; Can't import directly because types are incompatible.
+
+(define-mumble-synonym mumble::vector vector)
+
+(define-mumble-function-inline mumble::vector-length (vector)
+  (the fixnum (length (the simple-vector vector))))
+
+(define-mumble-function-inline mumble::vector-ref (x n)
+  (svref (the simple-vector x) (the fixnum n)))
+
+(define-setf-method mumble::vector-ref (vector n)
+  (get-setf-method `(svref ,vector ,n)))
+
+(define-mumble-function-inline mumble::vector->list (vector)
+  (the list (coerce (the simple-vector vector) 'list)))
+
+(define-mumble-function-inline mumble::list->vector (list)
+  (the simple-vector (coerce (the list list) 'simple-vector)))
+
+(define-mumble-function-inline mumble::vector-copy (vector)
+  (the simple-vector (copy-seq (the simple-vector vector))))
+
+
+;;;=====================================================================
+;;; Numbers
+;;;=====================================================================
+
+(define-mumble-synonym mumble::number? numberp)
+(define-mumble-synonym mumble::integer? integerp)
+(define-mumble-synonym mumble::rational? rationalp)
+(define-mumble-synonym mumble::float? floatp)
+
+(define-mumble-function-inline mumble::fixnum? (x)
+  (typep x 'fixnum))
+
+(define-mumble-synonym mumble::exact->inexact float)
+
+(define-mumble-import =)
+(define-mumble-import <)
+(define-mumble-import >)
+(define-mumble-import <=)
+(define-mumble-import >=)
+
+(define-mumble-synonym mumble::zero? zerop)
+(define-mumble-function-inline mumble::positive? (x)
+  (> x 0))
+(define-mumble-function-inline mumble::negative? (x)
+  (< x 0))
+
+(define-mumble-import min)
+(define-mumble-import max)
+
+(define-mumble-import