diff options
Diffstat (limited to 'src/interp/newfort.boot.pamphlet')
| -rw-r--r-- | src/interp/newfort.boot.pamphlet | 967 |
1 files changed, 0 insertions, 967 deletions
diff --git a/src/interp/newfort.boot.pamphlet b/src/interp/newfort.boot.pamphlet deleted file mode 100644 index b5720292..00000000 --- a/src/interp/newfort.boot.pamphlet +++ /dev/null @@ -1,967 +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} -<<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. - -@ -<<*>>= -<<license>> - ---% 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() - $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() - 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} |