reduce-historical/r37/packages/gentran/lsppasc.red

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;