Artifact 49f8365ec0a71a3517fa6ad6b47e8b4d8c25a92b2ef9821aca49c06473251de5:
- Executable file
r38/packages/gentran/lspfor.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 26771) [annotate] [blame] [check-ins using] [more...]
module lspfor; %% GENTRAN LISP-to-FORTRAN Translation Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Updates: % M. Warns 7 Oct 89 Patch in FORTEXP1 for negative constant exponents % and integer arguments of functions like SQRT added. % M.C. Dewar and J.H. Davenport 8 Jan 88 Double precision etc. added. % Entry Point: FortCode symbolic$ % To allow Fortran-90 Extensions: fluid '(!*f90)$ switch f90$ fluid '(!*gendecs)$ switch gendecs$ fluid '(!*getdecs)$ fluid '(!*makecalls)$ switch makecalls$ !*makecalls := t$ % User-Accessible Global Variables % global '(gentranlang!* fortlinelen!* minfortlinelen!* fortcurrind!* !*fortcurrind!* tablen!*)$ share fortcurrind!*, fortlinelen!*, minfortlinelen!*, tablen!*$ fortcurrind!* := 0$ !*fortcurrind!* := 6$ %current level of indentation for FORTRAN code fortlinelen!* := 72$ minfortlinelen!* := 40$ % Double Precision Switch (defaults to OFF) - mcd 13/1/88 % fluid '(!*double); % !*double := t; switch double; % GENTRAN Global Variables % global '(!*notfortranfuns!* !*endofloopstack!* !*subprogname!*)$ !*notfortranfuns!*:= '(acosh asinh atanh cot dilog ei erf sec)$ %mcd 10/11/87 !*endofloopstack!* := nil$ !*subprogname!* := nil$ %name of subprogram being generated global '(!*do!* deftype!*)$ % The following ought to be all the legal Fortran types mcd 19/11/87. global '(!*legalforttypes!*); !*legalforttypes!* := '(real integer complex real!*8 complex!*16 logical implicit! integer implicit! real implicit! complex implicit! real!*8 implicit! complex!*16 implicit! logical)$ global '(!*stdout!*)$ global '(!*posn!* !$!#); %% %% %% LISP-to-FORTRAN Translation Functions %% %% %% put('fortran,'formatter,'formatfort); put('fortran,'codegen,'fortcode); put('fortran,'proctem,'procforttem); put('fortran,'gendecs,'fortdecs); put('fortran,'assigner,'mkffortassign); put('fortran,'boolean!-type,'logical); %% Control Function %% symbolic procedure fortcode forms; for each f in forms conc if atom f then fortexp f else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then fortexp f else if lispstmtp f or lispstmtgpp f then if !*gendecs then begin scalar r; r := append(fortdecs symtabget('!*main!*, '!*decs!*), fortstmt f); symtabrem('!*main!*, '!*decs!*); return r end else fortstmt f else if lispdefp f then fortsubprog f else fortexp f$ %% Subprogram Translation %% symbolic procedure fortsubprog deff; begin scalar type, stype, name, params, body, lastst, r; name := !*subprogname!* := cadr deff; if onep length (body := cdddr deff) and lispstmtgpp car body then << body := cdar body; if null car body then body := cdr body >>; if lispreturnp (lastst := car reverse body) then body := append(body, list '(end)) else if not lispendp lastst then body := append(body, list('(return), '(end))); type := symtabget(name, name); if type then type := cadr type; stype := symtabget(name, '!*type!*) or ( if type or functionformp(body, name) then 'function else 'subroutine ); symtabrem(name, '!*type!*); params := symtabget(name, '!*params!*) or caddr deff; symtabrem(name, '!*params!*); if !*getdecs and null type and stype eq 'function then type := deftype!*; if type then << symtabrem(name, name); % Generate the correct double precision type name - mcd 28/1/88 % if !*double then if type memq '(real real!*8) then type := 'double! precision else if type eq 'complex then type := 'complex!*16; >>; r := mkffortsubprogdec(type, stype, name, params); if !*gendecs then r := append(r, fortdecs symtabget(name, '!*decs!*)); r := append(r, for each s in body conc fortstmt s); if !*gendecs then << symtabrem(name, nil); symtabrem(name, '!*decs!*) >>; return r end$ %% Generation of Declarations %% symbolic procedure fortdecs decs; for each tl in formtypelists decs conc mkffortdec(car tl, cdr tl)$ %% Expression Translation %% procedure fortexp exp; fortexp1(exp, 0)$ symbolic procedure fortexp1(exp, wtin); if atom exp then list fortranname exp else if listp exp and onep length exp then fortranname exp else if optype car exp then begin scalar wt, op, res; wt := fortranprecedence car exp; op := fortranop car exp; exp := cdr exp; if onep length exp then res := op . fortexp1(car exp, wt) else << res := fortexp1(car exp, wt); if op eq '!+ then while exp := cdr exp do << if atom car exp or caar exp neq 'minus then res := append(res, list op); res := append(res, fortexp1(car exp, wt)) >> else if op eq '!*!* then while exp := cdr exp do begin if numberp car exp and lessp(car exp, 0) then res := append(append(res, list op), insertparens fortexp1(car exp, wt)) else res := append(append(res, list op), fortexp1(car exp, wt)) end else while exp := cdr exp do res := append(append(res, list op), fortexp1(car exp, wt)) >>; if wtin >= wt then res := insertparens res; return res end else if car exp eq 'literal then fortliteral exp else if car exp eq 'range then append(fortexp cadr exp,'!: . fortexp caddr exp) else if car exp eq '!:rd!: then if smallfloatp cdr exp then list cdr exp else begin scalar mt; % Print bigfloats more naturally. MCD 26/2/90 integer dotpos,!:lower!-sci!:,!:upper!-sci!:; % This forces most numbers to exponential format. mt := rd!:explode exp; exp := car mt; mt := cadr mt + caddr mt - 1; exp := append(list('literal,car exp, '!.),cdr exp); if null (mt = 0) then exp := append(exp, list(if !*double then '!D else '!E,mt)) else if !*double then exp := append(exp,'(!D 0)); return fortliteral exp; end else if car exp eq '!:crn!: then fortexp1(!*crn2cr exp,wtin) else if car exp eq '!:gi!: then fortexp1(!*gi2cr exp,wtin) else if car exp eq '!:cr!: then if !*double and !*f90 then ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin), ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin), list( '!, , 'KIND!(!1!.!0!D!0!) , '!) )) ) else ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin), ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin), list '!))) % We must make this list up at run time, since there's % a CONC loop that relies on being able to RPLAC into it. % Yuck. JHD/MCD 19.6.89 else begin scalar op, res, intrinsic; intrinsic := get(car exp, '!*fortranname!*); op := fortranname car exp; exp := cdr exp; % Make the arguments of intrinsic functions real if we aren't % sure. Note that we can't simply evaluate the argument and % test that, unless it is a constant. MCD 7/11/89. res := cdr foreach u in exp conc '!, . if not intrinsic then fortexp1(u,0) else if fixp u then list float u else if isfloat u or memq(op,'(real dble)) then fortexp1(u,0) else (fortranname 'real . insertparens fortexp1(u,0)); return op . insertparens res end; symbolic procedure isfloat u; % Returns T if u is a float or a list whose car is an intrinsic % function name. MCD 7/11/89. floatp(u) or (idp u and declared!-as!-float(u) ) or pairp(u) and (car u eq '!:rd!: or get(car u,'!*fortranname!*) or declared!-as!-float(car u) ); procedure fortranop op; get(op, '!*fortranop!*) or op$ put('or, '!*fortranop!*, '!.or!. )$ put('and, '!*fortranop!*, '!.and!.)$ put('not, '!*fortranop!*, '!.not!.)$ put('equal, '!*fortranop!*, '!.eq!. )$ put('neq, '!*fortranop!*, '!.ne!. )$ put('greaterp, '!*fortranop!*, '!.gt!. )$ put('geq, '!*fortranop!*, '!.ge!. )$ put('lessp, '!*fortranop!*, '!.lt!. )$ put('leq, '!*fortranop!*, '!.le!. )$ put('plus, '!*fortranop!*, '!+ )$ put('times, '!*fortranop!*, '!* )$ put('quotient, '!*fortranop!*, '/ )$ put('minus, '!*fortranop!*, '!- )$ put('expt, '!*fortranop!*, '!*!* )$ % This procedure (and FORTRANNAME, RATFORNAME properties, and % the DOUBLE flag) are shared between FORTRAN and RATFOR procedure fortranname a; % Amended mcd 10/11/87 if stringp a then stringtoatom a % convert a to atom containing "'s else << if a memq !*notfortranfuns!* then << wrs cdr !*stdout!*; prin2 "*** WARNING: "; prin1 a; prin2t " is not an intrinsic Fortran function"; >>$ if !*double then get(a, '!*doublename!*) or a else get(a, '!*fortranname!*) or a >>$ put('true, '!*fortranname!*, '!.true!. )$ put('false, '!*fortranname!*, '!.false!.)$ %% mcd 10/11/87 %% Reduce functions' equivalent Fortran 77 real function names put('abs,'!*fortranname!*, 'abs)$ put('sqrt,'!*fortranname!*, 'sqrt)$ put('exp,'!*fortranname!*, 'exp)$ put('log,'!*fortranname!*, 'alog)$ put('ln,'!*fortranname!*, 'alog)$ put('sin,'!*fortranname!*, 'sin)$ put('cos,'!*fortranname!*, 'cos)$ put('tan,'!*fortranname!*, 'tan)$ put('acos,'!*fortranname!*, 'acos)$ put('asin,'!*fortranname!*, 'asin)$ put('atan,'!*fortranname!*, 'atan)$ put('sinh,'!*fortranname!*, 'sinh)$ put('cosh,'!*fortranname!*, 'cosh)$ put('tanh,'!*fortranname!*, 'tanh)$ put('real,'!*fortranname!*, 'real)$ put('max,'!*fortranname!*, 'amax1)$ put('min,'!*fortranname!*, 'amin1)$ %% Reduce function's equivalent Fortran 77 double-precision names put('abs,'!*doublename!*, 'dabs)$ put('sqrt,'!*doublename!*, 'dsqrt)$ put('exp,'!*doublename!*, 'dexp)$ put('log,'!*doublename!*, 'dlog)$ put('ln,'!*doublename!*, 'dlog)$ put('sin,'!*doublename!*, 'dsin)$ put('cos,'!*doublename!*, 'dcos)$ put('tan,'!*doublename!*, 'dtan)$ put('acos,'!*doublename!*, 'dacos)$ put('asin,'!*doublename!*, 'dasin)$ put('atan,'!*doublename!*, 'datan)$ put('sinh,'!*doublename!*, 'dsinh)$ put('cosh,'!*doublename!*, 'dcosh)$ put('tanh,'!*doublename!*, 'dtanh)$ put('true, '!*doublename!*, '!.true!. )$ put('false, '!*doublename!*, '!.false!.)$ put('real,'!*doublename!*, 'dble)$ put('max,' !*doublename!*, 'dmax1)$ put('min, '!*doublename!*, 'dmin1)$ %% end of mcd procedure fortranprecedence op; get(op, '!*fortranprecedence!*) or 9$ put('or, '!*fortranprecedence!*, 1)$ put('and, '!*fortranprecedence!*, 2)$ put('not, '!*fortranprecedence!*, 3)$ put('equal, '!*fortranprecedence!*, 4)$ put('neq, '!*fortranprecedence!*, 4)$ put('greaterp, '!*fortranprecedence!*, 4)$ put('geq, '!*fortranprecedence!*, 4)$ put('lessp, '!*fortranprecedence!*, 4)$ put('leq, '!*fortranprecedence!*, 4)$ put('plus, '!*fortranprecedence!*, 5)$ put('times, '!*fortranprecedence!*, 6)$ put('quotient, '!*fortranprecedence!*, 6)$ put('minus, '!*fortranprecedence!*, 7)$ put('expt, '!*fortranprecedence!*, 8)$ %% Statement Translation %% procedure fortstmt stmt; if null stmt then nil else if lisplabelp stmt then fortstmtnum stmt else if car stmt eq 'literal then fortliteral stmt else if lispreadp stmt then fortread stmt else if lispassignp stmt then fortassign stmt else if lispprintp stmt then fortwrite stmt else if lispcondp stmt then fortif stmt else if lispbreakp stmt then fortbreak stmt else if lispgop stmt then fortgoto stmt else if lispreturnp stmt then fortreturn stmt else if lispstopp stmt then fortstop stmt else if lispendp stmt then fortend stmt else if lispwhilep stmt then fortwhile stmt else if lisprepeatp stmt then fortrepeat stmt else if lispforp stmt then fortfor stmt else if lispstmtgpp stmt then fortstmtgp stmt else if lispdefp stmt then fortsubprog stmt else if lispcallp stmt then fortcall stmt$ procedure fortassign stmt; mkffortassign(cadr stmt, caddr stmt)$ procedure fortbreak stmt; if null !*endofloopstack!* then gentranerr('e, nil, "BREAK NOT INSIDE LOOP - CANNOT BE TRANSLATED", nil) else if atom car !*endofloopstack!* then begin scalar n1; n1 := genstmtnum(); rplaca(!*endofloopstack!*, list(car !*endofloopstack!*, n1)); return mkffortgo n1 end else mkffortgo cadar !*endofloopstack!*$ procedure fortcall stmt; mkffortcall(car stmt, cdr stmt)$ procedure fortfor stmt; begin scalar n1, result, var, loexp, stepexp, hiexp, stmtlst; var := cadr stmt; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; n1 := genstmtnum(); !*endofloopstack!* := n1 . !*endofloopstack!*; result := mkffortdo(n1, var, loexp, hiexp, stepexp); indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); indentfortlevel(-1); result := append(result, mkffortcontinue n1); if pairp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortend stmt; mkffortend()$ procedure fortgoto stmt; begin scalar stmtnum; if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum()); return mkffortgo stmtnum end$ symbolic procedure fortif stmt; begin scalar r, st; r := mkffortif caadr stmt; indentfortlevel(+1); st := seqtogp cdadr stmt; if eqcar(st, 'cond) and length st=2 then st := mkstmtgp(0, list st); r := append(r, fortstmt st); indentfortlevel(-1); stmt := cdr stmt; while (stmt := cdr stmt) and caar stmt neq t do << r := append(r, mkffortelseif caar stmt); indentfortlevel(+1); st := seqtogp cdar stmt; if eqcar(st, 'cond) and length st=2 then st := mkstmtgp(0, list st); r := append(r, fortstmt st); indentfortlevel(-1) >>; if stmt then << r := append(r, mkffortelse()); indentfortlevel(+1); st := seqtogp cdar stmt; if eqcar(st, 'cond) and length st=2 then st := mkstmtgp(0, list st); r := append(r, fortstmt st); indentfortlevel(-1) >>; return append(r,mkffortendif()); end$ symbolic procedure mkffortif exp; append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp), list('!),'! , 'then , mkfortterpri()))$ symbolic procedure mkffortelseif exp; append(append(list(mkforttab(), 'else, '! , 'if, '! , '!(), fortexp exp), list('!), 'then, mkcterpri()))$ symbolic procedure mkffortelse(); list(mkforttab(), 'else, mkfortterpri())$ symbolic procedure mkffortendif(); list(mkforttab(), 'endif, mkfortterpri())$ procedure fortliteral stmt; mkffortliteral cdr stmt$ procedure fortread stmt; mkffortread cadr stmt$ procedure fortrepeat stmt; begin scalar n, result, stmtlst, logexp; stmtlst := reverse cdr stmt; logexp := car stmtlst; stmtlst := reverse cdr stmtlst; n := genstmtnum(); !*endofloopstack!* := 'dummy . !*endofloopstack!*; result := mkffortcontinue n; indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); indentfortlevel(-1); result := append(result, mkffortifgo(list('not, logexp), n)); if pairp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortreturn stmt; if onep length stmt then mkffortreturn() else if !*subprogname!* then append(mkffortassign(!*subprogname!*, cadr stmt), mkffortreturn()) else gentranerr('e, nil, "RETURN NOT INSIDE FUNCTION - CANNOT BE TRANSLATED", nil)$ procedure fortstmtgp stmtgp; << if car stmtgp eq 'progn then stmtgp := cdr stmtgp else stmtgp := cddr stmtgp; for each stmt in stmtgp conc fortstmt stmt >>$ procedure fortstmtnum label; begin scalar stmtnum; if not ( stmtnum := get(label, '!*stmtnum!*) ) then stmtnum := put(label, '!*stmtnum!*, genstmtnum()); return mkffortcontinue stmtnum end$ procedure fortstop stmt; mkffortstop()$ procedure fortwhile stmt; begin scalar n1, n2, result, logexp, stmtlst; logexp := cadr stmt; stmtlst := cddr stmt; n1 := genstmtnum(); n2 := genstmtnum(); !*endofloopstack!* := n2 . !*endofloopstack!*; result := append(list(n1, '! ), mkffortifgo(list('not, logexp), n2)); indentfortlevel(+1); result := append(result, for each st in stmtlst conc fortstmt st); result := append(result, mkffortgo n1); indentfortlevel(-1); result := append(result, mkffortcontinue n2); if pairp car !*endofloopstack!* then result := append(result, mkffortcontinue cadar !*endofloopstack!*); !*endofloopstack!* := cdr !*endofloopstack!*; return result end$ procedure fortwrite stmt; mkffortwrite cdr stmt$ %% %% %% FORTRAN Code Formatting Functions %% %% %% %% Statement Formatting %% % A macro used to prevent things with *fortranname* or *doublename* % properties being evaluated in certain circumstances. MCD 28.3.94 symbolic smacro procedure fortexp_name(u); if atom u then list(u) else rplaca(fortexp ('dummyArrayToken . cdr u), car u)$ symbolic procedure mkffortassign(lhs, rhs); append(append(mkforttab() . fortexp_name lhs, '!= . fortexp rhs), list mkfortterpri())$ symbolic procedure mkffortcall(fname, params); % Installed the switch makecalls 18/11/88 mcd. << if params then params := append(append(list '!(, for each p in insertcommas params conc fortexp p), list '!)); % If we want to generate bits of statements, then what might % appear a subroutine call may in fact be a function reference. if !*makecalls then append(append(list(mkforttab(), 'call, '! ), fortexp fname), append(params, list mkfortterpri())) else append(fortexp fname,params) >>$ procedure mkffortcontinue stmtnum; list(stmtnum, '! , mkforttab(), 'continue, mkfortterpri())$ symbolic procedure mkffortdec(type, varlist); %Ammended mcd 13/11/87 << if type equal 'scalar then type := deftype!*; if type and null (type memq !*legalforttypes!*) then gentranerr('e,type,"Illegal Fortran type. ",nil); type := type or 'dimension; % Generate the correct double precision type name - mcd 14/1/88 % if !*double then if type memq '(real real!*8) then type := 'double! precision else if type memq '(implicit! real implicit! real!*8) then type := 'implicit! double! precision else if type eq 'complex then type := 'complex!*16 else if type eq 'implicit! complex then type := 'implicit! complex!*16; varlist := for each v in insertcommas varlist conc fortexp_name v; if implicitp type then append(list(mkforttab(), type, '! , '!(), append(varlist, list('!), mkfortterpri()))) else append(list(mkforttab(), type, '! ), append(varlist,list mkfortterpri())) >>$ procedure mkffortdo(stmtnum, var, lo, hi, incr); << if onep incr then incr := nil else if incr then incr := '!, . fortexp incr; append(append(append(list(mkforttab(), !*do!*, '! , stmtnum, '! ), fortexp var), append('!= . fortexp lo, '!, . fortexp hi)), append(incr, list mkfortterpri())) >>$ procedure mkffortend; list(mkforttab(), 'end, mkfortterpri())$ procedure mkffortgo stmtnum; list(mkforttab(), 'goto, '! , stmtnum, mkfortterpri())$ procedure mkffortifgo(exp, stmtnum); append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp), list('!), '! , 'goto, '! , stmtnum, mkfortterpri()))$ symbolic procedure mkffortliteral args; begin scalar !*lower; return for each a in args conc if a eq 'tab!* then list mkforttab() else if a eq 'cr!* then list mkfortterpri() else if pairp a then fortexp a else list stripquotes a end$ procedure mkffortread var; append(list(mkforttab(), 'read, '!(!*!,!*!), '! ), append(fortexp var, list mkfortterpri()))$ procedure mkffortreturn; list(mkforttab(), 'return, mkfortterpri())$ procedure mkffortstop; list(mkforttab(), 'stop, mkfortterpri())$ procedure mkffortsubprogdec(type, stype, name, params); << if params then params := append('!( . for each p in insertcommas params conc fortexp p, list '!)); if type then type := list(mkforttab(), type, '! , stype, '! ) else type := list(mkforttab(), stype, '! ); append(append(type, fortexp name), append(params, list mkfortterpri())) >>$ procedure mkffortwrite arglist; append(append(list(mkforttab(), 'write, '!(!*!,!*!), '! ), for each arg in insertcommas arglist conc fortexp arg), list mkfortterpri())$ %% Indentation Control %% procedure mkforttab; list('forttab, fortcurrind!* + 6)$ procedure indentfortlevel n; fortcurrind!* := fortcurrind!* + n * tablen!*$ procedure mkfortterpri; list 'fortterpri$ %% FORTRAN Code Formatting & Printing Functions %% fluid '(maxint); maxint := 2**31-1; symbolic procedure formatfort lst; begin scalar linelen,str,!*lower; linelen := linelength 300; !*posn!* := 0; for each elt in lst do if pairp elt then lispeval elt else << if fixp elt and (elt>maxint or elt<-maxint) then elt := cdr i2rd!* elt; str:=explode2 elt; if floatp elt then if !*double then if memq('!e,str) then str:=subst('!D,'!e,str) else if memq('!E,str) % some LISPs use E not e then str:=subst('!D,'!E,str) else str:=append(str,'(D !0)) else if memq('!e,str) then str:=subst('!E,'!e,str); % get the casing conventions correct if !*posn!* + length str > fortlinelen!* then fortcontline(); for each u in str do pprin2 u >>; linelength linelen end$ procedure fortcontline; << fortterpri(); pprin2 " ."; forttab !*fortcurrind!*; pprin2 " " >>$ procedure fortterpri; pterpri()$ procedure forttab n; << !*fortcurrind!* := max(min0(n, fortlinelen!* - minfortlinelen!*),6); if (n := !*fortcurrind!* - !*posn!*) > 0 then pprin2 nspaces n >>$ %% FORTRAN Template routines%% symbolic procedure procforttem; begin scalar c, linelen, !*lower; linelen := linelength 150; c := procfortcomm(); while c neq !$eof!$ do if c memq '(!F !f !S !s) then <<pprin2 c; c := procsubprogheading c>> else if c eq !$eol!$ then <<pterpri(); c := procfortcomm()>> else if c eq '!; then c := procactive() else <<pprin2 c; c := readch()>>; linelength linelen end$ procedure procfortcomm; % <col 1>C ... <cr> % % <col 1>c ... <cr> % begin scalar c; while (c := readch()) memq '(!C !c) do << pprin2 c; repeat if (c := readch()) neq !$eol!$ then pprin2 c until c eq !$eol!$; pterpri() >>; return c end$ %% This function is shared between FORTRAN and RATFOR %% procedure procsubprogheading c; % Altered to allow an active statement to be included in a subprogram % heading. This is more flexible than forbidding it as in the previous % version, although it does mean that where such a statement occurs the % value of !$!# may be incorrect. MCD 21/11/90 begin scalar lst, name, i, propname; lst := if c memq '(!F !f) then '((!U !u) (!N !n) (!C !c) (!T !t) (!I !i) (!O !o) (!N !n)) else '((!U !u) (!B !b) (!R !r) (!O !o) (!U !u) (!T !t) (!I !i) (!N !n) (!E !e)); while lst and (c := readch()) memq car lst do << pprin2 c; lst := cdr lst >>; if lst then return c; c:=flushspaces readch(); while not(seprp c or c eq '!() do << name := aconc(name, c); pprin2 c; c := readch() >>; name := intern compress name; if not !*gendecs then symtabput(name, nil, nil); propname := if gentranlang!* eq 'fortran then '!*fortranname!* else '!*ratforname!*; put('!$0, propname, name); c:=flushspaces c; if c neq '!( then return c; i := 1; pprin2 c; c := readch(); while c neq '!) and c neq '!; do << while c neq '!; and (seprp c or c eq '!,) do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; if c neq '!; then << name := list c; pprin2 c; while not (seprp (c := readch()) or c memq list('!,,'!;, '!))) do << name := aconc(name, c); pprin2 c >>; put(intern compress append(explode2 '!$, explode2 i), propname, intern compress name); i := add1 i; c:=flushspaces c; >>; >>; !$!# := sub1 i; while get(name := intern compress append(explode2 '!$, explode2 i), propname) do remprop(name, propname); return c end$ endmodule; end;