From 0850ca5458cb09b2d04cec162558500e9a05cf4a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 14:50:49 +0000 Subject: Revert commits to the wrong tree. --- src/interp/newfort.boot.pamphlet | 967 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 967 insertions(+) create mode 100644 src/interp/newfort.boot.pamphlet (limited to 'src/interp/newfort.boot.pamphlet') diff --git a/src/interp/newfort.boot.pamphlet b/src/interp/newfort.boot.pamphlet new file mode 100644 index 00000000..b5720292 --- /dev/null +++ b/src/interp/newfort.boot.pamphlet @@ -0,0 +1,967 @@ +\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. + +@ +<<*>>= +<> + +--% 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} -- cgit v1.2.3