Artifact 6dba290243834db7b10935ab1a78f985e6872a787b18f458430cb3561d10782c:
- Executable file
r37/packages/gentran/lsppasc.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: 27327) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/gentran/lsppasc.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: 27327) [annotate] [blame] [check-ins using]
module lsppasc; %% GENTRAN LISP-to-PASCAL Translation Module %% %% Author: John Fitch and James Davenport after Barbara L. Gates %% %% November 1987 %% % Entry Point: PASCCode symbolic$ fluid '(!*gendecs)$ switch gendecs$ % User-Accessible Global Variables % global '(pasclinelen!* minpasclinelen!* !*pasccurrind!* pasccurrind!* tablen!* pascfuncname!*)$ share pasclinelen!*, minpasclinelen!*, pasccurrind!*, tablen!*, pascfuncname!*$ pasccurrind!* := 0$ minpasclinelen!* := 40$ pasclinelen!* := 70$ !*pasccurrind!* := 0$ %current level of indentation for PASCAL code global '(!*do!* !*for!*)$ global '(!*posn!* !$!#)$ %% %% %% LISP-to-PASCAL Translation Functions %% %% %% put('pascal,'formatter,'formatpasc); put('pascal,'codegen,'pasccode); put('pascal,'proctem,'procpasctem); put('pascal,'gendecs,'pascdecs); put('pascal,'assigner,'mkfpascassign); put('pascal,'boolean!-type,'boolean); symbolic procedure pasc!-symtabput(name,type,value); % Like symtabput, but indirects through TYPE declarations. % has to be recursive begin scalar basetype, origtype, wastypedecl; basetype:=car value; if basetype = 'TYPE then << wastypedecl:=t; value:=cdr value; basetype:=car value >>; origtype:=symtabget(name,basetype) or symtabget('!*main!*,basetype); if pairp origtype then origtype:=cdr origtype; % strip off name; if pairp origtype and car origtype = 'TYPE then value:= (cadr origtype). append(cdr value,cddr origtype); if wastypedecl then symtabput(name,type,'TYPE . value) else symtabput(name,type,value); end; %% Control Function %% procedure pasccode forms; for each f in forms conc if atom f then pascexp f else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then pascexp f else if lispstmtp f or lispstmtgpp f then if !*gendecs then begin scalar r; r := append(pascdecs symtabget('!*main!*, '!*decs!*), pascstmt f); symtabrem('!*main!*, '!*decs!*); return r end else pascstmt f else if lispdefp f then pascproc f else pascexp f$ %% Procedure Translation %% procedure pascproc deff; begin scalar type, name, params, paramtypes, vartypes, body, r; name := 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 (type := symtabget(name, name)) then << type := cadr type; symtabrem(name, name) >>; params := symtabget(name, '!*params!*) or caddr deff; symtabrem(name, '!*params!*); for each dec in symtabget(name, '!*decs!*) do if car dec memq params then paramtypes := append(paramtypes, list dec) else if cadr dec neq 'TYPE then vartypes := append(vartypes, list dec); r := mkfpascprocdec(type, name, params, paramtypes); if !*gendecs then << r:= append(r,list(mkpasctab(),'label,mkpascterpri())); indentpasclevel(+1); r:= append(r,list(mkpasctab(),'99999, '!;, mkpascterpri())); indentpasclevel(-1); r := append(r, pascdecs vartypes) >>; r:= append(r, mkfpascbegingp() ); indentpasclevel(+1); r := append(r, for each s in body conc pascstmt s); indentpasclevel(-1); r:=append(r,list(mkpasctab(), 99999, '!:, mkpascterpri())); r := append(r, mkfpascendgp()); if !*gendecs then << symtabrem(name, nil); symtabrem(name, '!*decs!*) >>; return r end$ %% Generation of Declarations %% procedure pascdecs decs; begin scalar r; decs:=for each r in decs conc if cadr r eq 'type then nil else list r; if decs then << indentpasclevel(+1); decs:=for each tl in formtypelists decs conc mkfpascdec(car tl, cdr tl); indentpasclevel(-1); r:=append(list(mkpasctab(),'var, mkpascterpri()), decs) >>; return r end$ %% Expression Translation %% procedure pascexp exp; pascexp1(exp, 0)$ procedure pascexp1(exp, wtin); if atom exp then list pascname exp else if onep length exp then pascname exp else if optype car exp then begin scalar wt, op, res; wt := pascprecedence car exp; op := pascop car exp; exp := cdr exp; if onep length exp then res := op . pascexp1(car exp, wt) else << res := pascexp1(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, pascexp1(car exp, wt)) >> else while exp := cdr exp do res := append(append(res, list op), pascexp1(car exp, wt)) >>; if wtin >= wt then res := insertparens res; return res end else if car exp eq 'literal then pascliteral exp else if car exp eq 'range then append(pascexp cadr exp, '!.!. . pascexp caddr exp) else if car exp eq '!:rd!: then begin scalar mt; 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('!e,mt)); return pascliteral exp; end else if car exp memq '(!:cr!: !:crn!: !:gi!:) then gentranerr('e,exp,"Pascal doesn't support complex data",nil) else if arrayeltp exp then if cddr exp and ((caddr exp) equal '!.!.) then pascname car exp . pascinsertbrackets cdr exp else pascname car exp . pascinsertbrackets cdr foreach s in cdr exp conc '!, . pascexp1(s, 0) else begin scalar op, res; op := pascname car exp; exp := cdr exp; res := pascexp1(car exp, 0); while exp := cdr exp do res := append(append(res, list '!,), pascexp1(car exp, 0)); return op . insertparens res end$ procedure pascop op; get(op, '!*pascop!*) or op$ put('or, '!*pascop!*, 'or )$ put('and, '!*pascop!*, 'and )$ put('not, '!*pascop!*, 'not )$ put('equal, '!*pascop!*, '!= )$ put('neq, '!*pascop!*, '!<!>)$ put('greaterp, '!*pascop!*, '!> )$ put('geq, '!*pascop!*, '!>!=)$ put('lessp, '!*pascop!*, '!< )$ put('leq, '!*pascop!*, '!<!=)$ put('plus, '!*pascop!*, '!+ )$ put('times, '!*pascop!*, '!* )$ put('quotient, '!*pascop!*, '!/ )$ put('minus, '!*pascop!*, '!- )$ put('expt, '!*pascop!*, '!*!*)$ procedure pascname a; if stringp a then stringtopascatom a % convert a to atom containing ''s else get(a, '!*pascname!*) or a$ procedure stringtopascatom a; intern compress foreach c in append('!' . explode2 a, list '!') conc list('!!, c)$ put('true, '!*pascname!*, 'true)$ put('false, '!*pascname!*, 'false)$ procedure pascprecedence op; get(op, '!*pascprecedence!*) or 9$ put('or, '!*pascprecedence!*, 1)$ put('and, '!*pascprecedence!*, 2)$ put('equal, '!*pascprecedence!*, 3)$ put('neq, '!*pascprecedence!*, 3)$ put('greaterp, '!*pascprecedence!*, 4)$ put('geq, '!*pascprecedence!*, 4)$ put('lessp, '!*pascprecedence!*, 4)$ put('leq, '!*pascprecedence!*, 4)$ put('plus, '!*pascprecedence!*, 5)$ put('times, '!*pascprecedence!*, 6)$ put('quotient, '!*pascprecedence!*, 6)$ put('expt, '!*pascprecedence!*, 7)$ put('not, '!*pascprecedence!*, 8)$ put('minus, '!*pascprecedence!*, 8)$ %% Statement Translation %% procedure pascstmt stmt; if null stmt then nil else if lisplabelp stmt then pasclabel stmt % Are there labels? else if car stmt eq 'literal then pascliteral stmt else if lispassignp stmt then pascassign stmt else if lispcondp stmt then pascif stmt else if lispgop stmt then % Is there a go? pascgoto stmt else if lispreturnp stmt then pascreturn stmt else if lispstopp stmt then pascstop stmt else if lisprepeatp stmt then pascrepeat stmt else if lispwhilep stmt then pascwhile stmt else if lispforp stmt then pascfor stmt else if lispstmtgpp stmt then pascstmtgp stmt else if lispdefp stmt then pascproc stmt else pascexpstmt stmt$ procedure pascassign stmt; mkfpascassign(cadr stmt, caddr stmt)$ procedure pascstop stmt; mkfpascstop()$ procedure pascexpstmt exp; append(mkpasctab() . pascexp exp, list('!;, mkpascterpri()))$ procedure pascfor stmt; begin scalar r, variable, loexp, stepexp, hiexp, stmtlst; variable := cadr stmt; stmt := cddr stmt; loexp := caar stmt; stepexp := cadar stmt; hiexp := caddar stmt; stmtlst := cddr stmt; r := mkfpascfor(variable, loexp, hiexp, stepexp); indentpasclevel(+1); %% ?? Should not the stmtlst have only one member?? r := append(r, foreach st in stmtlst conc pascstmt st); indentpasclevel(-1); return r end$ procedure pascgoto stmt; begin scalar stmtnum; if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum()); return mkfpascgo stmtnum end$ procedure pascif stmt; begin scalar r, st; r := mkfpascif caadr stmt; indentpasclevel(+1); st := seqtogp cdadr stmt; if eqcar(st, 'cond) and length st=2 then st := mkstmtgp(0, list st); r := append(r, pascstmt st); indentpasclevel(-1); stmt := cddr stmt; if stmt then << r := append(r, mkfpascelse()); indentpasclevel(+1); st := seqtogp cdar stmt; if eqcar(st, 'cond) and length st=2 then st := mkstmtgp(0, list st); r := append(r, pascstmt st); indentpasclevel(-1) >>; return r end$ procedure pasclabel label; mkfpasclabel label$ procedure pascliteral stmt; mkfpascliteral cdr stmt$ procedure pascrepeat stmt; begin scalar r, stmtlst, logexp; stmt := reverse cdr stmt; logexp := car stmt; stmtlst := reverse cdr stmt; r := mkfpascrepeat(); indentpasclevel(+1); r := append(r, foreach st in stmtlst conc pascstmt st); r:=removefinalsemicolon(r); % Remove final semicolon indentpasclevel(-1); return append(r, mkfpascuntil logexp) end$ procedure pascreturn stmt; if cdr stmt then begin scalar r; r := mkfpascbegingp(); indentpasclevel(+1); r := append(r, mkfpascassign(pascfuncname!*, cadr stmt)); r := append(r, mkfpascreturn()); r := removefinalsemicolon(r); % Remove final semicolon indentpasclevel(-1); return append(r, mkfpascendgp()) end else mkfpascreturn()$ procedure pascstmtgp stmtgp; begin scalar r; if car stmtgp eq 'progn then stmtgp := cdr stmtgp else stmtgp :=cddr stmtgp; r := mkfpascbegingp(); indentpasclevel(+1); r := append(r, for each stmt in stmtgp conc pascstmt stmt); r:=removefinalsemicolon(r); % Remove final semicolon indentpasclevel(-1); return append(r, mkfpascendgp()) end$ procedure pascwhile stmt; begin scalar r, logexp, stmtlst; logexp := cadr stmt; stmtlst := cddr stmt; r := mkfpascwhile logexp; indentpasclevel(+1); r := append(r, foreach st in stmtlst conc pascstmt st); indentpasclevel(-1); return r end$ procedure removefinalsemicolon r; begin scalar rr; r:=reversip r; if car r eq '!; then return reversip cdr r; if not ('!; memq r) then return reversip r; rr:=r; while not (cadr rr eq '!;) do << rr := cdr rr >>; rplacd(rr, cddr rr); return reversip r end$ %% %% %% Pascal Code Formatting Functions %% %% %% %% Statement Formatting %% % A macro used to prevent things with *pascname* % properties being evaluated in certain circumstances. MCD 28.3.94 symbolic smacro procedure pascexp_name(u); if atom u then list(u) else rplaca(pascexp ('dummyArrayToken . cdr u), car u)$ procedure mkfpascassign(lhs, rhs); begin scalar st; st := append(pascexp_name lhs, '!:!= . pascexp rhs); return append(mkpasctab() . st, list('!;, mkpascterpri())) end$ procedure mkfpascbegingp; list(mkpasctab(), 'begin, mkpascterpri())$ symbolic procedure mkfpascdec (type, varlist); begin scalar simplet, arrayt; varlist := for each v in varlist do if atom v then simplet := v . simplet else arrayt := (car v . cdr for each dim in cdr v conc if eqcar(dim,'range) then list ('!, , cadr dim, '!.!., caddr dim ) else list ('!, , 0, '!.!., dim )) . arrayt; return append(if simplet then append(mkpasctab() . for each v in insertcommas simplet conc pascexp v, (list('!:! , type, '!;, mkpascterpri()))), for each v in arrayt conc append(mkpasctab() . car pascexp car v. '!:! . 'array . insertbrackets cdr v, list('! of! , type, '!;, mkpascterpri()))) end; procedure mkfpascdo; list(mkpasctab(), !*do!*, mkpascterpri())$ procedure mkfpascuntil exp; append(append(list(mkpasctab(), 'until, '! ), pascexp exp), list('!;, mkpascterpri() )); procedure mkfpascelse; list(mkpasctab(), 'else, mkpascterpri())$ procedure mkfpascendgp; list(mkpasctab(), 'end, '!;, mkpascterpri())$ procedure mkfpascstop; list(mkpasctab(), 'svr, '!(, '!0, '!), '!;, mkpascterpri())$ procedure mkfpascfor(var1, lo, hi, stepexp); << stepexp := if stepexp = 1 then list('! , 'to, '! ) else if (stepexp = -1) or (stepexp = '(minus 1)) then list('! , 'downto, '! ) else list('error); hi:=append(pascexp hi,list('! , !*do!*, mkpascterpri())); hi:=append(pascexp lo, nconc(stepexp, hi)); append(list(mkpasctab(), !*for!*, '! , var1, '!:!=), hi) >>$ procedure mkfpascgo label; list(mkpasctab(), 'goto, '! , label, '!;, mkpascterpri())$ procedure mkfpascif exp; append(append(list(mkpasctab(), 'if, '! ), pascexp exp), list('! , 'then, mkpascterpri()))$ procedure mkfpasclabel label; list(label, '!:, mkpascterpri())$ procedure mkfpascliteral args; for each a in args conc if a eq 'tab!* then list mkpasctab() else if a eq 'cr!* then list mkpascterpri() else if pairp a then pascexp a else list stripquotes a$ procedure mkfpascprocdec(type, name, params, paramtypes); << pascfuncname!* := name; params := append('!( . cdr for each p in params conc '!, . pascdum(p, paramtypes), list '!)); if type then append(mkpasctab() . 'function . '! . pascexp name, append(params,list( '!:, type, '!;, mkpascterpri()))) else append(mkpasctab() . 'procedure . '! . pascexp name, append(params, list('!;, mkpascterpri()))) >>$ symbolic procedure pascdum (p,types); begin scalar type; type := pascgettype(p,types); type := if atom type then list type else if null cdr type then type else append('array . insertbrackets cdr for each dim in cdr type conc if eqcar(dim,'range) then list('!,,cadr dim,'!.!.,caddr dim) else list ('!, , 0, '!.!., dim ), list ('! of! , car type)); return p . '!: . type end; symbolic procedure pascgettype(p,types); if null types then 'default else if p memq car types then cdr car types else pascgettype(p,cdr types); procedure mkfpascrepeat; list(mkpasctab(), 'repeat, mkpascterpri())$ procedure mkfpascreturn; list(mkpasctab(), 'goto, '! , 99999, '!;, '!{return!}, mkpascterpri())$ procedure mkfpascwhile exp; append(append(list(mkpasctab(), 'while, '! , '!(), pascexp exp), list('!), mkpascterpri()))$ %% Indentation Control %% procedure mkpasctab; list('pasctab, pasccurrind!*)$ procedure indentpasclevel n; pasccurrind!* := pasccurrind!* + n * tablen!*$ procedure mkpascterpri; list 'pascterpri$ %% %% %% Misc. Functions %% %% %% procedure pascinsertbrackets exp; '![ . append(exp, list '!] )$ %% PASCAL Code Formatting & Printing Functions %% procedure formatpasc lst; begin scalar linelen; linelen := linelength 300; !*posn!* := 0; for each elt in lst do if pairp elt then lispeval elt else << if !*posn!* + length explode2 elt > pasclinelen!* then pasccontline(); pprin2 elt >>; linelength linelen end$ procedure pasccontline; << pascterpri(); pasctab !*pasccurrind!*; pprin2 " " >>$ procedure pascterpri; pterpri()$ procedure pasctab n; << !*pasccurrind!* := min0(n, pasclinelen!* - minpasclinelen!*); if (n := !*pasccurrind!* - !*posn!*) > 0 then pprin2 nspaces n >>$ %% PASCAL %% %% John Fitch %% global '(pascfuncname!*)$ share pascfuncname!*$ symbolic procedure procpasctem; begin scalar c; c:=flushspaces readch(); while not (c eq !$eof!$ or c eq '!.) do c:=flushspaces procpasctem1(c); end; symbolic procedure procpasctem1 c; begin scalar l,w, linelen; linelen := linelength 150; pprin2 c; while c neq !$eof!$ and w neq 'END do << if c eq !$eol!$ then << pterpri(); c := readch() >> else if c eq '!{ then << c := procpasccomm(); w:= nil >> else if c eq '!; then << c := procactive(); pprin2 c; w:=nil >>; if null w then << if liter c then l:= list c; c := readch(); while liter c or digit c or c eq '!_ do << pprin2 c; l:=c . l; c := readch() >>; w:=intern compress reverse l; l:=nil >>; if w eq 'VAR then c:=procpascvar c else if w eq 'CONST then c:=procpascconst c else if w eq 'TYPE then c:=procpasctype c else if w memq '(FUNCTION PROCEDURE OPERATOR) then c:=procfuncoperheading(w,c) else if w eq 'BEGIN then c:= NIL . procpasctem1 c else if w neq 'END then << while c neq '!; do << if c eq '!{ then c := procpasccomm() else << pprin2 c; c := readch() >> >>; pprin2 c; c:=nil . readch() >>; % recursive, since PASCAL is if w eq 'END then << c:=flushspaces c; if not ( c memq '(!; !.)) then gentranerr('e,nil,"END not followed by ; or .",nil); pprin2 c; c:=readch() >> else << w:=car c; c:=flushspaces cdr c; >> >>; linelength linelen; return c; end$ symbolic procedure procpasctype c; % TYPE ...; ...; ... % begin scalar w,l; next: while not liter c do << if c eq !$eol!$ then pterpri() else pprin2 c; c:=readch() >>; l:=nil; while liter c or digit c or c eq '!_ do << pprin2 c; l:=c . l; c := readch() >>; w:=intern compress reverse l; if w memq '(FUNCTION PROCEDURE OPERATOR CONST VAR) then return w . c; c:=flushspaces c; if c neq '!= then gentranerr('e,nil,"Malformed TYPE declaration", nil); l:=readpascaltype c; c:=car l; pasc!-symtabput(pascfuncname!*,w,'TYPE . cdr l); goto next; end; symbolic procedure procpascvar c; % VAR ...; ...; ... % begin scalar name,l,namelist; next: while not liter c do << if c eq !$eol!$ then pterpri() else pprin2 c; c:=readch() >>; l:=nil; while liter c or digit c or c eq '!_ do << pprin2 c; l:=c . l; c := readch() >>; name:=intern compress reverse l; if name memq '(FUNCTION PROCEDURE OPERATOR CONST VAR BEGIN) then return name . c; c:=flushspaces c; namelist:=list name; while (c = '!, ) do << pprin2 c; c:=flushspaces readch(); l:=nil; while liter c or digit c or c eq '!_ do << pprin2 c; l:=c . l; c := readch() >>; name:=intern compress reverse l; namelist:= name . namelist; c:=flushspaces c >>; if c neq '!: then gentranerr('e,nil,"Malformed VAR declaration", nil); l:=readpascaltype c; c:=car l; for each name in namelist do pasc!-symtabput(pascfuncname!*,name, cdr l); goto next; end; symbolic procedure procpasccomm; % { ... } % begin scalar c; pprin2 '!{; c := readch(); while c neq '!} do << if c eq !$eol!$ then pterpri() else pprin2 c; c := readch() >>; pprin2 c; c := readch(); return c end$ symbolic procedure procfuncoperheading(keyword,c); % returns the word after the procedure, and the character delimiting it begin scalar lst, name, i, ty, args, myargs; c:=flushspaces c; while not(seprp c or c eq '!( or c eq '!: ) do << name := aconc(name, c); pprin2 c; c := readch() >>; name := intern compress name; put('!$0, '!*pascalname!*, name); symtabput(name,'!*type!*,keyword); pascfuncname!*:=name; c:=flushspaces c; if c eq '!( then << i := 1; pprin2 c; c := readch(); while c neq '!) do << c:=flushspacescommas c; 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), '!*pascalname!*, name:=intern compress name); myargs := name . myargs; i := add1 i; if c eq '!: then << ty:=readpascaltype(c); c:=car ty; ty:=cdr ty; foreach n in myargs do pasc!-symtabput(pascfuncname!*,n,ty); args:=append(myargs,args); myargs:=nil; if (c eq '!;) then << pprin2 c; c:=readch() >> >>; c:=flushspaces c >>; !$!# := sub1 i; >> else !$!# :=0; if c neq '!: then << pprin2 c; while not (((c := readch()) eq '!:) or (c eq !$eol!$)) do pprin2 c >>; if c eq '!: then << ty := readpascaltype c; pasc!-symtabput(name,name,cdr ty); c:=car ty >>; if numberp i then while get(name := intern compress append(explode2 '!$, explode2 i), '!*pascalname!*) do << remprop(name, '!*pascalname!*); i:=sub1 i >>; lst:=nil; c:=flushspaces c; while liter c or digit c or c eq '!_ do << pprin2 c; lst:=c . lst; c := readch() >>; if lst then lst:=intern compress reverse lst; return lst . c end$ symbolic procedure readpascaltype(c); begin scalar ty; pprin2 c; c := flushspaces readch(); ty := list c; pprin2 c; while not (seprp (c := readch()) or c memq list('!;, '!), '![ )) do << ty := aconc(ty, c); pprin2 c >>; ty := intern compress ty; if ty eq 'array then return readpascalarraydeclaration(c) else return c . list ty; end; symbolic procedure readpascalarraydeclaration (c); begin scalar lo,hi,ty; ty:= nil; c:=flushspaces c; if not (c eq '![) then gentranerr(c,nil,"invalid pascal array declaration",nil); pprin2 c; l: c:=flushspaces readch(); lo:= list c; pprin2 c; while not (seprp (c := readch()) or c eq '!.) do << lo:=aconc(lo,c); pprin2 c >>; lo := compress lo; c:=flushspaces c; if not numberp lo then lo:=intern lo; pprin2 c; c:=readch(); if not (c eq '!.) then gentranerr (c,nil,".. not found in array declaration",nil); pprin2 c; c:=flushspaces readch(); hi:= list c; pprin2 c; while not (seprp (c := readch()) or c memq list('!,, '!])) do << hi:=aconc(hi,c); pprin2 c >>; hi := compress hi; if not numberp hi then hi:=intern hi; ty:= hi . ty; pprin2 c; c:=flushspaces c; if c eq '!] then << ty:= reverse ty; c:=flushspaces readch(); if not(c memq '( !o !O)) then gentranerr(c,nil,"not 'of'",nil); pprin2 c; c:=readch(); if not(c memq '( !f !F)) then gentranerr(c,nil,"not 'of'",nil); pprin2 c; c:=readpascaltype(readch()); return car c . append(cdr c,ty) >>; goto l; end; procedure procpascheader c; begin scalar name, i; while seprp c and c neq !$eol!$ do << pprin2 c; c := readch() >>; while not(seprp c or c memq list('!{, '!;, '!()) do << name := aconc(name, c); pprin2 c; c := readch() >>; if c memq list(!$eol!$, '!{, '!;) then return c; while seprp c and c neq !$eol!$ do << pprin2 c; c := readch() >>; if c neq '!( then return c; name := intern compress name; if not !*gendecs then pasc!-symtabput(name, nil, nil); put('!$0, '!*cname!*, name); pprin2 c; i := 1; c := readch(); while c neq '!) do << c:=flushspacescommas c; 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), '!*cname!*, intern compress name); i := add1 i; c:=flushspaces c; >>; !$!# := sub1 i; while get(name := intern compress append(explode2 '!$, explode2 i), '!*cname!*) do remprop(name, '!*cname!*); return procpascfunction c end$ procedure procpascfunction c; begin scalar block!-count; while c neq '!{ do if c eq '!; then c := procactive() else if c eq !$eol!$ then << pterpri(); c := readch() >> else << pprin2 c; c := readch() >>; pprin2 c; block!-count := 1; c := readch(); while block!-count > 0 do if c eq 'begin then << block!-count := add1 block!-count; pprin2 c; c := readch() >> else if c eq 'end then << block!-count := sub1 block!-count; pprin2 c; c := readch() >> else if c eq '!{ then c := procpasccomm() else if c eq '!; then c := procactive() else if c eq !$eol!$ then << pterpri(); c := readch() >> else << pprin2 c; c := readch() >>; return c end$ % misc routines - JHD 15.12.87 endmodule; end;