1 files changed, 948 insertions, 0 deletions

diff --git a/src/interp/newfort.boot b/src/interp/newfort.boot
new file mode 100644
index 00000000..1ab40abe
--- /dev/null
+++ b/src/interp/newfort.boot
@@ -0,0 +1,948 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- 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.
+
+
+import '"macros"
+)package "BOOT"
+
+--% Translation of Expression to FORTRAN
+assignment2Fortran1(name,e) ==
+  $fortError : fluid := nil
+  checkLines fortran2Lines statement2Fortran ["=",name,e]
+
+integerAssignment2Fortran1(name,e) ==
+  $fortError : fluid := nil
+  $fortInts2Floats : fluid := nil
+  checkLines fortran2Lines statement2Fortran ["=",name,e]
+
+statement2Fortran e ==
+  -- takes an object of type Expression and returns a list of
+  -- strings. Any part of the expression which is a list starting
+  -- with 'FORTRAN is merely passed on in the list of strings. The
+  -- list of strings may contain '"%l".
+  -- This is used when formatting e.g. a DO loop from Lisp
+  $exp2FortTempVarIndex : local := 0
+  $fortName : fluid := "DUMMY"
+  $fortInts2Floats : fluid := nil
+  fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e
+
+expression2Fortran e ==
+  -- takes an object of type Expression and returns a list of
+  -- strings. Any part of the expression which is a list starting
+  -- with 'FORTRAN is merely passed on in the list of strings. The
+  -- list of strings may contain '"%l".
+  $exp2FortTempVarIndex : local := 0
+  $fortName : fluid := newFortranTempVar()
+  $fortInts2Floats : fluid := nil
+  fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e
+
+expression2Fortran1(name,e) ==
+  -- takes an object of type Expression and returns a list of
+  -- strings. Any part of the expression which is a list starting
+  -- with 'FORTRAN is merely passed on in the list of strings. The
+  -- list of strings may contain '"%l".
+  $exp2FortTempVarIndex : local := 0
+  $fortName : fluid := name
+  fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e
+
+newFortranTempVar() ==
+  $exp2FortTempVarIndex := 1 + $exp2FortTempVarIndex
+  newVar := INTERN STRCONC('"T",STRINGIMAGE $exp2FortTempVarIndex)
+  updateSymbolTable(newVar,$defaultFortranType)
+  newVar
+ 
+fortranCleanUp l ==
+  -- takes reversed list and cleans up a bit, putting it in
+  -- correct order
+  oldTok := NIL
+  m := NIL
+  for e in l repeat
+    if not (oldTok = '"-" and e = '"+") then m := [e,:m]
+    oldTok := e
+  m
+ 
+exp2Fort1 l ==
+  s := nil
+  for e in l repeat s := [:exp2Fort2(e,0,nil),:s]
+  s
+ 
+exp2Fort2(e,prec,oldOp) ==
+  null e    => nil
+  atom e    => [object2String e]
+  e is [ "=",lhs,rhs] or e is [ '"=",lhs,rhs] =>
+    ['"%l",:exp2Fort2(rhs,prec,'"="),'"=",:exp2Fort2(lhs,prec,'"=")]
+ 
+  unaryOps    := ['"-",'"^",'"~"]
+  unaryPrecs  := [700,260,50]
+  binaryOps   := ['"|",'"**",'"/",'".LT.",'".GT.",'".EQ.",'".LE.",'".GE.", _
+                  '"OVER",'".AND.",'".OR."]
+  binaryPrecs := [0, 900, 800, 400, 400, 400, 400, 400, 800, 70, 90]
+  naryOps     := ['"-",'"+",'"*",'",",'" ",'"ROW",'""]
+  naryPrecs   := [700,  700, 800,  110,   0,     0,  0]
+  nonUnaryOps := append(binaryOps,naryOps)
+  [op,:args] := e
+  op := object2String op
+  nargs := #args
+  nargs = 0 => exp2FortFn(op,args,0)
+  nargs = 1 =>
+    (p := position(op,unaryOps)) > -1 =>
+      nprec := unaryPrecs.p
+      s := [:exp2Fort2(first args,nprec,op),op]
+      op = '"-" and atom first args => s
+      op = oldOp and op in ['"*",'"+"] => s
+      nprec <= prec => ['")",:s,'"("]
+      s
+    exp2FortFn(op,args,nargs)
+  op = '"CMPLX" =>
+    ['")",:exp2Fort2(SECOND args, prec, op),'",",:exp2Fort2(first args,prec,op),'"("]
+  member(op,nonUnaryOps) =>
+    if nargs > 0 then arg1 := first args
+    nargs = 1 and op in '("+" "*") => exp2Fort2(arg1,prec,op)
+    if nargs > 1 then arg2 := first rest args
+    p := position(op,binaryOps)
+    if p = -1
+      then
+        p := position(op,naryOps)
+        nprec := naryPrecs.p
+      else nprec := binaryPrecs.p
+    s := nil
+    for arg in args repeat
+      op = '"+" and (arg is [m,a]) and m in '(_- "=") =>
+        if not s then s := ['junk]
+        s:= [op,:exp2Fort2(a,nprec,op),'"-",:rest s]
+      s := [op,:exp2Fort2(arg,nprec,op),:s]
+    s := rest s
+    op = oldOp and op in ['"*",'"+"] => s
+    nprec <= prec => ['")",:s,'"("]
+    s
+  exp2FortFn(op,args,nargs)
+ 
+ 
+exp2FortFn(op,args,nargs) ==
+  s := ['"(",op]
+  while args repeat
+    s := ['",",:exp2Fort2(first args,0,op),:s]
+    args := rest args
+  if nargs > 0 then ['")",:rest s]
+  else ['")",:s]
+ 
+ 
+--% Optimization of Expression
+ 
+exp2FortOptimize e ==
+  -- $fortranOptimizationLevel means:
+  --   0         just extract arrays
+  --   1         extract common subexpressions
+  --   2         try to optimize computing of powers
+  $exprStack : local := NIL
+  atom e => [e]
+  $fortranOptimizationLevel = 0 =>
+    e1 := exp2FortOptimizeArray e
+    NREVERSE [e1,:$exprStack]
+  e := minimalise e
+  for e1 in exp2FortOptimizeCS  e repeat
+    e2 := exp2FortOptimizeArray e1
+    $exprStack := [e2,:$exprStack]
+  NREVERSE $exprStack
+
+ 
+exp2FortOptimizeCS e ==
+  $fortCsList : local := NIL
+  $fortCsHash : local := MAKE_-HASHTABLE 'EQ
+  $fortCsExprStack : local := NIL
+  $fortCsFuncStack : local := NIL
+  f := exp2FortOptimizeCS1 e
+  NREVERSE [f,:$fortCsList]
+ 
+-- bug fix to beenHere 
+-- Thu Nov 05 12:01:46 CUT 1992 , Author: TTT
+-- Used in exp2FortOprtimizeCS 
+-- Original file : newfort.boot
+beenHere(e,n) ==
+  n.0 := n.0 + 1                      -- increase count (initially 1)
+  n.0 = 2 =>                          -- first time back again
+    var := n.1 := newFortranTempVar() -- stuff n.1 with new var
+    exprStk := n.2                    -- get expression
+    if exprStk then
+-- using COPY-TREE : RPLAC does not smash $fortCsList
+-- which led to inconsistencies in assignment of temp. vars.
+      $fortCsList := COPY_-TREE [['"=",var,e],:$fortCsList]
+      loc := CAR exprStk
+      fun := CAR n.3
+      fun = 'CAR =>
+        RPLACA(loc,var)
+      fun = 'CDR =>
+        if PAIRP QCDR loc
+          then RPLACD(loc,[var])
+          else RPLACD(loc,var)
+      SAY '"whoops"
+    var
+  n.1                     -- been here before, so just get variable
+
+
+exp2FortOptimizeCS1 e ==
+  -- we do nothing with atoms or simple lists containing atoms
+  atom(e) or (atom first e and null rest e) => e
+  e is [op,arg] and object2Identifier op = "-" and atom arg => e
+
+  -- see if we have been here before
+  not (object2Identifier QCAR e in '(ROW AGGLST)) and
+    (n := HGET($fortCsHash,e)) => beenHere(e,n) -- where
+
+  -- descend sucessive CARs of CDRs of e
+  f := e
+  while f repeat
+    pushCsStacks(f,'CAR) where pushCsStacks(x,y) ==
+      $fortCsExprStack := [x,:$fortCsExprStack]
+      $fortCsFuncStack := [y,:$fortCsFuncStack]
+    RPLACA(f,exp2FortOptimizeCS1 QCAR f)
+    popCsStacks(0) where popCsStacks(x) ==
+      $fortCsFuncStack := QCDR $fortCsFuncStack
+      $fortCsExprStack := QCDR $fortCsExprStack
+    g := QCDR f
+    -- check to see of we have an non-NIL atomic CDR
+    g and atom g =>
+      pushCsStacks(f,'CDR)
+      RPLACD(f,exp2FortOptimizeCS1 g)
+      popCsStacks(0)
+      f := NIL
+    f := g
+
+  MEMQ(object2Identifier QCAR e,'(ROW AGGLST)) => e
+
+  -- see if we have already seen this expression
+  n := HGET($fortCsHash,e)
+  null n =>
+    n := VECTOR(1,NIL,$fortCsExprStack,$fortCsFuncStack)
+    HPUT($fortCsHash,e,n)
+    e
+  beenHere(e,n)
+
+
+ 
+exp2FortOptimizeArray e ==
+  -- this handles arrays
+  atom e => e
+  [op,:args] := e
+  op1 := object2Identifier op
+  op1 in '(BRACE BRACKET) =>
+    args is [['AGGLST,:elts]] =>
+      LISTP first elts and first first elts in '(BRACE BRACKET) => fortError1 e
+      -- var := newFortranTempVar()
+      var := $fortName
+      $exprStack := [[op,var,['AGGLST,:exp2FortOptimizeArray elts]],
+        :$exprStack]
+      var
+  EQ(op1,'MATRIX) =>
+    -- var := newFortranTempVar()
+    var := $fortName
+    -- args looks like [NIL,[ROW,...],[ROW,...]]
+    $exprStack := [[op,var,:exp2FortOptimizeArray args],:$exprStack]
+    var
+  [exp2FortOptimizeArray op,:exp2FortOptimizeArray args]
+
+ 
+--% FORTRAN Line Breaking
+ 
+fortran2Lines f ==
+  -- f is a list of strings
+  -- returns: a list of strings where each string is a valid
+  -- FORTRAN line in fixed form
+ 
+  -- collect strings up to first %l or end of list. Then feed to
+  -- fortran2Lines1.
+  fs := NIL
+  lines := NIL
+  while f repeat
+    while f and (ff := first(f)) ^= '"%l" repeat
+      fs := [ff,:fs]
+      f := rest f
+    if f and first(f) = '"%l" then f := rest f
+    lines := append(fortran2Lines1 nreverse fs,lines)
+    fs := nil
+  nreverse lines
+ 
+fortran2Lines1 f ==
+  -- f is a list of strings making up 1 FORTRAN statement
+  -- return: a reverse list of FORTRAN lines
+  normPref := MAKE_-STRING($fortIndent)
+  --contPref := STRCONC(MAKE_-STRING($fortIndent-1),"&")
+  contPref := STRCONC("     &",MAKE_-STRING($fortIndent-6))
+  lines := NIL
+  ll := $fortIndent
+  while f repeat
+    ok := true
+    line := normPref
+    ff := first f
+    while ok repeat
+      (ll + (sff := SIZE ff)) <= $fortLength =>
+        ll := ll + sff
+        line := STRCONC(line,ff)
+        f := rest f
+        if f then ff := first f
+        else ok := nil
+      -- fill the line out to exactly $fortLength spaces if possible by splitting
+      -- up symbols.  This is helpful when doing the segmentation
+      -- calculations, and also means that very long strings (e.g. numbers
+      -- with more than $fortLength-$fortIndent digits) are printed in a
+      -- legal format. MCD
+      if (ll < $fortLength) and (ll + sff) > $fortLength then
+        spaceLeft := $fortLength - ll
+        line := STRCONC(line,SUBSEQ(ff,0,spaceLeft))
+        ff := SUBSEQ(ff,spaceLeft)
+      lines := [line,:lines]
+      ll := $fortIndent
+      line := contPref
+    if ll > $fortIndent then lines := [line,:lines]
+  lines
+ 
+-- The Fortran error functions
+fortError1 u ==
+  $fortError := "t"
+  sayErrorly("Fortran translation error",
+             "   No corresponding Fortran structure for:")
+  mathPrint u
+ 
+fortError(u,v) ==
+  $fortError := "t"
+  msg := STRCONC("   ",STRINGIMAGE u);
+  sayErrorly("Fortran translation error",msg)
+  mathPrint v
+ 
+--% Top Level Things to Call
+-- The names are the same as those used in the old fortran code
+
+dispStatement x ==
+  $fortError : fluid := nil
+  displayLines fortran2Lines statement2Fortran x
+
+
+getStatement(x,ints2Floats?) ==
+  $fortInts2Floats : fluid := ints2Floats?
+  $fortError : fluid := nil
+  checkLines fortran2Lines statement2Fortran x
+
+fortexp0 x ==
+  f := expression2Fortran x
+  p := position('"%l",f)
+  p < 0 => f
+  l := NIL
+  while p < 0 repeat
+    [t,:f] := f
+    l := [t,:l]
+  NREVERSE ['"...",:l]
+ 
+dispfortexp x ==
+  if atom(x) or x is [op,:.] and not object2Identifier op in
+    '(_= MATRIX construct ) then
+      var := INTERN STRCONC('"R",object2String $IOindex)
+      x := ['"=",var,x]
+  dispfortexp1 x
+ 
+dispfortexpf (xf, fortranName) ==
+  $fortError : fluid := nil
+  linef := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xf),2)
+  displayLines linef
+
+dispfortexpj (xj, fortranName) ==
+  $fortName : fluid := fortranName
+  $fortError : fluid := nil
+  linej := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xj),2)
+  displayLines linej
+
+
+dispfortexp1 x ==
+  $fortError : fluid := nil
+  displayLines fortran2Lines expression2Fortran x
+
+getfortexp1 x ==
+  $fortError : fluid := nil
+  checkLines fortran2Lines expression2Fortran x
+
+displayLines1 lines ==
+  for l in lines repeat
+    PRINTEXP(l,$fortranOutputStream)
+    TERPRI($fortranOutputStream)
+
+displayLines lines ==
+  if not $fortError then displayLines1 lines
+ 
+checkLines lines ==
+  $fortError => []
+  lines
+
+dispfortarrayexp (fortranName,m) ==
+  $fortError : fluid := nil
+  displayLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2)
+
+getfortarrayexp(fortranName,m,ints2floats?) ==
+  $fortInts2Floats : fluid := ints2floats?
+  $fortError : fluid := nil
+  checkLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2)
+
+ 
+-- Globals
+$currentSubprogram := nil
+$symbolTable := nil
+ 
+
+
+--fix [x,exp x]
+ 
+------------ exp2FortSpecial.boot --------------------
+ 
+exp2FortSpecial(op,args,nargs) ==
+  op = "CONCAT" and first args in ["<",">","<=",">=","~","and","or"] =>
+    mkFortFn(first args,CDADAR rest args,#(CDADAR rest args))
+  op = "CONCAT" and CADR(args)="EQ" =>
+    mkFortFn("EQ",[first args, CADDR args],2)
+  --the next line is NEVER used by FORTRAN code but is needed when
+  --  called to get a linearized form for the browser
+  op = "QUOTE" =>
+    atom (arg := first args) => STRINGIMAGE arg
+    tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg]
+    STRCONC('"[",first arg,tailPart,'"]")
+  op = "PAREN" =>
+    args := first args
+    not(first(args)="CONCATB") => fortError1 [op,:args]
+    -- Have a matrix element
+    mkMat(args)
+  op = "SUB" =>
+    $fortInts2Floats : fluid := nil
+    mkFortFn(first args,rest args,#(rest args))
+  op in ["BRACE","BRACKET"] =>
+    args is [var,['AGGLST,:elts]] =>
+      var := object2String var
+      si := $fortranArrayStartingIndex
+      hidim := #elts - 1 + si
+      if LISTP first elts and #elts=1 and first elts is [sOp,:sArgs] then
+        sOp in ['"SEGMENT","SEGMENT"] =>
+          #sArgs=1 => fortError1 first elts
+          not(NUMBERP(first sArgs) and NUMBERP(SECOND sArgs)) =>
+            fortError("Cannot expand segment: ",first elts)
+          first sArgs > SECOND sArgs => fortError1
+            '"Lower bound of segment exceeds upper bound."
+          for e in first sArgs .. SECOND sArgs for i in si.. repeat
+            $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack]
+      for e in elts for i in si.. repeat
+        $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack]
+    fortError1 [op,:args]
+  op in ["CONCAT","CONCATB"] =>
+    nargs = 0 => NIL
+    nargs = 1 => fortPre1 first args
+    nargs = 2 and first rest args in ["!",'"!"] =>
+      mkFortFn("FACTORIAL",[first args],1)
+    fortError1 [op,:args]
+  op in ['"MATRIX","MATRIX"] =>
+    args is [var, =NIL,:rows] =>
+      var := object2String var
+      nrows := #rows - 1
+      ncols := #(rest first rows) - 1
+      si := $fortranArrayStartingIndex
+      for r in rows for rx in si.. repeat
+        for c in rest r for cx in si.. repeat
+          $exprStack := [["=",[var,object2String rx,object2String cx],
+                          fortPre1(c)],:$exprStack]
+    fortError1 [op,:args]
+  fortError1 [op,:args]
+
+mkMat(args) ==
+  $fortInts2Floats : fluid := nil
+  mkFortFn(first rest args,rest rest args,#(rest rest args))
+
+ 
+mkFortFn(op,args,nargs) ==
+  [fortranifyFunctionName(STRINGIMAGE op,nargs), 
+   :MAPCAR(function fortPre1 , args) ]
+ 
+fortranifyFunctionName(op,nargs) ==
+  op = '"<" => '".LT."
+  op = '">" => '".GT."
+  op = '"<=" => '".LE."
+  op = '">=" => '".GE."
+  op = '"EQ" => '".EQ."
+  op = '"and" => '".AND."
+  op = '"or" => '".OR."
+  op = '"~" => '".NOT."
+  fortranifyIntrinsicFunctionName(op,nargs)
+
+fortranifyIntrinsicFunctionName(op,nargs) ==
+  $useIntrinsicFunctions =>
+    intrinsic := if op = '"acos" then '"ACOS"
+    else if op = '"asin" then '"ASIN"
+    else if op = '"atan" then
+      nargs = 2 => '"ATAN2"
+      '"ATAN"
+    else if op = '"cos" then '"COS"
+    else if op = '"cosh" then '"COSH"
+    else if op = '"cot" then '"COTAN"
+    else if op = '"erf" then '"ERF"
+    else if op = '"exp" then '"EXP"
+    else if op = '"log" then '"LOG"
+    else if op = '"log10" then '"LOG10"
+    else if op = '"sin" then '"SIN"
+    else if op = '"sinh" then '"SINH"
+    else if op = '"sqrt" then '"SQRT"
+    else if op = '"tan" then '"TAN"
+    else if op = '"tanh" then '"TANH"
+    intrinsic =>
+      $intrinsics := ADJOIN(intrinsic,$intrinsics)
+      intrinsic
+    op
+  $fortranPrecision = 'double =>
+    op = '"acos" => '"DACOS"
+    op = '"asin" => '"DASIN"
+    op = '"atan" =>
+      nargs = 2 => '"DATAN2"
+      '"DATAN"
+    op = '"cos" => '"DCOS"
+    op = '"cosh" => '"DCOSH"
+    op = '"cot" => '"DCOTAN"
+    op = '"erf" => '"DERF"
+    op = '"exp" => '"DEXP"
+    op = '"log" => '"DLOG"
+    op = '"log10" => '"DLOG10"
+    op = '"sin" => '"DSIN"
+    op = '"sinh" => '"DSINH"
+    op = '"sqrt" => '"DSQRT"
+    op = '"tan" => '"DTAN"
+    op = '"tanh" => '"DTANH"
+    op = '"abs" => '"DABS"
+    op
+  op = '"acos" => '"ACOS"
+  op = '"asin" => '"ASIN"
+  op = '"atan" =>
+    nargs = 2 => '"ATAN2"
+    '"ATAN"
+  op = '"cos" => '"COS"
+  op = '"cosh" => '"COSH"
+  op = '"cot" => '"COTAN"
+  op = '"erf" => '"ERF"
+  op = '"exp" => '"EXP"
+  op = '"log" => '"ALOG"
+  op = '"log10" => '"ALOG10"
+  op = '"sin" => '"SIN"
+  op = '"sinh" => '"SINH"
+  op = '"sqrt" => '"SQRT"
+  op = '"tan" => '"TAN"
+  op = '"tanh" => '"TANH"
+  op = '"abs" => '"ABS"
+  op
+
+--------------------------format.boot------------------------------------------
+
+-- These functions are all used by FortranCode and FortranProgram.
+-- Those used by FortranCode have been changed to return a list of
+-- lines rather than print them directly, thus allowing us to catch
+-- and display type declarations for temporary variables.
+--  MCD 25/3/93
+
+indentFortLevel(i) ==
+  $maximumFortranExpressionLength := $maximumFortranExpressionLength -2*i
+  $fortIndent := $fortIndent + 2*i
+
+changeExprLength(i) ==
+  $maximumFortranExpressionLength := $maximumFortranExpressionLength + i
+
+fortFormatDo(var,lo,hi,incr,lab) ==
+  $fortError : fluid := nil
+  $fortInts2Floats : fluid := nil
+  incr=1 =>
+    checkLines fortran2Lines
+      ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_
+       '",", :statement2Fortran hi]
+  checkLines fortran2Lines
+    ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_
+     '",", :statement2Fortran hi,'",",:statement2Fortran incr]
+
+fortFormatIfGoto(switch,label) ==
+  changeExprLength(-8) -- Leave room for IF( ... )GOTO
+  $fortError : fluid := nil
+  if first(switch) = "NULL" then switch := first rest switch
+  r := nreverse statement2Fortran switch
+  changeExprLength(8)
+  l := ['")GOTO ",STRINGIMAGE label]
+  while r and not(first(r) = '"%l") repeat
+    l := [first(r),:l]
+    r := rest(r)
+  checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r]
+
+fortFormatLabelledIfGoto(switch,label1,label2) ==
+  changeExprLength(-8) -- Leave room for IF( ... )GOTO
+  $fortError : fluid := nil
+  if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch
+  r := nreverse statement2Fortran switch
+  changeExprLength(8)
+  l := ['")GOTO ",STRINGIMAGE label2]
+  while r and not(first(r) = '"%l") repeat
+    l := [first(r),:l]
+    r := rest(r)
+  labString := STRINGIMAGE label1
+  for i in #(labString)..5 repeat labString := STRCONC(labString,'" ")
+  lines := fortran2Lines nreverse [:nreverse l,'"IF(",:r]
+  lines := [STRCONC(labString,SUBSEQ(first lines,6)),:rest lines]
+  checkLines lines
+
+fortFormatIf(switch) ==
+  changeExprLength(-8) -- Leave room for IF( ... )THEN
+  $fortError : fluid := nil
+  if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch
+  r := nreverse statement2Fortran switch
+  changeExprLength(8)
+  l := ['")THEN"]
+  while r and not(first(r) = '"%l") repeat
+    l := [first(r),:l]
+    r := rest(r)
+  checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r]
+
+fortFormatElseIf(switch) ==
+  -- Leave room for IF( ... )THEN
+  changeExprLength(-12)
+  $fortError : fluid := nil
+  if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch
+  r := nreverse statement2Fortran switch
+  changeExprLength(12)
+  l := ['")THEN"]
+  while r and not(first(r) = '"%l") repeat
+    l := [first(r),:l]
+    r := rest(r)
+  checkLines fortran2Lines nreverse [:nreverse l,'"ELSEIF(",:r]
+
+fortFormatHead(returnType,name,args) ==
+  $fortError : fluid := nil
+  $fortranSegment : fluid := nil
+  -- if returnType = '"_"_(_)_"" then 
+  if returnType = '"void" then
+    asp := ['"SUBROUTINE "]
+    changeExprLength(l := -11)
+  else
+    asp := [s := checkType STRINGIMAGE returnType,'" FUNCTION "]
+    changeExprLength(l := -10-LENGTH(s))
+  displayLines fortran2Lines [:asp,:statement2Fortran [name,:CDADR args] ]
+  changeExprLength(-l)
+
+checkType ty ==
+  ty := STRING_-UPCASE STRINGIMAGE ty
+  $fortranPrecision = "double" =>
+    ty = '"REAL" => '"DOUBLE PRECISION"
+    ty = '"COMPLEX" => '"DOUBLE COMPLEX"
+    ty
+  ty
+
+mkParameterList l ==
+  [par2string(u) for u in l] where par2string u ==
+      atom(u) => STRINGIMAGE u
+      u := rest first rest u
+      apply('STRCONC,[STRINGIMAGE(first u),'"(",_
+               :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"])
+
+nameLen n ==>
+ +/[1+LENGTH(u) for u in n]
+
+fortFormatTypes(typeName,names) ==
+  null names => return nil
+  $fortError : fluid := nil
+  $fortranSegment : fluid := nil
+  $fortInts2Floats : fluid := nil
+  typeName := checkType typeName
+  typeName = '"CHARACTER" =>
+    fortFormatCharacterTypes([unravel(u) for u in names])
+      where unravel u ==
+              atom u => u
+              CDADR u
+  fortFormatTypes1(typeName,mkParameterList names)
+
+fortFormatTypes1(typeName,names) ==
+  l := $maximumFortranExpressionLength-1-LENGTH(typeName)
+  while nameLen(names) > l repeat
+    n := []
+    ln := 0
+    while (ln := ln + LENGTH(first names) + 1) < l repeat
+      n := [first names,:n]
+      names := rest names
+    displayLines fortran2Lines [typeName,'" ",:addCommas n]
+  displayLines fortran2Lines [typeName,'" ",:addCommas names]
+
+insertEntry(size,el,aList) ==
+  entry := assoc(size,aList)
+  null entry => CONS(CONS(size,LIST el),aList)
+  RPLACD(entry,CONS(el,CDR entry))
+  aList
+
+fortFormatCharacterTypes(names) ==
+  sortedByLength := []
+  genuineArrays  := []
+  for u in names repeat
+    ATOM u => sortedByLength := insertEntry(0,u,sortedByLength)
+    #u=2 => sortedByLength := insertEntry(CADR u,CAR u,sortedByLength)
+    genuineArrays := [u,:genuineArrays]
+  for u in sortedByLength repeat
+    fortFormatTypes1(mkCharName car u, [STRINGIMAGE(s) for s in cdr(u)]) where
+       mkCharName v == CONCAT("CHARACTER*(",STRINGIMAGE v,")")
+  if (not null genuineArrays) then
+    fortFormatTypes1('"CHARACTER",mkParameterList2 genuineArrays) where
+       mkParameterList2 l ==
+         [par2string(u) for u in l] where par2string u ==
+             apply('STRCONC,[STRINGIMAGE(first u),'"(",_
+                      :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"])
+
+fortFormatIntrinsics(l) ==
+  $fortError : fluid := nil
+  null l => return nil
+  displayLines fortran2Lines ['"INTRINSIC ",:addCommas(l)]
+  
+ 
+------------------ fortDec.boot --------------------
+ 
+-- This file contains the stuff for creating and updating the Fortran symbol
+-- table.
+ 
+currentSP () ==
+  -- Return the name of the current subprogram being generated
+  $currentSubprogram or "MAIN"
+ 
+updateSymbolTable(name,type) ==
+    fun := ['$elt,'SYMS,'declare_!]
+    coercion := ['_:_:,STRING type,'FST]
+    $insideCompileBodyIfTrue: local := false
+    interpret([fun,["QUOTE",name],coercion])
+ 
+addCommas l ==
+  not l => nil
+  r := [STRINGIMAGE first l]
+  for e in rest l repeat r := [STRINGIMAGE e,'",",:r]
+  reverse r
+
+$intrinsics := []
+initialiseIntrinsicList() == 
+  $intrinsics := []
+
+getIntrinsicList() ==
+  $intrinsics
+
+ 
+-------------------- fortPre.boot ------------------
+ 
+fortPre l ==
+  -- Essentially, the idea is to fix things so that we know what size of
+  -- expression we will generate, which helps segment large expressions
+  -- and do transformations to double precision output etc..
+  $exprStack : fluid := nil -- sometimes we will add elements to this in
+                            -- other functions, for example when extracing
+                            -- lists etc.
+  for e in l repeat if new := fortPre1 e then
+     $exprStack := [new,:$exprStack]
+  reverse $exprStack
+ 
+fortPre1 e ==
+  -- replace spad function names by Fortran equivalents
+  -- where appropriate, replace integers by floats
+  -- extract complex numbers
+  -- replace powers of %e by calls to EXP
+  -- replace x**2 by x*x etc.
+  -- replace ROOT by either SQRT or **(1./ ... )
+  -- replace N-ary by binary functions
+  -- strip the '%' character off objects like %pi etc..
+  null e => nil
+  INTEGERP(e) =>
+    $fortInts2Floats = true =>
+      e >= 0 => fix2FortranFloat(e)
+      ['"-", fix2FortranFloat(-e)]
+    e
+  isFloat(e) => checkPrecision(e)
+  -- Keep strings as strings:
+  -- STRINGP(e) => STRCONC(STRING(34),e,STRING(34))
+  STRINGP(e) => e
+  e = "%e" => fortPre1 ["exp" , 1]
+  imags := ['"%i","%i"]
+  e in imags => ['"CMPLX",fortPre1(0),fortPre1(1)]
+  -- other special objects
+  ELT(STRINGIMAGE e,0) = "%" => SUBSEQ(STRINGIMAGE e,1)
+  atom e => e
+  [op, :args] := e
+  op in ["**" , '"**"] =>
+    [rand,exponent] := args
+    rand = "%e" => fortPre1 ["exp", exponent]
+    (IDENTP rand or STRINGP rand) and exponent=2 => ["*", rand, rand]
+    (FIXP exponent and ABS(exponent) < 32768) => ["**",fortPre1 rand,exponent]
+    ["**", fortPre1 rand,fortPre1 exponent]
+  op = "ROOT" =>
+    #args = 1 => fortPreRoot ["sqrt", first args]
+    [ "**" , fortPreRoot first args , [ "/" , fortPreRoot(1), fortPreRoot first rest args] ]
+  if op in ['"OVER", "OVER"] then op := '"/"
+  specialOps  := '(BRACKET BRACE SUB AGGLST SUPERSUB MATRIX SEGMENT ALTSUPERSUB
+                   PAREN CONCAT CONCATB QUOTE STRING SIGMA  STEP IN SIGMA2
+                   INTSIGN  PI PI2 INDEFINTEGRAL)
+  op in specialOps => exp2FortSpecial(op,args,#args)
+  op in ['"*", "*", '"+", "+", '"-", "-"] and (#args > 2) =>
+    binaryExpr := fortPre1 [op,first args, SECOND args]
+    for i in 3..#args repeat
+      binaryExpr := [op,binaryExpr,fortPre1 NTH(i-1,args)]
+    binaryExpr
+  -- Now look for any complex objects
+  #args = 2 =>
+    [arg1,arg2] := args
+    op in ["*",'"*"] and arg2 in imags => ['"CMPLX",fortPre1(0),fortPre1(arg1)]
+    op in ["+",'"+"] and arg2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(1)]
+    op in ["+",'"+"] and arg2 is [mop,m1,m2] and mop in ["*",'"*"] =>
+      m2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m1)]
+      m1 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m2)]
+      ["+",fortPre1 arg1,fortPre1 arg2]
+    op in ["+",'"+"] and arg1 is [mop,m1,m2] and mop in ["*",'"*"] =>
+      m2 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m1)]
+      m1 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m2)]
+      ["+",fortPre1 arg1,fortPre1 arg2]
+    mkFortFn(op,args,2)
+  mkFortFn(op,args,#args)
+
+fortPreRoot e ==
+-- To set $fortInts2Floats 
+  $fortInts2Floats : fluid := true
+  fortPre1 e
+ 
+fix2FortranFloat e ==
+  -- Return a Fortran float for a given integer.
+  $fortranPrecision = "double" => STRCONC(STRINGIMAGE(e),".0D0")
+  STRCONC(STRINGIMAGE(e),".")
+ 
+isFloat e ==
+  FLOATP(e) or STRINGP(e) and FIND(char ".",e)
+ 
+checkPrecision e ==
+  -- Do we have a string?
+  STRINGP(e) and CHAR_-CODE(CHAR(e,0)) = 34 => e
+  e := delete(char " ",STRINGIMAGE e)
+  $fortranPrecision = "double" =>
+    iPart := SUBSEQ(e,0,(period:=POSITION(char ".",e))+1)
+    expt  := if ePos := POSITION(char "E",e) then SUBSEQ(e,ePos+1) else "0"
+    rPart :=
+      ePos => SUBSEQ(e,period+1,ePos)
+      period+1 < LENGTH e => SUBSEQ(e,period+1)
+      "0"
+    STRCONC(iPart,rPart,"D",expt)
+  e
+ 
+----------------- segment.boot -----------------------
+ 
+fortExpSize e ==
+  -- computes a tree reflecting the number of characters of the printed
+  -- expression.
+  -- The first element of a list is the "total so far", while subsequent
+  -- elements are the sizes of the components.
+  --
+  -- This function overestimates the size because it assumes that e.g.
+  -- (+ x (+ y z)) will be printed as "x+(y+z)" rather than "x+y+z"
+  -- which is the actual case.
+  atom e => LENGTH STRINGIMAGE e
+  #e > 3 => 2+fortSize MAPCAR(function fortExpSize, e)
+  #e < 3 => 2+fortSize MAPCAR(function fortExpSize, e)
+  [op,arg1,arg2] := e
+  op := STRINGIMAGE op
+  op = '"CMPLX" => 3+fortSize [fortExpSize arg1,fortExpSize arg2]
+  narys := ['"+",'"*"] -- those nary ops we changed to binary
+  op in narys =>
+    LISTP arg1 and not(op=STRINGIMAGE first arg1) =>
+      2+fortSize MAPCAR(function fortExpSize, e)
+    LISTP arg2 and not(op=STRINGIMAGE first arg2) =>
+      2+fortSize MAPCAR(function fortExpSize, e)
+    1+fortSize [fortExpSize arg1,fortExpSize arg2]
+  2+fortSize MAPCAR(function fortExpSize, e)
+ 
+fortSize e ==
+  +/[elen u for u in e] where
+    elen z ==
+      atom z => z
+      first z
+ 
+tempLen () == 1 + LENGTH STRINGIMAGE $exp2FortTempVarIndex
+ 
+segment l ==
+  not $fortranSegment => l
+  s := nil
+  for e in l repeat
+    if LISTP(e) and first e in ["=",'"="] then
+      var := NTH(1,e)
+      exprs := segment1(THIRD e,
+                        $maximumFortranExpressionLength-1-fortExpSize var)
+      s:= [:[['"=",var,car exprs],:cdr exprs],:s]
+    else if LISTP(e) and first e in ['"RETURN"] then
+      exprs := segment1(SECOND e,
+                        $maximumFortranExpressionLength-2-fortExpSize first e)
+      s := [:[[first e,car exprs],:cdr exprs],:s]
+    else s:= [e,:s]
+  reverse s
+ 
+segment1(e,maxSize) ==
+  (size := fortExpSize e) < maxSize => [e]
+  expressions := nil;
+  newE := [first e]
+  -- Assume we have to replace each argument with a temporary variable, and
+  -- that the temporary variable may be larger than we expect.
+  safeSize := maxSize -  (#e-1)*(tempLen()+1) - fortExpSize newE
+  for i in 2..#e repeat
+    subSize := fortExpSize NTH(i-1,e)
+    -- We could have a check here for symbols which are simply too big
+    -- for Fortran (i.e. more than the maximum practical expression length)
+    subSize <= safeSize =>
+      safeSize := safeSize - subSize
+      newE := [:newE,NTH(i-1,e)]
+    -- this ones too big.
+    exprs := segment2(NTH(i-1,e),safeSize)
+    expressions := [:(cdr exprs),:expressions]
+    newE := [:newE,(car exprs)]
+    safeSize := safeSize - fortExpSize car exprs
+  [newE,:expressions]
+ 
+segment2(e,topSize) ==
+  maxSize := $maximumFortranExpressionLength -tempLen()-1
+  atom(e) => [e]
+  exprs := nil
+  newE  := [first e]
+  topSize := topSize - fortExpSize newE
+  for i in 2..#e repeat
+    subE := NTH(i-1,e)
+    (subSize := fortExpSize subE) > maxSize =>
+      subE := segment2(subE,maxSize)
+      exprs := [:(cdr subE),:exprs]
+      if (subSize := fortExpSize first subE) <= topSize then
+        newE := [:newE,first subE]
+        topSize := topSize - subSize
+      else
+        newVar := newFortranTempVar()
+        newE := [:newE,newVar]
+        exprs:=[['"=",newVar,first subE],:exprs]
+        topSize := topSize - fortExpSize newVar
+    newE := [:newE,subE]
+    topSize := topSize - subSize
+  topSize > 0 => [newE,:exprs]
+  newVar := newFortranTempVar()
+  [newVar,['"=",newVar,newE],:exprs]
+