* interp/lisp-backend.boot: New file. Consolidate Common Lisp

	backend module.
	* interp/Makefile.in (OBJS): Include it.
	(lisp-backend.$(FASLEXT)): New rule.

1 files changed, 0 insertions, 563 deletions

diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 355a78ff..9ea6cca1 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -43,7 +43,6 @@ module g_-util where
   pairList: (%List,%List) -> %List
   mkList: %List -> %List
   isSubDomain: (%Mode,%Mode) -> %Form
-  expandToVMForm: %Thing -> %Thing
   usedSymbol?: (%Symbol,%Code) -> %Boolean
   isDefaultPackageName: %Symbol -> %Boolean
 
@@ -121,568 +120,6 @@ mkVMForm(op,args) ==
     arg is ['%not,arg'] => arg'
     ['%not,:args]
 
---%
---% Opcode expansion to VM codes.
---%
-
-
---%
---% Iteration control structures
---%
---% Code generation for an iterator produces a sequence of 
---% length 5, whose components have the following meanings:
---%  0. list of loop-wide variables and their initializers
---%  1. list of body-wide variables and their initializers
---%  2. update code for next iteration
---%  3. predicate guarding loop body execution
---%  4. loop termination predicate
-
-++ Generate code that sequentially visits each component of a list.
-expandIN(x,l,early?) ==
-  g := gensym()           -- rest of the list yet to be visited
-  early? =>               -- give the loop variable a wider scope.
-    [[[g,middleEndExpand l],[x,'NIL]],
-      nil,[['SETQ,g,['CDR,g]]],
-        nil,[['ATOM,g],['PROGN,['SETQ,x,['CAR,g]],'NIL]]]
-  [[[g,middleEndExpand l]],
-    [[x,['CAR,g]]],[['SETQ,g,['CDR,g]]],
-      nil,[['ATOM,g]]]
-
-expandON(x,l) ==
-  [[[x,middleEndExpand l]],nil,[["SETQ",x,["CDR",x]]],nil,[["ATOM",x]]]
-  
-++ Generate code that traverses an interval with lower bound 'lo',
-++ arithmetic progression `step, and possible upper bound `final'.
-expandSTEP(id,lo,step,final)==
-  lo := middleEndExpand lo
-  step := middleEndExpand step
-  final := middleEndExpand final
-  loopvar := [[id,lo]]
-  inc :=
-    atomic? step => step
-    g1 := gensym()
-    loopvar := [:loopvar,[g1,step]]
-    g1
-  final :=
-    atom final => final
-    final is [hi] and atomic? hi => hi
-    g2 := gensym()
-    loopvar := [:loopvar,[g2,:final]]
-    g2
-  ex :=
-     final = nil => nil
-     integer? inc =>
-       pred :=
-	 MINUSP inc => "<"
-	 ">"
-       [[pred,id,final]]
-     [['COND,[['MINUSP,inc],
-	   ["<",id,final]],['T,[">",id,final]]]]
-  suc := [["SETQ",id,["+",id,inc]]]
-  [loopvar,nil,suc,nil,ex]
-
-++ Generate code for iterators that filter out execution state
-++ not satisfying predicate `p'.
-expandSUCHTHAT p == 
-  [nil,nil,nil,[middleEndExpand p],nil]
-
-++ Generate code for iterators that stop loop iteration when the
-++ state fails predicate `p'.
-expandWHILE p == 
-  [nil,nil,nil,nil,[["NOT",middleEndExpand p]]]
-
-expandUNTIL p ==
-  g := gensym()
-  [[[g,false]],nil,[["SETQ",g,middleEndExpand p]],nil,[g]]
-
-expandInit(var,val) ==
-  [[[var,middleEndExpand val]],nil,nil,nil,nil]
-
-expandIterators iters ==
-  -- Exit predicates may reference iterator variables.  In that case,
-  -- the scope the variables must cover the generated loop body.  The
-  -- following is much more coarse approximation than we may want,
-  -- but it will do.  For now.
-  early? := or/[ it.op in '(WHILE UNTIL) for it in iters]
-  [toLisp(it,early?) or leave "failed" for it in iters] where
-     toLisp(it,early?) ==
-       it is ["STEP",var,lo,inc,:hi] => expandSTEP(var,lo,inc,hi)
-       it is ["IN",var,seq] => expandIN(var,seq,early?)
-       it is ["ON",var,seq] => expandON(var,seq)
-       it is ["WHILE",pred] => expandWHILE pred
-       it is [op,pred] and op in '(SUCHTHAT _|) => expandSUCHTHAT pred
-       it is ["UNTIL",pred] => expandUNTIL pred
-       it is ["%init",var,val] => expandInit(var,val)
-       nil
-
-expandLoop ['%loop,:iters,body,ret] ==
-  itersCode := expandIterators iters
-  itersCode = "failed" => systemErrorHere ["expandLoop",iters]
-  body := middleEndExpand body
-  itersCode := "coagulate"/itersCode
-    where
-      coagulate(it1,it2) == [append(it1.k,it2.k) for k in 0..4]
-  [loopInits,bodyInits,cont,filters,exits] := itersCode
-  -- Guard the execution of the body by the filters.
-  if filters ~= nil then
-    body := mkpf([:filters,body],"AND")
-  -- If there is any body-wide initialization, now is the time.
-  if bodyInits ~= nil then
-    body := ["LET",bodyInits,body]
-  exits := ["COND",
-             [mkpf(exits,"OR"),["RETURN",expandToVMForm ret]],
-               [true,body]]
-  body := ["LOOP",exits,:cont]
-  -- Finally, set up loop-wide initializations.
-  loopInits = nil => body
-  ["LET",loopInits,body]
-
-++ Generate code for list comprehension.
-expandCollect ['%collect,:iters,body] ==
-  val := gensym()    -- result of the list comprehension
-  -- Transform the body to build the list as we go.
-  body := ["SETQ",val,["CONS",middleEndExpand body,val]]
-  -- Initialize the variable holding the result; expand as 
-  -- if ordinary loop.  But don't forget we built the result
-  -- in reverse order.
-  expandLoop ['%loop,:iters,["%init",val,nil],body,["NREVERSE",val]]
-
-expandListlit(x is ['%listlit,:args]) ==
-  args := [expandToVMForm arg for arg in args]
-  args = nil => nil
-  args' := [simpleValue? arg or leave 'failed for arg in args]
-     where simpleValue? arg ==
-             integer? arg or string? arg => arg
-             arg is ['QUOTE,form] => form
-             nil
-  args' = 'failed => ['LIST,:args]
-  quoteForm args'
-
-expandReturn(x is ['%return,.,y]) ==
-  $FUNNAME = nil => systemErrorHere ['expandReturn,x]
-  ['RETURN_-FROM,$FUNNAME,expandToVMForm y]
-  
--- Pointer operations
-expandPeq ['%peq,x,y] ==
-  x = '%nil => ['NULL,expandToVMForm y]
-  y = '%nil => ['NULL,expandToVMForm x]
-  ['EQ,expandToVMForm x, expandToVMForm y]
-
-expandBefore? ['%before?,x,y] ==
-  ['GGREATERP,expandToVMForm y,expandToVMForm x]
-
--- Byte operations
-expandBcompl ['%bcompl,x] ==
-  integer? x => 255 - x
-  ['_+,256,['LOGNOT,expandToVMForm x]]
-
--- Character operations
-expandCcst ['%ccst,s] ==
-  -- FIXME: this expander should return forms, instead of character constants
-  not string? s => error "operand is not a string constant"
-  stringToChar s
-
-++ string-to-character conversion.  
-expandS2c ['%s2c, x] ==
-  string? x => expandCcst ['%ccst, x]
-  ['stringToChar, x]
-
--- Integer operations
-expandIneg ['%ineg,x] ==
-  x := expandToVMForm x
-  integer? x => -x
-  ['_-,x]
-
-expandIdivide ['%idivide,x,y] ==
-  ['MULTIPLE_-VALUE_-CALL,['FUNCTION,'CONS],
-    ['TRUNCATE,expandToVMForm x,expandToVMForm y]]
-
-expandIeq ['%ieq,a,b] ==
-  a := expandToVMForm a
-  integer? a and a = 0 => ['ZEROP,expandToVMForm b]
-  b := expandToVMForm b
-  integer? b and b = 0 => ['ZEROP,a]
-  ['EQL,a,b]
-
-expandIlt ['%ilt,x,y] ==
-  integer? x and x = 0 =>
-    integer? y => y > 0
-    ['PLUSP,expandToVMForm y]
-  integer? y and y = 0 =>
-    integer? x => x < 0
-    ['MINUSP,expandToVMForm x]
-  ['_<,expandToVMForm x,expandToVMForm y]
-
-expandIgt ['%igt,x,y] ==
-  expandIlt ['%ilt,y,x]
-
-expandBitand ['%bitand,x,y] ==
-  ['BOOLE,'BOOLE_-AND,expandToVMForm x,expandToVMForm y]
-
-expandBitior ['%bitior,x,y] ==
-  ['BOOLE,'BOOLE_-IOR,expandToVMForm x,expandToVMForm y]
-
-expandBitnot ['%bitnot,x] ==
-  ['LOGNOT,expandToVMForm x]
-
--- Floating point support
-
-expandFbase ['%fbase] ==
-  FLOAT_-RADIX $DoubleFloatMaximum
-
-expandFprec ['%fprec] ==
-  FLOAT_-DIGITS $DoubleFloatMaximum
-
-expandFminval ['%fminval] ==
-  '$DoubleFloatMinimum
-
-expandFmaxval ['%fmaxval] ==
-  '$DoubleFloatMaximum
-
-expandI2f ['%i2f,x] ==
-  x := expandToVMForm x
-  integer? x and (x = 0 or x = 1) => FLOAT(x,$DoubleFloatMaximum)
-  ['FLOAT,x,'$DoubleFloatMaximum]
-
-expandFneg ['%fneg,x] ==
-  ['_-,expandToVMForm x]
-
-expandFeq ['%feq,a,b] ==
-  a is ['%i2f,0] => ['ZEROP,expandToVMForm b]
-  b is ['%i2f,0] => ['ZEROP,expandToVMForm a]
-  ['_=,expandToVMForm a,expandToVMForm b]
-
-expandFlt ['%flt,x,y] ==
-  x is ['%i2f,0] => ['PLUSP,expandToVMForm y]
-  y is ['%i2f,0] => ['MINUSP,expandToVMForm x]
-  ['_<,expandToVMForm x,expandToVMForm y]
-
-expandFgt ['%fgt,x,y] ==
-  expandFlt ['%flt,y,x]
-
-expandFcstpi ['%fcstpi] ==
-  ['COERCE,'PI,quoteForm '%DoubleFloat]
-
--- String operations
-
-++ string equality comparison
-expandStreq ['%streq,x,y] ==
-  expandToVMForm ['%not,['%peq,['STRING_=,x,y],'%nil]]
-
-++ string lexicographic comparison  
-expandStrlt ['%strlt,x,y] ==
-  expandToVMForm ['%not,['%peq,['STRING_<,x,y],'%nil]]
-
-++ deposit a character `z' at slot number `y' in string object `x'.  
-expandStrstc ['%strstc,x,y,z] ==
-  expandToVMForm ['%store,['%schar,x,y],z]
-
--- bit vector operations
-expandBitvecnot ['%bitvecnot,x] ==
-  ['BIT_-NOT,expandToVMForm x]
-
-expandBitvecand ['%bitvecand,x,y] ==
-  ['BIT_-AND,expandToVMForm x,expandToVMForm y]
-
-expandBitvecnand ['%bitvecnand,x,y] ==
-  ['BIT_-NAND,expandToVMForm x,expandToVMForm y]
-
-expandBitvecor ['%bitvecor,x,y] ==
-  ['BIT_-IOR,expandToVMForm x,expandToVMForm y]
-
-expandBitvecnor ['%bitvecnor,x,y] ==
-  ['BIT_-NOR,expandToVMForm x,expandToVMForm y]
-
-expandBitvecxor ['%bitvecxor,x,y] ==
-  ['BIT_-XOR,expandToVMForm x,expandToVMForm y]
-
-expandBitveclength ['%bitveclength,x] ==
-  ['LENGTH,expandToVMForm x]
-
-expandBitveccopy ['%bitveccopy,x] ==
-  ['COPY_-SEQ,expandToVMForm x]
-
-expandBitvecconc ['%bitvecconc,x,y] ==
-  ['CONCATENATE, quoteForm '%BitVector,expandToVMForm x,expandToVMForm y]
-
-expandBitvecref ['%bitvecref,x,y] ==
-  ['SBIT,expandToVMForm x,expandToVMForm y]
-
-expandBitveceq ['%bitveceq,x,y] ==
-  ['EQUAL,expandToVMForm x,expandToVMForm y]
-
-expandMakebitvec ['%makebitvec,x,y] ==
-  ['MAKE_-ARRAY,['LIST,expandToVMForm x],
-     KEYWORD::ELEMENT_-TYPE,quoteForm '%Bit,
-       KEYWORD::INITIAL_-ELEMENT,expandToVMForm y]
-
--- Local variable bindings
-expandBind ['%bind,inits,:body] ==
-  body := expandToVMForm body
-  inits := [[first x,expandToVMForm second x] for x in inits]
-  -- FIXME: we should consider turning LET* into LET or direct inlining.
-  op :=
-    or/[CONTAINED(v,x) for [[v,.],:x] in tails inits] => 'LET_*
-    'LET
-  [op,inits,:body]
-
--- Memory load/store
-
-expandDynval ["%dynval",:args] ==
-  ["SYMBOL-VALUE",:expandToVMForm args]
-
-expandStore ["%store",place,value] ==
-  value := expandToVMForm value
-  place is ['%head,x] => ['RPLACA,expandToVMForm x,value]
-  place is ['%tail,x] => ['RPLACD,expandToVMForm x,value]
-  place := expandToVMForm place
-  cons? place => ["SETF",place,value]
-  ["SETQ",place,value]
-
--- non-local control transfer
-
-$OpenAxiomCatchTag == KEYWORD::OpenAxiomCatchPoint
-
-expandThrow ['%throw,m,x] ==
-  ['THROW,$OpenAxiomCatchTag,
-    ['CONS,$OpenAxiomCatchTag,
-      ['CONS,expandToVMForm m,expandToVMForm x]]]
-
-++ Subroutine of expandTry.  Generate code for domain matching
-++ of object `obj' with domain `dom'.
-domainMatchCode(dom,obj) ==
-  -- FIXME: Instead of domain equality, we should also consider
-  -- FIXME: cases of sub-domains, or domain schemes with constraints.
-  ['domainEqual,dom,['%head,obj]]
-
-expandTry ['%try,expr,handlers,cleanup] ==
-  g := gensym()              -- hold the exception object
-  ys := [[domainMatchCode(mode,['%tail,g]),
-          ['%bind,[[var,['%tail,['%tail,g]]]],stmt]]
-            for [.,var,mode,stmt] in handlers]
-  handlerBody :=
-    ys = nil => g
-    ys := [:ys,['%true,['THROW,$OpenAxiomCatchTag,g]]]
-    ['%when,
-      [['%and,['%pair?,g],
-        ['%peq,['%head,g],$OpenAxiomCatchTag]], ['%when,:ys]],
-          ['%true,g]]
-  tryBlock := expandBind
-    ['%bind,[[g,['CATCH,$OpenAxiomCatchTag,expr]]],handlerBody]
-  cleanup = nil => tryBlock
-  ['UNWIND_-PROTECT,tryBlock,:expandToVMForm rest cleanup]
-  
-++ Opcodes with direct mapping to target operations.
-for x in [
-    -- Boolean constants
-    -- ['%false, :'NIL],
-    ['%true,  :'T],
-    -- unary Boolean operations
-    ['%not,   :'NOT],
-    ['%2bit,  :'TRUTH_-TO_-BIT],
-    ['%2bool, :'BIT_-TO_-TRUTH],
-    -- binary Boolean operations
-    ['%and,   :'AND],
-    ['%or,    :'OR],
-
-    -- character operations
-    ['%ceq,    :'CHAR_=],
-    ['%clt,    :'CHAR_<],
-    ['%cle,    :'CHAR_<_=],
-    ['%cgt,    :'CHAR_>],
-    ['%cge,    :'CHAR_>_=],
-    ['%cup,    :'CHAR_-UPCASE],
-    ['%cdown,  :'CHAR_-DOWNCASE],
-    ['%c2i,    :'CHAR_-CODE],
-    ['%i2c,    :'CODE_-CHAR],
-
-    -- byte operations
-    ['%beq, :'byteEqual],
-    ['%blt, :'byteLessThan],
-
-    -- unary integer operations.
-    ['%iabs,    :'ABS],
-    ['%ieven?,  :'EVENP],
-    ['%integer?,:'INTEGERP],
-    ['%iodd?,   :'ODDP],
-    ['%ismall?, :'FIXNUMP],
-    ['%i2s,   :'WRITE_-TO_-STRING],
-    ['%ilength, :'INTEGER_-LENGTH],
-    ['%ibit,    :'INTEGER_-BIT],
-    -- binary integer operations.
-    ['%iadd,    :"+"],
-    ['%igcd,    :'GCD],
-    ['%ige,     :">="],
-    ['%iinc,    :"1+"],
-    ['%idec,    :"1-"],
-    ['%ilcm,    :'LCM],
-    ['%ile,     :"<="],
-    ['%imax,    :'MAX],
-    ['%imin,    :'MIN],
-    ['%imul,    :"*"],
-    ['%irem,    :'REM],
-    ['%iquo,    :'TRUNCATE],
-    ['%ipow,    :'EXPT],
-    ['%isub,    :"-"],
-
-    -- unary float operations.
-    ['%fabs,  :'ABS],
-    ['%float?,:'FLOATP],
-    ['%ftrunc,:'TRUNCATE],
-    -- binary float operations.
-    ['%fadd,  :"+"],
-    ['%fdiv,  :"/"],
-    ['%fge,   :">="],
-    ['%fle,   :"<="],
-    ['%fmax,  :'MAX],
-    ['%fmin,  :'MIN],
-    ['%fmul,  :"*"],
-    ['%fpow,  :'EXPT],
-    ['%fsub,  :"-"],
-
-    ['%fsin,   :'SIN],
-    ['%fcos,   :'COS],
-    ['%ftan,   :'TAN],
-    ['%fcot,   :'COT],
-    ['%fsec,   :'SEC],
-    ['%fcsc,   :'CSC],
-    ['%fatan,  :'ATAN],
-    ['%facot,  :'ACOT],
-    ['%fsinh,  :'SINH],
-    ['%fcosh,  :'COSH],
-    ['%ftanh,  :'TANH],
-    ['%fcsch,  :'CSCH],
-    ['%fcoth,  :'COTH],
-    ['%fsech,  :'SECH],
-    ['%fasinh, :'ASINH],
-    ['%facsch, :'ACSCH],
-
-    -- string operations
-    ['%f2s,   :'DFLOAT_-FORMAT_-GENERAL],
-
-    -- list contants
-    -- ['%nil, :'NIL],
-    -- unary list operations
-    ['%head,      :'CAR],
-    ['%makepair,  :'CONS],
-    ['%lempty?,   :'NULL],
-    ['%lfirst,    :'CAR],
-    ['%llength,   :'LIST_-LENGTH],
-    ['%lreverse,  :'REVERSE],
-    ['%lreverse_!,:'NREVERSE],
-    ['%lsecond,   :'CADR],
-    ['%lthird,    :'CADDR],
-    ['%pair?,     :'CONSP],
-    ['%tail,      :'CDR],
-    -- binary list operations
-    ['%lconcat,   :'APPEND],
-
-    -- simple vector operations
-    ['%vfill,     :'FILL],
-    ['%vlength,   :'sizeOfSimpleArray],
-    ['%veclit,    :'VECTOR],
-    ['%vref,      :'SVREF],
-    ['%aref,      :'getSimpleArrayEntry],
-    ['%makevector,:'MAKE_-ARRAY],
-
-    -- symbol unary functions
-    ['%gensym,  :'GENSYM],
-    ['%sname,   :'SYMBOL_-NAME],
-    ['%ident?,  :'SYMBOLP],
-
-    -- string functions
-    ['%string?, :'STRINGP],
-    ['%strlength, :'LENGTH],
-    ['%schar,     :'CHAR],
-    ['%strconc,   :'STRCONC],
-    ['%strcopy,   :'COPY_-SEQ],
-
-    -- general utility
-    ['%hash,     :'SXHASH],
-    ['%equal,    :'EQUAL],
-    ['%sptreq,    :'EQL],               -- system pointer equality
-    ['%lam,      :'LAMBDA],
-    ['%leave,    :'RETURN],
-    ['%otherwise,:'T],
-    ['%when,     :'COND]
-  ] repeat property(first x,'%Rename) := rest x
-
-++ Table of opcode-expander pairs.  
-for x in [
-   ['%listlit, :function expandListlit],
-   ['%collect, :function expandCollect],
-   ['%loop,    :function expandLoop],
-   ['%return,  :function expandReturn],
-
-   ['%bcompl,  :function expandBcompl],
-
-   ['%ccst,    :function expandCcst],
-   ['%s2c,     :function expandS2c],
-
-   ['%ieq,     :function expandIeq],
-   ['%igt,     :function expandIgt],
-   ['%ilt,     :function expandIlt],
-   ['%ineg,    :function expandIneg],
-   ['%idivide, :function expandIdivide],
-   ['%bitand,  :function expandBitand],
-   ['%bitior,  :function expandBitior],
-   ['%bitnot,  :function expandBitnot],
-
-   ['%i2f,     :function expandI2f],
-   ['%fbase,   :function expandFbase],
-   ['%feq,     :function expandFeq],
-   ['%fgt,     :function expandFgt],
-   ['%flt,     :function expandFlt],
-   ['%fmaxval, :function expandFmaxval],
-   ['%fminval, :function expandFminval],
-   ['%fneg,    :function expandFneg],
-   ['%fprec,   :function expandFprec],
-   ['%fcstpi,  :function expandFcstpi],
-
-   ['%streq,   :function expandStreq],
-   ['%strlt,   :function expandStrlt],
-   ['%strstc,  :function expandStrstc],
-
-   ['%bitvecnot,    :function expandBitvecnot],
-   ['%bitvecand,    :function expandBitvecand],
-   ['%bitvecnand,   :function expandBitvecnand],
-   ['%bitvecor,     :function expandBitvecor],
-   ['%bitvecxor,    :function expandBitvecxor],
-   ['%bitvecnor,    :function expandBitvecnor],
-   ['%bitveclength, :function expandBitveclength],
-   ['%bitveccopy,   :function expandBitveccopy],
-   ['%bitvecconc,   :function expandBitvecconc],
-   ['%bitveceq,     :function expandBitveceq],
-   ['%bitvecref,   :function expandBitvecref],
-   ['%makebitvec,   :function expandMakebitvec],
-
-   ['%peq,     :function expandPeq],
-   ['%before?, :function expandBefore?],
-
-   ['%bind,   :function expandBind],
-   ['%store,  :function expandStore],
-   ['%dynval, :function expandDynval],
-   ['%throw,  :function expandThrow],
-   ['%try,    :function expandTry]
- ] repeat property(first x,'%Expander) := rest x
-
-++ Return the expander of a middle-end opcode, or nil if there is none.
-getOpcodeExpander op ==
-  op has %Expander
-
-++ Expand all opcodes contained in the form `x' into a form
-++ suitable for evaluation by the VM.
-expandToVMForm x ==
-  x = '%false or x = '%nil => 'NIL
-  IDENTP x and (x' := x has %Rename) => x'
-  atomic? x => x
-  [op,:args] := x
-  IDENTP op and (fun:= getOpcodeExpander op) => apply(fun,x,nil)
-  op' := expandToVMForm op
-  args' := expandToVMForm args
-  EQ(op,op') and EQ(args,args') => x
-  [op',:args']
-  
 ++
 $interpOnly := false