path: root/src/boot/ast.boot

-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2009, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical Algorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

--
-- Abstract:
--   This file defines the AST data structure and helper functions
--   for representing Boot programs.
--

import includer
namespace BOOTTRAN
module ast

++ True means that Boot functions should be translated to use
++ hash tables to remember values.  By default, functions are
++ translated with the obvious semantics, e.g. no caching.
$bfClamming := false

++ List of identifiers defined as constants in the current
++ translation unit.
$constantIdentifiers := nil

++ When non-nil holds the scope nominated  in the most recent
++ namespace definition.
$activeNamespace := nil

--% Basic types used in Boot codes.

%Thing <=> true

%Boolean <=> BOOLEAN

%String <=> STRING

%Symbol <=> SYMBOL

%Short <=> FIXNUM

++ Ideally, we would like to say that a List T if either nil or a 
++ cons of a T and List of T. 
%List <=> LIST

%Vector <=> VECTOR

%Sequence <=> SEQUENCE

++ Currently, the Boot processor uses Lisp symbol datatype for names.
++ That causes the BOOTTRAN package to contain more symbols than we would
++ like.  In the future, we want to intern `on demand'.  How that
++ interacts with renaming is to be worked out.
structure %Name == 
  %Name(%Symbol)

structure %Ast ==
  Command(%String)                      -- includer command
  %Module(%Name,%List)                  -- module declaration
  Import(%String)                       -- import module
  ImportSignature(Name, Signature)      -- import function declaration
  %TypeAlias(%Head, %List)              -- type alias definition
  Signature(Name, Mapping)              -- op: S -> T
  Mapping(Ast, %List)                   -- (S1, S2) -> T
  SuffixDot(Ast)                        -- x . 
  Quote(Ast)                            -- 'x
  EqualName(Name)                       -- =x        -- patterns
  Colon(Name)                           -- :x
  QualifiedName(Name, Name)             -- m::x
  %DefaultValue(%Name,%Ast)             -- opt. value for function param.
  Bracket(Ast)                          -- [x, y]
  UnboundedSegment(Ast)                 -- 3..
  BoundedSgement(Ast, Ast)              -- 2..4
  Tuple(List)                           -- comma-separated expression sequence
  ColonAppend(Ast, Ast)                 -- [:y] or [x, :y]
  Is(Ast, Ast)                          -- e is p    -- patterns
  Isnt(Ast, Ast)                        -- e isnt p  -- patterns
  Reduce(Ast, Ast)                      -- +/[...]
  PrefixExpr(Name, Ast)                 -- #v
  Call(Ast,%Sequence)                   -- f(x, y , z)
  InfixExpr(Name, Ast, Ast)             -- x + y
  ConstantDefinition(Name, Ast)         -- x == y
  Definition(Name, List, Ast, Ast)      -- f x == y
  Macro(Name, List, Ast)                -- m x ==> y
  SuchThat(Ast)                         -- | p
  %Assignment(Ast, Ast)                -- x := y
  While(Ast)                            -- while p           -- iterator
  Until(Ast)                            -- until p           -- iterator
  For(Ast, Ast, Ast)                    -- for x in e by k   -- iterator
  Exit(Ast, Ast)                        -- p => x
  Iterators(List)                       -- list of iterators
  Cross(List)                           -- iterator cross product
  Repeat(%Sequence,Ast)                 -- while p repeat s
  Pile(%Sequence)                       -- pile of expression sequence
  Append(%Sequence)                     -- concatenate lists
  Case(Ast,%Sequence)                   -- case x of ...
  Return(Ast)                           -- return x
  %Throw(Ast)                           -- throw OutOfRange 3
  %Catch(Ast)                           -- catch OutOfRange
  %Try(Ast,%Sequence)                   -- try x / y catch DivisionByZero
  Where(Ast,%Sequence)                  -- e where f x == y
  Structure(Ast,%Sequence)              -- structure Foo == ...

-- TRUE if we are currently building the syntax tree for an 'is' 
-- expression.
$inDefIS := false


++ returns a `quote' ast for x.
quote x ==
  ["QUOTE",x]

--%

bfGenSymbol: () -> %Symbol 
bfGenSymbol()==
    $GenVarCounter:=$GenVarCounter+1
    INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter))

bfListOf: %List -> %List 
bfListOf x==
  x
 
bfColon: %Thing -> %List
bfColon x== 
  ["COLON",x]

bfColonColon: (%Symbol,%Symbol) -> %Symbol
bfColonColon(package, name) == 
  %hasFeature KEYWORD::CLISP and package in '(EXT FFI) =>
    FIND_-SYMBOL(SYMBOL_-NAME name,package)
  INTERN(SYMBOL_-NAME name, package)

bfSymbol: %Thing -> %Thing 
bfSymbol x==
   STRINGP x=> x
   ['QUOTE,x]

 
bfDot: () -> %Symbol
bfDot() == 
  "DOT"
 
bfSuffixDot: %Thing -> %List
bfSuffixDot x ==
  [x,"DOT"]

bfEqual: %Thing -> %List 
bfEqual(name) == 
  ["EQUAL",name]

bfBracket: %Thing -> %Thing 
bfBracket(part) == 
  part
 
bfPile: %List -> %List
bfPile(part) == 
  part
 
bfAppend: %List -> %List
bfAppend x== 
  APPLY(function APPEND,x)
 
bfColonAppend: (%List,%Thing) -> %List
bfColonAppend(x,y) ==
     if null x
     then
      if y is ["BVQUOTE",:a]
      then ["&REST",["QUOTE",:a]]
      else ["&REST",y]
     else cons(first x,bfColonAppend(rest x,y))

bfDefinition: (%Thing,%Thing,%Thing) -> %List 
bfDefinition(bflhsitems, bfrhs,body) ==
       ['DEF,bflhsitems,bfrhs,body]

bfSimpleDefinition: (%Thing,%Thing) -> %Thing
bfSimpleDefinition(lhs,rhs) ==
  if atom lhs then
    $constantIdentifiers := [lhs,:$constantIdentifiers]
  else if lhs is ["%Signature",id,.] then
    $constantIdentifiers := [id,:$constantIdentifiers]
  ConstantDefinition(lhs,rhs)
 


bfMDefinition: (%Thing,%Thing,%Thing) -> %List 
bfMDefinition(bflhsitems, bfrhs,body) ==
       bfMDef('MDEF,bflhsitems,bfrhs,body)

bfCompDef: %Thing -> %List 
bfCompDef x ==
  case x of
    ConstantDefinition(.,.) => x
    otherwise =>
      x is [def, op, args, body] =>
        bfDef(def,op,args,body)
      coreError '"invalid AST"

bfBeginsDollar: %Thing -> %Boolean 
bfBeginsDollar x ==  
  EQL('"$".0,(PNAME x).0)
 
compFluid id == 
  ["FLUID",id]
 
compFluidize x==
  IDENTP x and bfBeginsDollar x=>compFluid x
  atom x =>x
  EQCAR(x,"QUOTE")=>x
  cons(compFluidize(first x),compFluidize(rest x))
 
bfTuple x== ["TUPLE",:x]
 
bfTupleP x==EQCAR(x,"TUPLE")

++ If `bf' is a tuple return its elements; otherwise `bf'.
bfUntuple bf ==
  bfTupleP bf => cdr bf
  bf
 
bfTupleIf x==
  if bfTupleP x
  then x
  else bfTuple x
 
bfTupleConstruct b ==
  a:= if bfTupleP b
      then cdr b
      else [b]
  or/[x is ["COLON",.] for x in a] => bfMakeCons a
  ["LIST",:a]
 
bfConstruct b ==
  a:= if bfTupleP b
      then cdr b
      else [b]
  bfMakeCons a
 
bfMakeCons l ==
  null l => NIL
  l is [["COLON",a],:l1] =>
    l1 => ['APPEND,a,bfMakeCons l1]
    a
  ['CONS,first l,bfMakeCons rest l]
 
bfFor(bflhs,U,step) ==
     if EQCAR (U,'tails)
     then  bfForTree('ON, bflhs, second U)
     else
       if EQCAR(U,"SEGMENT")
       then  bfSTEP(bflhs,second U,step,third U)
       else  bfForTree('IN, bflhs, U)
 
bfForTree(OP,lhs,whole)==
         whole:=if bfTupleP whole then bfMakeCons cdr whole else whole
         atom lhs =>bfINON [OP,lhs,whole]
         lhs:=if bfTupleP lhs then second lhs else lhs
         EQCAR(lhs,"L%T") =>
             G:=second lhs
             [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,third lhs)]
         G:=bfGenSymbol()
         [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)]
 
 
bfSTEP(id,fst,step,lst)==
      initvar:=[id]
      initval:=[fst]
      inc:=if atom step
           then step
           else
               g1:=bfGenSymbol()
               initvar:=cons(g1,initvar)
               initval:=cons(step,initval)
               g1
      final:=if atom lst
             then lst
             else
               g2:=bfGenSymbol()
               initvar:=cons(g2,initvar)
               initval:=cons(lst,initval)
               g2
      ex:=
          null lst=> []
          INTEGERP inc =>
              pred:=if MINUSP inc then "<" else ">"
              [[pred,id,final]]
          [['COND,[['MINUSP,inc],
                ["<",id,final]],['T,[">",id,final]]]]
      suc:=[['SETQ,id,["+",id,inc]]]
      [[initvar,initval,suc,[],ex,[]]]
 
 
bfINON x==
    [op,id,whole]:=x
    if EQ(op,"ON")
    then bfON(id,whole)
    else bfIN(id,whole)
 
bfIN(x,E)==
    g:=bfGenSymbol()
    [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[],
        [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]]
 
bfON(x,E)==
    [[[x],[E],[['SETQ,x,['CDR, x]]],[],
        [['ATOM,x]],[]]]
 
bfSuchthat p== [[[],[],[],[p],[],[]]]
 
bfWhile p== [[[],[],[],[],[bfNOT p],[]]]
 
bfUntil p==
     g:=bfGenSymbol()
     [[[g],[nil],[['SETQ,g,p]],[],[g],[]]]
 
bfIterators x==["ITERATORS",:x]
 
bfCross x== ["CROSS",:x]
 
bfLp(iters,body)==
     EQCAR (iters,"ITERATORS")=>bfLp1(rest iters,body)
     bfLpCross(rest iters,body)
 
bfLpCross(iters,body)==
     if null cdr iters
     then bfLp(first iters,body)
     else bfLp(first iters,bfLpCross(rest iters,body))
 
bfSep(iters)==
     if null iters
     then [[],[],[],[],[],[]]
     else
         f:=first iters
         r:=bfSep rest iters
         [append(i,j) for i in f for j in r]
 
bfReduce(op,y)==
     a:=if EQCAR(op,"QUOTE") then second op else op
     op:=bfReName a
     init := GET(a,"SHOETHETA") or GET(op,"SHOETHETA")
     g:=bfGenSymbol()
     g1:=bfGenSymbol()
     body:=['SETQ,g,[op,g,g1]]
     if null init
     then
        g2:=bfGenSymbol()
        init:=['CAR,g2]
        ny:=['CDR,g2]
        it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]]
        bfMKPROGN [['L%T,g2,y],bfLp(it,body)]
     else
        init:=car init
        it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]]
        bfLp(it,body)
 
bfReduceCollect(op,y)==
   if EQCAR (y,"COLLECT")
   then
     body:=y.1
     itl:=y.2
     a:=if EQCAR(op,"QUOTE") then second op else op
     op:=bfReName a
     init := GET(a, "SHOETHETA") or GET(op,"SHOETHETA")
     bfOpReduce(op,init,body,itl)
   else
     a:=bfTupleConstruct (y.1)
     bfReduce(op,a)
 
-- delayed collect
 
bfDCollect(y,itl)== ["COLLECT",y,itl]
 
bfDTuple x== ["DTUPLE",x]
 
bfCollect(y,itl) ==
      y is ["COLON",a] => bf0APPEND(a,itl)
      y is ["TUPLE",:.] =>
        newBody:=bfConstruct y
        bf0APPEND(newBody,itl)
      bf0COLLECT(y,itl)
 
bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl)
 
 
bf0APPEND(y,itl)==
     g:=bfGenSymbol()
     body:=['SETQ,g,['APPEND,['REVERSE,y],g]]
     extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
     bfLp2(extrait,itl,body)
 
bfListReduce(op,y,itl)==
     g:=bfGenSymbol()
     body:=['SETQ,g,[op,y,g]]
     extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]]
     bfLp2(extrait,itl,body)
 
bfLp1(iters,body)==
      [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters
      nbody:=if null filters then body else bfAND [:filters,body]
      value:=if null value then "NIL" else first value
      exits:= ["COND",[bfOR exits,["RETURN",value]],
                  ['(QUOTE T),nbody]]
      loop := ["LOOP",exits,:sucs]
      if vars then loop := 
        ["LET",[[v, i] for v in vars for i in inits], loop]
      loop
 
bfLp2(extrait,itl,body)==
     EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,rest itl),body)
     iters:=rest itl
     bfLpCross
          ([["ITERATORS",extrait,:CDAR iters],:rest iters],body)
 
bfOpReduce(op,init,y,itl)==
     g:=bfGenSymbol()
     body:=
         EQ(op,"AND")=>
                bfMKPROGN [["SETQ",g,y],
                    ['COND, [['NOT,g],['RETURN,'NIL]]]]
         EQ(op,"OR") =>
                bfMKPROGN [["SETQ",g,y],
                             ['COND, [g,['RETURN,g]]]]
         ['SETQ,g,[op,g,y]]
     if null init
     then
        g1:=bfGenSymbol()
        init:=['CAR,g1]
        y:=['CDR,g1]          -- ??? bogus self-assignment/initialization
        extrait:= [[[g],[init],[],[],[],[g]]]
        bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)]
     else
        init:=first init
        extrait:= [[[g],[init],[],[],[],[g]]]
        bfLp2(extrait,itl,body)
 
bfLoop1 body == bfLp (bfIterators nil,body)
 
bfSegment1(lo)==     ["SEGMENT",lo,nil]
 
bfSegment2(lo,hi)==   ["SEGMENT",lo,hi]
 
bfForInBy(variable,collection,step)==
         bfFor(variable,collection,step)
 
bfForin(lhs,U)==bfFor(lhs,U,1)
 
bfLocal(a,b)==
         EQ(b,"FLUID")=>  compFluid a
         EQ(b,"fluid")=>  compFluid a
         EQ(b,"local") =>  compFluid a
    --   $typings:=cons(["TYPE",b,a],$typings)
         a
 
bfTake(n,x)==
     null x=>x
     n=0 => nil
     cons(first x,bfTake(n-1,rest x))
 
bfDrop(n,x)==
     null x or n=0 =>x
     bfDrop(n-1,rest x)
 
bfDefSequence l ==  
  ['SEQ,: l]
 
bfReturnNoName a ==
      ["RETURN",a]
 
bfSUBLIS(p,e)==
  atom e=>bfSUBLIS1(p,e)
  EQCAR(e,"QUOTE")=>e
  cons(bfSUBLIS(p,first e),bfSUBLIS(p,rest e))
 
+++ Returns e/p, where e is an atom.  We assume that the
+++ DEFs form a system admitting a fix point; otherwise we may
+++ loop forever.  That can happen only if nullary goats
+++ are recursive -- which they are not supposed to be.
+++ We don't enforce that restriction though.
bfSUBLIS1(p,e)==
   null p =>e
   f:=first p
   EQ(first f,e)=> bfSUBLIS(p, rest f)
   bfSUBLIS1(cdr p,e)
 
defSheepAndGoats(x)==
    EQCAR (x,"DEF") =>
        [def,op,args,body]:=x
        argl:=if bfTupleP args
              then rest args
              else [args]
        if null argl
        then
          opassoc:=[[op,:body]]
          [opassoc,[],[]]
        else
          op1:=INTERN CONCAT(PNAME $op,'",",PNAME op)
          opassoc:=[[op,:op1]]
          defstack:=[["DEF",op1,args,body]]
          [opassoc,defstack,[]]
    EQCAR (x,"SEQ") =>  defSheepAndGoatsList(rest x)
    [[],[],[x]]
 
defSheepAndGoatsList(x)==
     if null x
     then [[],[],[]]
     else
       [opassoc,defs,nondefs]    := defSheepAndGoats first x
       [opassoc1,defs1,nondefs1] := defSheepAndGoatsList rest x
       [append(opassoc,opassoc1),append(defs,defs1),
            append(nondefs,nondefs1)]
--% LET
 
bfLetForm(lhs,rhs) ==   
  ['L%T,lhs,rhs]
 
bfLET1(lhs,rhs) ==
  IDENTP lhs         => bfLetForm(lhs,rhs)
  lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
  IDENTP rhs and not bfCONTAINED(rhs,lhs) =>
    rhs1 := bfLET2(lhs,rhs)
    EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs]
    EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs])
    if IDENTP first rhs1 then rhs1 := CONS(rhs1,NIL)
    bfMKPROGN [:rhs1,rhs]
  CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := second rhs) =>
    -- handle things like [a] := x := foo
    l1 := bfLET1(name,third rhs)
    l2 := bfLET1(lhs,name)
    EQCAR(l2,'PROGN) => bfMKPROGN [l1,:rest l2]
    if IDENTP first l2 then l2 := cons(l2,nil)
    bfMKPROGN [l1,:l2,name]
  g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter)
  $letGenVarCounter := $letGenVarCounter + 1
  rhs1 := ['L%T,g,rhs]
  let1 := bfLET1(lhs,g)
  EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:rest let1]
  if IDENTP first let1 then let1 := CONS(let1,NIL)
  bfMKPROGN [rhs1,:let1,g]
 
bfCONTAINED(x,y)==
    EQ(x,y) => true
    atom y=> false
    bfCONTAINED(x,car y) or bfCONTAINED(x,cdr y)
 
bfLET2(lhs,rhs) ==
  IDENTP lhs => bfLetForm(lhs,rhs)
  NULL lhs   => NIL
  lhs is ['FLUID,.] => bfLetForm(lhs,rhs)
  lhs is ['L%T,a,b] =>
    a := bfLET2(a,rhs)
    null (b := bfLET2(b,rhs)) => a
    atom b => [a,b]
    CONSP first b => CONS(a,b)
    [a,b]
  lhs is ['CONS,var1,var2] =>
    var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) =>
      bfLET2(var2,addCARorCDR('CDR,rhs))
    l1 := bfLET2(var1,addCARorCDR('CAR,rhs))
    null var2 or EQ(var2,"DOT") =>l1
    if CONSP l1 and atom first l1 then l1 := cons(l1,nil)
    IDENTP var2 =>
      [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))]
    l2 := bfLET2(var2,addCARorCDR('CDR,rhs))
    if CONSP l2 and atom first l2 then l2 := cons(l2,nil)
    APPEND(l1,l2)
  lhs is ['APPEND,var1,var2] =>
    patrev := bfISReverse(var2,var1)
    rev := ['REVERSE,rhs]
    g := INTERN CONCAT('"LETTMP#", STRINGIMAGE $letGenVarCounter)
    $letGenVarCounter := $letGenVarCounter + 1
    l2 := bfLET2(patrev,g)
    if CONSP l2 and atom first l2 then l2 := cons(l2,nil)
    var1 = "DOT" => [['L%T,g,rev],:l2]
    last l2 is ['L%T, =var1, val1] =>
      [['L%T,g,rev],:REVERSE rest REVERSE l2,
       bfLetForm(var1,['NREVERSE,val1])]
    [['L%T,g,rev],:l2,bfLetForm(var1,['NREVERSE,var1])]
  lhs is ["EQUAL",var1] =>
    ['COND,[["EQUAL",var1,rhs],var1]]
  -- The original expression may be one that involves literals as 
  -- sub-patterns, e.g.
  --      ['SEQ, :l, ['exit, 1, x]] := item
  -- We continue the processing as if that expression had been written
  --      item is ['SEQ, :l, ['exit, 1, x]]
  -- and generate appropriate codes.
  --                  -- gdr/2007-04-02.
  isPred :=
    $inDefIS => bfIS1(rhs,lhs)
    bfIS(rhs,lhs)
  ['COND,[isPred,rhs]]
 
 
bfLET(lhs,rhs) ==
  $letGenVarCounter : local := 1
--  $inbfLet : local := true
  bfLET1(lhs,rhs)
 
addCARorCDR(acc,expr) ==
  NULL CONSP expr => [acc,expr]
  acc = 'CAR and EQCAR(expr,'REVERSE) =>
      ["CAR",["LAST",:rest expr]]
 --   cons('last,rest expr)
  funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
            CDAAR CDDAR CDADR CDDDR)
  p := bfPosition(first expr,funs)
  p = -1 => [acc,expr]
  funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR
             CAADDR CADAAR CADDAR CADADR CADDDR)
  funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR
             CDADDR CDDAAR CDDDAR CDDADR CDDDDR)
  if acc = 'CAR then CONS(funsA.p,rest expr)
  else               CONS(funsR.p,rest expr)
 
bfPosition(x,l) ==  bfPosn(x,l,0)
bfPosn(x,l,n) ==
      null l => -1
      x=first l => n
      bfPosn(x,rest l,n+1)
 
--% IS
 
bfISApplication(op,left,right)==
   EQ(op ,"IS")      => bfIS(left,right)
   EQ(op ,"ISNT")    => bfNOT bfIS(left,right)
   [op ,left,right]
 
bfIS(left,right)==
    $isGenVarCounter:local :=1
    $inDefIS :local :=true
    bfIS1(left,right)
 
bfISReverse(x,a) ==
  x is ['CONS,:.] =>
    null third x => ['CONS,second x, a]
    y := bfISReverse(third x, NIL)
    RPLACA(CDDR y,['CONS,second x,a])
    y
  bpSpecificErrorHere '"Error in bfISReverse"
  bpTrap()
 
bfIS1(lhs,rhs) ==
  null rhs =>
    ['NULL,lhs]
  STRINGP rhs =>
    ['EQ,lhs,['QUOTE,INTERN rhs]]
  NUMBERP rhs =>
    ["EQUAL",lhs,rhs]
  atom rhs =>
    ['PROGN,bfLetForm(rhs,lhs),''T]
  rhs is ['QUOTE,a] =>
    IDENTP a => ['EQ,lhs,rhs]
    ["EQUAL",lhs,rhs]
  rhs is ['L%T,c,d] =>
    l :=
      bfLET(c,lhs)
--    $inbfLet => bfLET1(c,lhs)
--    bfLET(c,lhs)
    bfAND [bfIS1(lhs,d),bfMKPROGN [l,''T]]
  rhs is ["EQUAL",a] =>
    ["EQUAL",lhs,a]
  CONSP lhs =>
    g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
    $isGenVarCounter := $isGenVarCounter + 1
    bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)]
  rhs is ['CONS,a,b] =>
    a = "DOT" =>
      NULL b =>
        bfAND [['CONSP,lhs],
               ['EQ,['CDR,lhs],'NIL]]
      bfAND [['CONSP,lhs],
             bfIS1(['CDR,lhs],b)]
    NULL b =>
      bfAND [['CONSP,lhs],
             ['EQ,['CDR,lhs],'NIL],_
             bfIS1(['CAR,lhs],a)]
    b = "DOT" =>
      bfAND [['CONSP,lhs],bfIS1(['CAR,lhs],a)]
    a1 := bfIS1(['CAR,lhs],a)
    b1 := bfIS1(['CDR,lhs],b)
    a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] =>
      bfAND [['CONSP,lhs],bfMKPROGN [c,:cls]]
    bfAND [['CONSP,lhs],a1,b1]
  rhs is ['APPEND,a,b] =>
    patrev := bfISReverse(b,a)
    g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter)
    $isGenVarCounter := $isGenVarCounter + 1
    rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['REVERSE,lhs]],''T]]
    l2 := bfIS1(g,patrev)
    if CONSP l2 and atom first l2 then l2 := cons(l2,nil)
    a = "DOT" => bfAND [rev,:l2]
    bfAND [rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),''T]]
  bpSpecificErrorHere '"bad IS code is generated"
  bpTrap()
 
bfApplication(bfop, bfarg) ==
         if bfTupleP bfarg
         then cons(bfop,rest bfarg)
         else cons(bfop,[bfarg])
 

++ Token renaming.  New Boot and Old Boot differs in the set of
++ tokens they rename.  When converting code written in Old Boot
++ to New Boot, it is helpful to have some noise about potential
++ divergence in semantics.  So, when compiling with --boot=old,
++ we compute the renaming in both Old Boot and New Boot and compare
++ the results.  If they differ, we prefer the old meaning, with some
++ warnings.  Notice that the task is compounded by the fact the
++ tokens in both language do not always agreee.
++ However, to minimize the flood of false positive, we
++ keep a list of symbols which apparently differ in meanings, but
++ which have been verified to agree.  
++ This is a valuable automated tool during the transition period.

-- return the meaning of the x in Old Boot.
bfGetOldBootName x ==
  a := GET(x, "OLD-BOOT") => first a
  x

-- returns true if x has same meaning in both Old Boot and New Boot.
bfSameMeaning x ==
  GET(x, 'RENAME_-OK)
 
-- returns the meaning of x in the appropriate Boot dialect.
bfReName x==
  newName :=
    a := GET(x,"SHOERENAME") => first a
    x
  $translatingOldBoot and not bfSameMeaning x =>
    oldName := bfGetOldBootName x
    if newName ^= oldName then
       warn [PNAME x, '" as `", PNAME newName, _
             '"_' differs from Old Boot `", PNAME oldName,_
             '"_' at ", diagnosticLocation $stok]
    oldName
  newName

 
bfInfApplication(op,left,right)==
   EQ(op,"EQUAL") => bfQ(left,right)
   EQ(op,"/=")    => bfNOT bfQ(left,right)
   EQ(op,">")     => bfLessp(right,left)
   EQ(op,"<")     => bfLessp(left,right)
   EQ(op,"<=")    => bfNOT bfLessp(right,left)
   EQ(op,">=")    => bfNOT bfLessp(left,right)
   EQ(op,"OR")    => bfOR [left,right]
   EQ(op,"AND")   => bfAND [left,right]
   [op,left,right]
 
bfNOT x==
   x is ["NOT",a]=> a
   x is ["NULL",a]=> a
   ["NOT",x]
 
bfFlatten(op, x) ==
      EQCAR(x,op) => rest x
      [x]
 
bfOR l  ==
       null l => NIL
       null rest l => first l
       ["OR",:[:bfFlatten("OR",c) for c in l]]
 
bfAND l ==
       null l=> 'T
       null rest l => first l
       ["AND",:[:bfFlatten("AND",c) for c in l]]
 
 
defQuoteId x==  EQCAR(x,"QUOTE") and IDENTP second x
 
bfSmintable x==
  INTEGERP x or CONSP x and
      first x in '(SIZE LENGTH char)
 
bfQ(l,r)==
  bfSmintable l or bfSmintable r => ["EQL",l,r]
  defQuoteId l or defQuoteId r => ["EQ",l,r]
  null l => ["NULL",r]
  null r => ["NULL",l]
  EQ(l,true) or EQ(r,true) => ["EQ",l,r]
  ["EQUAL",l,r]
 
bfLessp(l,r)==
      if r=0
      then ["MINUSP", l]
      else ["<",l,r]
 
bfMDef (defOp,op,args,body) ==
  argl:=if bfTupleP args then cdr args else [args]
  [gargl,sgargl,nargl,largl]:=bfGargl argl
  sb:=[cons(i,j) for i in nargl for j in sgargl]
  body:= SUBLIS(sb,body)
  sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl]
  body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]]
  lamex:= ["MLAMBDA",gargl,body]
  def:= [op,lamex]
  bfTuple
     cons(shoeComp def,[:shoeComps bfDef1 d for d in $wheredefs])
 
bfGargl argl==
      if null argl
      then [[],[],[],[]]
      else
        [a,b,c,d]:=bfGargl rest argl
        if first argl="&REST"
        then [cons(first argl,b),b,c,
             cons(["CONS",["QUOTE","LIST"],first d],rest d)]
        else
            f:=bfGenSymbol()
            [cons(f,a),cons(f,b),cons(first argl,c),cons(f,d)]
 
bfDef1 [defOp,op,args,body] ==
  argl:=if bfTupleP args then rest args else [args]
  [quotes,control,arglp,body]:=bfInsertLet (argl,body)
  quotes=>shoeLAM(op,arglp,control,body)
  [[op,["LAMBDA",arglp,body]]]
 
shoeLAM (op,args,control,body)==
  margs :=bfGenSymbol()
  innerfunc:=INTERN(CONCAT(PNAME op,",LAM"))
  [[innerfunc,["LAMBDA",args,body]],
     [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc],
                    ["WRAP",margs, ["QUOTE", control]]]]]]
 
bfDef(defOp,op,args,body) ==
 $bfClamming =>
          [.,op1,arg1,:body1]:=shoeComp first bfDef1 [defOp,op,args,body]
          bfCompHash(op1,arg1,body1)
 bfTuple
  [:shoeComps bfDef1 d for d in  cons([defOp,op,args,body],$wheredefs)]
 
shoeComps  x==
  [shoeComp def for def in x]

shoeComp x==
     a:=shoeCompTran second x
     if EQCAR(a,"LAMBDA")
     then ["DEFUN",first x,second a,:CDDR a]
     else ["DEFMACRO",first x,second a,:CDDR a]


++ Translate function parameter list to Lisp.
++ We are processing a function definition.  `p2' is the list of
++ parameters we have seen so far, and we are about to add a 
++ parameter `p1'.  Check that the new specification is coherent
++ with the previous one.  In particular, check that restrictions
++ on parameters with default values are satisfied.  Return the
++ new augmented parameter list.
bfParameterList(p1,p2) ==
  p2=nil and not atom p1 => p1
  p1 is ["&OPTIONAL",:.] =>
    p2 isnt ["&OPTIONAL",:.] => bpSpecificErrorHere '"default value required"
    [first p1,:rest p1,:rest p2]
  p2 is ["&OPTIONAL",:.] =>   [p1,first p2,:rest p2]
  [p1,:p2]
 
bfInsertLet(x,body)==
   if null x
   then [false,nil,x,body]
   else
      if x is ["&REST",a]
      then if a is ["QUOTE",b]
           then [true,"QUOTE",["&REST",b],body]
           else [false,nil,x,body]
      else
       [b,norq,name1,body1]:=  bfInsertLet1 (first x,body)
       [b1,norq1,name2,body2]:=  bfInsertLet (rest x,body1)
       [b or b1,cons(norq,norq1),bfParameterList(name1,name2),body2]
 
bfInsertLet1(y,body)==
   y is ["L%T",l,r] => [false,nil,l,bfMKPROGN [bfLET(r,l),body]]
   IDENTP y => [false,nil,y,body]
   y is ["BVQUOTE",b] => [true,"QUOTE",b,body]
   g:=bfGenSymbol()
   atom y => [false,nil,g,body]
   case y of
     %DefaultValue(p,v) => [false,nil,["&OPTIONAL",[p,v]],body]
     otherwise => [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]]
 
shoeCompTran x==
   lamtype:=first x
   args   :=second x
   body   :=CDDR x
   $fluidVars:local:=nil
   $locVars:local:=nil
   $dollarVars:local:=nil
   shoeCompTran1 body
   $locVars:=SETDIFFERENCE(SETDIFFERENCE($locVars,
                                  $fluidVars),shoeATOMs args)
   body:=
     lvars:=append($fluidVars,$locVars)
     $fluidVars:=UNION($fluidVars,$dollarVars)
     body' := body
     if $typings then body' := [["DECLARE",:$typings],:body']
     if $fluidVars then
       fvars:=["DECLARE",["SPECIAL",:$fluidVars]]
       body' := [fvars,:body']
     if lvars or needsPROG body then shoePROG(lvars,body') else body'
   fl:=shoeFluids args
   body:=if fl
         then
           fvs:=["DECLARE",["SPECIAL",:fl]]
           cons(fvs,body)
         else body
   [lamtype,args, :body]

needsPROG body ==
  atom body => false
  [op,:args] := body
  op in '(RETURN RETURN_-FROM) => true
  op in '(LET PROG LOOP BLOCK DECLARE LAMBDA) => false
  or/[needsPROG t for t in body] => true
  false

shoePROG(v,b)==
    null b => [["PROG", v]]
    [:blist,blast] := b
    [["PROG",v,:blist,["RETURN", blast]]]

shoeFluids x==
         if null x
         then nil
         else if IDENTP x and bfBeginsDollar x
              then [x]
              else
                if EQCAR(x,"QUOTE")
                then []
                else
                  if atom x
                  then nil
                  else  append(shoeFluids first x,shoeFluids rest x)
shoeATOMs x==
         if null x
         then nil
         else if atom x
              then [x]
              else append(shoeATOMs first x,shoeATOMs rest x)

++ Return true if `x' is an identifier name that designates a
++ dynamic (e.g. Lisp special) variable.  
isDynamicVariable x ==
  IDENTP x and bfBeginsDollar x =>
    MEMQ(x,$constantIdentifiers) => false
    CONSTANTP x => false
    BOUNDP x or null $activeNamespace => true
    y := FIND_-SYMBOL(STRING x,$activeNamespace) => not CONSTANTP y
    true
  false
 
shoeCompTran1 x==
    atom x=>
      isDynamicVariable x =>
	$dollarVars:=
	   MEMQ(x,$dollarVars)=>$dollarVars
	   cons(x,$dollarVars)
      nil
    U:=car x
    EQ(U,"QUOTE")=>nil
    x is ["L%T",l,r]=>
                RPLACA (x,"SETQ")
                shoeCompTran1 r
                IDENTP l =>
                  not bfBeginsDollar l=>
                    $locVars:=
                          MEMQ(l,$locVars)=>$locVars
                          cons(l,$locVars)
                  $dollarVars:=
                          MEMQ(l,$dollarVars)=>$dollarVars
                          cons(l,$dollarVars)
                EQCAR(l,"FLUID")=>
                    $fluidVars:=
                         MEMQ(second l,$fluidVars)=>$fluidVars
                         cons(second l,$fluidVars)
                    RPLACA (rest x,second l)
    MEMQ(U,'(PROG LAMBDA))=>
         newbindings:=nil
         for y in second x repeat
             not MEMQ(y,$locVars)=>
                  $locVars:=cons(y,$locVars)
                  newbindings:=cons(y,newbindings)
         res:=shoeCompTran1 CDDR x
         $locVars:=[y for y in $locVars | not MEMQ(y,newbindings)]
    shoeCompTran1 first x
    shoeCompTran1 rest x
 
bfTagged(a,b)==
  null $op => Signature(a,b)        -- surely a toplevel decl
  IDENTP a =>
    EQ(b,"FLUID") =>  bfLET(compFluid a,NIL)
    EQ(b,"fluid") =>  bfLET(compFluid a,NIL)
    EQ(b,"local") =>  bfLET(compFluid a,NIL)
    $typings:=cons(["TYPE",b,a],$typings)
    a
  ["THE",b,a]
 
bfAssign(l,r)==
   if bfTupleP l then bfSetelt(second l,CDDR l ,r) else bfLET(l,r)
 
bfSetelt(e,l,r)==
    if null rest l
    then defSETELT(e,car l,r)
    else bfSetelt(bfElt(e,first l),rest l,r)
 
bfElt(expr,sel)==
      y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
      y=>
         INTEGERP y => ["ELT",expr,y]
         [y,expr]
      ["ELT",expr,sel]
 
defSETELT(var,sel,expr)==
      y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
      y=>
         INTEGERP y => ["SETF",["ELT",var,y],expr]
         ["SETF",[y,var],expr]
      ["SETF",["ELT",var,sel],expr]
 
bfIfThenOnly(a,b)==
    b1:=if EQCAR (b,"PROGN") then rest b else [b]
    ["COND",[a,:b1]]
 
bfIf(a,b,c)==
    b1:=if EQCAR (b,"PROGN") then rest b else [b]
    EQCAR (c,"COND") => ["COND",[a,:b1],:rest c]
    c1:=if EQCAR (c,"PROGN") then rest c else [c]
    ["COND",[a,:b1],['(QUOTE T),:c1]]
 
bfExit(a,b)==  
  ["COND",[a,["IDENTITY",b]]]
 
bfMKPROGN l==
    a:=[:bfFlattenSeq c for c in tails l]
    null a=> nil
    null rest a=> first a
    ["PROGN",:a]
 
bfFlattenSeq x ==
      null x=>NIL
      f:=first x
      atom f =>if rest x then nil else [f]
      EQCAR(f,"PROGN") =>
              rest x=>  [i for i in rest f| not atom i]
              rest f
      [f]
 
bfSequence l ==
      null l=> NIL
      transform:= [[a,b] for x in l while
              x is ["COND",[a,["IDENTITY",b]]]]
      no:=#transform
      before:= bfTake(no,l)
      aft   := bfDrop(no,l)
      null before =>
              null rest l =>
                   f:=first l
                   if EQCAR(f,"PROGN")
                   then bfSequence rest f
                   else f
              bfMKPROGN [first l,bfSequence rest l]
      null aft => ["COND",:transform]
      ["COND",:transform,['(QUOTE T),bfSequence aft]]
 
bfWhere (context,expr)==
  [opassoc,defs,nondefs] := defSheepAndGoats context
  a:=[[def,op,args,bfSUBLIS(opassoc,body)]
               for d in defs  |d is [def,op,args,body]]
  $wheredefs:=append(a,$wheredefs)
  bfMKPROGN bfSUBLIS(opassoc,NCONC(nondefs,[expr]))
 
--shoeReadLispString(s,n)==
--    n>= # s => nil
--    [exp,ind]:=shoeReadLisp(s,n)
--    null exp => nil
--    cons(exp,shoeReadLispString(s,ind))
 
bfReadLisp string ==
  bfTuple shoeReadLispString (string,0)

bfCompHash(op,argl,body) ==
  auxfn:= INTERN CONCAT (PNAME op,'";")
  computeFunction:= ["DEFUN",auxfn,argl,:body]
  bfTuple [computeFunction,:bfMain(auxfn,op)]
 
shoeCompileTimeEvaluation x ==
  ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x]

shoeEVALANDFILEACTQ x==  
  ["EVAL-WHEN", [KEYWORD::EXECUTE, KEYWORD::LOAD_-TOPLEVEL], x]
 
bfMain(auxfn,op)==
  g1:= bfGenSymbol()
  arg:=["&REST",g1]
  computeValue := ['APPLY,["FUNCTION",auxfn],g1]
  cacheName:= INTERN CONCAT (PNAME op,'";AL")
  g2:= bfGenSymbol()
  getCode:=   ['GETHASH,g1,cacheName]
  secondPredPair:= [['SETQ,g2,getCode],g2]
  putCode:=   ['SETF ,getCode,computeValue]
  thirdPredPair:= ['(QUOTE T),putCode]
  codeBody:= ['PROG,[g2],
               ['RETURN,['COND,secondPredPair,thirdPredPair]]]
  mainFunction:= ["DEFUN",op,arg,codeBody]
 
  cacheType:=     'hash_-table
  cacheResetCode:=   ['SETQ,cacheName,['MAKE_-HASHTABLE,
                        ["QUOTE","UEQUAL"]]]
  cacheCountCode:= ['hashCount,cacheName]
  cacheVector:=
      [op,cacheName,cacheType,cacheResetCode,cacheCountCode]
  defCode := ["DEFPARAMETER",cacheName,
                ['MAKE_-HASHTABLE,["QUOTE","UEQUAL"]]]
  [defCode,mainFunction,
    shoeEVALANDFILEACTQ
      ["SETF",["GET",
           ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]]]


bfNameOnly: %Thing -> %List 
bfNameOnly x==
      if x="t"
      then ["T"]
      else  [x]

bfNameArgs: (%Thing,%Thing) -> %List 
bfNameArgs (x,y)==
    y:=if EQCAR(y,"TUPLE") then rest y else [y]
    cons(x,y)
 
bfStruct: (%Thing,%List) -> %List
bfStruct(name,arglist)==
  bfTuple [bfCreateDef i for i in arglist]

bfCreateDef: %Thing -> %List
bfCreateDef x==
     if null rest x
     then
       f:=first x
       ["DEFCONSTANT",f,["LIST",["QUOTE",f]]]
     else
       a:=[bfGenSymbol() for i in rest x]
       ["DEFUN",first x,a,["CONS",["QUOTE",first x],["LIST",:a]]]

bfCaseItem: (%Thing,%Thing) -> %List 
bfCaseItem(x,y) ==
  [x,y]

bfCase: (%Thing,%Thing) -> %List
bfCase(x,y)==
         g:=bfGenSymbol()
         g1:=bfGenSymbol()
         a:=bfLET(g,x)
         b:=bfLET(g1,["CDR",g])
         c:=bfCaseItems (g1,y)
         bfMKPROGN [a,b,["CASE",["CAR", g],:c]]

bfCaseItems: (%Thing,%List) -> %List 
bfCaseItems(g,x) ==  
  [bfCI(g,i,j) for [i,j] in x]

bfCI: (%Thing,%Thing,%Thing) -> %List 
bfCI(g,x,y)==
    a:=rest x
    if null a
    then [first x,y]
    else
       b:=[[i,bfCARCDR(j,g)] for i in a for j in 0.. | i ^= "DOT"]
       null b => [first x,y]
       [first x,["LET",b,y]]

bfCARCDR: (%Short,%Thing) -> %List 
bfCARCDR(n,g) ==
  [INTERN CONCAT ('"CA",bfDs n,'"R"),g]

bfDs: %Short -> %String 
bfDs n== 
  if n=0 then '"" else CONCAT('"D",bfDs(n-1))


++ Generate code for try-catch expressions.
bfTry: (%Thing,%List) -> %Thing
bfTry(e,cs) ==
  null cs => e
  case first cs of
    %Catch(tag) => 
      atom tag => bfTry(["CATCH",["QUOTE",tag],e],rest cs)
      bpTrap()  -- sorry
    otherwise => bpTrap()

++ Generate code for `throw'-expressions
bfThrow e ==
  atom e => ["THROW",["QUOTE",e],nil]
  not atom first e => bpTrap()
  ["THROW",["QUOTE",first e],:rest e]

--% Type alias definition

backquote(form,params) ==
  null params => quote  form
  atom form =>
    form in params => form
    quote form
  ["LIST",:[backquote(t,params) for t in form]]

genTypeAlias(head,body) ==
  [op,:args] := head
  ["DEFTYPE",op,args,backquote(body,args)]

--%
--% Native Interface Translation
--%

-- The Native Interface Translation support the following datatypes
--     void:  No value, useful only as function return type.
--
--     char:  Character type, corresponds to C type 'char'.
--
--     byte:  8-bit data type for the unit of information; corresponds 
--            to C type 'unsigned char' on 8-bit char machines.
--
--     Note:  We require 2's complement representation.
--
--     int8:  8-bit signed integer data type; int8_t in ISO C.
--    uint8:  8-bit unsigned integer data type; uint8_t in ISO C.
--    int16:  16-bit signed integer data type; int16_t is ISO C.
--   uint16:  16-bit unsigned integer data type; uint16_t in ISO C.
--    int32:  32-bit signed integer data type; int32_t in ISO C.
--   uint32:  32-bit unsigned integer data type; uint32_t in ISO C.
--    int64:  64-bit signed integer data type; int64_t in ISO C.
--   uint64:  64-bit unsigned integer data type; uint64_t in ISO C.
--
--      int:  Native integer data type.  Ideally should be wide enough
--            to represent native address space.  However, only ECL
--            and GCL seems to give that guarantee at the moment.
--
--    float:  single precision datatype for floating poing values.
--  float32   Corresponds to C type 'float'.  On most architecture,
--            this is a 32-bit precision IEEE 756 data type.
--
--   double:  double precision datatype for floating point values.
--  float64   Corresponds to C type 'double'.  On most architecture,
--            this is a 64-bit precision IEEE 756 data type.
--
--   string:  a data type for strings of characters.  The general
--            semantics is that a string is passed by value (e.g.
--            copied into a separate storage) to a native
--            function.  In many cases, that is appropriate (e.g.
--            mkdir "foo") if just wasteful.  In other cases, that is
--            not appropriate, as the native function may expect a
--            pass-by-reference semantics, e.g. modify the argument.
--            Consequently, argument types may be combined with the
--            modifiers `readonly' and `writeonly'.  Note that a
--            function return type may not use modifiers.
--            Corresponds to C's notion of NUL-terminated string,
--            'char*'.  In particular, the length of a string is
--            stored as separate datum part of the data being
--            transmitted.
--
--   buffer:  A data type constructor for array of simple data 
--            (e.g. array of bytes, array of float, array of double).
--            This is used to communicate data between native
--            functions and OpenAxiom functions.  The `buffer' type
--            constructor must be used in conjunction with one of the 
--            modifiers `readonly', `writeonly', or `readwrite', and 
--            instantiated with one of `char', `byte', `int', `float',
--            and `double'.  It cannot be used as function return type.
--            Note that the length of the array is not stored as 
--            part of the data being transmitted.
--
--  pointer:  A data type constructor for pointer to simple data 
--            This is used to communicate pointer to foreign data 
--            between native functions and OpenAxiom functions.
--            The `buffer' type constructor must be used in
--            conjunction with one of the modifiers `readonly',
--            `writeonly', or `readwrite'.

$NativeSimpleDataTypes ==
  '(char   byte    int 
    int8   uint8
    int16  uint16
    int32  uint32
    int64  uint64
    float  float32
    double float64)

$NativeSimpleReturnTypes ==
  [:$NativeSimpleDataTypes,:'(void string)]

++ Returns true if `t' is a simple native data type.
isSimpleNativeType t ==
  t in $NativeSimpleReturnTypes

coreSymbol: %Symbol -> %Symbol
coreSymbol s ==
  INTERN(SYMBOL_-NAME s, "AxiomCore")

bootSymbol: %Symbol -> %Symbol
bootSymbol s ==
  INTERN SYMBOL_-NAME s


unknownNativeTypeError t ==
  fatalError CONCAT('"unsupported native type: ", SYMBOL_-NAME t)


nativeType t ==
  t = nil => t
  atom t =>
    t' := rest ASSOC(coreSymbol t,$NativeTypeTable) => 
      t' := 
	%hasFeature KEYWORD::SBCL => bfColonColon("SB-ALIEN", t')
	%hasFeature KEYWORD::CLISP => bfColonColon("FFI",t')
	t'
      -- ??? decree we have not discovered Unicode yet.
      t = "string" and %hasFeature KEYWORD::SBCL =>
	[t',KEYWORD::EXTERNAL_-FORMAT,KEYWORD::ASCII,
	   KEYWORD::ELEMENT_-TYPE, "BASE-CHAR"]
      t'
    t in '(byte uint8) =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),8]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT8")
      %hasFeature KEYWORD::ECL => KEYWORD::UNSIGNED_-BYTE
      nativeType "char"           -- approximate by 'char' for GCL
    t = "int16" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),16]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT16")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
         KEYWORD::INT16_-T
      unknownNativeTypeError t
    t = "uint16" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),16]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT16")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
         KEYWORD::UINT16_-T
      unknownNativeTypeError t
    t = "int32" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),32]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
         KEYWORD::INT32_-T
      unknownNativeTypeError t
    t = "uint32" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),32]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
         KEYWORD::UINT32_-T
      unknownNativeTypeError t
    t = "int64" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),64]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT64")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
         KEYWORD::INT64_-T
      unknownNativeTypeError t
    t = "uint64" =>
      %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),64]
      %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT64")
      %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
         KEYWORD::UINT64_-T
      unknownNativeTypeError t
    t = "float32" => nativeType "float"
    t = "float64" => nativeType "double"
    unknownNativeTypeError t
  -- composite, reference type.
  first t = "buffer" =>
    %hasFeature KEYWORD::GCL => "OBJECT"
    %hasFeature KEYWORD::ECL => KEYWORD::OBJECT
    %hasFeature KEYWORD::SBCL => ["*",nativeType second t]
    %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
    unknownNativeTypeError t
  first t = "buffer" =>
    %hasFeature KEYWORD::GCL => "fixnum"
    %hasFeature KEYWORD::ECL => KEYWORD::OBJECT
    %hasFeature KEYWORD::SBCL => ["*",nativeType second t]
    %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
    unknownNativeTypeError t
  unknownNativeTypeError t


++ Check that `t' is a valid return type for a native function, and
++ returns its translation
nativeReturnType t ==
  t in $NativeSimpleReturnTypes => nativeType t
  coreError strconc('"invalid return type for native function: ", 
              SYMBOL_-NAME t)


++ Check that `t' is a valid parameter type for a native function,
++ and returns its translation.
nativeArgumentType t ==
  t in $NativeSimpleDataTypes => nativeType t
  -- Allow 'string'  for `pass-by-value'
  t = "string" => nativeType t
  -- anything else must use a modified reference type.
  atom t or #t ^= 2 => 
     coreError '"invalid argument type for a native function"
  [m,[c,t']] := t
  -- Require a modifier.
  not (m in '(readonly writeonly readwrite)) =>
    coreError '"missing modifier for argument type for a native function"
  -- Only 'pointer' and 'buffer' can be instantiated.
  not (c in '(buffer pointer)) =>
    coreError '"expect 'buffer' or 'pointer' type instance"
  not (t' in $NativeSimpleDataTypes) =>
    coreError '"expected simple native data type"
  nativeType second t
  

++ True if objects of type native type `t' are sensible to GC.
needsStableReference? t ==
  t is [m,:.] and m in '(readonly writeonly readwrite)

++ coerce argument `a' to native type `t', in preparation for
++ a call to a native functions.
coerceToNativeType(a,t) ==
  -- GCL, ECL, and CLISP don't do it this way.
  %hasFeature KEYWORD::GCL or %hasFeature KEYWORD::ECL
     or %hasFeature KEYWORD::CLISP  => a
  %hasFeature KEYWORD::SBCL =>
    not needsStableReference? t => a
    [.,[c,y]] := t
    c = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a]
    c = "pointer" => [bfColonColon("SB-SYS","ALIEN-SAP"),a]
    needsStableReference? t =>
      fatalError strconc('"don't know how to coerce argument for native type",
        SYMBOL_-NAME c)
  fatalError '"don't know how to coerce argument for native type"


++ Generate GCL native translation for import op: s -> t for op'
++ `argtypes' is the list of GCL FFI names for types in `s'.
++ `rettype' is the GCL FFI name for `t'.
genGCLnativeTranslation(op,s,t,op') ==
  argtypes := [nativeArgumentType x for x in s]
  rettype := nativeReturnType t
  -- If a simpel DEFENTRY will do, go for it
  and/[isSimpleNativeType x for x in [t,:s]] =>
    [["DEFENTRY", op, argtypes, [rettype, SYMBOL_-NAME op']]]
  -- Otherwise, do it the hard way.
  [["CLINES",ccode], ["DEFENTRY", op, argtypes, [rettype, cop]]] where
    cop := strconc(SYMBOL_-NAME op','"__stub")
    ccode := 
      "strconc"/[gclTypeInC t, '" ", cop, '"(",
	 :[cparm(x,a) for x in tails s for a in tails cargs],
	   '") { ", (t ^= "void" => '"return "; ""),
	     SYMBOL_-NAME op', '"(",
	       :[gclArgsInC(x,a) for x in tails s for a in tails cargs],
		  '"); }" ]
                where cargs := [mkCArgName i for i in 0..(#s - 1)]
    mkCArgName i == strconc('"x",STRINGIMAGE i)
    cparm(x,a) ==
      strconc(gclTypeInC first x, '" ", first a,
	(rest x => '", "; '""))
    gclTypeInC x ==
      x in $NativeSimpleDataTypes => SYMBOL_-NAME x
      x = "void" => '"void"
      x = "string" => '"char*"
      x is [.,["pointer",.]] => "fixnum"
      '"object" 
    gclArgInC(x,a) ==
      x in $NativeSimpleDataTypes => a
      x = "string" => a   -- GCL takes responsability for the conversion
      [.,[c,y]] := x
      c = "pointer" => a
      y = "char" => strconc(a,'"->st.st__self")
      y = "byte" => strconc(a,'"->ust.ust__self")
      y = "int" => strconc(a,'"->fixa.fixa__self")
      y = "float" => strconc(a,'"->sfa.sfa__self")
      y = "double" => strconc(a,'"->lfa.lfa__self")
      coreError '"unknown argument type"
    gclArgsInC(x,a) ==
      strconc(gclArgInC(first x, first a),
	(rest x => '", "; '""))  

genECLnativeTranslation(op,s,t,op') ==
  args := nil
  argtypes := nil
  for x in s repeat
     argtypes := [nativeArgumentType x,:argtypes]
     args := [GENSYM(),:args]
  args := reverse args
  rettype := nativeReturnType t
  [["DEFUN",op, args,
    [bfColonColon("FFI","C-INLINE"),args, nreverse argtypes,
      rettype, callTemplate(op',#args,s), 
        KEYWORD::ONE_-LINER, true]]] where
	  callTemplate(op,n,s) ==
	    "strconc"/[SYMBOL_-NAME op,'"(",
	      :[sharpArg(i,x) for i in 0..(n-1) for x in s],'")"]
	  sharpArg(i,x) == 
	    i = 0 => strconc('"(#0)",selectDatum x)
	    strconc('",",'"(#", STRINGIMAGE i, '")", selectDatum x)
	  selectDatum x ==
	    isSimpleNativeType x => '""
	    [.,[c,y]] := x
            c = "buffer" => 
	      y = "char" or y = "byte" => 
                AxiomCore::$ECLVersionNumber < 90100 => '"->vector.self.ch"
                y = "char" => '"->vector.self.i8"
                '"->vector.self.b8"
	      y = "int" => '"->vector.self.fix"
	      y = "float" => '"->vector.self.sf"
	      y = "double" => '"->vector.self.df"
	      coreError '"unknown argument to buffer type constructor"
            c = "pointer" => ""
            coreError '"unknown type constructor"

genCLISPnativeTranslation(op,s,t,op') ==
  -- check parameter types and return types.
  rettype := nativeReturnType t
  argtypes := [nativeArgumentType x for x in s]

  -- There is a curious bug in the CLisp's FFI support whereby
  -- foreign declarations compiled separately will have the wrong
  -- types when used in other modules.  We work around that problem
  -- by defining forwarding functions to the foreign declarations
  -- in the same module the latter are declared.  Even if and when
  -- that bug is fixed, we still need forwarding function because,
  -- CLISP's FFI takes every step to ensure that Lisp world objects
  -- do not mix with C world object, presumably because they are not
  -- from the same class.  Consequently, we must allocate C-storage,
  -- copy data there, pass pointers to them, and possibly copy
  -- them back.  Ugh.  
  n := INTERN strconc(SYMBOL_-NAME op, '"%clisp-hack")
  parms := [GENSYM '"parm" for x in s]  -- parameters of the forward decl.

  -- Now, separate non-simple data from the rest.  This is a triple-list
  -- of the form ((parameter boot-time . ffi-type) ...)
  unstableArgs := nil
  for p in parms for x in s for y in argtypes repeat
    needsStableReference? x =>
      unstableArgs := [[p,x,:y],:unstableArgs]

  -- The actual FFI declaration for the native call.  Note that 
  -- parameter of non-simple datatype are described as being poinyers.
  foreignDecl := 
    [bfColonColon("FFI","DEF-CALL-OUT"),n,
      [KEYWORD::NAME,SYMBOL_-NAME op'],
	[KEYWORD::ARGUMENTS,:[[a, x] for x in argtypes for a in parms]],
	  [KEYWORD::RETURN_-TYPE, rettype],
	      [KEYWORD::LANGUAGE,KEYWORD::STDC]]

  -- The forwarding function.  We have to introduce local foreign
  -- variables to hold the address of converted Lisp objects.  Then
  -- we have to copy back those that are `writeonly' or `readwrite' to
  -- simulate the reference semantics.  Don't ever try to pass around
  -- gigantic buffer, you might find out that it is insanely inefficient.
  forwardingFun := 
    null unstableArgs => ["DEFUN",op,parms, [n,:parms]]
    localPairs := [[a,x,y,:GENSYM '"loc"] for [a,x,:y] in unstableArgs]
    call := 
      [n,:[actualArg(p,localPairs) for p in parms]] where
	    actualArg(p,pairs) ==
	      a' := rest ASSOC(p,pairs) => rest rest a'
	      p
    -- Fix up the call if there is any `write' parameter.
    call := 
      fixups := [q | not null (q := copyBack p) for p in localPairs] where
                  copyBack [p,x,y,:a] ==
                    x is ["readonly",:.] => nil
                    ["SETF", p, [bfColonColon("FFI","FOREIGN-VALUE"), a]]
      null fixups => [call]
      [["PROG1",call, :fixups]]
    -- Set up local foreign variables to hold address of traveling data
    for [p,x,y,:a] in localPairs repeat
      call := 
        [[bfColonColon("FFI","WITH-FOREIGN-OBJECT"),
            [a, ["FUNCALL",
               ["INTERN",'"getCLISPType",'"BOOTTRAN"], p], p], :call]]
    -- Finally, define the forwarding function.
    ["DEFUN",op,parms,:call]
  $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp]
  [forwardingFun]

getCLISPType a ==
  [bfColonColon("FFI","C-ARRAY"), #a]


genSBCLnativeTranslation(op,s,t,op') ==    
  -- check return type and argument types.
  rettype := nativeReturnType t
  argtypes := [nativeArgumentType x for x in s]

  args := [GENSYM() for x in s]
  unstableArgs := nil
  newArgs := nil
  for a in args for x in s repeat
    newArgs := [coerceToNativeType(a,x), :newArgs]
    if needsStableReference? x then
      unstableArgs := [a,:unstableArgs]
  
  op' :=
    %hasFeature KEYWORD::WIN32 => strconc('"__",SYMBOL_-NAME op')
    SYMBOL_-NAME op'
    
  null unstableArgs =>
    [["DEFUN",op,args,
      [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"),
	[INTERN('"EXTERN-ALIEN",'"SB-ALIEN"), op',
	  ["FUNCTION",rettype,:argtypes]], :args]]]
  [["DEFUN",op,args,
    [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"), nreverse unstableArgs,
      [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"),
	[INTERN('"EXTERN-ALIEN",'"SB-ALIEN"), op',
	  ["FUNCTION",rettype,:argtypes]], :nreverse newArgs]]]]


++ Generate an import declaration for `op' as equivalent of the
++ foreign signature `sig'.  Here, `foreign' operationally means that
++ the entity is from the C language world. 
genImportDeclaration(op, sig) ==
  sig isnt ["Signature", op', m] => coreError '"invalid signature"
  m isnt ["Mapping", t, s] => coreError '"invalid function type"
  if not null s and SYMBOLP s then s := [s]

  %hasFeature KEYWORD::GCL => genGCLnativeTranslation(op,s,t,op')
  %hasFeature KEYWORD::SBCL => genSBCLnativeTranslation(op,s,t,op')
  %hasFeature KEYWORD::CLISP => genCLISPnativeTranslation(op,s,t,op')
  %hasFeature KEYWORD::ECL => genECLnativeTranslation(op,s,t,op')
  fatalError '"import declaration not implemented for this Lisp"