/* ------------------------------------------------------------------- */
/* File ROSE.EXEC                       1993-05-26/18:10  Ver  1.00.34 */
/*                                                                     */
/* Generate and configure REXX and XEDIT scripts from a PRODUCT file.  */
/* Generating ASSEMBLE files in fixed format is supported.             */
/*                                                                     */
/* Usage: ROSE product fix (options                                    */
/* Options:                                                            */
/*   level=<n>   ... prompt level                                      */
/*                   1 .. everything                                   */
/*                   2 .. only unfixed items                           */
/*                   3 .. dont dare to ask                             */
/*                                                                     */
/* written:       1992-08-17 <Gerhard.Gonter@wu-wien.ac.at>            */
/* latest update: 1993-05-26                                           */
/* ------------------------------------------------------------------- */
 
parse arg product fix '('opts
 
DL=0;                   /* debugging level                 */
program='ROSE'
RWdisk='A';
prompt_level=2;         /* 1 .. ask for everything         */
                        /* 2 .. ask for unfixed items only */
                        /* 3 .. dont dare to ask at all    */
 
if product='' then do;
  do zeile = 1
    if substr(sourceline(zeile),1,2) /= "/*" then exit(0);
    say sourceline(zeile);
  end;
end;
 
upper product fix;
if fix='' then fix=product
 
do while opts/='';
  parse var opts opt opts
  if left(opt,6)='level=' then prompt_level=substr(opt,7);
end;
 
x=get_fileinfo();
x=init_vars();
if fix_size>0 then x=proc_fix_file();
x=proc_product_file();
x=write_fix(fix_file);
 
exit(0);
 
/* ------------------------------------------------------------------- */
get_fileinfo:
 
/* find out about the PRODUCT file */
q=queued();
'LISTFILE' product 'PRODUCT * (LIFO ALLOC NOHEAD'
if rc/=0 then do;
  say 'Error: didn''t find product' product
  exit(1);
end;
q=queued()-q;
do q;
  pull fn ft fm . . siz .
  product_file=fn ft fm;
  product_size=siz;
end;
say 'product file:' product_file';' product_size 'lines.'
 
/* find out about the FIX file */
fix_file=fix 'FIX A'
fix_size=0;
q=queued();
'LISTFILE' fix 'FIX * (LIFO ALLOC NOHEAD'
if rc/=0 then do;
  say 'Note: didn''t find fix' fix 'for product' product
end; else do;
  q=queued()-q;
  do q;
    pull fn ft fm . . siz .
    if substr(fm,1,1)/='A' then do;
      say 'Warning: there is a fix file on 'fm'; I''m not using it...'
    end; else do;
      fix_file=fn ft fm;
      fix_size=siz;
    end;
  end;
  say 'fix     file:' fix_file';' fix_size 'records.'
end;
return 0;
 
/* ------------------------------------------------------------------- */
init_vars:
out_module='';          /* name of file that is currently generated    */
out_recs= 0;            /* number of lines sofar in generated file     */
mod_fixed= 0;           /* 1 .. file is to be written in fixed format  */
 
help_count=0;           /* number of help texts found                  */
help_name.='';          /* name of help items                          */
help_start.='';         /* start of help text for a given item         */
help_size.='';          /* number of help lines for a given item       */
help_point=0;           /* total number of lines for help messages     */
help_text.='';          /* text lines for help messages                */
 
xvar_count=0;           /* number of variables encountered             */
xvar_name.='';          /* name of variables                           */
xvar_value.='';         /* predefined values for the variables         */
xvar_fixed.='';         /* values for variables found in a fix file    */
 
switch_level=0;         /* switch-stack pointer                        */
switch_name.='';        /* name of the control variable                */
switch_type.='';        /* type of the switch statement: SWITCH        */
switch_mode.='';        /* last text_mode for writing                  */
switch_default.='';     /* 1 .. default has to be processed            */
switch_cflg.='';        /* stack for case_flg                          */
 
 
text_mode=0;            /* 0 .. dont generate output but analyze       */
                        /*      ROSE commands                          */
                        /* 1 .. write to text file                     */
                        /* 2 .. store help text                        */
lin.0=0
return 0;
 
/* ------------------------------------------------------------------- */
proc_fix_file:
say 'Note: processing fix file'
do fi=1 to fix_size;
  'EXECIO * DISKR' fix_file '(STEM LIN.'
  if lin.0=0 then leave;
  do i=1 to lin.0;
    x=var_set(lin.i);
  end;
end;
'FINIS' fix_file
return 0;
 
/* ------------------------------------------------------------------- */
proc_product_file:
say 'Note: processing product file'
case_flg=1;     /* case flag: 1 .. positive case */
do pi=1 to product_size;
  'EXECIO 1 DISKR' product_file '(STEM LIN.'
  if lin.0=0 then do;
    say 'EOF: stop processing of' product_file 'at line' pi
    leave;
  end;
  li=lin.1;
  if substr(li,1,1)='#' & substr(li,1,2)/='##' then do;
    if DL>0 then do;
      say 'textmode='textmode 'product_size='product_size 'pi='pi
      say 'line['pi']='li;
    end;
    if out_module/='' & out_recs/=0 then 'FINIS' out_module;
    parse var li cmd par
    select;
      when cmd='#help' & case_flg=1 then do;
        hc= help_count;
        help_count= help_count+1;
        help_name.hc= par;
        help_start.hc= help_point;
        text_mode= 2;
      end;
      when cmd='#endhelp' then do;
        text_mode= 0;
      end;
      when cmd='#set' & case_flg=1 then do;
        x= var_set('VALUE' par);
      end;
      when cmd='#prompt' & case_flg=1 then do;
        x= prompt(par);
        if x=-1 then signal STOP;
      end;
      when cmd='#fix' then do;
        vii=var_find(par);
        if vii/=-1 then do;
          if text_mode=1 then do;
            lin.0=1;
            lin.1=xvar_value.vii;
            out_recs= out_recs+1;
            if mod_fixed=1 then do;
              LIN.1= fixed_line(LIN.1, out_recs);
              'EXECIO 1 DISKW' out_module out_recs 'F (STEM LIN.'
            end; else do;
             'EXECIO 1 DISKW' out_module '(STEM LIN.'
            end;
          end; else do;
            say 'fix value for' par 'is:' xvar_value.vii;
          end;
        end;
      end;
      when cmd='#erase' & case_flg=1 then do;
        out_module=par RWdisk;
        upper out_module;
        address command 'STATEW' out_module;
        if rc=0 then do;
          say 'erasing module' out_module;
          'ERASE' out_module;
        end; else do;
          address command 'STATE' out_module;
          if rc=0 then say '******* FILE' out_module 'exists on R/O disk'
        end;
      end;
      when cmd='#module' then do;
        parse var par out_module '('mod_opts
        upper mod_opts;
        mod_fixed= 0;
        if index(mod_opts,'FIX')>0 then mod_fixed=1;
        out_recs= 0;
        if words(out_module)/=2 then do;
          say product_file'('pi') invalid module name:' module
          exit(1);
        end;
        out_module=out_module RWdisk;
        upper out_module;
        say 'writing module' out_module;
        text_mode=1;
      end;
      when cmd='#switch' then do;
        switch_name.switch_level=par;
        switch_type.switch_level='SWITCH';
        switch_mode.switch_level=text_mode;
        switch_default.switch_level=1;
        switch_cflg.switch_level=1;
        switch_level=switch_level+1;
        text_mode=0;
      end;
      when cmd='#case' | cmd='#default' then do;
        text_mode=0;
        if switch_level<1 then do;
          say product_file'('pi') error: invalid' li
          exit(1);
        end;
        swlev=switch_level-1;
        if switch_mode.swlev/=0 then do;
          /* more text will be processed only when output was   */
          /* generated before, otherwise ignore any text.       */
          dp=0; /* do processing of block; otherwise skip block */
          case_flg=0; /* *************** ATTENTION ************ */
          if cmd='#case' then do;
            vii=var_find(switch_name.swlev);
            if vii/= -1 then do;
              if xvar_value.vii=par then do;
                dp=1;
                switch_default.swlev=0;
              end;
            end;
          end;
          if cmd='#default' & switch_default.swlev=1 then dp=1;
          if dp=1 then do;
            text_mode=switch_mode.swlev;
            case_flg=1;
          end;
        end;
      end;
      when cmd='#endswitch' then do;
        if switch_level<1 then do;
          say product_file'('pi') error: invalid' li
          exit(1);
        end;
        switch_level=switch_level-1;
        text_mode=switch_mode.switch_level;
        case_flg=switch_cflg.switch_level;
      end;
      when cmd='#call' then do;
        parse var par pgm par
        pgm_line= pgm;
        do while par/='';
          parse var par xpar par;
          vii= var_find(xpar);
          if vii/= -1 then xpar= xvar_value.vii;
          pgm_line= pgm_line xpar;
        end;
        say 'executing:' pgm_line
        interpret pgm_line
      end;
      when cmd='#end' then signal STOP;
      when cmd='#' then do;
        /* nothing, just comment */
      end;
      when cmd='#section'       | cmd='#subsection'  |,
           cmd='#subsubsection' | cmd='#paragraph'   |,
           cmd='#verbatim'      | cmd='#endverbatim' | cmd='#v' then do;
        /* nothing; these commands are for typesetting */
      end;
      otherwise do;
          say product_file'('pi') warning: unknown command' li
      end;
    end/*select*/;
  end; else do; /* normal text */
    if substr(li,1,2)='##' then li=substr(li,2); /* chop off first # */
    do forever;
      mii=index(li,'#<');
      if mii=0 then leave;
      mij=index(li,'>#');
      if mij=0 | mij < mii then do;
        say product_file'('pi') error: macro syntax:' li
        exit(1);
      end;
      mnam=substr(li,mii+2,mij-mii-2);
      vii=var_find(mnam);
      if vii=-1 then do;
        say product_file'('pi') error: macro name:' li
        exit(1);
      end;
      li=substr(li,1,mii-1)||xvar_value.vii||substr(li,mij+2);
    end;
    lin.1=li;
    select;
      when text_mode=1 then do; /* text to file */
        lin.0=1;
        out_recs= out_recs+1;
        if mod_fixed=1 then do;
          LIN.1= fixed_line(LIN.1, out_recs);
          'EXECIO 1 DISKW' out_module out_recs 'F (STEM LIN.'
        end; else do;
          'EXECIO 1 DISKW' out_module '(STEM LIN.'
        end;
      end;
      when text_mode=2 then do; /* text to help buffer */
        help_text.help_point=li;
        help_point=help_point+1;
      end;
      otherwise do; /* nothing .. */ end;
    end/*select*/
  end;
end;
say 'pi='pi
 
STOP:
'FINIS' product_file
return 0;
 
/* ------------------------------------------------------------------- */
var_set: parse arg what nam val
vii=var_find(nam);
if vii= -1 then do;
  vii=xvar_count;
  xvar_count=xvar_count+1;
  xvar_name.vii=nam;
  if what='VALUE' then do;
    xvar_fixed.vii='';
  end;
  if what='FIX' then do;
    xvar_value.vii=nam;
  end;
end;
if what='VALUE' then do;
  xvar_value.vii=val;
end;
if what='FIX' then do;
  xvar_fixed.vii=val;
end;
return 0;
 
/* ------------------------------------------------------------------- */
var_find: parse arg nam .
vii=-1;
do vi=0 to xvar_count-1;
  if xvar_name.vi=nam then vii=vi;
end;
return vii;
 
/* ------------------------------------------------------------------- */
help_find: parse arg nam .
hii=-1;
/* say 'help_count='help_count  'nam='nam */
do hi=0 to help_count-1;
  /* say 'help_name.'hi'='help_name.hi */
  if help_name.hi=nam then hii=hi;
end;
return hii;
 
/* ------------------------------------------------------------------- */
display_help: parse var hii .
if hii=-1 then return -1;
if hii+1 < help_count then hij=help_start.(hii+1); else hij=help_point;
do i=help_start.hii to hij-1;
  say help_text.i;
end;
return 0;
 
/* ------------------------------------------------------------------- */
write_fix: parse arg fnm_fix
'STATE' fnm_fix
if rc=0 then 'ERASE' fnm_fix;
do i=0 to xvar_count-1;
  lin.0=1;
  lin.1='FIX' xvar_name.i xvar_value.i
  'EXECIO 1 DISKW' fnm_fix '(STEM LIN.'
end;
'FINIS' fnm_fix;
return 0;
 
/* ------------------------------------------------------------------- */
fixed_line: parse arg str, num
if mod_fixed=0 then return str;
str= substr(str,1,72)||translate(format(num,7),'0',' ')||'0';
return str;
 
/* ------------------------------------------------------------------- */
/* prompt a value for the variable named nam and check it against      */
/* values, if this is specified                                        */
prompt: parse arg nam values
 
vii=var_find(nam);
if (vii=-1) then do;
  say '** WARNING **  Didn''t find a help text for' nam '('arg')'
  return 0;
end;
hii=help_find(nam);
/* say 'help_find('nam') -> 'hii */
 
select;
  when prompt_level=1 then do;
    /* nothing, it's ok to ask */
  end;
  when prompt_level=2 then do;
    if xvar_fixed.vii/='' then do;
      xvar_value.vii=xvar_fixed.vii;
      return 0;
    end;
  end;
  when prompt_level=3 then do;
    if xvar_fixed.vii='' then return -1;
    xvar_value.vii=xvar_vii.fixed;
    return 0;
  end;
  otherwise do;
    say 'illegal prompt level' prompt_level;
    return -1;
  end;
end;
 
c2= 3;
do forever;
  'VMFCLEAR'
  say copies('*',72);
  if hii/=-1 then do;
    x= display_help(hii);
    say '-------';
  end; else say 'fix value for' nam
  say '1. use predefined value:' xvar_value.vii;
  say '2. use fixed value:' xvar_fixed.vii
  say '3. enter new value';
  say 'X. stop';
  pull x1
  if x1='X'|x1='Q' then return -1;
  if x1='1'|x1='' then return 0;
  if x1='2' then do;
    xvar_value.vii= xvar_vii.fixed;
    return 0;
  end;
  if x1='3' then do;
    say 'enter new value for' nam
    parse pull nv;
    ok= 1;
    if values/='' then do;
      ok= 0;
      do c1=1 to words(values);
        if word(values,c1)=nv then ok= 1;
      end;
    end;
    c2= c2-1;
    if ok=0 & c2>0 then iterate;
    xvar_value.vii= nv;
    return 0;
  end;
 
  /* any other value is interpreted as fix value */
  ok= 1;
  if values/='' then do;
    ok= 0;
    do c1=1 to words(values);
      if word(values,c1)=x1 then ok= 1;
    end;
  end;
  c2= c2-1;
  if ok=0 & c2>0 then iterate;
  xvar_value.vii= x1;
  return 0;
end;
return -1;