aboutsummaryrefslogtreecommitdiff
path: root/src/interp/newfort.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/newfort.boot.pamphlet')
-rw-r--r--src/interp/newfort.boot.pamphlet967
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}