File r38/packages/gentran/segmnt.red artifact c9ad1826d4 part of check-in 5f584e9b52


module segmnt;    %%  Segmentation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry points:  Seg, MARKEDVARP, MARKVAR, TEMPVAR, UNMARKVAR


symbolic$

% User-Accessible Global Variables %
global '(gentranlang!* maxexpprintlen!* tempvarname!* tempvarnum!*
         tempvartype!*)$
share gentranlang!*, maxexpprintlen!*, tempvarname!*, tempvarnum!*,
      tempvartype!*$
maxexpprintlen!* := 800$
tempvarname!*    := 't$
tempvarnum!*     := 0$
tempvartype!*    := nil$

% User-Accessible Primitive Functions %
operator markedvarp, markvar, tempvar, unmarkvar$

global '(!*do!* !*for!*)$


%%                       %%
%% Segmentation Routines %%
%%                       %%


procedure seg forms;
% exp --+--> exp                                          %
%       +--> (assign    assign    ... assign      exp   ) %
%                   (1)       (2)           (n-1)    (n)  %
% stmt --+--> stmt                                        %
%        +--> stmtgp                                      %
% stmtgp --> stmtgp                                       %
% def --> def                                             %
for each f in forms collect
    if lispexpp f then
        if toolongexpp f then
            segexp(f, 'unknown)
        else
            f
    else if lispstmtp f then
        segstmt f
    else if lispstmtgpp f then
        if toolongstmtgpp f then
            seggroup f
        else
            f
    else if lispdefp f then
        if toolongdefp f then
            segdef f
        else
            f
    else
        f$


procedure segexp(exp, type);
% exp --> (assign    assign    ... assign      exp   ) %
%                (1)       (2)           (n-1)    (n)  %
reverse segexp1(exp, type)$

procedure segexp1(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar res;
res := segexp2(exp, type);
unmarkvar res;
if car res = cadadr res then
<<
    res := cdr res;
    rplaca(res, caddar res)
>>;
return res
end$

procedure segexp2(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar expn, assigns, newassigns, unops, op, termlist, var, tmp;
expn := exp;
while length expn=2 do
<<  unops := car expn . unops;  expn := cadr expn  >>;
op := car expn;
for each term in cdr expn do
<<
    if toolongexpp term then
    <<
        tmp := segexp2(term, type);
        term := car tmp;
        newassigns := cdr tmp
    >>
    else
        newassigns := '();
    if toolongexpp (op . term . termlist) and
       termlist and
       (length termlist > 1 or pairp car termlist) then
        <<
            unmarkvar termlist;
            var := var or tempvar type;
            markvar var;
            assigns := mkassign(var, if onep length termlist
                                        then car termlist
                                        else op . termlist) . assigns;
            termlist := list(var, term)
        >>
        else
            termlist := append(termlist, list term);
        assigns := append(newassigns, assigns)
>>;
expn := if onep length termlist
           then car termlist
           else op . termlist;
while unops do
<<  expn := list(car unops, expn);  unops := cdr unops  >>;
if expn = exp then
<<
    unmarkvar expn;
    var := var or tempvar type;
    markvar var;
    assigns := list mkassign(var, expn);
    expn := var
>>;
return expn . assigns
end$


procedure segstmt stmt;
% assign --+--> assign %
%          +--> stmtgp %
% cond --+--> cond     %
%        +--> stmtgp   %
% while --+--> while   %
%         +--> stmtgp  %
% repeat --> repeat    %
% for --+--> for       %
%       +--> stmtgp    %
% return --+--> return %
%          +--> stmtgp %
if lispassignp stmt then
    if toolongassignp stmt then
        segassign stmt
    else
        stmt
else if lispcondp stmt then
    if toolongcondp stmt then
        segcond stmt
    else
        stmt
else if lispwhilep stmt then
    if toolongwhilep stmt then
        segwhile stmt
    else
        stmt
else if lisprepeatp stmt then
    if toolongrepeatp stmt then
        segrepeat stmt
    else
        stmt
else if lispforp stmt then
    if toolongforp stmt then
        segfor stmt
    else
        stmt
else if lispreturnp stmt then
    if toolongreturnp stmt then
        segreturn stmt
    else
        stmt
else
    stmt$


procedure segassign stmt;
% assign --> stmtgp %
begin
scalar var, exp, type;
var := cadr stmt;
type := getvartype var;
exp := caddr stmt;
stmt := segexp1(exp, type);
rplaca(stmt, mkassign(var, car stmt));
return mkstmtgp(nil, reverse stmt)
end$

procedure segcond condd;
% cond --+--> cond   %
%        +--> stmtgp %
begin
scalar tassigns, res, markedvars, type;
%if gentranlang!* eq 'c
%    then type := 'int
%    else type := 'logical;
type:=get(gentranlang!*,'boolean!-type) or get('fortran,'boolean!-type);
while condd := cdr condd do
    begin
    scalar exp, stmt;
    if toolongexpp(exp := caar condd) then
    <<
        exp := segexp1(exp, type);
        tassigns := append(cdr exp, tassigns);
        exp := car exp;
        markvar exp;
        markedvars := exp . markedvars
    >>;
    stmt := for each st in cdar condd conc seg list st;
    res := (exp . stmt) . res
    end;
unmarkvar markedvars;
return
    if tassigns then
        mkstmtgp(nil, reverse(mkcond reverse res . tassigns))
    else
        mkcond reverse res
end$

procedure segwhile stmt;
% while --+--> while  %
%         +--> stmtgp %
begin
scalar logexp, stmtlst, tassigns, type, res;
logexp := cadr stmt;
stmtlst := cddr stmt;
if toolongexpp logexp then
<<
    type:=get(gentranlang!*,'boolean!-type)
          or get('fortran,'boolean!-type);
%    if gentranlang!* eq 'c
%       then type := 'int
%       else type := 'logical;
    tassigns := segexp1(logexp, type);
    logexp := car tassigns;
    tassigns := cdr tassigns
>>;
stmtlst := foreach st in stmtlst
                   conc seg list st;
res := 'while . logexp . stmtlst;
if tassigns then
<<
    res := append(res, reverse tassigns);
    res := 'progn . append(reverse tassigns, list res)
>>;
return res
end$

procedure segrepeat stmt;
% repeat --> repeat %
begin
scalar stmtlst, logexp, type;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
stmtlst := foreach st in stmtlst conc seg list st;
if toolongexpp logexp then
<<
    type:=get(gentranlang!*,'boolean!-type)
          or get('fortran,'boolean!-type);
%    if gentranlang!* eq 'c
%       then type := 'int
%       else type := 'logical;
    logexp := segexp1(logexp, type);
    stmtlst := append(stmtlst, reverse cdr logexp);
    logexp := car logexp
>>;
return 'repeat . append(stmtlst, list logexp)
end$

procedure segfor stmt;
% for --+--> for    %
%       +--> stmtgp %
begin
scalar var, loexp, stepexp, hiexp, stmtlst, tassigns1, tassigns2, type,
       markedvars, res;
var := cadr stmt;
type := getvartype var;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
if toolongexpp loexp then
<<
    loexp := segexp1(loexp, type);
    tassigns1 := reverse cdr loexp;
    loexp := car loexp;
    markvar loexp;
    markedvars := loexp . markedvars
>>;
if toolongexpp stepexp then
<<
    stepexp := segexp1(stepexp, type);
    tassigns2 := reverse cdr stepexp;
    stepexp := car stepexp;
    markvar stepexp;
    markedvars := stepexp . markedvars
>>;
if toolongexpp hiexp then
<<
    hiexp := segexp1(hiexp, type);
    tassigns1 := append(tassigns1, reverse cdr hiexp);
    tassigns2 := append(tassigns2, reverse cdr hiexp);
    hiexp := car hiexp
>>;
unmarkvar markedvars;
stmtlst := foreach st in stmtlst conc seg list st;
stmtlst := append(stmtlst, tassigns2);
res := !*for!* . var . list(loexp, stepexp, hiexp) . !*do!* . stmtlst;
if tassigns1 then
    return mkstmtgp(nil, append(tassigns1, list res))
else
    return res
end$

procedure segreturn ret;
% return --> stmtgp %
<<
    ret := segexp1(cadr ret, 'unknown);
    rplaca(ret, mkreturn car ret);
    mkstmtgp(nil, reverse ret)
>>$

procedure seggroup stmtgp;
% stmtgp --> stmtgp %
begin
scalar locvars, res;
if car stmtgp eq 'prog then
<<
    locvars := cadr stmtgp;
    stmtgp := cdr stmtgp
>>
else
    locvars := 0;
while stmtgp := cdr stmtgp do
    res := append(seg list car stmtgp, res);
return mkstmtgp(locvars, reverse res)
end$

procedure segdef deff;
% def --> def %
mkdef(cadr deff, caddr deff,
      for each stmt in cdddr deff conc seg list stmt)$


%%                                        %%
%% Long Statement & Expression Predicates %%
%%                                        %%


procedure toolongexpp exp;
numprintlen exp > maxexpprintlen!*$

procedure toolongstmtp stmt;
if atom stmt then nil else
if lispstmtp stmt then
    if lispcondp stmt then
        toolongcondp stmt
    else if lispassignp stmt then
        toolongassignp stmt
    else if lispreturnp stmt then
        toolongreturnp stmt
    else if lispwhilep stmt then
        toolongwhilep stmt
    else if lisprepeatp stmt then
        toolongrepeatp stmt
    else if lispforp stmt then
        toolongforp stmt
    else lispeval('or . for each exp in stmt collect toolongexpp exp)
else
    toolongstmtgpp stmt$

procedure toolongassignp assign;
toolongexpp caddr assign$

procedure toolongcondp condd;
begin
scalar toolong;
while condd := cdr condd do
    if toolongexpp caar condd or toolongstmtp cadar condd then
        toolong := t;
return toolong
end$

procedure toolongwhilep stmt;
   toolongexpp cadr stmt or
      lispeval('or . foreach st in cddr stmt collect toolongstmtp st)$

procedure toolongrepeatp stmt;
<<
    stmt := reverse cdr stmt;
    toolongexpp car stmt or
    lispeval('or . foreach st in cdr stmt collect toolongstmtp st)
>>$

procedure toolongforp stmt;
lispeval('or . foreach exp in caddr stmt collect
                   toolongexpp exp          ) or
lispeval('or . foreach st in cddddr stmt collect
                   toolongstmtp st          )$

procedure toolongreturnp ret;
cdr ret and toolongexpp cadr ret$

procedure toolongstmtgpp stmtgp;
lispeval('or . for each stmt in cdr stmtgp collect
               toolongstmtp stmt              )$

procedure toolongdefp deff;
if lispstmtgpp cadddr deff then
    toolongstmtgpp cadddr deff
else
    lispeval('or .
	     for each stmt in cdddr deff collect toolongstmtp stmt)$


%%                       %%
%% Print Length Function %%
%%                       %%

symbolic procedure numprintlen exp;
if atom exp then
    length explode exp
else if onep length exp then
    numprintlen car exp
else if car exp = '!:rd!: then
%     2+length explode cadr exp + length explode cddr exp
%else if car exp memq '( !:cr!: !:crn!: !:gi!: ) then
%     8+length explode cadr exp + length explode cddr exp
<< 
     exp := rd!:explode exp;
     2+length car exp + length explode cadr exp
>>
else if car exp memq '( !:cr!: !:crn!: !:gi!: ) then
<<
    exp := cons (rd!:explode('!:rd!: . cadr exp), 
                 rd!:explode('!:rd!: . cddr exp));
    12 + length caar exp + length explode cdar exp 
       + length cadr exp + length explode cddr exp
>>
else
    length exp + lispeval('plus . for each elt in cdr exp collect
                                numprintlen elt              )$


%%                                                              %%
%% Temporary Variable Generation, Marking & Unmarking Functions %%
%%                                                              %%


procedure tempvar type;
%                                                             %
%  IF type Member '(NIL 0) THEN type <- TEMPVARTYPE!*         %
%                                                             %
%  IF type Neq 'NIL And type Neq 'UNKNOWN THEN                %
%    var <- 1st unmarked tvar of VType type or of VType NIL   %
%           which isn't in the symbol table                   %
%    put type on var's VType property list                    %
%    put declaration in symbol table                          %
%  ELSE IF type = NIL THEN                                    %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%  ELSE type = 'UNKNOWN                                       %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%    put 'UNKNOWN on var's VType property list                %
%    print warning - "undeclared"                             %
%                                                             %
%  RETURN var                                                 %
%                                                             %
begin
scalar tvar, xname, num;
if type memq '(nil 0) then type := tempvartype!*;
xname := explode tempvarname!*;
num := tempvarnum!*;
if type memq '(nil unknown) then
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and not get(tvar, '!*vtype!*) and
          not getvartype tvar
else
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and
          (get(tvar, '!*vtype!*) eq type or
           not get(tvar, '!*vtype!*) and not getvartype tvar);
put(tvar, '!*vtype!*, type);
if type eq 'unknown then
    gentranerr('w, tvar, "UNDECLARED VARIABLE", nil)
else if type then
    symtabput(nil, tvar, list type);
return tvar
end$


symbolic procedure isnumber u;
numberp(u) or (pairp(u) and memq(car u,domainlist!*) )$

symbolic procedure markvar var;
if isnumber var then
    var
else if atom var then
<<  flag(list var, '!*marked!*);  var  >>
else
<<  for each v in var do markvar v;  var  >>$

symbolic procedure markedvarp var;
flagp(var, '!*marked!*)$

symbolic procedure unmarkvar var;
if isnumber var then
    var
else if atom var then
    remflag(list var, '!*marked!*)
else
    foreach elt in var do
        unmarkvar elt$


endmodule;

end;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]