diff --git a/changelog b/changelog index 91e289c..689fe8d 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090827 tpd src/axiom-website/patches.html 20090827.01.tpd.patch +20090827 tpd src/interp/Makefile move fortcall.boot to fortcall.lisp +20090827 tpd src/interp/fortcall.lisp added, rewritten from fortcall.boot +20090827 tpd src/interp/fortcall.boot removed, rewritten to fortcall.lisp 20090826 tpd src/axiom-website/patches.html 20090826.07.tpd.patch 20090826 tpd src/interp/Makefile move termrw.boot to termrw.lisp 20090826 tpd src/interp/termrw.lisp added, rewritten from termrw.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index e876d84..550dbb6 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1910,5 +1910,7 @@ profile.lisp rewrite from boot to lisp
template.lisp rewrite from boot to lisp
20090826.07.tpd.patch termrw.lisp rewrite from boot to lisp
+20090827.01.tpd.patch +fortcall.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 9a333ff..1d9fa16 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -1024,49 +1024,29 @@ ${DOC}/fnewmeta.lisp.dvi: ${IN}/fnewmeta.lisp.pamphlet @ -\subsection{fortcall.boot \cite{16}} +\subsection{fortcall.lisp} <>= -${OUT}/fortcall.${O}: ${MID}/fortcall.clisp - @ echo 54 making ${OUT}/fortcall.${O} from ${MID}/fortcall.clisp - @ (cd ${MID} ; \ +${OUT}/fortcall.${O}: ${MID}/fortcall.lisp + @ echo 136 making ${OUT}/fortcall.${O} from ${MID}/fortcall.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/fortcall.clisp"' \ - ':output-file "${OUT}/fortcall.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/fortcall.lisp"' \ + ':output-file "${OUT}/fortcall.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/fortcall.clisp"' \ - ':output-file "${OUT}/fortcall.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ + echo '(progn (compile-file "${MID}/fortcall.lisp"' \ + ':output-file "${OUT}/fortcall.${O}") (${BYE}))' | ${DEPSYS} \ + >${TMP}/trace ; \ fi ) @ -<>= -${MID}/fortcall.clisp: ${IN}/fortcall.boot.pamphlet - @ echo 55 making ${MID}/fortcall.lisp from ${IN}/fortcall.boot.pamphlet - @( cd ${MID} ; \ - ${TANGLE} ${IN}/fortcall.boot.pamphlet >fortcall.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "fortcall.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "fortcall.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm fortcall.boot ) - -@ -<>= -${DOC}/fortcall.boot.dvi: ${IN}/fortcall.boot.pamphlet - @echo 56 making ${DOC}/fortcall.boot.dvi \ - from ${IN}/fortcall.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/fortcall.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} fortcall.boot ; \ - rm -f ${DOC}/fortcall.boot.pamphlet ; \ - rm -f ${DOC}/fortcall.boot.tex ; \ - rm -f ${DOC}/fortcall.boot ) +<>= +${MID}/fortcall.lisp: ${IN}/fortcall.lisp.pamphlet + @ echo 137 making ${MID}/fortcall.lisp from \ + ${IN}/fortcall.lisp.pamphlet + @ (cd ${MID} ; \ + ${TANGLE} ${IN}/fortcall.lisp.pamphlet >fortcall.lisp ) @ - \subsection{hypertex.lisp} <>= ${OUT}/hypertex.${O}: ${MID}/hypertex.lisp @@ -5591,8 +5571,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/fortcall.boot.pamphlet b/src/interp/fortcall.boot.pamphlet deleted file mode 100644 index 9513e31..0000000 --- a/src/interp/fortcall.boot.pamphlet +++ /dev/null @@ -1,820 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp fortcall.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. - -@ -<<*>>= -<> - -makeFort(name,args,decls,results,returnType,aspInfo) == - -- Create an executable Fortran file to call a given library function, - -- and a stub Axiom function to process its arguments. - -- the following is a list of objects for which values need not be - -- passed by the user. - dummies := [SECOND(u) for u in args | EQUAL(car u,0)] - args := [untangle2(u) for u in args] -- lose spad Union representation - where untangle2 u == - atom (v := rest(u)) => v - first(v) - userArgs := [u for u in args | not member(u,dummies)] -- Temporary - decls := [untangle(u) for u in decls] -- lose spad Union representation - where untangle u == - [if atom(rest(v)) then rest(v) else _ - [if atom(w) then w else rest(w) for w in rest(v)] for v in u] - makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) - -makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) == - asps := [first(u) for u in aspInfo] - -- Now reorder the arguments so that all the scalars come first, so - -- that when we come to deal with arrays we know all the dimensions. - scalarArgs := [u for u in args | atom getFortranType(u,decls)] - arrayArgs := [u for u in args | not member(u,scalarArgs)] - orderedArgs := [:scalarArgs,:arrayArgs] - file := if $fortranDirectory then - STRCONC($fortranDirectory,"/",STRINGIMAGE name) - else - STRINGIMAGE name - makeFortranFun(name,orderedArgs,args,dummies,decls,results,file, - $fortranDirectory,returnType,asps) - makeSpadFun(name,userArgs,orderedArgs,dummies,decls,results,returnType,asps, - aspInfo,file) - name - -makeFortranFun(name,args,fortranArgs,dummies,decls,results,file,dir, - returnType,asps) == - -- Create a C file to call the library function, and compile it. - fp := MAKE_-OUTSTREAM(STRCONC(file,".c")) - writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) - if null dir then dir := '"." - asps => SYSTEM STRCONC("cc -c ",file,".c ; mv ",file,".o ",dir) - SYSTEM STRCONC("cc ",file,".c -o ",file,".spadexe ",$fortranLibraries) - -writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) == - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#ifndef NULL",fp) - WRITE_-LINE('"#define NULL 0",fp) - WRITE_-LINE('"#endif NULL",fp) - WRITE_-LINE('"#define MAX__ARRAY(x) (x ? x : 20000)",fp) - WRITE_-LINE('"#define CHECK(x) if (!x) {fprintf(stderr,_"xdr failed_"); exit(1);}",fp) - WRITE_-LINE('"void main()",fp) - WRITE_-LINE('"{",fp) - WRITE_-LINE('" XDR xdrs;",fp) - WRITE_-LINE('" {",fp) - if $addUnderscoreToFortranNames then - routineName := STRCONC(name,STRING(95)) - else - routineName := name - -- If it is a function then give it somewhere to stick its result: - if returnType then - returnName := INTERN STRCONC(name,"__result") - wl(['" ",getCType returnType,'" ",returnName,'",",routineName,'"();"],fp) - -- print out type declarations for the Fortran parameters, and build an - -- ordered list of pairs [ , ] - argList := nil - for a in args repeat - argList := [[a, getCType getFortranType(a,decls)], :argList] - printDec(SECOND first argList,a,asps,fp) - argList := nreverse argList; - -- read in the data - WRITE_-LINE('" xdrstdio__create(&xdrs, stdin, XDR__DECODE);",fp) - for a in argList repeat - if LISTP SECOND a then writeMalloc(first a,first SECOND a,rest SECOND a,fp) - not MEMQ(first a,[:dummies,:asps]) => writeXDR(a,'"&xdrs",fp) - -- now call the Library routine. FORTRAN names may have an underscore - -- appended. - if returnType then - wt(['" ",returnName,'"="],fp) - else - wt(['" "],fp) - wt([routineName,'"("],fp) - if first fortranArgs then - printCName(first fortranArgs,isPointer?(first fortranArgs,decls),asps,fp) - for a in rest fortranArgs repeat - PRINC('",",fp) - printCName(a,isPointer?(a,decls),asps,fp) - writeStringLengths(fortranArgs,decls,fp) - WRITE_-LINE('");",fp) - -- now export the results. - WRITE_-LINE('" xdrstdio__create(&xdrs, stdout, XDR__ENCODE);",fp) - if returnType then - writeXDR([returnName,getCType returnType],'"&xdrs",fp) - for r in results repeat - writeXDR([r,getCType getFortranType(r,decls)],'"&xdrs",fp) - WRITE_-LINE('" exit(0);",fp) - WRITE_-LINE('" }",fp) - WRITE_-LINE('"}",fp) - -writeStringLengths(fortranArgs,decls,fp) == - for a in fortranArgs repeat - if isString?(a,decls) then wt(['",&",a,'"__length"],fp) - -isString?(u,decls) == - EQUAL(ty := getFortranType(u,decls),"character") or - LISTP(ty) and EQUAL(first ty,"character") - -isPointer?(u,decls) == - ty := getFortranType(u,decls) - LISTP(ty) or ty in ["character","complex","double complex"] - -printCName(u,ispointer,asps,fp) == - member(u,asps) => - PRINC(u,fp) - if $addUnderscoreToFortranNames then PRINC(STRING(95),fp) - if not ispointer then PRINC('"&",fp) - PRINC(u,fp) - -getFortranType(u,decls) == - -- find u in decls, return the given (Fortran) type. - result := nil - for d in decls repeat for dec in rest d repeat - atom(dec) and dec=u => - return( result := first d ) - LISTP(dec) and first(dec)=u => - return( result := [first d,:rest dec] ) - result => result - error ['"Undeclared Fortran parameter: ",u] - -getCType t == - -- Return the equivalent C type. - LISTP(t) => - --[if first(t)="character" then '"char" else getCType first t,:rest t] - first(t)="character" => ['"char",:rest t] - first(t)="complex" => ['"float",2,:rest t] - first(t)="double complex" => ['"double",2,:rest t] - [getCType first t,:rest t] - t="double" => '"double" - t="double precision" => '"double" - t="integer" => '"int" - t="real" => '"float" - t="logical" => '"int" - t="character" => ['"char",1] - t="complex" => ['"float",2] --'"Complex" -- we use our own typedef - t="double complex" => ['"double",2] --'"DComplex" -- we use our own typedef - error ['"Unrecognised Fortran type: ",t] - -XDRFun t == - LISTP(ty := SECOND t) => - if first(ty)='"char" then '"wrapstring" else '"array" - ty - -printDec(type,dec,asps,fp) == - wt(['" ",if LISTP(type) then first(type) else type,'" "],fp) - member(dec,asps) => - if $addUnderscoreToFortranNames then - wl([dec,STRING(95),'"();"],fp) - else - wl([dec,'"();"],fp) - LISTP(type) => - wl(['"*",dec,'" = NULL;"],fp) - wl(['" u__int ",dec, '"__length = 0;"],fp) - type = '"char" => - wl(['"*",dec,'" = NULL;"],fp) - wl([dec, '";"],fp) - -writeXDR(v,str,fp) == - -- Generate the calls to the filters which will read from the temp - -- file. The CHECK macro ensures that the translation worked. - underscore := STRING CHAR("__:",0) -- to avoid a compiler bug which won't - -- parse " ... __" properly. - wt(['" CHECK(xdr",underscore, XDRFun(v), '"(", str, '",&", first(v)],fp) - if (LISTP (ty :=SECOND v)) and not EQUAL(first ty,'"char") then - wt(['",&",first(v),'"__length,MAX__ARRAY(",first(v),'"__length),"],fp) - wt(['"sizeof(",first(ty),'"),xdr",underscore,first ty],fp) - wl(['"));"],fp) - -prefix2Infix(l) == - atom(l) => [l] - #l=2 => [first l,"(",:prefix2Infix SECOND l,")"] - #l=3 => ["(",:prefix2Infix SECOND l,first l,:prefix2Infix THIRD l,")"] - error '"Function in array dimensions with more than two arguments" - -writeMalloc(name,type,dims,fp) == - -- Write out a malloc for array arguments - -- Need the size as well - wl(['" ",name,'"__length=",prefix2Infix first dims,:[:["*",:prefix2Infix u] - for u in rest dims],'";"], fp) - type = '"char" => - wl(['" ",name,'"=(",type," *)malloc((1+",name, - '"__length)*sizeof(",type,'"));"],fp) - wl(['" ",name,'"=(",type," *)malloc(",name, - '"__length*sizeof(",type,'"));"],fp) - -wl (l,fp) == - for u in l repeat PRINC(u,fp) - TERPRI(fp) - -wt (l,fp) == - for u in l repeat PRINC(u,fp) - --- spadRecordType(v,decs) == --- -- Build a lisp representation of the declaration of a spad record. --- -- This will be the returned type of the spad function which calls the --- -- Fortran code. --- ["Record",:[spadRecordType1(u,decs) for u in v]] --- --- spadRecordType1(u,decls) == --- -- Create a list of the form '( |:| u ) --- [":",u,spadTypeTTT getFortranType(u,decls)] - -spadTypeTTT u == - -- Return the spad domain equivalent to the given Fortran type. - -- Changed by MCD 8/4/94 to reflect correct format for domains in - -- current system. - LISTP u => - first(u)="character" => ["String"] - first(u)="logical" and #u=2 => ["List",["Boolean"]] - first(u)="logical" => ["List",["List",["Boolean"]]] - #u=2 => ["Matrix",spadTypeTTT first u] - #u=3 => ["Matrix",spadTypeTTT first u] - #u=4 => ["ThreeDimensionalMatrix",spadTypeTTT first u] - error '"Can only handle one-, two- and three-dimensional matrices" - u = "double" => ["DoubleFloat"] - u = "double precision" => ["DoubleFloat"] - u = "real" => ["DoubleFloat"] - u = "integer" => ["Integer"] - u = "logical" => ["Boolean"] - u = "character" => ["String"] - u = "complex" => ["Complex",["DoubleFloat"]] - u = "double complex" => ["Complex",["DoubleFloat"]] - error ['"Unrecognised Fortran type: ",u] - -mkQuote l == - [addQuote(u)for u in l] where - addQuote u == - atom u => ['QUOTE,u] - ["construct",:[addQuote(v) for v in u]] - -makeLispList(l) == - outputList := [] - for u in l repeat - outputList := [:outputList, _ - if atom(u) then ['QUOTE,u] else [["$elt","Lisp","construct"],_ - :makeLispList(u)]] - outputList - -makeSpadFun(name,userArgs,args,dummies,decls,results,returnType,asps,aspInfo, - file) == - -- Create an interpreter function for the user to call. - - fType := ["List", ["Record" , [":","key","Symbol"], [":","entry","Any"]]] - - -- To make sure the spad interpreter isn't confused: - if returnType then - returnName := INTERN STRCONC(name,"Result") - decls := [[returnType,returnName], :decls] - results := [returnName, :results] - argNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in userArgs] - aType := [axiomType(a,decls,asps,aspInfo) for a in userArgs] - aspTypes := [SECOND NTH(POSITION(u,userArgs),aType) for u in asps] - nilLst := MAKE_-LIST(#args+1) - decPar := [["$elt","Lisp","construct"],:makeLispList decls] - fargNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in args | - not (MEMQ(u,dummies) or MEMQ(u,asps)) ] - for u in asps repeat - fargNames := delete(INTERN STRCONC(STRINGIMAGE(u),'"__arg"),fargNames) - resPar := ["construct",["@",["construct",:fargNames],_ - ["List",["Any"]]]] - call := [["$elt","Lisp","invokeFortran"],STRCONC(file,".spadexe"),_ - [["$elt","Lisp","construct"],:mkQuote args],_ - [["$elt","Lisp","construct"],:mkQuote union(asps,dummies)], decPar,_ - [["$elt","Lisp","construct"],:mkQuote results],resPar] - if asps then - -- Make a unique(ish) id for asp files - aspId := STRCONC(getEnv('"SPADNUM"), GENTEMP('"NAG")) - body := ["SEQ",:makeAspGenerators(asps,aspTypes,aspId),_ - makeCompilation(asps,file,aspId),_ - ["pretend",call,fType] ] - else - body := ["pretend",call,fType] - interpret ["DEF",[name,:argNames],["Result",:aType],nilLst,_ - [["$elt","Result","construct"],body]] - -stripNil u == - [CAR(u), ["construct",:CADR(u)], if CADDR(u) then "true" else "false"] - -makeUnion aspType == - -- The argument is the type of the asp to be generated. We would like to - -- allow the user to be able to provide a fileName as an alternative - -- argument, so this builds the Union of aspType and FileName. - ["Union",[":","fp",aspType],[":","fn","FileName"]] - -axiomType(a,decls,asps,aspInfo) == - a in asps => - entry := first [u for u in aspInfo | first(u) = a] - ftc := ["$elt","FortranType","construct"] - rc := ["$elt", _ - ["Record",[":","key","Symbol"],[":","entry","FortranType"]], _ - "construct"] - makeUnion ["FortranProgram",_ - a,_ - CADR(entry),_ - ["construct",:mkQuote CADDR entry], _ - [ ["$elt", "SymbolTable","symbolTable"],_ - ["construct",_ - :[[rc,first(v),[ftc,:stripNil rest(v)]] for v in CADDDR entry]]_ - ] ] - spadTypeTTT(getFortranType(a,decls)) - -makeAspGenerators(asps,types,aspId) == --- The code generated here will manipulate the Fortran output stack and write --- the asps out as Fortran. - [:makeAspGenerators1(u,v,aspId) for u in asps for v in types] - -makeAspGenerators1(asp,type,aspId) == - [[["$elt","FOP","pushFortranOutputStack"] ,_ - ["filename",'"",STRCONC(STRINGIMAGE asp,aspId),'"f"]] , _ - makeOutputAsFortran INTERN STRCONC(STRINGIMAGE(asp),'"__arg"), _ - [["$elt","FOP","popFortranOutputStack"]] _ - ] - -makeOutputAsFortran arg == - ["IF",["case",arg,"fn"],["outputAsFortran",[arg,"fn"]],_ - ["outputAsFortran",[arg,"fp"]] ] - -makeCompilation(asps,file,aspId) == - [["$elt","Lisp","compileAndLink"],_ - ["construct",:[STRCONC(STRINGIMAGE a,aspId,'".f") for a in asps]], _ - $fortranCompilerName,_ - STRCONC(file,'".o"),_ - STRCONC(file,'".spadexe"),_ - $fortranLibraries] - - -compileAndLink(fortFileList,fortCompiler,cFile,outFile,linkerArgs) == - SYSTEM STRCONC (fortCompiler, addSpaces fortFileList,_ - cFile, " -o ",outFile," ",linkerArgs) - -addSpaces(stringList) == - l := " " - for s in stringList repeat l := STRCONC(l,s," ") - l - -complexRows z == --- Take a list of lists of complexes (i.e. pairs of floats) and --- make them look like a Fortran vector! - [:[:pair2list(u.i) for u in z] for i in 0..#(z.0)-1] - -pair2list u == [car u,cdr u] -vec2Lists1 u == [ELT(u,i) for i in 0..#u-1] -vec2Lists u == [vec2Lists1 ELT(u,i) for i in 0..#u-1] - -spad2lisp(u) == - -- Turn complexes into arrays of floats - first first(u)="Complex" => - makeVector([makeVector([CADR u,CDDR u],'DOUBLE_-FLOAT)],NIL) - -- Turn arrays of complexes into arrays of floats so that tarnsposing - -- them puts them in the correct fortran order - first first(u)="Matrix" and first SECOND first(u) = "Complex" => - makeVector([makeVector(complexRows vec2Lists rest u,'DOUBLE_-FLOAT)],NIL) - rest(u) - -invokeFortran(objFile,args,dummies,decls,results,actual) == - actual := [spad2lisp(u) for u in first actual] - returnedValues := spadify( _ - fortCall(objFile,prepareData(args,dummies,actual,decls),_ - prepareResults(results,args,dummies,actual,decls)),_ - results,decls,inFirstNotSecond(args,dummies),actual) - --- -- If there are one or two elements in returnedValues we must return a --- -- cons cell, otherwise a vector. This is to match the internal --- -- representation of an Axiom Record. --- #returnedValues = 1 => returnedValues --- #returnedValues = 2 => CONS(first returnedValues,SECOND returnedValues) --- makeVector(returnedValues,nil) - -int2Bool u == - -- Return something which looks like an axiom boolean - u=1 => "TRUE" - NIL - -makeResultRecord(name,type,value) == - -- Take an object returned by the NAG routine and make it into an AXIOM - -- object of type Record(key:Symbol,entry:Any) for use by Result. - CONS(name,CONS(spadTypeTTT type,value)) - -spadify(l,results,decls,names,actual) == - -- The elements of list l are the output forms returned from the Fortran - -- code: integers, floats and vectors. Return spad forms of these, of - -- type Record(key:Symbol,entry:Any) (for use with the Result domain). - SETQ(RESULTS,l) - spadForms := nil - for i in 0..(#l -1) repeat - fort := NTH(i,l) - name := NTH(i,results) - ty := getFortranType(name,decls) - -- Result is a string - STRINGP fort => - spadForms := [makeResultRecord(name,ty,fort), :spadForms] - -- Result is a Complex Scalar - ty in ["double complex" , "complex"] => - spadForms := [makeResultRecord(name,ty, _ - CONS(ELT(fort,0),ELT(fort,1)) ),:spadForms] - -- Result is a Complex vector or array - LISTP(ty) and first(ty) in ["double complex" , "complex"] => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - if #dims=1 then - els := [makeVector([CONS(ELT(fort,2*i),ELT(fort,2*i+1)) _ - for i in 0..(first(dims)-1)],nil)] - else if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - offset := 2*(c*first(dims)+r) - innerEls := [CONS(ELT(fort,offset),ELT(fort,offset+1)),:innerEls] - els := [makeVector(NREVERSE innerEls,nil),:els] - else - error ['"Can't cope with complex output dimensions higher than 2"] - spadForms := [makeResultRecord(name,ty,makeVector(NREVERSE els,nil)), - :spadForms] - -- Result is a Boolean vector or array - LISTP(ty) and first(ty)="logical" and #ty=2 => - dim := getVal(first rest ty,names,actual) - spadForms := [makeResultRecord(name,ty,_ - [int2Bool ELT(fort,i) for i in 0..dim-1]), :spadForms] - LISTP(ty) and first(ty)="logical" => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - innerEls := [int2Bool ELT(fort,c*first(dims)+r),:innerEls] - els := [NREVERSE innerEls,:els] - else - error ['"Can't cope with logical output dimensions higher than 2"] - spadForms := [makeResultRecord(name,ty,NREVERSE els), :spadForms] - -- Result is a vector or array - VECTORP fort => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - -- Check to see whether we are dealing with a dummy (0-dimensional) array. - if MEMQ(0,dims) then - els := [[]] - else if #dims=1 then - els := [makeVector([ELT(fort,i) for i in 0..(first(dims)-1)],nil)] - else if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - innerEls := [ELT(fort,c*first(dims)+r),:innerEls] - els := [makeVector(NREVERSE innerEls,nil),:els] - else if #dims=3 then - iDim := first(dims) - jDim := SECOND dims - kDim := THIRD dims - for r in 0..(iDim - 1) repeat - middleEls := nil - for c in 0..(jDim - 1) repeat - innerEls := nil - for p in 0..(kDim - 1) repeat - offset := p*jDim + c*kDim + r - innerEls := [ELT(fort,offset),:innerEls] - middleEls := [makeVector(NREVERSE innerEls,nil),:middleEls] - els := [makeVector(NREVERSE middleEls,nil),:els] - else - error ['"Can't cope with output dimensions higher than 3"] - if not MEMQ(0,dims) then els := makeVector(NREVERSE els,nil) - spadForms := [makeResultRecord(name,ty,els), :spadForms] - -- Result is a Boolean Scalar - atom fort and ty="logical" => - spadForms := [makeResultRecord(name,ty,int2Bool fort), :spadForms] - -- Result is a Scalar - atom fort => - spadForms := [makeResultRecord(name,ty,fort),:spadForms] - error ['"Unrecognised output format: ",fort] - NREVERSE spadForms - -lispType u == - -- Return the lisp type equivalent to the given Fortran type. - LISTP u => lispType first u - u = "real" => "SHORT-FLOAT" - u = "double" => "DOUBLE-FLOAT" - u = "double precision" => "DOUBLE-FLOAT" - u = "integer" => "FIXNUM" - u = "logical" => "BOOLEAN" - u = "character" => "CHARACTER" - u = "complex" => "SHORT-FLOAT" - u = "double complex" => "DOUBLE-FLOAT" - error ['"Unrecognised Fortran type: ",u] - -getVal(u,names,values) == - -- if u is the i'th element of names, return the i'th element of values, - -- otherwise if it is an arithmetic expression evaluate it. - NUMBERP(u) => u - LISTP(u) => eval [first(u), :[getVal(v,names,values) for v in rest u]] - (place := POSITION(u,names)) => NTH(place,values) - error ['"No value found for parameter: ",u] - - -prepareData(args,dummies,values,decls) == --- TTT: we don't --- writeData handles all the mess - [args,dummies,values,decls] - - -checkForBoolean u == - u = "BOOLEAN" => "FIXNUM" - u - -prepareResults(results,args,dummies,values,decls) == - -- Create the floating point zeros (boot doesn't like 0.0d0, 0.0D0 etc) - shortZero : fluid := COERCE(0.0,'SHORT_-FLOAT) - longZero : fluid := COERCE(0.0,'DOUBLE_-FLOAT) - data := nil - for u in results repeat - type := getFortranType(u,decls) - data := [defaultValue(type,inFirstNotSecond(args,dummies),values),:data] - where defaultValue(type,argNames,actual) == - LISTP(type) and first(type)="character" => MAKE_-STRING(1) - LISTP(type) and first(type) in ["complex","double complex"] => - makeVector( makeList( - 2*APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ - if first(type)="complex" then shortZero else longZero),_ - if first(type)="complex" then "SHORT-FLOAT" else "DOUBLE-FLOAT" ) - LISTP type => makeVector(_ - makeList( - APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ - defaultValue(first type,argNames,actual)),_ - checkForBoolean lispType first(type) ) - type = "integer" => 0 - type = "real" => shortZero - type = "double" => longZero - type = "double precision" => longZero - type = "logical" => 0 - type = "character" => MAKE_-STRING(1) - type = "complex" => makeVector([shortZero,shortZero],'SHORT_-FLOAT) - type = "double complex" => makeVector([longZero,longZero],'LONG_-FLOAT) - error ['"Unrecognised Fortran type: ",type] - NREVERSE data - --- TTT this is dead code now --- transposeVector(u,type) == --- -- Take a vector of vectors and return a single vector which is in column --- -- order (i.e. swap from C to Fortran order). --- els := nil --- rows := CAR ARRAY_-DIMENSIONS(u)-1 --- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 --- -- Could be a 3D Matrix --- if VECTORP ELT(ELT(u,0),0) then --- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 --- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(ELT(u,i),j),k),:els] --- else --- for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(u,i),j),:els] --- makeVector(NREVERSE els,type) - - -writeData(tmpFile,indata) == - -- Write the elements of the list data to a temporary file. Return the - -- name of that file. - -- - str := MAKE_-OUTSTREAM(tmpFile) - xstr := xdrOpen(str,true) - [args,dummies,values,decls] := indata - for v in values repeat - -- the two Boolean values - v = "T" => - xdrWrite(xstr,1) - NULL v => - xdrWrite(xstr,0) - -- characters - STRINGP v => - xdrWrite(xstr,v) - -- some array - VECTORP v => - rows := CAR ARRAY_-DIMENSIONS(v) - -- is it 2d or more (most likely) ? - VECTORP ELT(v,0) => - cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) - -- is it 3d ? - VECTORP ELT(ELT(v,0),0) => - planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) - -- write 3d array - xdrWrite(xstr,rows*cols*planes) - for k in 0..planes-1 repeat - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat - xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) - -- write 2d array - xdrWrite(xstr,rows*cols) - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) - -- write 1d array - xdrWrite(xstr,rows) - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) - -- this is used for lists of booleans apparently in f01 - LISTP v => - xdrWrite(xstr,LENGTH v) - for el in v repeat - if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) - -- integers - INTEGERP v => - xdrWrite(xstr,v) - -- floats - FLOATP v => - xdrWrite(xstr,v) - SHUT(str) - tmpFile - -readData(tmpFile,results) == - -- read in the results from tmpFile. The list results is a list of - -- dummy objects of the correct type which will receive the data. - str := MAKE_-INSTREAM(tmpFile) - xstr := xdrOpen(str,false) - results := [xdrRead1(xstr,r) for r in results] where - xdrRead1(x,dummy) == - VECTORP(dummy) and ZEROP(LENGTH dummy) => dummy - xdrRead(x,dummy) - SHUT(str) - results - -generateDataName()==STRCONC($fortranTmpDir,getEnv('"HOST"), - getEnv('"SPADNUM"), GENTEMP('"NAG"),'"data") -generateResultsName()==STRCONC($fortranTmpDir,getEnv('"HOST"), - getEnv('"SPADNUM"), GENTEMP('"NAG"),'"results") - - -fortCall(objFile,data,results) == - tmpFile1 := writeData(generateDataName(),data) - tmpFile2 := generateResultsName() - SYSTEM STRCONC(objFile," < ",tmpFile1," > ",tmpFile2) - results := readData(tmpFile2,results) - -- SYSTEM STRCONC("rm -f ",tmpFile1," ",tmpFile2) - PROBE_-FILE(tmpFile1) and DELETE_-FILE(tmpFile1) - PROBE_-FILE(tmpFile2) and DELETE_-FILE(tmpFile2) - results - -invokeNagman(objFiles,nfile,args,dummies,decls,results,actual) == - actual := [spad2lisp(u) for u in first actual] - result := spadify(protectedNagCall(objFiles,nfile, _ - prepareData(args,dummies,actual,decls),_ - prepareResults(results,args,dummies,actual,decls)),_ - results,decls,inFirstNotSecond(args,dummies),actual) - -- Tidy up asps - -- if objFiles then SYSTEM STRCONC("rm -f ",addSpaces objFiles) - for fn in objFiles repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) - result - - -nagCall(objFiles,nfile,data,results,tmpFiled,tmpFiler) == - nagMessagesString := - $nagMessages => '"on" - '"off" - writeData(tmpFiled,data) - toSend:=STRCONC($nagHost," ",nfile," ",tmpFiler," ",tmpFiled," ",_ - STRINGIMAGE($fortPersistence)," ", nagMessagesString," ",addSpaces objFiles) - sockSendString(8,toSend) - if sockGetInt(8)=1 then - results := readData(tmpFiler,results) - else - error ['"An error was detected while reading data: ", _ - '"perhaps an incorrect array index was given ?"] - results - -protectedNagCall(objFiles,nfile,data,results) == - errors :=true - val:=NIL - td:=generateDataName() - tr:=generateResultsName() - UNWIND_-PROTECT( (val:=nagCall(objFiles,nfile,data,results,td,tr) ;errors :=NIL), - errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) - val - - -cleanUpAfterNagman(f1,f2,listf)== - PROBE_-FILE(f1) and DELETE_-FILE(f1) - PROBE_-FILE(f2) and DELETE_-FILE(f2) - for fn in listf repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) - -sendNagmanErrorSignal()== --- excite nagman's signal handler! - sockSendSignal(8,15) - - --- Globals --- $fortranDirectory := nil --- $fortranLibraries := '"-L/usr/local/lib/f90 -lf90 -L/usr/local/lib -lnag -lm" --- $fortranTmpDir := '"/tmp/" --- $addUnderscoreToFortranNames := true --- $fortranCompilerName := '"f90" - -inFirstNotSecond(f,s)== - [i for i in f | not i in s] - --- Code for use in the Windows version of the AXIOM/NAG interface. - -multiToUnivariate f == - -- Take an AnonymousFunction, replace the bound variables by references to - -- elements of a vector, and compile it. - (first f) ^= "+->" => error "in multiToUnivariate: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - body := COPY_-TREE CADDR f - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - body := NSUBST(["elt",newVariable,index+1],vars.(index),body) - -- We want a Vector DoubleFloat -> DoubleFloat - target := [["DoubleFloat"],["Vector",["DoubleFloat"]]] - rest interpret ["ADEF",[newVariable],target,[[],[]],body] - -functionAndJacobian f == - -- Take a mapping into n functions of n variables, produce code which will - -- evaluate function and jacobian values. - (first f) ^= "+->" => error "in functionAndJacobian: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - #(vars) ^= #(CDADDR f) => - error "number of variables should equal number of functions" - funBodies := COPY_-TREE CDADDR f - jacBodies := [:[DF(f,v) for v in vars] for f in funBodies] where - DF(fn,var) == - ["@",["convert",["differentiate",fn,var]],"InputForm"] - jacBodies := CDDR interpret [["$elt",["List",["InputForm"]],"construct"],:jacBodies] - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) - jacBodies := NSUBST(["elt",newVariable,index+1],vars.(index),jacBodies) - target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]],["Integer"]] - rest interpret - ["ADEF",[newVariable,"flag"],target,[[],[],[]],_ - ["IF", ["=","flag",1],_ - ["vector",["construct",:funBodies]],_ - ["vector",["construct",:jacBodies]]]] - - -vectorOfFunctions f == - -- Take a mapping into n functions of m variables, produce code which will - -- evaluate function values. - (first f) ^= "+->" => error "in vectorOfFunctions: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - funBodies := COPY_-TREE CDADDR f - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) - target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]]] - rest interpret ["ADEF",[newVariable],target,[[],[]],["vector",["construct",:funBodies]]] - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/fortcall.lisp.pamphlet b/src/interp/fortcall.lisp.pamphlet new file mode 100644 index 0000000..3b025d4 --- /dev/null +++ b/src/interp/fortcall.lisp.pamphlet @@ -0,0 +1,2973 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp fortcall.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;makeFort(name,args,decls,results,returnType,aspInfo) == +; -- Create an executable Fortran file to call a given library function, +; -- and a stub Axiom function to process its arguments. +; -- the following is a list of objects for which values need not be +; -- passed by the user. +; dummies := [SECOND(u) for u in args | EQUAL(car u,0)] +; args := [untangle2(u) for u in args] -- lose spad Union representation +; where untangle2 u == +; atom (v := rest(u)) => v +; first(v) +; userArgs := [u for u in args | not member(u,dummies)] -- Temporary +; decls := [untangle(u) for u in decls] -- lose spad Union representation +; where untangle u == +; [if atom(rest(v)) then rest(v) else _ +; [if atom(w) then w else rest(w) for w in rest(v)] for v in u] +; makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) + +(DEFUN |makeFort,untangle2| (|u|) + (PROG (|v|) + (RETURN + (SEQ (IF (ATOM (SPADLET |v| (CDR |u|))) (EXIT |v|)) + (EXIT (CAR |v|)))))) + +(DEFUN |makeFort,untangle| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G166067) + (SPADLET G166067 NIL) + (RETURN + (DO ((G166072 |u| (CDR G166072)) (|v| NIL)) + ((OR (ATOM G166072) + (PROGN (SETQ |v| (CAR G166072)) NIL)) + (NREVERSE0 G166067)) + (SEQ (EXIT (SETQ G166067 + (CONS (IF (ATOM (CDR |v|)) (CDR |v|) + (PROG (G166082) + (SPADLET G166082 NIL) + (RETURN + (DO + ((G166087 (CDR |v|) + (CDR G166087)) + (|w| NIL)) + ((OR (ATOM G166087) + (PROGN + (SETQ |w| + (CAR G166087)) + NIL)) + (NREVERSE0 G166082)) + (SEQ + (EXIT + (SETQ G166082 + (CONS + (IF (ATOM |w|) |w| + (CDR |w|)) + G166082)))))))) + G166067))))))))))) + +(DEFUN |makeFort| + (|name| |args| |decls| |results| |returnType| |aspInfo|) + (PROG (|dummies| |userArgs|) + (RETURN + (SEQ (PROGN + (SPADLET |dummies| + (PROG (G166105) + (SPADLET G166105 NIL) + (RETURN + (DO ((G166111 |args| (CDR G166111)) + (|u| NIL)) + ((OR (ATOM G166111) + (PROGN + (SETQ |u| (CAR G166111)) + NIL)) + (NREVERSE0 G166105)) + (SEQ (EXIT (COND + ((EQL (CAR |u|) 0) + (SETQ G166105 + (CONS (SECOND |u|) + G166105)))))))))) + (SPADLET |args| + (PROG (G166121) + (SPADLET G166121 NIL) + (RETURN + (DO ((G166126 |args| (CDR G166126)) + (|u| NIL)) + ((OR (ATOM G166126) + (PROGN + (SETQ |u| (CAR G166126)) + NIL)) + (NREVERSE0 G166121)) + (SEQ (EXIT (SETQ G166121 + (CONS + (|makeFort,untangle2| |u|) + G166121)))))))) + (SPADLET |userArgs| + (PROG (G166137) + (SPADLET G166137 NIL) + (RETURN + (DO ((G166143 |args| (CDR G166143)) + (|u| NIL)) + ((OR (ATOM G166143) + (PROGN + (SETQ |u| (CAR G166143)) + NIL)) + (NREVERSE0 G166137)) + (SEQ (EXIT (COND + ((NULL + (|member| |u| |dummies|)) + (SETQ G166137 + (CONS |u| G166137)))))))))) + (SPADLET |decls| + (PROG (G166153) + (SPADLET G166153 NIL) + (RETURN + (DO ((G166158 |decls| (CDR G166158)) + (|u| NIL)) + ((OR (ATOM G166158) + (PROGN + (SETQ |u| (CAR G166158)) + NIL)) + (NREVERSE0 G166153)) + (SEQ (EXIT (SETQ G166153 + (CONS (|makeFort,untangle| |u|) + G166153)))))))) + (|makeFort1| |name| |args| |userArgs| |dummies| |decls| + |results| |returnType| |aspInfo|)))))) + +;makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) == +; asps := [first(u) for u in aspInfo] +; -- Now reorder the arguments so that all the scalars come first, so +; -- that when we come to deal with arrays we know all the dimensions. +; scalarArgs := [u for u in args | atom getFortranType(u,decls)] +; arrayArgs := [u for u in args | not member(u,scalarArgs)] +; orderedArgs := [:scalarArgs,:arrayArgs] +; file := if $fortranDirectory then +; STRCONC($fortranDirectory,"/",STRINGIMAGE name) +; else +; STRINGIMAGE name +; makeFortranFun(name,orderedArgs,args,dummies,decls,results,file, +; $fortranDirectory,returnType,asps) +; makeSpadFun(name,userArgs,orderedArgs,dummies,decls,results,returnType,asps, +; aspInfo,file) +; name + +(DEFUN |makeFort1| + (|name| |args| |userArgs| |dummies| |decls| |results| + |returnType| |aspInfo|) + (PROG (|asps| |scalarArgs| |arrayArgs| |orderedArgs| |file|) + (RETURN + (SEQ (PROGN + (SPADLET |asps| + (PROG (G166180) + (SPADLET G166180 NIL) + (RETURN + (DO ((G166185 |aspInfo| (CDR G166185)) + (|u| NIL)) + ((OR (ATOM G166185) + (PROGN + (SETQ |u| (CAR G166185)) + NIL)) + (NREVERSE0 G166180)) + (SEQ (EXIT (SETQ G166180 + (CONS (CAR |u|) G166180)))))))) + (SPADLET |scalarArgs| + (PROG (G166196) + (SPADLET G166196 NIL) + (RETURN + (DO ((G166202 |args| (CDR G166202)) + (|u| NIL)) + ((OR (ATOM G166202) + (PROGN + (SETQ |u| (CAR G166202)) + NIL)) + (NREVERSE0 G166196)) + (SEQ (EXIT (COND + ((ATOM + (|getFortranType| |u| + |decls|)) + (SETQ G166196 + (CONS |u| G166196)))))))))) + (SPADLET |arrayArgs| + (PROG (G166213) + (SPADLET G166213 NIL) + (RETURN + (DO ((G166219 |args| (CDR G166219)) + (|u| NIL)) + ((OR (ATOM G166219) + (PROGN + (SETQ |u| (CAR G166219)) + NIL)) + (NREVERSE0 G166213)) + (SEQ (EXIT (COND + ((NULL + (|member| |u| |scalarArgs|)) + (SETQ G166213 + (CONS |u| G166213)))))))))) + (SPADLET |orderedArgs| (APPEND |scalarArgs| |arrayArgs|)) + (SPADLET |file| + (COND + (|$fortranDirectory| + (STRCONC |$fortranDirectory| '/ + (STRINGIMAGE |name|))) + ('T (STRINGIMAGE |name|)))) + (|makeFortranFun| |name| |orderedArgs| |args| |dummies| + |decls| |results| |file| |$fortranDirectory| + |returnType| |asps|) + (|makeSpadFun| |name| |userArgs| |orderedArgs| |dummies| + |decls| |results| |returnType| |asps| |aspInfo| + |file|) + |name|))))) + +;makeFortranFun(name,args,fortranArgs,dummies,decls,results,file,dir, +; returnType,asps) == +; -- Create a C file to call the library function, and compile it. +; fp := MAKE_-OUTSTREAM(STRCONC(file,".c")) +; writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) +; if null dir then dir := '"." +; asps => SYSTEM STRCONC("cc -c ",file,".c ; mv ",file,".o ",dir) +; SYSTEM STRCONC("cc ",file,".c -o ",file,".spadexe ",$fortranLibraries) + +(DEFUN |makeFortranFun| + (|name| |args| |fortranArgs| |dummies| |decls| |results| |file| + |dir| |returnType| |asps|) + (PROG (|fp|) + (RETURN + (PROGN + (SPADLET |fp| + (MAKE-OUTSTREAM (STRCONC |file| (INTERN ".c" "BOOT")))) + (|writeCFile| |name| |args| |fortranArgs| |dummies| |decls| + |results| |returnType| |asps| |fp|) + (COND ((NULL |dir|) (SPADLET |dir| (MAKESTRING ".")))) + (COND + (|asps| (SYSTEM (STRCONC '|cc -c | |file| + (INTERN ".c ; mv " "BOOT") |file| + (INTERN ".o " "BOOT") |dir|))) + ('T + (SYSTEM (STRCONC '|cc | |file| (INTERN ".c -o " "BOOT") + |file| (INTERN ".spadexe " "BOOT") + |$fortranLibraries|)))))))) + +;writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) == +; WRITE_-LINE('"#include ",fp) +; WRITE_-LINE('"#include ",fp) +; WRITE_-LINE('"#include ",fp) +; WRITE_-LINE('"#ifndef NULL",fp) +; WRITE_-LINE('"#define NULL 0",fp) +; WRITE_-LINE('"#endif NULL",fp) +; WRITE_-LINE('"#define MAX__ARRAY(x) (x ? x : 20000)",fp) +; WRITE_-LINE('"#define CHECK(x) if (!x) {fprintf(stderr,_"xdr failed_"); exit(1);}",fp) +; WRITE_-LINE('"void main()",fp) +; WRITE_-LINE('"{",fp) +; WRITE_-LINE('" XDR xdrs;",fp) +; WRITE_-LINE('" {",fp) +; if $addUnderscoreToFortranNames then +; routineName := STRCONC(name,STRING(95)) +; else +; routineName := name +; -- If it is a function then give it somewhere to stick its result: +; if returnType then +; returnName := INTERN STRCONC(name,"__result") +; wl(['" ",getCType returnType,'" ",returnName,'",",routineName,'"();"],fp) +; -- print out type declarations for the Fortran parameters, and build an +; -- ordered list of pairs [ , ] +; argList := nil +; for a in args repeat +; argList := [[a, getCType getFortranType(a,decls)], :argList] +; printDec(SECOND first argList,a,asps,fp) +; argList := nreverse argList; +; -- read in the data +; WRITE_-LINE('" xdrstdio__create(&xdrs, stdin, XDR__DECODE);",fp) +; for a in argList repeat +; if LISTP SECOND a then writeMalloc(first a,first SECOND a,rest SECOND a,fp) +; not MEMQ(first a,[:dummies,:asps]) => writeXDR(a,'"&xdrs",fp) +; -- now call the Library routine. FORTRAN names may have an underscore +; -- appended. +; if returnType then +; wt(['" ",returnName,'"="],fp) +; else +; wt(['" "],fp) +; wt([routineName,'"("],fp) +; if first fortranArgs then +; printCName(first fortranArgs,isPointer?(first fortranArgs,decls),asps,fp) +; for a in rest fortranArgs repeat +; PRINC('",",fp) +; printCName(a,isPointer?(a,decls),asps,fp) +; writeStringLengths(fortranArgs,decls,fp) +; WRITE_-LINE('");",fp) +; -- now export the results. +; WRITE_-LINE('" xdrstdio__create(&xdrs, stdout, XDR__ENCODE);",fp) +; if returnType then +; writeXDR([returnName,getCType returnType],'"&xdrs",fp) +; for r in results repeat +; writeXDR([r,getCType getFortranType(r,decls)],'"&xdrs",fp) +; WRITE_-LINE('" exit(0);",fp) +; WRITE_-LINE('" }",fp) +; WRITE_-LINE('"}",fp) + +(DEFUN |writeCFile| + (|name| |args| |fortranArgs| |dummies| |decls| |results| + |returnType| |asps| |fp|) + (PROG (|routineName| |returnName| |argList|) + (RETURN + (SEQ (PROGN + (WRITE-LINE (MAKESTRING "#include ") |fp|) + (WRITE-LINE (MAKESTRING "#include ") |fp|) + (WRITE-LINE (MAKESTRING "#include ") |fp|) + (WRITE-LINE (MAKESTRING "#ifndef NULL") |fp|) + (WRITE-LINE (MAKESTRING "#define NULL 0") |fp|) + (WRITE-LINE (MAKESTRING "#endif NULL") |fp|) + (WRITE-LINE + (MAKESTRING "#define MAX_ARRAY(x) (x ? x : 20000)") + |fp|) + (WRITE-LINE + (MAKESTRING + "#define CHECK(x) if (!x) {fprintf(stderr,\"xdr failed\"); exit(1);}") + |fp|) + (WRITE-LINE (MAKESTRING "void main()") |fp|) + (WRITE-LINE (MAKESTRING "{") |fp|) + (WRITE-LINE (MAKESTRING " XDR xdrs;") |fp|) + (WRITE-LINE (MAKESTRING " {") |fp|) + (COND + (|$addUnderscoreToFortranNames| + (SPADLET |routineName| (STRCONC |name| (STRING 95)))) + ('T (SPADLET |routineName| |name|))) + (COND + (|returnType| + (SPADLET |returnName| + (INTERN (STRCONC |name| '|_result|))) + (|wl| (CONS (MAKESTRING " ") + (CONS (|getCType| |returnType|) + (CONS (MAKESTRING " ") + (CONS |returnName| + (CONS (MAKESTRING ",") + (CONS |routineName| + (CONS (MAKESTRING "();") NIL))))))) + |fp|))) + (SPADLET |argList| NIL) + (DO ((G166252 |args| (CDR G166252)) (|a| NIL)) + ((OR (ATOM G166252) + (PROGN (SETQ |a| (CAR G166252)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |argList| + (CONS + (CONS |a| + (CONS + (|getCType| + (|getFortranType| |a| |decls|)) + NIL)) + |argList|)) + (|printDec| (SECOND (CAR |argList|)) |a| + |asps| |fp|))))) + (SPADLET |argList| (NREVERSE |argList|)) + (WRITE-LINE + (MAKESTRING + " xdrstdio_create(&xdrs, stdin, XDR_DECODE);") + |fp|) + (DO ((G166263 |argList| (CDR G166263)) (|a| NIL)) + ((OR (ATOM G166263) + (PROGN (SETQ |a| (CAR G166263)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (COND + ((LISTP (SECOND |a|)) + (|writeMalloc| (CAR |a|) + (CAR (SECOND |a|)) + (CDR (SECOND |a|)) |fp|))) + (COND + ((NULL (MEMQ (CAR |a|) + (APPEND |dummies| |asps|))) + (|writeXDR| |a| (MAKESTRING "&xdrs") + |fp|))))))) + (COND + (|returnType| + (|wt| (CONS (MAKESTRING " ") + (CONS |returnName| + (CONS (MAKESTRING "=") NIL))) + |fp|)) + ('T (|wt| (CONS (MAKESTRING " ") NIL) |fp|))) + (|wt| (CONS |routineName| (CONS (MAKESTRING "(") NIL)) + |fp|) + (COND + ((CAR |fortranArgs|) + (|printCName| (CAR |fortranArgs|) + (|isPointer?| (CAR |fortranArgs|) |decls|) |asps| + |fp|))) + (DO ((G166274 (CDR |fortranArgs|) (CDR G166274)) + (|a| NIL)) + ((OR (ATOM G166274) + (PROGN (SETQ |a| (CAR G166274)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (PRINC (MAKESTRING ",") |fp|) + (|printCName| |a| + (|isPointer?| |a| |decls|) |asps| |fp|))))) + (|writeStringLengths| |fortranArgs| |decls| |fp|) + (WRITE-LINE (MAKESTRING ");") |fp|) + (WRITE-LINE + (MAKESTRING + " xdrstdio_create(&xdrs, stdout, XDR_ENCODE);") + |fp|) + (COND + (|returnType| + (|writeXDR| + (CONS |returnName| + (CONS (|getCType| |returnType|) NIL)) + (MAKESTRING "&xdrs") |fp|))) + (DO ((G166283 |results| (CDR G166283)) (|r| NIL)) + ((OR (ATOM G166283) + (PROGN (SETQ |r| (CAR G166283)) NIL)) + NIL) + (SEQ (EXIT (|writeXDR| + (CONS |r| + (CONS + (|getCType| + (|getFortranType| |r| |decls|)) + NIL)) + (MAKESTRING "&xdrs") |fp|)))) + (WRITE-LINE (MAKESTRING " exit(0);") |fp|) + (WRITE-LINE (MAKESTRING " }") |fp|) + (WRITE-LINE (MAKESTRING "}") |fp|)))))) + +;writeStringLengths(fortranArgs,decls,fp) == +; for a in fortranArgs repeat +; if isString?(a,decls) then wt(['",&",a,'"__length"],fp) + +(DEFUN |writeStringLengths| (|fortranArgs| |decls| |fp|) + (SEQ (DO ((G166301 |fortranArgs| (CDR G166301)) (|a| NIL)) + ((OR (ATOM G166301) + (PROGN (SETQ |a| (CAR G166301)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|isString?| |a| |decls|) + (|wt| (CONS (MAKESTRING ",&") + (CONS |a| + (CONS (MAKESTRING "_length") NIL))) + |fp|)) + ('T NIL))))))) + +;isString?(u,decls) == +; EQUAL(ty := getFortranType(u,decls),"character") or +; LISTP(ty) and EQUAL(first ty,"character") + +(DEFUN |isString?| (|u| |decls|) + (PROG (|ty|) + (RETURN + (OR (BOOT-EQUAL (SPADLET |ty| (|getFortranType| |u| |decls|)) + '|character|) + (AND (LISTP |ty|) (BOOT-EQUAL (CAR |ty|) '|character|)))))) + +;isPointer?(u,decls) == +; ty := getFortranType(u,decls) +; LISTP(ty) or ty in ["character","complex","double complex"] + +(DEFUN |isPointer?| (|u| |decls|) + (PROG (|ty|) + (RETURN + (PROGN + (SPADLET |ty| (|getFortranType| |u| |decls|)) + (OR (LISTP |ty|) + (|member| |ty| + (CONS '|character| + (CONS '|complex| (CONS '|double complex| NIL))))))))) + +;printCName(u,ispointer,asps,fp) == +; member(u,asps) => +; PRINC(u,fp) +; if $addUnderscoreToFortranNames then PRINC(STRING(95),fp) +; if not ispointer then PRINC('"&",fp) +; PRINC(u,fp) + +(DEFUN |printCName| (|u| |ispointer| |asps| |fp|) + (COND + ((|member| |u| |asps|) (PRINC |u| |fp|) + (COND + (|$addUnderscoreToFortranNames| (PRINC (STRING 95) |fp|)) + ('T NIL))) + ('T (COND ((NULL |ispointer|) (PRINC (MAKESTRING "&") |fp|))) + (PRINC |u| |fp|)))) + +;getFortranType(u,decls) == +; -- find u in decls, return the given (Fortran) type. +; result := nil +; for d in decls repeat for dec in rest d repeat +; atom(dec) and dec=u => +; return( result := first d ) +; LISTP(dec) and first(dec)=u => +; return( result := [first d,:rest dec] ) +; result => result +; error ['"Undeclared Fortran parameter: ",u] + +(DEFUN |getFortranType| (|u| |decls|) + (PROG (|result|) + (RETURN + (SEQ (PROGN + (SPADLET |result| NIL) + (DO ((G166329 |decls| (CDR G166329)) (|d| NIL)) + ((OR (ATOM G166329) + (PROGN (SETQ |d| (CAR G166329)) NIL)) + NIL) + (SEQ (EXIT (DO ((G166338 (CDR |d|) (CDR G166338)) + (|dec| NIL)) + ((OR (ATOM G166338) + (PROGN + (SETQ |dec| (CAR G166338)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (ATOM |dec|) + (BOOT-EQUAL |dec| |u|)) + (RETURN + (SPADLET |result| + (CAR |d|)))) + ((AND (LISTP |dec|) + (BOOT-EQUAL (CAR |dec|) |u|)) + (RETURN + (SPADLET |result| + (CONS (CAR |d|) + (CDR |dec|)))))))))))) + (COND + (|result| |result|) + ('T + (|error| (CONS (MAKESTRING + "Undeclared Fortran parameter: ") + (CONS |u| NIL)))))))))) + +;getCType t == +; -- Return the equivalent C type. +; LISTP(t) => +; --[if first(t)="character" then '"char" else getCType first t,:rest t] +; first(t)="character" => ['"char",:rest t] +; first(t)="complex" => ['"float",2,:rest t] +; first(t)="double complex" => ['"double",2,:rest t] +; [getCType first t,:rest t] +; t="double" => '"double" +; t="double precision" => '"double" +; t="integer" => '"int" +; t="real" => '"float" +; t="logical" => '"int" +; t="character" => ['"char",1] +; t="complex" => ['"float",2] --'"Complex" -- we use our own typedef +; t="double complex" => ['"double",2] --'"DComplex" -- we use our own typedef +; error ['"Unrecognised Fortran type: ",t] + +(DEFUN |getCType| (|t|) + (COND + ((LISTP |t|) + (COND + ((BOOT-EQUAL (CAR |t|) '|character|) + (CONS (MAKESTRING "char") (CDR |t|))) + ((BOOT-EQUAL (CAR |t|) '|complex|) + (CONS (MAKESTRING "float") (CONS 2 (CDR |t|)))) + ((BOOT-EQUAL (CAR |t|) '|double complex|) + (CONS (MAKESTRING "double") (CONS 2 (CDR |t|)))) + ('T (CONS (|getCType| (CAR |t|)) (CDR |t|))))) + ((BOOT-EQUAL |t| '|double|) (MAKESTRING "double")) + ((BOOT-EQUAL |t| '|double precision|) (MAKESTRING "double")) + ((BOOT-EQUAL |t| '|integer|) (MAKESTRING "int")) + ((BOOT-EQUAL |t| '|real|) (MAKESTRING "float")) + ((BOOT-EQUAL |t| '|logical|) (MAKESTRING "int")) + ((BOOT-EQUAL |t| '|character|) + (CONS (MAKESTRING "char") (CONS 1 NIL))) + ((BOOT-EQUAL |t| '|complex|) + (CONS (MAKESTRING "float") (CONS 2 NIL))) + ((BOOT-EQUAL |t| '|double complex|) + (CONS (MAKESTRING "double") (CONS 2 NIL))) + ('T + (|error| (CONS (MAKESTRING "Unrecognised Fortran type: ") + (CONS |t| NIL)))))) + +;XDRFun t == +; LISTP(ty := SECOND t) => +; if first(ty)='"char" then '"wrapstring" else '"array" +; ty + +(DEFUN |XDRFun| (|t|) + (PROG (|ty|) + (RETURN + (COND + ((LISTP (SPADLET |ty| (SECOND |t|))) + (COND + ((BOOT-EQUAL (CAR |ty|) (MAKESTRING "char")) + (MAKESTRING "wrapstring")) + ('T (MAKESTRING "array")))) + ('T |ty|))))) + +;printDec(type,dec,asps,fp) == +; wt(['" ",if LISTP(type) then first(type) else type,'" "],fp) +; member(dec,asps) => +; if $addUnderscoreToFortranNames then +; wl([dec,STRING(95),'"();"],fp) +; else +; wl([dec,'"();"],fp) +; LISTP(type) => +; wl(['"*",dec,'" = NULL;"],fp) +; wl(['" u__int ",dec, '"__length = 0;"],fp) +; type = '"char" => +; wl(['"*",dec,'" = NULL;"],fp) +; wl([dec, '";"],fp) + +(DEFUN |printDec| (|type| |dec| |asps| |fp|) + (PROGN + (|wt| (CONS (MAKESTRING " ") + (CONS (COND ((LISTP |type|) (CAR |type|)) ('T |type|)) + (CONS (MAKESTRING " ") NIL))) + |fp|) + (COND + ((|member| |dec| |asps|) + (COND + (|$addUnderscoreToFortranNames| + (|wl| (CONS |dec| + (CONS (STRING 95) + (CONS (MAKESTRING "();") NIL))) + |fp|)) + ('T (|wl| (CONS |dec| (CONS (MAKESTRING "();") NIL)) |fp|)))) + ((LISTP |type|) + (|wl| (CONS (MAKESTRING "*") + (CONS |dec| (CONS (MAKESTRING " = NULL;") NIL))) + |fp|) + (|wl| (CONS (MAKESTRING " u_int ") + (CONS |dec| (CONS (MAKESTRING "_length = 0;") NIL))) + |fp|)) + ((BOOT-EQUAL |type| (MAKESTRING "char")) + (|wl| (CONS (MAKESTRING "*") + (CONS |dec| (CONS (MAKESTRING " = NULL;") NIL))) + |fp|)) + ('T (|wl| (CONS |dec| (CONS (MAKESTRING ";") NIL)) |fp|))))) + +;writeXDR(v,str,fp) == +; -- Generate the calls to the filters which will read from the temp +; -- file. The CHECK macro ensures that the translation worked. +; underscore := STRING CHAR("__:",0) -- to avoid a compiler bug which won't +; -- parse " ... __" properly. +; wt(['" CHECK(xdr",underscore, XDRFun(v), '"(", str, '",&", first(v)],fp) +; if (LISTP (ty :=SECOND v)) and not EQUAL(first ty,'"char") then +; wt(['",&",first(v),'"__length,MAX__ARRAY(",first(v),'"__length),"],fp) +; wt(['"sizeof(",first(ty),'"),xdr",underscore,first ty],fp) +; wl(['"));"],fp) + +(DEFUN |writeXDR| (|v| |str| |fp|) + (PROG (|underscore| |ty|) + (RETURN + (PROGN + (SPADLET |underscore| (STRING (CHAR '|_:| 0))) + (|wt| (CONS (MAKESTRING " CHECK(xdr") + (CONS |underscore| + (CONS (|XDRFun| |v|) + (CONS (MAKESTRING "(") + (CONS |str| + (CONS (MAKESTRING ",&") + (CONS (CAR |v|) NIL))))))) + |fp|) + (COND + ((AND (LISTP (SPADLET |ty| (SECOND |v|))) + (NULL (BOOT-EQUAL (CAR |ty|) (MAKESTRING "char")))) + (|wt| (CONS (MAKESTRING ",&") + (CONS (CAR |v|) + (CONS (MAKESTRING "_length,MAX_ARRAY(") + (CONS (CAR |v|) + (CONS (MAKESTRING "_length),") NIL))))) + |fp|) + (|wt| (CONS (MAKESTRING "sizeof(") + (CONS (CAR |ty|) + (CONS (MAKESTRING "),xdr") + (CONS |underscore| + (CONS (CAR |ty|) NIL))))) + |fp|))) + (|wl| (CONS (MAKESTRING "));") NIL) |fp|))))) + +;prefix2Infix(l) == +; atom(l) => [l] +; #l=2 => [first l,"(",:prefix2Infix SECOND l,")"] +; #l=3 => ["(",:prefix2Infix SECOND l,first l,:prefix2Infix THIRD l,")"] +; error '"Function in array dimensions with more than two arguments" + +(DEFUN |prefix2Infix| (|l|) + (COND + ((ATOM |l|) (CONS |l| NIL)) + ((EQL (|#| |l|) 2) + (CONS (CAR |l|) + (CONS '|(| + (APPEND (|prefix2Infix| (SECOND |l|)) (CONS '|)| NIL))))) + ((EQL (|#| |l|) 3) + (CONS '|(| + (APPEND (|prefix2Infix| (SECOND |l|)) + (CONS (CAR |l|) + (APPEND (|prefix2Infix| (THIRD |l|)) + (CONS '|)| NIL)))))) + ('T + (|error| (MAKESTRING + "Function in array dimensions with more than two arguments"))))) + +;writeMalloc(name,type,dims,fp) == +; -- Write out a malloc for array arguments +; -- Need the size as well +; wl(['" ",name,'"__length=",prefix2Infix first dims,:[:["*",:prefix2Infix u] +; for u in rest dims],'";"], fp) +; type = '"char" => +; wl(['" ",name,'"=(",type," *)malloc((1+",name, +; '"__length)*sizeof(",type,'"));"],fp) +; wl(['" ",name,'"=(",type," *)malloc(",name, +; '"__length*sizeof(",type,'"));"],fp) + +(DEFUN |writeMalloc| (|name| |type| |dims| |fp|) + (PROG () + (RETURN + (SEQ (PROGN + (|wl| (CONS (MAKESTRING " ") + (CONS |name| + (CONS (MAKESTRING "_length=") + (CONS + (|prefix2Infix| (CAR |dims|)) + (APPEND + (PROG (G166377) + (SPADLET G166377 NIL) + (RETURN + (DO + ((G166382 (CDR |dims|) + (CDR G166382)) + (|u| NIL)) + ((OR (ATOM G166382) + (PROGN + (SETQ |u| + (CAR G166382)) + NIL)) + G166377) + (SEQ + (EXIT + (SETQ G166377 + (APPEND G166377 + (CONS '* + (|prefix2Infix| |u|))))))))) + (CONS (MAKESTRING ";") NIL)))))) + |fp|) + (COND + ((BOOT-EQUAL |type| (MAKESTRING "char")) + (|wl| (CONS (MAKESTRING " ") + (CONS |name| + (CONS (MAKESTRING "=(") + (CONS |type| + (CONS '| *)malloc((1+| + (CONS |name| + (CONS + (MAKESTRING + "_length)*sizeof(") + (CONS |type| + (CONS (MAKESTRING "));") + NIL))))))))) + |fp|)) + ('T + (|wl| (CONS (MAKESTRING " ") + (CONS |name| + (CONS (MAKESTRING "=(") + (CONS |type| + (CONS '| *)malloc(| + (CONS |name| + (CONS + (MAKESTRING + "_length*sizeof(") + (CONS |type| + (CONS (MAKESTRING "));") + NIL))))))))) + |fp|)))))))) + +;wl (l,fp) == +; for u in l repeat PRINC(u,fp) +; TERPRI(fp) + +(DEFUN |wl| (|l| |fp|) + (SEQ (PROGN + (DO ((G166396 |l| (CDR G166396)) (|u| NIL)) + ((OR (ATOM G166396) + (PROGN (SETQ |u| (CAR G166396)) NIL)) + NIL) + (SEQ (EXIT (PRINC |u| |fp|)))) + (TERPRI |fp|)))) + +;wt (l,fp) == +; for u in l repeat PRINC(u,fp) + +(DEFUN |wt| (|l| |fp|) + (SEQ (DO ((G166408 |l| (CDR G166408)) (|u| NIL)) + ((OR (ATOM G166408) + (PROGN (SETQ |u| (CAR G166408)) NIL)) + NIL) + (SEQ (EXIT (PRINC |u| |fp|)))))) + +;-- spadRecordType(v,decs) == +;-- -- Build a lisp representation of the declaration of a spad record. +;-- -- This will be the returned type of the spad function which calls the +;-- -- Fortran code. +;-- ["Record",:[spadRecordType1(u,decs) for u in v]] +;-- +;-- spadRecordType1(u,decls) == +;-- -- Create a list of the form '( |:| u ) +;-- [":",u,spadTypeTTT getFortranType(u,decls)] +;spadTypeTTT u == +; -- Return the spad domain equivalent to the given Fortran type. +; -- Changed by MCD 8/4/94 to reflect correct format for domains in +; -- current system. +; LISTP u => +; first(u)="character" => ["String"] +; first(u)="logical" and #u=2 => ["List",["Boolean"]] +; first(u)="logical" => ["List",["List",["Boolean"]]] +; #u=2 => ["Matrix",spadTypeTTT first u] +; #u=3 => ["Matrix",spadTypeTTT first u] +; #u=4 => ["ThreeDimensionalMatrix",spadTypeTTT first u] +; error '"Can only handle one-, two- and three-dimensional matrices" +; u = "double" => ["DoubleFloat"] +; u = "double precision" => ["DoubleFloat"] +; u = "real" => ["DoubleFloat"] +; u = "integer" => ["Integer"] +; u = "logical" => ["Boolean"] +; u = "character" => ["String"] +; u = "complex" => ["Complex",["DoubleFloat"]] +; u = "double complex" => ["Complex",["DoubleFloat"]] +; error ['"Unrecognised Fortran type: ",u] + +(DEFUN |spadTypeTTT| (|u|) + (COND + ((LISTP |u|) + (COND + ((BOOT-EQUAL (CAR |u|) '|character|) (CONS '|String| NIL)) + ((AND (BOOT-EQUAL (CAR |u|) '|logical|) (EQL (|#| |u|) 2)) + (CONS '|List| (CONS (CONS '|Boolean| NIL) NIL))) + ((BOOT-EQUAL (CAR |u|) '|logical|) + (CONS '|List| + (CONS (CONS '|List| (CONS (CONS '|Boolean| NIL) NIL)) + NIL))) + ((EQL (|#| |u|) 2) + (CONS '|Matrix| (CONS (|spadTypeTTT| (CAR |u|)) NIL))) + ((EQL (|#| |u|) 3) + (CONS '|Matrix| (CONS (|spadTypeTTT| (CAR |u|)) NIL))) + ((EQL (|#| |u|) 4) + (CONS '|ThreeDimensionalMatrix| + (CONS (|spadTypeTTT| (CAR |u|)) NIL))) + ('T + (|error| (MAKESTRING + "Can only handle one-, two- and three-dimensional matrices"))))) + ((BOOT-EQUAL |u| '|double|) (CONS '|DoubleFloat| NIL)) + ((BOOT-EQUAL |u| '|double precision|) (CONS '|DoubleFloat| NIL)) + ((BOOT-EQUAL |u| '|real|) (CONS '|DoubleFloat| NIL)) + ((BOOT-EQUAL |u| '|integer|) (CONS '|Integer| NIL)) + ((BOOT-EQUAL |u| '|logical|) (CONS '|Boolean| NIL)) + ((BOOT-EQUAL |u| '|character|) (CONS '|String| NIL)) + ((BOOT-EQUAL |u| '|complex|) + (CONS '|Complex| (CONS (CONS '|DoubleFloat| NIL) NIL))) + ((BOOT-EQUAL |u| '|double complex|) + (CONS '|Complex| (CONS (CONS '|DoubleFloat| NIL) NIL))) + ('T + (|error| (CONS (MAKESTRING "Unrecognised Fortran type: ") + (CONS |u| NIL)))))) + +;mkQuote l == +; [addQuote(u)for u in l] where +; addQuote u == +; atom u => ['QUOTE,u] +; ["construct",:[addQuote(v) for v in u]] + +(DEFUN |mkQuote,addQuote| (|u|) + (PROG () + (RETURN + (SEQ (IF (ATOM |u|) (EXIT (CONS 'QUOTE (CONS |u| NIL)))) + (EXIT (CONS '|construct| + (PROG (G166427) + (SPADLET G166427 NIL) + (RETURN + (DO ((G166432 |u| (CDR G166432)) + (|v| NIL)) + ((OR (ATOM G166432) + (PROGN + (SETQ |v| (CAR G166432)) + NIL)) + (NREVERSE0 G166427)) + (SEQ (EXIT (SETQ G166427 + (CONS (|mkQuote,addQuote| |v|) + G166427))))))))))))) + +(DEFUN |mkQuote| (|l|) + (PROG () + (RETURN + (SEQ (PROG (G166447) + (SPADLET G166447 NIL) + (RETURN + (DO ((G166452 |l| (CDR G166452)) (|u| NIL)) + ((OR (ATOM G166452) + (PROGN (SETQ |u| (CAR G166452)) NIL)) + (NREVERSE0 G166447)) + (SEQ (EXIT (SETQ G166447 + (CONS (|mkQuote,addQuote| |u|) + G166447))))))))))) + +;makeLispList(l) == +; outputList := [] +; for u in l repeat +; outputList := [:outputList, _ +; if atom(u) then ['QUOTE,u] else [["$elt","Lisp","construct"],_ +; :makeLispList(u)]] +; outputList + +(DEFUN |makeLispList| (|l|) + (PROG (|outputList|) + (RETURN + (SEQ (PROGN + (SPADLET |outputList| NIL) + (DO ((G166466 |l| (CDR G166466)) (|u| NIL)) + ((OR (ATOM G166466) + (PROGN (SETQ |u| (CAR G166466)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |outputList| + (APPEND |outputList| + (CONS + (COND + ((ATOM |u|) + (CONS 'QUOTE (CONS |u| NIL))) + ('T + (CONS + (CONS '|$elt| + (CONS '|Lisp| + (CONS '|construct| NIL))) + (|makeLispList| |u|)))) + NIL)))))) + |outputList|))))) + +;makeSpadFun(name,userArgs,args,dummies,decls,results,returnType,asps,aspInfo, +; file) == +; -- Create an interpreter function for the user to call. +; fType := ["List", ["Record" , [":","key","Symbol"], [":","entry","Any"]]] +; -- To make sure the spad interpreter isn't confused: +; if returnType then +; returnName := INTERN STRCONC(name,"Result") +; decls := [[returnType,returnName], :decls] +; results := [returnName, :results] +; argNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in userArgs] +; aType := [axiomType(a,decls,asps,aspInfo) for a in userArgs] +; aspTypes := [SECOND NTH(POSITION(u,userArgs),aType) for u in asps] +; nilLst := MAKE_-LIST(#args+1) +; decPar := [["$elt","Lisp","construct"],:makeLispList decls] +; fargNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in args | +; not (MEMQ(u,dummies) or MEMQ(u,asps)) ] +; for u in asps repeat +; fargNames := delete(INTERN STRCONC(STRINGIMAGE(u),'"__arg"),fargNames) +; resPar := ["construct",["@",["construct",:fargNames],_ +; ["List",["Any"]]]] +; call := [["$elt","Lisp","invokeFortran"],STRCONC(file,".spadexe"),_ +; [["$elt","Lisp","construct"],:mkQuote args],_ +; [["$elt","Lisp","construct"],:mkQuote union(asps,dummies)], decPar,_ +; [["$elt","Lisp","construct"],:mkQuote results],resPar] +; if asps then +; -- Make a unique(ish) id for asp files +; aspId := STRCONC(getEnv('"SPADNUM"), GENTEMP('"NAG")) +; body := ["SEQ",:makeAspGenerators(asps,aspTypes,aspId),_ +; makeCompilation(asps,file,aspId),_ +; ["pretend",call,fType] ] +; else +; body := ["pretend",call,fType] +; interpret ["DEF",[name,:argNames],["Result",:aType],nilLst,_ +; [["$elt","Result","construct"],body]] + +(DEFUN |makeSpadFun| + (|name| |userArgs| |args| |dummies| |decls| |results| + |returnType| |asps| |aspInfo| |file|) + (PROG (|fType| |returnName| |argNames| |aType| |aspTypes| |nilLst| + |decPar| |fargNames| |resPar| |call| |aspId| |body|) + (RETURN + (SEQ (PROGN + (SPADLET |fType| + (CONS '|List| + (CONS (CONS '|Record| + (CONS + (CONS '|:| + (CONS '|key| + (CONS '|Symbol| NIL))) + (CONS + (CONS '|:| + (CONS '|entry| + (CONS '|Any| NIL))) + NIL))) + NIL))) + (COND + (|returnType| + (SPADLET |returnName| + (INTERN (STRCONC |name| '|Result|))) + (SPADLET |decls| + (CONS (CONS |returnType| + (CONS |returnName| NIL)) + |decls|)) + (SPADLET |results| (CONS |returnName| |results|)))) + (SPADLET |argNames| + (PROG (G166484) + (SPADLET G166484 NIL) + (RETURN + (DO ((G166489 |userArgs| (CDR G166489)) + (|u| NIL)) + ((OR (ATOM G166489) + (PROGN + (SETQ |u| (CAR G166489)) + NIL)) + (NREVERSE0 G166484)) + (SEQ (EXIT (SETQ G166484 + (CONS + (INTERN + (STRCONC (STRINGIMAGE |u|) + (MAKESTRING "_arg"))) + G166484)))))))) + (SPADLET |aType| + (PROG (G166499) + (SPADLET G166499 NIL) + (RETURN + (DO ((G166504 |userArgs| (CDR G166504)) + (|a| NIL)) + ((OR (ATOM G166504) + (PROGN + (SETQ |a| (CAR G166504)) + NIL)) + (NREVERSE0 G166499)) + (SEQ (EXIT (SETQ G166499 + (CONS + (|axiomType| |a| |decls| + |asps| |aspInfo|) + G166499)))))))) + (SPADLET |aspTypes| + (PROG (G166514) + (SPADLET G166514 NIL) + (RETURN + (DO ((G166519 |asps| (CDR G166519)) + (|u| NIL)) + ((OR (ATOM G166519) + (PROGN + (SETQ |u| (CAR G166519)) + NIL)) + (NREVERSE0 G166514)) + (SEQ (EXIT (SETQ G166514 + (CONS + (SECOND + (NTH + (POSITION |u| |userArgs|) + |aType|)) + G166514)))))))) + (SPADLET |nilLst| (MAKE-LIST (PLUS (|#| |args|) 1))) + (SPADLET |decPar| + (CONS (CONS '|$elt| + (CONS '|Lisp| + (CONS '|construct| NIL))) + (|makeLispList| |decls|))) + (SPADLET |fargNames| + (PROG (G166530) + (SPADLET G166530 NIL) + (RETURN + (DO ((G166536 |args| (CDR G166536)) + (|u| NIL)) + ((OR (ATOM G166536) + (PROGN + (SETQ |u| (CAR G166536)) + NIL)) + (NREVERSE0 G166530)) + (SEQ (EXIT (COND + ((NULL + (OR (MEMQ |u| |dummies|) + (MEMQ |u| |asps|))) + (SETQ G166530 + (CONS + (INTERN + (STRCONC (STRINGIMAGE |u|) + (MAKESTRING "_arg"))) + G166530)))))))))) + (DO ((G166545 |asps| (CDR G166545)) (|u| NIL)) + ((OR (ATOM G166545) + (PROGN (SETQ |u| (CAR G166545)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |fargNames| + (|delete| + (INTERN + (STRCONC (STRINGIMAGE |u|) + (MAKESTRING "_arg"))) + |fargNames|))))) + (SPADLET |resPar| + (CONS '|construct| + (CONS (CONS '@ + (CONS + (CONS '|construct| + |fargNames|) + (CONS + (CONS '|List| + (CONS (CONS '|Any| NIL) NIL)) + NIL))) + NIL))) + (SPADLET |call| + (CONS (CONS '|$elt| + (CONS '|Lisp| + (CONS '|invokeFortran| NIL))) + (CONS (STRCONC |file| + (INTERN ".spadexe" "BOOT")) + (CONS (CONS + (CONS '|$elt| + (CONS '|Lisp| + (CONS '|construct| NIL))) + (|mkQuote| |args|)) + (CONS + (CONS + (CONS '|$elt| + (CONS '|Lisp| + (CONS '|construct| NIL))) + (|mkQuote| + (|union| |asps| |dummies|))) + (CONS |decPar| + (CONS + (CONS + (CONS '|$elt| + (CONS '|Lisp| + (CONS '|construct| NIL))) + (|mkQuote| |results|)) + (CONS |resPar| NIL)))))))) + (COND + (|asps| (SPADLET |aspId| + (STRCONC (|getEnv| + (MAKESTRING "SPADNUM")) + (GENTEMP (MAKESTRING "NAG")))) + (SPADLET |body| + (CONS 'SEQ + (APPEND + (|makeAspGenerators| |asps| + |aspTypes| |aspId|) + (CONS + (|makeCompilation| |asps| + |file| |aspId|) + (CONS + (CONS '|pretend| + (CONS |call| + (CONS |fType| NIL))) + NIL)))))) + ('T + (SPADLET |body| + (CONS '|pretend| + (CONS |call| (CONS |fType| NIL)))))) + (|interpret| + (CONS 'DEF + (CONS (CONS |name| |argNames|) + (CONS (CONS '|Result| |aType|) + (CONS |nilLst| + (CONS + (CONS + (CONS '|$elt| + (CONS '|Result| + (CONS '|construct| NIL))) + (CONS |body| NIL)) + NIL))))))))))) + +;stripNil u == +; [CAR(u), ["construct",:CADR(u)], if CADDR(u) then "true" else "false"] + +(DEFUN |stripNil| (|u|) + (CONS (CAR |u|) + (CONS (CONS '|construct| (CADR |u|)) + (CONS (COND ((CADDR |u|) '|true|) ('T '|false|)) NIL)))) + +;makeUnion aspType == +; -- The argument is the type of the asp to be generated. We would like to +; -- allow the user to be able to provide a fileName as an alternative +; -- argument, so this builds the Union of aspType and FileName. +; ["Union",[":","fp",aspType],[":","fn","FileName"]] + +(DEFUN |makeUnion| (|aspType|) + (CONS '|Union| + (CONS (CONS '|:| (CONS '|fp| (CONS |aspType| NIL))) + (CONS (CONS '|:| (CONS '|fn| (CONS '|FileName| NIL))) + NIL)))) + +;axiomType(a,decls,asps,aspInfo) == +; a in asps => +; entry := first [u for u in aspInfo | first(u) = a] +; ftc := ["$elt","FortranType","construct"] +; rc := ["$elt", _ +; ["Record",[":","key","Symbol"],[":","entry","FortranType"]], _ +; "construct"] +; makeUnion ["FortranProgram",_ +; a,_ +; CADR(entry),_ +; ["construct",:mkQuote CADDR entry], _ +; [ ["$elt", "SymbolTable","symbolTable"],_ +; ["construct",_ +; :[[rc,first(v),[ftc,:stripNil rest(v)]] for v in CADDDR entry]]_ +; ] ] +; spadTypeTTT(getFortranType(a,decls)) + +(DEFUN |axiomType| (|a| |decls| |asps| |aspInfo|) + (PROG (|entry| |ftc| |rc|) + (RETURN + (SEQ (COND + ((|member| |a| |asps|) + (SPADLET |entry| + (CAR (PROG (G166587) + (SPADLET G166587 NIL) + (RETURN + (DO ((G166593 |aspInfo| + (CDR G166593)) + (|u| NIL)) + ((OR (ATOM G166593) + (PROGN + (SETQ |u| (CAR G166593)) + NIL)) + (NREVERSE0 G166587)) + (SEQ (EXIT + (COND + ((BOOT-EQUAL (CAR |u|) |a|) + (SETQ G166587 + (CONS |u| G166587))))))))))) + (SPADLET |ftc| + (CONS '|$elt| + (CONS '|FortranType| + (CONS '|construct| NIL)))) + (SPADLET |rc| + (CONS '|$elt| + (CONS (CONS '|Record| + (CONS + (CONS '|:| + (CONS '|key| + (CONS '|Symbol| NIL))) + (CONS + (CONS '|:| + (CONS '|entry| + (CONS '|FortranType| NIL))) + NIL))) + (CONS '|construct| NIL)))) + (|makeUnion| + (CONS '|FortranProgram| + (CONS |a| + (CONS (CADR |entry|) + (CONS + (CONS '|construct| + (|mkQuote| (CADDR |entry|))) + (CONS + (CONS + (CONS '|$elt| + (CONS '|SymbolTable| + (CONS '|symbolTable| NIL))) + (CONS + (CONS '|construct| + (PROG (G166603) + (SPADLET G166603 NIL) + (RETURN + (DO + ((G166608 + (CADDDR |entry|) + (CDR G166608)) + (|v| NIL)) + ((OR (ATOM G166608) + (PROGN + (SETQ |v| + (CAR G166608)) + NIL)) + (NREVERSE0 G166603)) + (SEQ + (EXIT + (SETQ G166603 + (CONS + (CONS |rc| + (CONS (CAR |v|) + (CONS + (CONS |ftc| + (|stripNil| + (CDR |v|))) + NIL))) + G166603)))))))) + NIL)) + NIL))))))) + ('T (|spadTypeTTT| (|getFortranType| |a| |decls|)))))))) + +;makeAspGenerators(asps,types,aspId) == +;-- The code generated here will manipulate the Fortran output stack and write +;-- the asps out as Fortran. +; [:makeAspGenerators1(u,v,aspId) for u in asps for v in types] + +(DEFUN |makeAspGenerators| (|asps| |types| |aspId|) + (PROG () + (RETURN + (SEQ (PROG (G166622) + (SPADLET G166622 NIL) + (RETURN + (DO ((G166628 |asps| (CDR G166628)) (|u| NIL) + (G166629 |types| (CDR G166629)) (|v| NIL)) + ((OR (ATOM G166628) + (PROGN (SETQ |u| (CAR G166628)) NIL) + (ATOM G166629) + (PROGN (SETQ |v| (CAR G166629)) NIL)) + G166622) + (SEQ (EXIT (SETQ G166622 + (APPEND G166622 + (|makeAspGenerators1| |u| |v| + |aspId|)))))))))))) + +;makeAspGenerators1(asp,type,aspId) == +; [[["$elt","FOP","pushFortranOutputStack"] ,_ +; ["filename",'"",STRCONC(STRINGIMAGE asp,aspId),'"f"]] , _ +; makeOutputAsFortran INTERN STRCONC(STRINGIMAGE(asp),'"__arg"), _ +; [["$elt","FOP","popFortranOutputStack"]] _ +; ] + +(DEFUN |makeAspGenerators1| (|asp| |type| |aspId|) + (CONS (CONS (CONS '|$elt| + (CONS 'FOP (CONS '|pushFortranOutputStack| NIL))) + (CONS (CONS '|filename| + (CONS (MAKESTRING "") + (CONS (STRCONC (STRINGIMAGE |asp|) + |aspId|) + (CONS (MAKESTRING "f") NIL)))) + NIL)) + (CONS (|makeOutputAsFortran| + (INTERN (STRCONC (STRINGIMAGE |asp|) + (MAKESTRING "_arg")))) + (CONS (CONS (CONS '|$elt| + (CONS 'FOP + (CONS '|popFortranOutputStack| + NIL))) + NIL) + NIL)))) + +;makeOutputAsFortran arg == +; ["IF",["case",arg,"fn"],["outputAsFortran",[arg,"fn"]],_ +; ["outputAsFortran",[arg,"fp"]] ] + +(DEFUN |makeOutputAsFortran| (|arg|) + (CONS 'IF + (CONS (CONS '|case| (CONS |arg| (CONS '|fn| NIL))) + (CONS (CONS '|outputAsFortran| + (CONS (CONS |arg| (CONS '|fn| NIL)) NIL)) + (CONS (CONS '|outputAsFortran| + (CONS (CONS |arg| (CONS '|fp| NIL)) + NIL)) + NIL))))) + +;makeCompilation(asps,file,aspId) == +; [["$elt","Lisp","compileAndLink"],_ +; ["construct",:[STRCONC(STRINGIMAGE a,aspId,'".f") for a in asps]], _ +; $fortranCompilerName,_ +; STRCONC(file,'".o"),_ +; STRCONC(file,'".spadexe"),_ +; $fortranLibraries] + +(DEFUN |makeCompilation| (|asps| |file| |aspId|) + (PROG () + (RETURN + (SEQ (CONS (CONS '|$elt| + (CONS '|Lisp| (CONS '|compileAndLink| NIL))) + (CONS (CONS '|construct| + (PROG (G166652) + (SPADLET G166652 NIL) + (RETURN + (DO ((G166657 |asps| + (CDR G166657)) + (|a| NIL)) + ((OR (ATOM G166657) + (PROGN + (SETQ |a| (CAR G166657)) + NIL)) + (NREVERSE0 G166652)) + (SEQ + (EXIT + (SETQ G166652 + (CONS + (STRCONC (STRINGIMAGE |a|) + |aspId| (MAKESTRING ".f")) + G166652)))))))) + (CONS |$fortranCompilerName| + (CONS (STRCONC |file| (MAKESTRING ".o")) + (CONS + (STRCONC |file| + (MAKESTRING ".spadexe")) + (CONS |$fortranLibraries| NIL)))))))))) + +;compileAndLink(fortFileList,fortCompiler,cFile,outFile,linkerArgs) == +; SYSTEM STRCONC (fortCompiler, addSpaces fortFileList,_ +; cFile, " -o ",outFile," ",linkerArgs) + +(DEFUN |compileAndLink| + (|fortFileList| |fortCompiler| |cFile| |outFile| |linkerArgs|) + (SYSTEM (STRCONC |fortCompiler| (|addSpaces| |fortFileList|) |cFile| + '| -o | |outFile| '| | |linkerArgs|))) + +;addSpaces(stringList) == +; l := " " +; for s in stringList repeat l := STRCONC(l,s," ") +; l + +(DEFUN |addSpaces| (|stringList|) + (PROG (|l|) + (RETURN + (SEQ (PROGN + (SPADLET |l| '| |) + (DO ((G166674 |stringList| (CDR G166674)) (|s| NIL)) + ((OR (ATOM G166674) + (PROGN (SETQ |s| (CAR G166674)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |l| (STRCONC |l| |s| '| |))))) + |l|))))) + +;complexRows z == +;-- Take a list of lists of complexes (i.e. pairs of floats) and +;-- make them look like a Fortran vector! +; [:[:pair2list(u.i) for u in z] for i in 0..#(z.0)-1] + +(DEFUN |complexRows| (|z|) + (PROG () + (RETURN + (SEQ (PROG (G166685) + (SPADLET G166685 NIL) + (RETURN + (DO ((G166690 (SPADDIFFERENCE (|#| (ELT |z| 0)) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166690) G166685) + (SEQ (EXIT (SETQ G166685 + (APPEND G166685 + (PROG (G166694) + (SPADLET G166694 NIL) + (RETURN + (DO + ((G166699 |z| + (CDR G166699)) + (|u| NIL)) + ((OR (ATOM G166699) + (PROGN + (SETQ |u| + (CAR G166699)) + NIL)) + G166694) + (SEQ + (EXIT + (SETQ G166694 + (APPEND G166694 + (|pair2list| + (ELT |u| |i|)))))))))))))))))))) + +;pair2list u == [car u,cdr u] + +(DEFUN |pair2list| (|u|) (CONS (CAR |u|) (CONS (CDR |u|) NIL))) + +;vec2Lists1 u == [ELT(u,i) for i in 0..#u-1] + +(DEFUN |vec2Lists1| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G166717) + (SPADLET G166717 NIL) + (RETURN + (DO ((G166722 (SPADDIFFERENCE (|#| |u|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166722) (NREVERSE0 G166717)) + (SEQ (EXIT (SETQ G166717 + (CONS (ELT |u| |i|) G166717))))))))))) + +;vec2Lists u == [vec2Lists1 ELT(u,i) for i in 0..#u-1] + +(DEFUN |vec2Lists| (|u|) + (PROG () + (RETURN + (SEQ (PROG (G166734) + (SPADLET G166734 NIL) + (RETURN + (DO ((G166739 (SPADDIFFERENCE (|#| |u|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166739) (NREVERSE0 G166734)) + (SEQ (EXIT (SETQ G166734 + (CONS (|vec2Lists1| (ELT |u| |i|)) + G166734))))))))))) + +;spad2lisp(u) == +; -- Turn complexes into arrays of floats +; first first(u)="Complex" => +; makeVector([makeVector([CADR u,CDDR u],'DOUBLE_-FLOAT)],NIL) +; -- Turn arrays of complexes into arrays of floats so that tarnsposing +; -- them puts them in the correct fortran order +; first first(u)="Matrix" and first SECOND first(u) = "Complex" => +; makeVector([makeVector(complexRows vec2Lists rest u,'DOUBLE_-FLOAT)],NIL) +; rest(u) + +(DEFUN |spad2lisp| (|u|) + (COND + ((BOOT-EQUAL (CAR (CAR |u|)) '|Complex|) + (|makeVector| + (CONS (|makeVector| (CONS (CADR |u|) (CONS (CDDR |u|) NIL)) + 'DOUBLE-FLOAT) + NIL) + NIL)) + ((AND (BOOT-EQUAL (CAR (CAR |u|)) '|Matrix|) + (BOOT-EQUAL (CAR (SECOND (CAR |u|))) '|Complex|)) + (|makeVector| + (CONS (|makeVector| (|complexRows| (|vec2Lists| (CDR |u|))) + 'DOUBLE-FLOAT) + NIL) + NIL)) + ('T (CDR |u|)))) + +;invokeFortran(objFile,args,dummies,decls,results,actual) == +; actual := [spad2lisp(u) for u in first actual] +; returnedValues := spadify( _ +; fortCall(objFile,prepareData(args,dummies,actual,decls),_ +; prepareResults(results,args,dummies,actual,decls)),_ +; results,decls,inFirstNotSecond(args,dummies),actual) + +(DEFUN |invokeFortran| + (|objFile| |args| |dummies| |decls| |results| |actual|) + (PROG (|returnedValues|) + (RETURN + (SEQ (PROGN + (SPADLET |actual| + (PROG (G166756) + (SPADLET G166756 NIL) + (RETURN + (DO ((G166761 (CAR |actual|) + (CDR G166761)) + (|u| NIL)) + ((OR (ATOM G166761) + (PROGN + (SETQ |u| (CAR G166761)) + NIL)) + (NREVERSE0 G166756)) + (SEQ (EXIT (SETQ G166756 + (CONS (|spad2lisp| |u|) + G166756)))))))) + (SPADLET |returnedValues| + (|spadify| + (|fortCall| |objFile| + (|prepareData| |args| |dummies| |actual| + |decls|) + (|prepareResults| |results| |args| + |dummies| |actual| |decls|)) + |results| |decls| + (|inFirstNotSecond| |args| |dummies|) + |actual|))))))) + +;-- -- If there are one or two elements in returnedValues we must return a +;-- -- cons cell, otherwise a vector. This is to match the internal +;-- -- representation of an Axiom Record. +;-- #returnedValues = 1 => returnedValues +;-- #returnedValues = 2 => CONS(first returnedValues,SECOND returnedValues) +;-- makeVector(returnedValues,nil) +;int2Bool u == +; -- Return something which looks like an axiom boolean +; u=1 => "TRUE" +; NIL + +(DEFUN |int2Bool| (|u|) (COND ((EQL |u| 1) 'TRUE) ('T NIL))) + +;makeResultRecord(name,type,value) == +; -- Take an object returned by the NAG routine and make it into an AXIOM +; -- object of type Record(key:Symbol,entry:Any) for use by Result. +; CONS(name,CONS(spadTypeTTT type,value)) + +(DEFUN |makeResultRecord| (|name| |type| |value|) + (CONS |name| (CONS (|spadTypeTTT| |type|) |value|))) + +;spadify(l,results,decls,names,actual) == +; -- The elements of list l are the output forms returned from the Fortran +; -- code: integers, floats and vectors. Return spad forms of these, of +; -- type Record(key:Symbol,entry:Any) (for use with the Result domain). +; SETQ(RESULTS,l) +; spadForms := nil +; for i in 0..(#l -1) repeat +; fort := NTH(i,l) +; name := NTH(i,results) +; ty := getFortranType(name,decls) +; -- Result is a string +; STRINGP fort => +; spadForms := [makeResultRecord(name,ty,fort), :spadForms] +; -- Result is a Complex Scalar +; ty in ["double complex" , "complex"] => +; spadForms := [makeResultRecord(name,ty, _ +; CONS(ELT(fort,0),ELT(fort,1)) ),:spadForms] +; -- Result is a Complex vector or array +; LISTP(ty) and first(ty) in ["double complex" , "complex"] => +; dims := [getVal(u,names,actual) for u in rest ty] +; els := nil +; if #dims=1 then +; els := [makeVector([CONS(ELT(fort,2*i),ELT(fort,2*i+1)) _ +; for i in 0..(first(dims)-1)],nil)] +; else if #dims=2 then +; for r in 0..(first(dims) - 1) repeat +; innerEls := nil +; for c in 0..(SECOND(dims) - 1) repeat +; offset := 2*(c*first(dims)+r) +; innerEls := [CONS(ELT(fort,offset),ELT(fort,offset+1)),:innerEls] +; els := [makeVector(NREVERSE innerEls,nil),:els] +; else +; error ['"Can't cope with complex output dimensions higher than 2"] +; spadForms := [makeResultRecord(name,ty,makeVector(NREVERSE els,nil)), +; :spadForms] +; -- Result is a Boolean vector or array +; LISTP(ty) and first(ty)="logical" and #ty=2 => +; dim := getVal(first rest ty,names,actual) +; spadForms := [makeResultRecord(name,ty,_ +; [int2Bool ELT(fort,i) for i in 0..dim-1]), :spadForms] +; LISTP(ty) and first(ty)="logical" => +; dims := [getVal(u,names,actual) for u in rest ty] +; els := nil +; if #dims=2 then +; for r in 0..(first(dims) - 1) repeat +; innerEls := nil +; for c in 0..(SECOND(dims) - 1) repeat +; innerEls := [int2Bool ELT(fort,c*first(dims)+r),:innerEls] +; els := [NREVERSE innerEls,:els] +; else +; error ['"Can't cope with logical output dimensions higher than 2"] +; spadForms := [makeResultRecord(name,ty,NREVERSE els), :spadForms] +; -- Result is a vector or array +; VECTORP fort => +; dims := [getVal(u,names,actual) for u in rest ty] +; els := nil +; -- Check to see whether we are dealing with a dummy (0-dimensional) array. +; if MEMQ(0,dims) then +; els := [[]] +; else if #dims=1 then +; els := [makeVector([ELT(fort,i) for i in 0..(first(dims)-1)],nil)] +; else if #dims=2 then +; for r in 0..(first(dims) - 1) repeat +; innerEls := nil +; for c in 0..(SECOND(dims) - 1) repeat +; innerEls := [ELT(fort,c*first(dims)+r),:innerEls] +; els := [makeVector(NREVERSE innerEls,nil),:els] +; else if #dims=3 then +; iDim := first(dims) +; jDim := SECOND dims +; kDim := THIRD dims +; for r in 0..(iDim - 1) repeat +; middleEls := nil +; for c in 0..(jDim - 1) repeat +; innerEls := nil +; for p in 0..(kDim - 1) repeat +; offset := p*jDim + c*kDim + r +; innerEls := [ELT(fort,offset),:innerEls] +; middleEls := [makeVector(NREVERSE innerEls,nil),:middleEls] +; els := [makeVector(NREVERSE middleEls,nil),:els] +; else +; error ['"Can't cope with output dimensions higher than 3"] +; if not MEMQ(0,dims) then els := makeVector(NREVERSE els,nil) +; spadForms := [makeResultRecord(name,ty,els), :spadForms] +; -- Result is a Boolean Scalar +; atom fort and ty="logical" => +; spadForms := [makeResultRecord(name,ty,int2Bool fort), :spadForms] +; -- Result is a Scalar +; atom fort => +; spadForms := [makeResultRecord(name,ty,fort),:spadForms] +; error ['"Unrecognised output format: ",fort] +; NREVERSE spadForms + +(DEFUN |spadify| (|l| |results| |decls| |names| |actual|) + (PROG (|fort| |name| |ty| |dim| |dims| |iDim| |jDim| |kDim| |offset| + |innerEls| |middleEls| |els| |spadForms|) + (RETURN + (SEQ (PROGN + (SETQ RESULTS |l|) + (SPADLET |spadForms| NIL) + (DO ((G166820 (SPADDIFFERENCE (|#| |l|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G166820) NIL) + (SEQ (EXIT (PROGN + (SPADLET |fort| (NTH |i| |l|)) + (SPADLET |name| (NTH |i| |results|)) + (SPADLET |ty| + (|getFortranType| |name| |decls|)) + (COND + ((STRINGP |fort|) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| |fort|) + |spadForms|))) + ((|member| |ty| + (CONS '|double complex| + (CONS '|complex| NIL))) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| + (CONS (ELT |fort| 0) + (ELT |fort| 1))) + |spadForms|))) + ((AND (LISTP |ty|) + (|member| (CAR |ty|) + (CONS '|double complex| + (CONS '|complex| NIL)))) + (SPADLET |dims| + (PROG (G166828) + (SPADLET G166828 NIL) + (RETURN + (DO + ((G166833 (CDR |ty|) + (CDR G166833)) + (|u| NIL)) + ((OR (ATOM G166833) + (PROGN + (SETQ |u| + (CAR G166833)) + NIL)) + (NREVERSE0 G166828)) + (SEQ + (EXIT + (SETQ G166828 + (CONS + (|getVal| |u| |names| + |actual|) + G166828)))))))) + (SPADLET |els| NIL) + (COND + ((EQL (|#| |dims|) 1) + (SPADLET |els| + (CONS + (|makeVector| + (PROG (G166843) + (SPADLET G166843 NIL) + (RETURN + (DO + ((G166848 + (SPADDIFFERENCE + (CAR |dims|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| + G166848) + (NREVERSE0 + G166843)) + (SEQ + (EXIT + (SETQ G166843 + (CONS + (CONS + (ELT |fort| + (TIMES 2 |i|)) + (ELT |fort| + (PLUS + (TIMES 2 |i|) + 1))) + G166843))))))) + NIL) + NIL))) + ((EQL (|#| |dims|) 2) + (DO ((G166860 + (SPADDIFFERENCE (CAR |dims|) 1)) + (|r| 0 (QSADD1 |r|))) + ((QSGREATERP |r| G166860) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |innerEls| NIL) + (DO + ((G166869 + (SPADDIFFERENCE + (SECOND |dims|) 1)) + (|c| 0 (QSADD1 |c|))) + ((QSGREATERP |c| G166869) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |offset| + (TIMES 2 + (PLUS + (TIMES |c| + (CAR |dims|)) + |r|))) + (SPADLET |innerEls| + (CONS + (CONS + (ELT |fort| |offset|) + (ELT |fort| + (PLUS |offset| 1))) + |innerEls|)))))) + (SPADLET |els| + (CONS + (|makeVector| + (NREVERSE |innerEls|) NIL) + |els|))))))) + ('T + (|error| (CONS + (MAKESTRING + "Can't cope with complex output dimensions higher than 2") + NIL)))) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| + (|makeVector| + (NREVERSE |els|) NIL)) + |spadForms|))) + ((AND (LISTP |ty|) + (BOOT-EQUAL (CAR |ty|) '|logical|) + (EQL (|#| |ty|) 2)) + (SPADLET |dim| + (|getVal| (CAR (CDR |ty|)) + |names| |actual|)) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| + (PROG (G166877) + (SPADLET G166877 NIL) + (RETURN + (DO + ((G166882 + (SPADDIFFERENCE |dim| + 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| + G166882) + (NREVERSE0 G166877)) + (SEQ + (EXIT + (SETQ G166877 + (CONS + (|int2Bool| + (ELT |fort| |i|)) + G166877)))))))) + |spadForms|))) + ((AND (LISTP |ty|) + (BOOT-EQUAL (CAR |ty|) '|logical|)) + (SPADLET |dims| + (PROG (G166890) + (SPADLET G166890 NIL) + (RETURN + (DO + ((G166895 (CDR |ty|) + (CDR G166895)) + (|u| NIL)) + ((OR (ATOM G166895) + (PROGN + (SETQ |u| + (CAR G166895)) + NIL)) + (NREVERSE0 G166890)) + (SEQ + (EXIT + (SETQ G166890 + (CONS + (|getVal| |u| |names| + |actual|) + G166890)))))))) + (SPADLET |els| NIL) + (COND + ((EQL (|#| |dims|) 2) + (DO ((G166907 + (SPADDIFFERENCE (CAR |dims|) 1)) + (|r| 0 (QSADD1 |r|))) + ((QSGREATERP |r| G166907) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |innerEls| NIL) + (DO + ((G166914 + (SPADDIFFERENCE + (SECOND |dims|) 1)) + (|c| 0 (QSADD1 |c|))) + ((QSGREATERP |c| G166914) + NIL) + (SEQ + (EXIT + (SPADLET |innerEls| + (CONS + (|int2Bool| + (ELT |fort| + (PLUS + (TIMES |c| + (CAR |dims|)) + |r|))) + |innerEls|))))) + (SPADLET |els| + (CONS (NREVERSE |innerEls|) + |els|))))))) + ('T + (|error| (CONS + (MAKESTRING + "Can't cope with logical output dimensions higher than 2") + NIL)))) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| (NREVERSE |els|)) + |spadForms|))) + ((VECTORP |fort|) + (SPADLET |dims| + (PROG (G166922) + (SPADLET G166922 NIL) + (RETURN + (DO + ((G166927 (CDR |ty|) + (CDR G166927)) + (|u| NIL)) + ((OR (ATOM G166927) + (PROGN + (SETQ |u| + (CAR G166927)) + NIL)) + (NREVERSE0 G166922)) + (SEQ + (EXIT + (SETQ G166922 + (CONS + (|getVal| |u| |names| + |actual|) + G166922)))))))) + (SPADLET |els| NIL) + (COND + ((MEMQ 0 |dims|) + (SPADLET |els| (CONS NIL NIL))) + ((EQL (|#| |dims|) 1) + (SPADLET |els| + (CONS + (|makeVector| + (PROG (G166937) + (SPADLET G166937 NIL) + (RETURN + (DO + ((G166942 + (SPADDIFFERENCE + (CAR |dims|) 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| + G166942) + (NREVERSE0 + G166937)) + (SEQ + (EXIT + (SETQ G166937 + (CONS + (ELT |fort| |i|) + G166937))))))) + NIL) + NIL))) + ((EQL (|#| |dims|) 2) + (DO ((G166952 + (SPADDIFFERENCE (CAR |dims|) 1)) + (|r| 0 (QSADD1 |r|))) + ((QSGREATERP |r| G166952) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |innerEls| NIL) + (DO + ((G166959 + (SPADDIFFERENCE + (SECOND |dims|) 1)) + (|c| 0 (QSADD1 |c|))) + ((QSGREATERP |c| G166959) + NIL) + (SEQ + (EXIT + (SPADLET |innerEls| + (CONS + (ELT |fort| + (PLUS + (TIMES |c| + (CAR |dims|)) + |r|)) + |innerEls|))))) + (SPADLET |els| + (CONS + (|makeVector| + (NREVERSE |innerEls|) NIL) + |els|))))))) + ((EQL (|#| |dims|) 3) + (SPADLET |iDim| (CAR |dims|)) + (SPADLET |jDim| (SECOND |dims|)) + (SPADLET |kDim| (THIRD |dims|)) + (DO ((G166974 + (SPADDIFFERENCE |iDim| 1)) + (|r| 0 (QSADD1 |r|))) + ((QSGREATERP |r| G166974) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |middleEls| NIL) + (DO + ((G166986 + (SPADDIFFERENCE |jDim| 1)) + (|c| 0 (QSADD1 |c|))) + ((QSGREATERP |c| G166986) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |innerEls| NIL) + (DO + ((G166995 + (SPADDIFFERENCE |kDim| + 1)) + (|p| 0 (QSADD1 |p|))) + ((QSGREATERP |p| + G166995) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |offset| + (PLUS + (PLUS + (TIMES |p| + |jDim|) + (TIMES |c| + |kDim|)) + |r|)) + (SPADLET |innerEls| + (CONS + (ELT |fort| + |offset|) + |innerEls|)))))) + (SPADLET |middleEls| + (CONS + (|makeVector| + (NREVERSE |innerEls|) + NIL) + |middleEls|)))))) + (SPADLET |els| + (CONS + (|makeVector| + (NREVERSE |middleEls|) NIL) + |els|))))))) + ('T + (|error| (CONS + (MAKESTRING + "Can't cope with output dimensions higher than 3") + NIL)))) + (COND + ((NULL (MEMQ 0 |dims|)) + (SPADLET |els| + (|makeVector| + (NREVERSE |els|) NIL)))) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| |els|) + |spadForms|))) + ((AND (ATOM |fort|) + (BOOT-EQUAL |ty| '|logical|)) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| (|int2Bool| |fort|)) + |spadForms|))) + ((ATOM |fort|) + (SPADLET |spadForms| + (CONS + (|makeResultRecord| |name| + |ty| |fort|) + |spadForms|))) + ('T + (|error| (CONS + (MAKESTRING + "Unrecognised output format: ") + (CONS |fort| NIL))))))))) + (NREVERSE |spadForms|)))))) + +;lispType u == +; -- Return the lisp type equivalent to the given Fortran type. +; LISTP u => lispType first u +; u = "real" => "SHORT-FLOAT" +; u = "double" => "DOUBLE-FLOAT" +; u = "double precision" => "DOUBLE-FLOAT" +; u = "integer" => "FIXNUM" +; u = "logical" => "BOOLEAN" +; u = "character" => "CHARACTER" +; u = "complex" => "SHORT-FLOAT" +; u = "double complex" => "DOUBLE-FLOAT" +; error ['"Unrecognised Fortran type: ",u] + +(DEFUN |lispType| (|u|) + (COND + ((LISTP |u|) (|lispType| (CAR |u|))) + ((BOOT-EQUAL |u| '|real|) 'SHORT-FLOAT) + ((BOOT-EQUAL |u| '|double|) 'DOUBLE-FLOAT) + ((BOOT-EQUAL |u| '|double precision|) 'DOUBLE-FLOAT) + ((BOOT-EQUAL |u| '|integer|) 'FIXNUM) + ((BOOT-EQUAL |u| '|logical|) 'BOOLEAN) + ((BOOT-EQUAL |u| '|character|) 'CHARACTER) + ((BOOT-EQUAL |u| '|complex|) 'SHORT-FLOAT) + ((BOOT-EQUAL |u| '|double complex|) 'DOUBLE-FLOAT) + ('T + (|error| (CONS (MAKESTRING "Unrecognised Fortran type: ") + (CONS |u| NIL)))))) + +;getVal(u,names,values) == +; -- if u is the i'th element of names, return the i'th element of values, +; -- otherwise if it is an arithmetic expression evaluate it. +; NUMBERP(u) => u +; LISTP(u) => eval [first(u), :[getVal(v,names,values) for v in rest u]] +; (place := POSITION(u,names)) => NTH(place,values) +; error ['"No value found for parameter: ",u] + +(DEFUN |getVal| (|u| |names| |values|) + (PROG (|place|) + (RETURN + (SEQ (COND + ((NUMBERP |u|) |u|) + ((LISTP |u|) + (|eval| (CONS (CAR |u|) + (PROG (G167059) + (SPADLET G167059 NIL) + (RETURN + (DO ((G167064 (CDR |u|) + (CDR G167064)) + (|v| NIL)) + ((OR (ATOM G167064) + (PROGN + (SETQ |v| (CAR G167064)) + NIL)) + (NREVERSE0 G167059)) + (SEQ (EXIT + (SETQ G167059 + (CONS + (|getVal| |v| |names| + |values|) + G167059)))))))))) + ((SPADLET |place| (POSITION |u| |names|)) + (NTH |place| |values|)) + ('T + (|error| (CONS (MAKESTRING + "No value found for parameter: ") + (CONS |u| NIL))))))))) + +;prepareData(args,dummies,values,decls) == +;-- TTT: we don't +;-- writeData handles all the mess +; [args,dummies,values,decls] + +(DEFUN |prepareData| (|args| |dummies| |values| |decls|) + (CONS |args| (CONS |dummies| (CONS |values| (CONS |decls| NIL))))) + +;checkForBoolean u == +; u = "BOOLEAN" => "FIXNUM" +; u + +(DEFUN |checkForBoolean| (|u|) + (COND ((BOOT-EQUAL |u| 'BOOLEAN) 'FIXNUM) ('T |u|))) + +;prepareResults(results,args,dummies,values,decls) == +; -- Create the floating point zeros (boot doesn't like 0.0d0, 0.0D0 etc) +; shortZero : fluid := COERCE(0.0,'SHORT_-FLOAT) +; longZero : fluid := COERCE(0.0,'DOUBLE_-FLOAT) +; data := nil +; for u in results repeat +; type := getFortranType(u,decls) +; data := [defaultValue(type,inFirstNotSecond(args,dummies),values),:data] +; where defaultValue(type,argNames,actual) == +; LISTP(type) and first(type)="character" => MAKE_-STRING(1) +; LISTP(type) and first(type) in ["complex","double complex"] => +; makeVector( makeList( +; 2*APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ +; if first(type)="complex" then shortZero else longZero),_ +; if first(type)="complex" then "SHORT-FLOAT" else "DOUBLE-FLOAT" ) +; LISTP type => makeVector(_ +; makeList( +; APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ +; defaultValue(first type,argNames,actual)),_ +; checkForBoolean lispType first(type) ) +; type = "integer" => 0 +; type = "real" => shortZero +; type = "double" => longZero +; type = "double precision" => longZero +; type = "logical" => 0 +; type = "character" => MAKE_-STRING(1) +; type = "complex" => makeVector([shortZero,shortZero],'SHORT_-FLOAT) +; type = "double complex" => makeVector([longZero,longZero],'LONG_-FLOAT) +; error ['"Unrecognised Fortran type: ",type] +; NREVERSE data + +(DEFUN |prepareResults,defaultValue| (|type| |argNames| |actual|) + (PROG () + (RETURN + (SEQ (IF (AND (LISTP |type|) + (BOOT-EQUAL (CAR |type|) '|character|)) + (EXIT (MAKE-STRING 1))) + (IF (AND (LISTP |type|) + (|member| (CAR |type|) + (CONS '|complex| (CONS '|double complex| NIL)))) + (EXIT (|makeVector| + (|makeList| + (TIMES 2 + (APPLY '* + (PROG (G167087) + (SPADLET G167087 NIL) + (RETURN + (DO + ((G167092 (CDR |type|) + (CDR G167092)) + (|tt| NIL)) + ((OR (ATOM G167092) + (PROGN + (SETQ |tt| + (CAR G167092)) + NIL)) + (NREVERSE0 G167087)) + (SEQ + (EXIT + (SETQ G167087 + (CONS + (|getVal| |tt| + |argNames| |actual|) + G167087))))))))) + (IF (BOOT-EQUAL (CAR |type|) '|complex|) + |shortZero| |longZero|)) + (IF (BOOT-EQUAL (CAR |type|) '|complex|) + 'SHORT-FLOAT 'DOUBLE-FLOAT)))) + (IF (LISTP |type|) + (EXIT (|makeVector| + (|makeList| + (APPLY '* + (PROG (G167102) + (SPADLET G167102 NIL) + (RETURN + (DO + ((G167107 (CDR |type|) + (CDR G167107)) + (|tt| NIL)) + ((OR (ATOM G167107) + (PROGN + (SETQ |tt| + (CAR G167107)) + NIL)) + (NREVERSE0 G167102)) + (SEQ + (EXIT + (SETQ G167102 + (CONS + (|getVal| |tt| |argNames| + |actual|) + G167102)))))))) + (|prepareResults,defaultValue| + (CAR |type|) |argNames| |actual|)) + (|checkForBoolean| (|lispType| (CAR |type|)))))) + (IF (BOOT-EQUAL |type| '|integer|) (EXIT 0)) + (IF (BOOT-EQUAL |type| '|real|) (EXIT |shortZero|)) + (IF (BOOT-EQUAL |type| '|double|) (EXIT |longZero|)) + (IF (BOOT-EQUAL |type| '|double precision|) + (EXIT |longZero|)) + (IF (BOOT-EQUAL |type| '|logical|) (EXIT 0)) + (IF (BOOT-EQUAL |type| '|character|) (EXIT (MAKE-STRING 1))) + (IF (BOOT-EQUAL |type| '|complex|) + (EXIT (|makeVector| + (CONS |shortZero| (CONS |shortZero| NIL)) + 'SHORT-FLOAT))) + (IF (BOOT-EQUAL |type| '|double complex|) + (EXIT (|makeVector| + (CONS |longZero| (CONS |longZero| NIL)) + 'LONG-FLOAT))) + (EXIT (|error| (CONS (MAKESTRING + "Unrecognised Fortran type: ") + (CONS |type| NIL)))))))) + +(DEFUN |prepareResults| (|results| |args| |dummies| |values| |decls|) + (PROG (|shortZero| |longZero| |type| |data|) + (DECLARE (SPECIAL |shortZero| |longZero|)) + (RETURN + (SEQ (PROGN + (SPADLET |shortZero| (COERCE 0.0 'SHORT-FLOAT)) + (SPADLET |longZero| (COERCE 0.0 'DOUBLE-FLOAT)) + (SPADLET |data| NIL) + (DO ((G167126 |results| (CDR G167126)) (|u| NIL)) + ((OR (ATOM G167126) + (PROGN (SETQ |u| (CAR G167126)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |type| + (|getFortranType| |u| |decls|)) + (SPADLET |data| + (CONS + (|prepareResults,defaultValue| + |type| + (|inFirstNotSecond| |args| + |dummies|) + |values|) + |data|)))))) + (NREVERSE |data|)))))) + +;-- TTT this is dead code now +;-- transposeVector(u,type) == +;-- -- Take a vector of vectors and return a single vector which is in column +;-- -- order (i.e. swap from C to Fortran order). +;-- els := nil +;-- rows := CAR ARRAY_-DIMENSIONS(u)-1 +;-- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 +;-- -- Could be a 3D Matrix +;-- if VECTORP ELT(ELT(u,0),0) then +;-- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 +;-- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat +;-- els := [ELT(ELT(ELT(u,i),j),k),:els] +;-- else +;-- for j in 0..cols repeat for i in 0..rows repeat +;-- els := [ELT(ELT(u,i),j),:els] +;-- makeVector(NREVERSE els,type) +;writeData(tmpFile,indata) == +; -- Write the elements of the list data to a temporary file. Return the +; -- name of that file. +; -- +; str := MAKE_-OUTSTREAM(tmpFile) +; xstr := xdrOpen(str,true) +; [args,dummies,values,decls] := indata +; for v in values repeat +; -- the two Boolean values +; v = "T" => +; xdrWrite(xstr,1) +; NULL v => +; xdrWrite(xstr,0) +; -- characters +; STRINGP v => +; xdrWrite(xstr,v) +; -- some array +; VECTORP v => +; rows := CAR ARRAY_-DIMENSIONS(v) +; -- is it 2d or more (most likely) ? +; VECTORP ELT(v,0) => +; cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) +; -- is it 3d ? +; VECTORP ELT(ELT(v,0),0) => +; planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) +; -- write 3d array +; xdrWrite(xstr,rows*cols*planes) +; for k in 0..planes-1 repeat +; for j in 0..cols-1 repeat +; for i in 0..rows-1 repeat +; xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) +; -- write 2d array +; xdrWrite(xstr,rows*cols) +; for j in 0..cols-1 repeat +; for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) +; -- write 1d array +; xdrWrite(xstr,rows) +; for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) +; -- this is used for lists of booleans apparently in f01 +; LISTP v => +; xdrWrite(xstr,LENGTH v) +; for el in v repeat +; if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) +; -- integers +; INTEGERP v => +; xdrWrite(xstr,v) +; -- floats +; FLOATP v => +; xdrWrite(xstr,v) +; SHUT(str) +; tmpFile + +(DEFUN |writeData| (|tmpFile| |indata|) + (PROG (|str| |xstr| |args| |dummies| |values| |decls| |rows| |cols| + |planes|) + (RETURN + (SEQ (PROGN + (SPADLET |str| (MAKE-OUTSTREAM |tmpFile|)) + (SPADLET |xstr| (|xdrOpen| |str| 'T)) + (SPADLET |args| (CAR |indata|)) + (SPADLET |dummies| (CADR |indata|)) + (SPADLET |values| (CADDR |indata|)) + (SPADLET |decls| (CADDDR |indata|)) + (DO ((G167158 |values| (CDR G167158)) (|v| NIL)) + ((OR (ATOM G167158) + (PROGN (SETQ |v| (CAR G167158)) NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |v| 'T) (|xdrWrite| |xstr| 1)) + ((NULL |v|) (|xdrWrite| |xstr| 0)) + ((STRINGP |v|) (|xdrWrite| |xstr| |v|)) + ((VECTORP |v|) + (SPADLET |rows| + (CAR (ARRAY-DIMENSIONS |v|))) + (COND + ((VECTORP (ELT |v| 0)) + (SPADLET |cols| + (CAR + (ARRAY-DIMENSIONS + (ELT |v| 0)))) + (COND + ((VECTORP (ELT (ELT |v| 0) 0)) + (SPADLET |planes| + (CAR + (ARRAY-DIMENSIONS + (ELT (ELT |v| 0) 0)))) + (|xdrWrite| |xstr| + (TIMES (TIMES |rows| |cols|) + |planes|)) + (DO + ((G167167 + (SPADDIFFERENCE |planes| 1)) + (|k| 0 (QSADD1 |k|))) + ((QSGREATERP |k| G167167) NIL) + (SEQ + (EXIT + (DO + ((G167174 + (SPADDIFFERENCE |cols| 1)) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G167174) + NIL) + (SEQ + (EXIT + (DO + ((G167181 + (SPADDIFFERENCE |rows| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167181) + NIL) + (SEQ + (EXIT + (|xdrWrite| |xstr| + (ELT + (ELT (ELT |v| |i|) + |j|) + |k|)))))))))))) + ('T + (|xdrWrite| |xstr| + (TIMES |rows| |cols|)) + (DO + ((G167188 + (SPADDIFFERENCE |cols| 1)) + (|j| 0 (QSADD1 |j|))) + ((QSGREATERP |j| G167188) NIL) + (SEQ + (EXIT + (DO + ((G167195 + (SPADDIFFERENCE |rows| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167195) + NIL) + (SEQ + (EXIT + (|xdrWrite| |xstr| + (ELT (ELT |v| |i|) |j|))))))))))) + ('T (|xdrWrite| |xstr| |rows|) + (DO ((G167202 + (SPADDIFFERENCE |rows| 1)) + (|i| 0 (QSADD1 |i|))) + ((QSGREATERP |i| G167202) NIL) + (SEQ (EXIT + (|xdrWrite| |xstr| + (ELT |v| |i|)))))))) + ((LISTP |v|) + (|xdrWrite| |xstr| (LENGTH |v|)) + (DO ((G167209 |v| (CDR G167209)) + (|el| NIL)) + ((OR (ATOM G167209) + (PROGN + (SETQ |el| (CAR G167209)) + NIL)) + NIL) + (SEQ (EXIT + (COND + (|el| (|xdrWrite| |xstr| 1)) + ('T (|xdrWrite| |xstr| 0))))))) + ((INTEGERP |v|) (|xdrWrite| |xstr| |v|)) + ((FLOATP |v|) (|xdrWrite| |xstr| |v|)))))) + (SHUT |str|) + |tmpFile|))))) + +;readData(tmpFile,results) == +; -- read in the results from tmpFile. The list results is a list of +; -- dummy objects of the correct type which will receive the data. +; str := MAKE_-INSTREAM(tmpFile) +; xstr := xdrOpen(str,false) +; results := [xdrRead1(xstr,r) for r in results] where +; xdrRead1(x,dummy) == +; VECTORP(dummy) and ZEROP(LENGTH dummy) => dummy +; xdrRead(x,dummy) +; SHUT(str) +; results + +(DEFUN |readData,xdrRead1| (|x| |dummy|) + (SEQ (IF (AND (VECTORP |dummy|) (ZEROP (LENGTH |dummy|))) + (EXIT |dummy|)) + (EXIT (|xdrRead| |x| |dummy|)))) + +(DEFUN |readData| (|tmpFile| |results|) + (PROG (|str| |xstr|) + (RETURN + (SEQ (PROGN + (SPADLET |str| (MAKE-INSTREAM |tmpFile|)) + (SPADLET |xstr| (|xdrOpen| |str| NIL)) + (SPADLET |results| + (PROG (G167237) + (SPADLET G167237 NIL) + (RETURN + (DO ((G167242 |results| (CDR G167242)) + (|r| NIL)) + ((OR (ATOM G167242) + (PROGN + (SETQ |r| (CAR G167242)) + NIL)) + (NREVERSE0 G167237)) + (SEQ (EXIT (SETQ G167237 + (CONS + (|readData,xdrRead1| |xstr| + |r|) + G167237)))))))) + (SHUT |str|) + |results|))))) + +;generateDataName()==STRCONC($fortranTmpDir,getEnv('"HOST"), +; getEnv('"SPADNUM"), GENTEMP('"NAG"),'"data") + +(DEFUN |generateDataName| () + (STRCONC |$fortranTmpDir| (|getEnv| (MAKESTRING "HOST")) + (|getEnv| (MAKESTRING "SPADNUM")) + (GENTEMP (MAKESTRING "NAG")) (MAKESTRING "data"))) + +;generateResultsName()==STRCONC($fortranTmpDir,getEnv('"HOST"), +; getEnv('"SPADNUM"), GENTEMP('"NAG"),'"results") + +(DEFUN |generateResultsName| () + (STRCONC |$fortranTmpDir| (|getEnv| (MAKESTRING "HOST")) + (|getEnv| (MAKESTRING "SPADNUM")) + (GENTEMP (MAKESTRING "NAG")) (MAKESTRING "results"))) + +;fortCall(objFile,data,results) == +; tmpFile1 := writeData(generateDataName(),data) +; tmpFile2 := generateResultsName() +; SYSTEM STRCONC(objFile," < ",tmpFile1," > ",tmpFile2) +; results := readData(tmpFile2,results) +; -- SYSTEM STRCONC("rm -f ",tmpFile1," ",tmpFile2) +; PROBE_-FILE(tmpFile1) and DELETE_-FILE(tmpFile1) +; PROBE_-FILE(tmpFile2) and DELETE_-FILE(tmpFile2) +; results + +(DEFUN |fortCall| (|objFile| |data| |results|) + (PROG (|tmpFile1| |tmpFile2|) + (RETURN + (PROGN + (SPADLET |tmpFile1| (|writeData| (|generateDataName|) |data|)) + (SPADLET |tmpFile2| (|generateResultsName|)) + (SYSTEM (STRCONC |objFile| '| < | |tmpFile1| '| > | |tmpFile2|)) + (SPADLET |results| (|readData| |tmpFile2| |results|)) + (AND (PROBE-FILE |tmpFile1|) (DELETE-FILE |tmpFile1|)) + (AND (PROBE-FILE |tmpFile2|) (DELETE-FILE |tmpFile2|)) + |results|)))) + +;invokeNagman(objFiles,nfile,args,dummies,decls,results,actual) == +; actual := [spad2lisp(u) for u in first actual] +; result := spadify(protectedNagCall(objFiles,nfile, _ +; prepareData(args,dummies,actual,decls),_ +; prepareResults(results,args,dummies,actual,decls)),_ +; results,decls,inFirstNotSecond(args,dummies),actual) +; -- Tidy up asps +; -- if objFiles then SYSTEM STRCONC("rm -f ",addSpaces objFiles) +; for fn in objFiles repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) +; result + +(DEFUN |invokeNagman| + (|objFiles| |nfile| |args| |dummies| |decls| |results| |actual|) + (PROG (|result|) + (RETURN + (SEQ (PROGN + (SPADLET |actual| + (PROG (G167273) + (SPADLET G167273 NIL) + (RETURN + (DO ((G167278 (CAR |actual|) + (CDR G167278)) + (|u| NIL)) + ((OR (ATOM G167278) + (PROGN + (SETQ |u| (CAR G167278)) + NIL)) + (NREVERSE0 G167273)) + (SEQ (EXIT (SETQ G167273 + (CONS (|spad2lisp| |u|) + G167273)))))))) + (SPADLET |result| + (|spadify| + (|protectedNagCall| |objFiles| |nfile| + (|prepareData| |args| |dummies| |actual| + |decls|) + (|prepareResults| |results| |args| + |dummies| |actual| |decls|)) + |results| |decls| + (|inFirstNotSecond| |args| |dummies|) + |actual|)) + (DO ((G167287 |objFiles| (CDR G167287)) (|fn| NIL)) + ((OR (ATOM G167287) + (PROGN (SETQ |fn| (CAR G167287)) NIL)) + NIL) + (SEQ (EXIT (AND (PROBE-FILE |fn|) (DELETE-FILE |fn|))))) + |result|))))) + +;nagCall(objFiles,nfile,data,results,tmpFiled,tmpFiler) == +; nagMessagesString := +; $nagMessages => '"on" +; '"off" +; writeData(tmpFiled,data) +; toSend:=STRCONC($nagHost," ",nfile," ",tmpFiler," ",tmpFiled," ",_ +; STRINGIMAGE($fortPersistence)," ", nagMessagesString," ",addSpaces objFiles) +; sockSendString(8,toSend) +; if sockGetInt(8)=1 then +; results := readData(tmpFiler,results) +; else +; error ['"An error was detected while reading data: ", _ +; '"perhaps an incorrect array index was given ?"] +; results + +(DEFUN |nagCall| + (|objFiles| |nfile| |data| |results| |tmpFiled| |tmpFiler|) + (PROG (|nagMessagesString| |toSend|) + (RETURN + (PROGN + (SPADLET |nagMessagesString| + (COND + (|$nagMessages| (MAKESTRING "on")) + ('T (MAKESTRING "off")))) + (|writeData| |tmpFiled| |data|) + (SPADLET |toSend| + (STRCONC |$nagHost| '| | |nfile| '| | |tmpFiler| '| | + |tmpFiled| '| | + (STRINGIMAGE |$fortPersistence|) '| | + |nagMessagesString| '| | + (|addSpaces| |objFiles|))) + (|sockSendString| 8 |toSend|) + (COND + ((EQL (|sockGetInt| 8) 1) + (SPADLET |results| (|readData| |tmpFiler| |results|))) + ('T + (|error| (CONS (MAKESTRING + "An error was detected while reading data: ") + (CONS (MAKESTRING + "perhaps an incorrect array index was given ?") + NIL))))) + |results|)))) + +;protectedNagCall(objFiles,nfile,data,results) == +; errors :=true +; val:=NIL +; td:=generateDataName() +; tr:=generateResultsName() +; UNWIND_-PROTECT( (val:=nagCall(objFiles,nfile,data,results,td,tr) ;errors :=NIL), +; errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) +; val + +(DEFUN |protectedNagCall| (|objFiles| |nfile| |data| |results|) + (PROG (|td| |tr| |val| |errors|) + (RETURN + (SEQ (PROGN + (SPADLET |errors| 'T) + (SPADLET |val| NIL) + (SPADLET |td| (|generateDataName|)) + (SPADLET |tr| (|generateResultsName|)) + (SEQ (UNWIND-PROTECT + (PROGN + (SPADLET |val| + (|nagCall| |objFiles| |nfile| |data| + |results| |td| |tr|)) + (SPADLET |errors| NIL)) + (COND + (|errors| + (EXIT (PROGN + (|resetStackLimits|) + (|sendNagmanErrorSignal|) + (|cleanUpAfterNagman| |td| |tr| + |objFiles|)))))) + (EXIT |val|))))))) + +;cleanUpAfterNagman(f1,f2,listf)== +; PROBE_-FILE(f1) and DELETE_-FILE(f1) +; PROBE_-FILE(f2) and DELETE_-FILE(f2) +; for fn in listf repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) + +(DEFUN |cleanUpAfterNagman| (|f1| |f2| |listf|) + (SEQ (PROGN + (AND (PROBE-FILE |f1|) (DELETE-FILE |f1|)) + (AND (PROBE-FILE |f2|) (DELETE-FILE |f2|)) + (DO ((G167323 |listf| (CDR G167323)) (|fn| NIL)) + ((OR (ATOM G167323) + (PROGN (SETQ |fn| (CAR G167323)) NIL)) + NIL) + (SEQ (EXIT (AND (PROBE-FILE |fn|) (DELETE-FILE |fn|)))))))) + +;sendNagmanErrorSignal()== +;-- excite nagman's signal handler! +; sockSendSignal(8,15) + +(DEFUN |sendNagmanErrorSignal| () (|sockSendSignal| 8 15)) + +;-- Globals +;-- $fortranDirectory := nil +;-- $fortranLibraries := '"-L/usr/local/lib/f90 -lf90 -L/usr/local/lib -lnag -lm" +;-- $fortranTmpDir := '"/tmp/" +;-- $addUnderscoreToFortranNames := true +;-- $fortranCompilerName := '"f90" +;inFirstNotSecond(f,s)== +; [i for i in f | not i in s] + +(DEFUN |inFirstNotSecond| (|f| |s|) + (PROG () + (RETURN + (SEQ (PROG (G167340) + (SPADLET G167340 NIL) + (RETURN + (DO ((G167346 |f| (CDR G167346)) (|i| NIL)) + ((OR (ATOM G167346) + (PROGN (SETQ |i| (CAR G167346)) NIL)) + (NREVERSE0 G167340)) + (SEQ (EXIT (COND + ((NULL (|member| |i| |s|)) + (SETQ G167340 (CONS |i| G167340))))))))))))) + +;-- Code for use in the Windows version of the AXIOM/NAG interface. +;multiToUnivariate f == +; -- Take an AnonymousFunction, replace the bound variables by references to +; -- elements of a vector, and compile it. +; (first f) ^= "+->" => error "in multiToUnivariate: not an AnonymousFunction" +; if PAIRP CADR f then +; vars := CDADR f -- throw away 'Tuple at start of variable list +; else +; vars := [CADR f] +; body := COPY_-TREE CADDR f +; newVariable := GENSYM() +; for index in 0..#vars-1 repeat +; -- Remember that AXIOM lists, vectors etc are indexed from 1 +; body := NSUBST(["elt",newVariable,index+1],vars.(index),body) +; -- We want a Vector DoubleFloat -> DoubleFloat +; target := [["DoubleFloat"],["Vector",["DoubleFloat"]]] +; rest interpret ["ADEF",[newVariable],target,[[],[]],body] + +(DEFUN |multiToUnivariate| (|f|) + (PROG (|vars| |newVariable| |body| |target|) + (RETURN + (SEQ (COND + ((NEQUAL (CAR |f|) '+->) + (|error| '|in multiToUnivariate: not an AnonymousFunction|)) + ('T + (COND + ((PAIRP (CADR |f|)) (SPADLET |vars| (CDADR |f|))) + ('T (SPADLET |vars| (CONS (CADR |f|) NIL)))) + (SPADLET |body| (COPY-TREE (CADDR |f|))) + (SPADLET |newVariable| (GENSYM)) + (DO ((G167360 (SPADDIFFERENCE (|#| |vars|) 1)) + (|index| 0 (QSADD1 |index|))) + ((QSGREATERP |index| G167360) NIL) + (SEQ (EXIT (SPADLET |body| + (NSUBST + (CONS '|elt| + (CONS |newVariable| + (CONS (PLUS |index| 1) NIL))) + (ELT |vars| |index|) |body|))))) + (SPADLET |target| + (CONS (CONS '|DoubleFloat| NIL) + (CONS (CONS '|Vector| + (CONS (CONS '|DoubleFloat| NIL) + NIL)) + NIL))) + (CDR (|interpret| + (CONS 'ADEF + (CONS (CONS |newVariable| NIL) + (CONS |target| + (CONS (CONS NIL (CONS NIL NIL)) + (CONS |body| NIL))))))))))))) + +;functionAndJacobian f == +; -- Take a mapping into n functions of n variables, produce code which will +; -- evaluate function and jacobian values. +; (first f) ^= "+->" => error "in functionAndJacobian: not an AnonymousFunction" +; if PAIRP CADR f then +; vars := CDADR f -- throw away 'Tuple at start of variable list +; else +; vars := [CADR f] +; #(vars) ^= #(CDADDR f) => +; error "number of variables should equal number of functions" +; funBodies := COPY_-TREE CDADDR f +; jacBodies := [:[DF(f,v) for v in vars] for f in funBodies] where +; DF(fn,var) == +; ["@",["convert",["differentiate",fn,var]],"InputForm"] +; jacBodies := CDDR interpret [["$elt",["List",["InputForm"]],"construct"],:jacBodies] +; newVariable := GENSYM() +; for index in 0..#vars-1 repeat +; -- Remember that AXIOM lists, vectors etc are indexed from 1 +; funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) +; jacBodies := NSUBST(["elt",newVariable,index+1],vars.(index),jacBodies) +; target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]],["Integer"]] +; rest interpret +; ["ADEF",[newVariable,"flag"],target,[[],[],[]],_ +; ["IF", ["=","flag",1],_ +; ["vector",["construct",:funBodies]],_ +; ["vector",["construct",:jacBodies]]]] + +(DEFUN |functionAndJacobian,DF| (|fn| |var|) + (CONS '@ + (CONS (CONS '|convert| + (CONS (CONS '|differentiate| + (CONS |fn| (CONS |var| NIL))) + NIL)) + (CONS '|InputForm| NIL)))) + +(DEFUN |functionAndJacobian| (|f|) + (PROG (|vars| |newVariable| |funBodies| |jacBodies| |target|) + (RETURN + (SEQ (COND + ((NEQUAL (CAR |f|) '+->) + (|error| '|in functionAndJacobian: not an AnonymousFunction|)) + ('T + (COND + ((PAIRP (CADR |f|)) (SPADLET |vars| (CDADR |f|))) + ('T (SPADLET |vars| (CONS (CADR |f|) NIL)))) + (COND + ((NEQUAL (|#| |vars|) (|#| (CDADDR |f|))) + (|error| '|number of variables should equal number of functions|)) + ('T (SPADLET |funBodies| (COPY-TREE (CDADDR |f|))) + (SPADLET |jacBodies| + (PROG (G167379) + (SPADLET G167379 NIL) + (RETURN + (DO ((G167384 |funBodies| + (CDR G167384)) + (|f| NIL)) + ((OR (ATOM G167384) + (PROGN + (SETQ |f| (CAR G167384)) + NIL)) + G167379) + (SEQ (EXIT + (SETQ G167379 + (APPEND G167379 + (PROG (G167394) + (SPADLET G167394 NIL) + (RETURN + (DO + ((G167399 |vars| + (CDR G167399)) + (|v| NIL)) + ((OR (ATOM G167399) + (PROGN + (SETQ |v| + (CAR G167399)) + NIL)) + (NREVERSE0 G167394)) + (SEQ + (EXIT + (SETQ G167394 + (CONS + (|functionAndJacobian,DF| + |f| |v|) + G167394))))))))))))))) + (SPADLET |jacBodies| + (CDDR (|interpret| + (CONS + (CONS '|$elt| + (CONS + (CONS '|List| + (CONS (CONS '|InputForm| NIL) + NIL)) + (CONS '|construct| NIL))) + |jacBodies|)))) + (SPADLET |newVariable| (GENSYM)) + (DO ((G167410 (SPADDIFFERENCE (|#| |vars|) 1)) + (|index| 0 (QSADD1 |index|))) + ((QSGREATERP |index| G167410) NIL) + (SEQ (EXIT (PROGN + (SPADLET |funBodies| + (NSUBST + (CONS '|elt| + (CONS |newVariable| + (CONS (PLUS |index| 1) NIL))) + (ELT |vars| |index|) + |funBodies|)) + (SPADLET |jacBodies| + (NSUBST + (CONS '|elt| + (CONS |newVariable| + (CONS (PLUS |index| 1) NIL))) + (ELT |vars| |index|) + |jacBodies|)))))) + (SPADLET |target| + (CONS (CONS '|Vector| + (CONS (CONS '|DoubleFloat| NIL) + NIL)) + (CONS (CONS '|Vector| + (CONS (CONS '|DoubleFloat| NIL) + NIL)) + (CONS (CONS '|Integer| NIL) NIL)))) + (CDR (|interpret| + (CONS 'ADEF + (CONS (CONS |newVariable| + (CONS '|flag| NIL)) + (CONS |target| + (CONS + (CONS NIL + (CONS NIL (CONS NIL NIL))) + (CONS + (CONS 'IF + (CONS + (CONS '= + (CONS '|flag| (CONS 1 NIL))) + (CONS + (CONS '|vector| + (CONS + (CONS '|construct| + |funBodies|) + NIL)) + (CONS + (CONS '|vector| + (CONS + (CONS '|construct| + |jacBodies|) + NIL)) + NIL)))) + NIL))))))))))))))) + +;vectorOfFunctions f == +; -- Take a mapping into n functions of m variables, produce code which will +; -- evaluate function values. +; (first f) ^= "+->" => error "in vectorOfFunctions: not an AnonymousFunction" +; if PAIRP CADR f then +; vars := CDADR f -- throw away 'Tuple at start of variable list +; else +; vars := [CADR f] +; funBodies := COPY_-TREE CDADDR f +; newVariable := GENSYM() +; for index in 0..#vars-1 repeat +; -- Remember that AXIOM lists, vectors etc are indexed from 1 +; funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) +; target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]]] +; rest interpret ["ADEF",[newVariable],target,[[],[]],["vector",["construct",:funBodies]]] + +(DEFUN |vectorOfFunctions| (|f|) + (PROG (|vars| |newVariable| |funBodies| |target|) + (RETURN + (SEQ (COND + ((NEQUAL (CAR |f|) '+->) + (|error| '|in vectorOfFunctions: not an AnonymousFunction|)) + ('T + (COND + ((PAIRP (CADR |f|)) (SPADLET |vars| (CDADR |f|))) + ('T (SPADLET |vars| (CONS (CADR |f|) NIL)))) + (SPADLET |funBodies| (COPY-TREE (CDADDR |f|))) + (SPADLET |newVariable| (GENSYM)) + (DO ((G167432 (SPADDIFFERENCE (|#| |vars|) 1)) + (|index| 0 (QSADD1 |index|))) + ((QSGREATERP |index| G167432) NIL) + (SEQ (EXIT (SPADLET |funBodies| + (NSUBST + (CONS '|elt| + (CONS |newVariable| + (CONS (PLUS |index| 1) NIL))) + (ELT |vars| |index|) |funBodies|))))) + (SPADLET |target| + (CONS (CONS '|Vector| + (CONS (CONS '|DoubleFloat| NIL) NIL)) + (CONS (CONS '|Vector| + (CONS (CONS '|DoubleFloat| NIL) + NIL)) + NIL))) + (CDR (|interpret| + (CONS 'ADEF + (CONS (CONS |newVariable| NIL) + (CONS |target| + (CONS (CONS NIL (CONS NIL NIL)) + (CONS + (CONS '|vector| + (CONS + (CONS '|construct| |funBodies|) + NIL)) + NIL))))))))))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}