/*********************************************************************/
/*                                                                   */
/*  ROUTINE:      REXXFORM                                           */
/*                                                                   */
/*  PURPOSE:      Structure/indent REXX execs                        */
/*                                                                   */
/*  AUTHOR:       Robert Fowles, 02/04/84                            */
/*                (based on original exec by Jeffery Almoney)        */
/*                Pennsylvania State University                      */
/*                Center for Academic Computing                      */
/*                107 Computer Building                              */
/*                University Park, PA  16802                         */
/*                814 865-4774                                       */
/*                SHARE Installation code: PSU                       */
/*                Bitnet: RBF@PSUVM                                  */
/*                Internet: RBF@PSUVM.PSU.EDU                        */
/*                                                                   */
/*  REVISIONS:                                                       */
/*   11/20/90 RBF Include changes made in 07/25/85 by Denis J. Audet,*/
/*                Computing Centre, Univ of Ottawa: refine           */
/*                detection of comments and quotes across split      */
/*                lines, prevent truncation.  Make changes based on  */
/*                ideas from PHS3@WATDCS.                            */
/*   11/20/90 RBF Change syntax to allow: reformatting of selected   */
/*                parts of file; left margin for all lines.  Move    */
/*                Help info to Help File.                            */
/*   12/16/90 RBF Change name to REXXFORM (old name REXFORM).        */
/*   03/17/91 RBF Add more syntax checking.                          */
/*   05/30/13 FJH Mods to allows use in Xedit/Kedit/THE              */
/*                Fran Hensler     Slippery Rock University          */
/*                                                                   */
/*********************************************************************/
   parse arg a                  /* Allows mixed case Arg */     /*FJH*/
   if a='?' then call Help
 
   signal on syntax
 
   'COMMAND PRESERVE'
   'COMMAND SET MACRO OFF'; 'COMMAND SET SYNONYM OFF';
   'SET ZONE 1 *'; 'SET LINEND OFF'; 'SET IMAGE OFF';
   'SET RANGE :0 *'; 'SET DISPLAY 0 *'; 'SET CASE M I'; 'SET AUTO OFF';
   'EXTRACT /LINE/SIZE/TRUNC/';
   startl = line.1
 
   cj=0; ci=0;
   call ScanOpts
 
   com=0; dqu=0; squ=0; indent=0; cont=0; unbal=''; lines=0;
 
   ds='';   /* Line-number stack for DO's and SELECT's.              */
   es='';   /* Line-number stack for END's.                          */
 
   do i=startl to endl-1
      '+1'
      if rc>0 then leave
      lines=lines+1
      'EXTRACT/CURLINE/'; line=curline.3;
      line = strip(line,'T')
      sline=strip(line,'L')
      if sline=' ' then iterate i
      w1=GetFW(line)
      lw=GetLW(line)
 
      j = Lscan(sline)
 
      if j>0 then lastdo=i
      else if j<0 then indent=indent+j
      if indent<0 then indent=1
 
      if dqu > 0 | squ > 0 then do
         if dqu = 2 then dqu = 0
         if squ = 2 then squ = 0
         iterate
      end
      else do
         if com>0 then do
            if cj then repline= sline
            else if ci then repline=,
              substr(' ',1,lm+(indent)*in) || sline
            else repline= line
            if com>1 then com=0
         end
         else
         if substr(w1,length(w1),1)=':' | word(line,2)=':'
         then repline=substr(' ',1,max(0,lm+(indent-1)*in))||sline
         else
         repline= substr(' ',1,lm+cont+indent*in)||sline
         if length(repline) > trunc.1
         then 'EMSG *** Unable to indent',
           ' line:'i+1' within current XEDIT truncation setting ***'
         else if repline == line then nop
         else 'REPLACE' repline
         if com == -1 then com = 1
         else if dqu == -1 then dqu = 1
         else if squ == -1 then squ = 1
         else if substr(lw,length(lw))=',' then cont=2
         else cont=0
      end
      if j>0 then indent=indent+j
   end
 
   ':'startl 'RESTORE'
   if es<>'' then 'EMSG Unbalanced "END"s detected at lines: 'es
   if ds<>'' then do
      nds=''
      do i=1 to words(ds)
         nds=word(ds,i) nds
      end
      'EMSG Unbalanced "DO"s or "SELECT"s at lines: ' nds
   end
   if com>0 then 'EMSG Unbalanced comment'
   if squ+dqu>0 then 'EMSG Unbalanced string constant'
   'MSG' lines 'lines restructured from' startl 'to' endl-1
   exit 0
 
ScanOpts:
   i=pos('(',a)
   if i>0 then if pos('(',a,i+1)>0
   then call Errstop 'Left parentheses not allowed in targets'
   parse var a a '(' opts
   if a='' then a='* 4 3'
   Parse var a target t
/* call ParseTarget */                                                 /*FJH*/
   parse var t lm in r                                                 /*FJH*/
   if lm='' then lm=4
   if in='' then in=3
   if datatype(lm,'W')=0 | datatype(in,'W')=0 then call Errstop,
     'Left margin and Indent values must be whole numbers'
   if lm<0 | in<0 then call Errstop,
     'Left margin and Indent values cannot be negative'
   if r<>'' then call Errstop 'Incorrect arguments'
   if lm+in>trunc.1 then call Errstop,
     'Left margin plus Indent value cannot exceed the TRUNC setting'
   if lm=0 then call Errstop 'Left margin value must be greater than 0'
   if lm>trunc.1
   then call Errstop 'Left margin can''t exceed TRUNC setting'
   lm=lm-1
   do i=1 to words(opts)
      s=word(opts,i)
      upper s /*FJH */
      select
         when s='CJ' then cj=1
         when s='CI' then ci=1
         otherwise call ErrStop 'Incorrect arguments'
      end
   end
   if target = '*' then 'BOTTOM'                               /*FJH*/
   else do                                                     /*FJH*/
      'LOCATE' target                                          /*FJH*/
      if rc<>0 then call Errstop 'Target' target 'not found'   /*FJH*/
   end                                                         /*FJH*/
   'EXTRACT/LINE/'
   endl = line.1
   ':'startl 'UP1'
   return
 
/* This procedure will not work in Kedit   05/30/2013            FJH*/
/* ParseTarget:                                                  FJH*/
/*    target=''                                                  FJH*/
/*    push a                                                     FJH*/
/*    'PARSE 1 T'                                                FJH*/
/*    if rc<>0 then call Errstop 'Incorrect target'              FJH*/
/*    pull .                                                     FJH*/
/*    pull t1 t2                                                 FJH*/
/*    interpret 'parse var a' t1 'target' t1+t2 't' */           FJH*/
/*    return                                                     FJH*/
 
Lscan: Procedure expose com dqu squ i ds es
   arg s
 
   Select
      when com=1 then do
         k= pos('*/',s)
         if k>0 then do
            s= substr(s,k+2)
            com=2
         end
         else return 0
      end
 
      when dqu=1 then do
         k= pos('"',s)
         if k>0 then do
            s= substr(s,k+1)
            dqu=2
         end
         else return 0
      end
 
      when squ=1 then do
         k= pos("'",s)
         if k>0 then do
            s= substr(s,k+1)
            squ=2
         end
         else return 0
      end
      otherwise nop
   End
 
   qu = 0
   do until s2 = '' | s = ' '
      ls = 1+length(s)
      kcom = pos('/*',s)
      if kcom=0 then kcom=ls
      kdqu = pos('"',s)
      if kdqu=0 then kdqu=ls
      ksqu = pos("'",s)
      if ksqu=0 then ksqu=ls
 
      select
         when kcom<kdqu & kcom<ksqu then do
            if pos('*/',s,kcom+2) = 0 then do
               com = com-1
               parse var s s '/*'
               s2 = ''
            end
            else do
               parse var s s1 '/*' s2 '*/' s3
               s2 = '*'
               s=s1 s3
            end
            iterate
         end
 
         when ksqu<kdqu then do
            qu = 1
            if pos("'",s,ksqu+1) = 0 then do
               squ = squ-1
               parse var s s "'"
               s2 = ''
            end
            else do
               parse var s s1 "'" s2 "'" s3
               s2 = '*'
               s=s1 s3
            end
            iterate
         end
 
         when kdqu<ksqu then do
            qu = 1
            if pos('"',s,kdqu+1) = 0 then do
               dqu = dqu-1
               parse var s s '"'
               s2 = ''
            end
            else do
               parse var s s1 '"' s2 '"' s3
               s2 = '*'
               s=s1 s3
            end
            iterate
         end
         otherwise s2 = ''
      end
   end
 
   if s = '' then do
      if qu=0 & com<1 & dqu=squ then com = com + 2
      return 0
   end
 
   k = 0
   s=translate(s,' ',';')
 
   do j=1 to words(s)
      w=word(s,j)
      select
         when w='DO' | w='SELECT' then do
            k=k+1; ds=i ds;
         end
         when w='END' then do
            k=k-1;
            if ds='' then es=es i
            ds=delword(ds,1,1);
         end
         otherwise nop
      end
   end
   return k
GetFW:
   arg rc "'"
   parse var rc rc '"'
   return ' 'word(rc,1)
GetLW:
   arg rc
   do while rc <> ''
      lw=word(rc,words(rc))
      if right(lw, 2) <> '*/' then return lw
      if index(rc, '/*') = 0 then return lw
      j = lastpos('/*', rc)
      rc = substr(rc,1,j-1)
   end
   return ' '
Errstop:
   parse arg m
   ':'startl                                                    /*FJH*/
   'SET MSGM ON'
   'EMSG' m
   'RESTORE'
   exit 16
 
Help:
/* Help block rewritten by FJH */
   call Saydo
 
/* ********************************************************************/
/*                                                                    */
/* The REXXFORM macro will read a Rexx file in Xedit/Kedit/THE        */
/* storage, and justify all Do, Select, If-Then-Do and Else-Do        */
/* statements from the current line down to the target.               */
/*                                                                    */
/* REXXFORM <target left-margin indent> <( <CJ> | <CI> >              */
/*                                                                    */
/* Defaults:  target=*, lm=4, in=3 ( CJ                               */
/*                                                                    */
/* Target Ex:   *    5    /string/    :23   .e                        */
/* Left margin: left margin start column                              */
/* Indent: number spaces to indent statements in DO or SELECT block   */
/*                                                                    */
/* Lines beginning with a comment delimiter are not shifted unless CJ */
/* or CI is given.  The option CI causes comments to be indented like */
/* all other lines, and CJ causes them to be left-justified.          */
/*                                                                    */
/* When REXXFORM completes, it will display the line numbers of lines */
/* containing unbalanced DOs, SELECTs, or ENDs.                       */
/*                                                                    */
/* REXXFORM cannot handle all possible combinations of comment        */
/* constructions and literals with slash-asterisk or asterisk-slash.  */
/* The worst that can happen is that the indentation will not be      */
/* consistent throughout the file.  It detects and processes comment  */
/* blocks (a block starting with slash-asterisk and ending with       */
/* asterisk-slash but not containing any comment delimiters).         */
/*                                                                    */
/* ********************************************************************/
 
   call Sayend
   exit 0
 
Saydo:  L1=sigl+2; return;
Sayend: Procedure Expose L1 sigl
   L2=sigl-2
   do i=L1 to L2
      'MSG' sourceline(i)
   end
   return
 
Syntax:
   rr = rc
   'EMSG REXFORM LINE:' sigl sourceline(sigl)
   'EMSG +++' errortext(rr)
   'EMSG >>> error at file line 'i
   'RESTORE'
   exit 16
