From d3ec46dd9a15a12b6456c70b9e92ab0a780adacf Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 4 Nov 2007 17:44:31 +0000 Subject: --- src/interp/newfort.boot | 948 ++++++++++++++++++++++++++++++++++++++ src/interp/newfort.boot.pamphlet | 970 --------------------------------------- 2 files changed, 948 insertions(+), 970 deletions(-) create mode 100644 src/interp/newfort.boot delete mode 100644 src/interp/newfort.boot.pamphlet 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] + diff --git a/src/interp/newfort.boot.pamphlet b/src/interp/newfort.boot.pamphlet deleted file mode 100644 index dea2a580..00000000 --- a/src/interp/newfort.boot.pamphlet +++ /dev/null @@ -1,970 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp newfort.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- 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] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3