$LARGE
$TITLE ('PL/M-VAX CONTROL LANGUAGE HANDLER')

CONTROL_MODULE: do;     /* Module to handle PLM control lines. */

/*************************************************************************/
/*									 */
/*				CONTROL.PLM				 */
/*                                                                       */
/*               D I S C L A I M E R   N O T I C E                       */
/*               -------------------   -----------                       */
/*                                                                       */
/*  This document and/or portions of the material and data furnished     */
/*  herewith, was developed under sponsorship of the U. S. Government.   */
/*  Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior  */
/*  University, nor their employees, nor their respective contractors,   */
/*  subcontractors, or their employees, makes any warranty, express or   */
/*  implied, or assumes any liability or responsibility for accuracy,    */
/*  completeness or usefulness of any information, apparatus, product    */
/*  or process disclosed, or represents that its use will not infringe   */
/*  privately-owned rights.  Mention of any product, its manufacturer,   */
/*  or suppliers shall not, nor is it intended to, imply approval, dis-  */
/*  approval, or fitness for any particular use.  The U. S. and the      */
/*  University at all times retain the right to use and disseminate same */
/*  for any purpose whatsoever.  Such distribution shall be made by the  */
/*  National Energy Software Center at the Argonne National Laboratory   */
/*  and only subject to the distributee furnishing satisfactory proof    */
/*  that he has a valid license from the Intel Corporation in effect.    */
/*                                                                       */
/*-----------------------------------------------------------------------*/
/*									 */
/*    This module of the PL/M-VAX compiler processes the invocation	 */
/*    line and all control statements within the source text.		 */
/*									 */
/*-----------------------------------------------------------------------*/
/*									 */
/*		R E V I S I O N   H I S T O R Y				 */
/*									 */
/*    14OCT81  Alex Hunter  1. Added disclaimer notice.			 */
/*    09NOV81  Alex Hunter  1. Added ASSUME control. (V5.8)              */
/*    10NOV81  Alex Hunter  1. Added DBG assumption. (V6.0)		 */
/*    10JAN82  Alex Hunter  1. Call DQ$SET$DELIMITERS. (V6.4)            */
/*    14JAN82  Alex Hunter  1. Ignore $-signs in switch names. (V6.5)    */
/*									 */
/*-----------------------------------------------------------------------*/
$INCLUDE (PLM$UDI:CUSTOMARY.LIT)
$INCLUDE (PLM$UDI:UDI.DEF)
$INCLUDE (PLM$UDI:DESCRIPT.LIT)
$INCLUDE (PLM$UDI:ASCII.LIT)
$INCLUDE (PLM$UDI:EXCEPT.LIT)
 
declare t literally 'TRUE',
	f literally 'FALSE';

/***********************************************************************

         Switch-Name Symbol Table Declarations.

***********************************************************************/

declare max_switch literally '50';   /* maximum # of switch names */

declare switch (1:max_switch) structure (name(32) byte, value byte);

declare last_switch integer initial (0);

/**********************************************************************/

declare tokn byte,
        delimiter byte initial (' '),
        argument (81) byte,
        arg_length byte initial (0);

declare C_AND literally '201',
        C_OR  literally '202',
        C_XOR literally '203',
        C_NOT literally '204';

$SUBTITLE ("ERROR MESSAGE STUFF")
/***********************************************************************

         Error Message Stuff.

***********************************************************************/

declare msg0 (*) byte initial ('INVALID CONTROL'),
        msg1 (*) byte initial ('ILLEGAL LIMITED EXPRESSION'),
        msg2 (*) byte initial ('CONTROL CARD SYNTAX ERROR'),
        msg3 (*) byte initial ('TOO MANY SWITCHES'),
        msg4 (*) byte initial ('ATTEMPT TO DIVIDE BY ZERO'),
        msg5 (*) byte initial ('BAD DIGIT IN WHOLE-NUMBER'),
        msg6 (*) byte initial ('ILLEGAL VALUE FOR PARAMETER'),
        msg7 (*) byte initial ('PATH NAME ERROR'),
        msg8 (*) byte initial
         ('ILLEGAL USE OF PRIMARY CONTROL AFTER NON-CONTROL LINE'),
        msg9 (*) byte initial ('INCLUDE FILES NESTED TOO DEEPLY'),
        msg10 (*) byte initial ('INCLUDE MUST BE LAST CONTROL ON LINE'),
        msg11 (*) byte initial ('TOO MANY SAVES/RESTORES'),
        msg12 (*) byte initial
          ('IF/ELSEIF/ELSE/ENDIF in illegal context'),
        msg13 (*) byte initial ('IF/ENDIF nested too deeply'),
	msg14 (*) byte initial ('Unrecognized ASSUME code');

declare error_msg$d (0:14) descriptor initial (
                size(msg0),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg0,
                size(msg1),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg1,
                size(msg2),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg2,
                size(msg3),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg3,
                size(msg4),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg4,
                size(msg5),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg5,
                size(msg6),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg6,
                size(msg7),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg7,
                size(msg8),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg8,
                size(msg9),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg9,
                size(msg10),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg10,
                size(msg11),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg11,
                size(msg12),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg12,
                size(msg13),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg13,
		size(msg14),DSC$K_DTYPE_T,DSC$K_CLASS_S,@msg14);


FATAL: procedure (msg$d) external;
        declare msg$d pointer;
        end FATAL;


control_error: procedure (error$number);
        declare error$number byte;
        call FATAL(@error_msg$d(error$number));
        end control_error;


$SUBTITLE ("SYNTAX ANALYSIS PROCEDURES")
match: procedure (string1$p,string2$p) byte;
        declare (string1$p,string2$p) pointer;
        declare (string1 based string1$p, string2 based string2$p)
                 (32) byte;
        declare i integer;

        do i=0 to string1(0);
           if string1(i)<>string2(i) then return FALSE;
        end;
        return TRUE;
        end match;


get_control_token: procedure;
        declare i integer, status word;

        do while arg_length=0 and delimiter=' ';
           delimiter=DQ$GET$ARGUMENT(@argument,@status);
           arg_length=argument(0);
           end;

        if arg_length <> 0 then do;
           arg_length=0;
           if match(@argument,@(3,'AND')) then
              tokn=C_AND;
           else if match(@argument,@(2,'OR')) then
              tokn=C_OR;
           else if match(@argument,@(3,'XOR')) then
              tokn=C_XOR;
           else if match(@argument,@(3,'NOT')) then
              tokn=C_NOT;
           else
              tokn=0;
           end;

        else do;
           tokn=delimiter;
           delimiter=' ';
           end;

        end get_control_token;


must_match: procedure (test_token);
        declare test_token byte;

        if test_token <> tokn then
           call control_error(2);
        else
           call get_control_token;
        end must_match;


whole_number: procedure byte;
        declare (value,digit) byte, i integer;

        value=0;

        do i=1 to argument(0);
           if argument(i)<'0' or argument(i)>'9' then do;
              call control_error(5);
              digit=0;
              end;
           else
              digit=argument(i)-'0';
           value=value*10+digit;
           end;

        call get_control_token;
        return value;
        end whole_number;


whole_number_parameter: procedure (min,max,default) byte;
        declare (min,max,default) byte;
        declare value byte;

        call must_match('(');
        value=whole_number;
        call must_match(')');

        if value<min or value>max then do;
           call control_error(6);
           value=default;
           end;

        return value;
        end whole_number_parameter;


path_name_parameter: procedure (path$p,extension$p);
        declare (path$p,extension$p) pointer;
        declare (path based path$p) (46) byte;
        declare (explicit_extension,inside_directory) byte,
                i integer, status word;

        if argument(0)>45 then do;
           call control_error(7);
           argument(0)=45;
           end;

        explicit_extension,inside_directory=FALSE;

        path(0)=argument(0);
        do i=1 to argument(0);
           path(i)=argument(i);
           if path(i)='[' then
              inside_directory=TRUE;
           else if path(i)='[' then
              inside_directory=FALSE;
           else if not inside_directory and path(i)='.' then
              explicit_extension=TRUE;
           end;

        if not explicit_extension then do;
           call DQ$CHANGE$EXTENSION(path$p,extension$p,@status);
           if status<>E$OK then call control_error(7);
           end;

        end path_name_parameter;
 
 
purge_dollar_signs: procedure (string$p);
	declare string$p pointer;
	declare (string based string$p) (1) byte;
	declare (i,j) byte;
 
	do i=1 to string(0);
	   if string(i)='$' then
	      do;
                 string(0)=string(0)-1;
                 do j=i to string(0);
                    string(j)=string(j+1);
                 end;
              end;
	end;
end purge_dollar_signs;
 
switch_value: procedure byte;
        declare sw integer;

	call purge_dollar_signs(@argument);
        if argument(0) > 31 then argument(0)=31;

        sw=1;

        do while sw <= last_switch and
                 not match(@argument,@switch(sw).name);
           sw=sw+1;
           end;

        if sw > last_switch then
           return FALSE;
        else
           return switch(sw).value;
        end switch_value;


define_switch_value: procedure (lhs$p,value);
        declare lhs$p pointer, value byte;
        declare (lhs based lhs$p) (32) byte, (sw,i) integer;

	call purge_dollar_signs(@lhs);
        if lhs(0) > 31 then lhs(0)=31;

        sw=1;

        do while sw <= last_switch and not match(@lhs,@switch(sw).name);
           sw=sw+1;
           end;

        if sw > last_switch then do;
           if sw > max_switch then
              call control_error(3);
           else do;
              last_switch=sw;
              do i=0 to lhs(0); switch(sw).name(i)=lhs(i); end;
              switch(sw).value=value;
              end;
           end;
        else
           switch(sw).value=value;
        end define_switch_value;


limited_expression: procedure byte reentrant forward;
        end;


primary: procedure byte reentrant;
        declare value byte;

        if tokn='(' then do;
           call get_control_token;
           value=limited_expression;
           call must_match(')');
           end;
        else if tokn <> 0 then
           call control_error(1);
        else if argument(1)>='0' and argument(1)<='9' then
           value=whole_number;
        else do;
           value=switch_value; call get_control_token; end;

        return value;
        end primary;


secondary: procedure byte reentrant;

        if tokn='+' then do;
           call get_control_token; return primary; end;
        else if tokn='-' then do;
           call get_control_token; return -primary; end;
        else
           return primary;
        end secondary;


term: procedure byte reentrant;
        declare (value,divisor) byte;

        value=secondary;

        do while tokn='*' or tokn='/';
           if tokn='*' then do;
              call get_control_token; value=value*secondary; end;
           else do;
              call get_control_token;
              divisor=secondary;
              if divisor=0 then call control_error(4);
              else value=value/divisor;
              end;
           end;

        return value;
        end term;


arithmetic_expression: procedure byte reentrant;
        declare value byte;

        value=term;

        do while tokn='+' or tokn='-';
           if tokn='+' then do;
              call get_control_token; value=value+term; end;
           else do;
              call get_control_token; value=value-term; end;
           end;

        return value;
        end arithmetic_expression;


logical_primary: procedure byte reentrant;
        declare value byte;

        value=arithmetic_expression;

        if tokn='<' then do;
           call get_control_token;
           if tokn='>' then do;
              call get_control_token;
              value = (value <> arithmetic_expression);
              end;
           else if tokn='=' then do;
              call get_control_token;
              value = (value <= arithmetic_expression);
              end;
           else
              value = (value < arithmetic_expression);
           end;
        else if tokn='>' then do;
           call get_control_token;
           if tokn='=' then do;
              call get_control_token;
              value = (value >= arithmetic_expression);
              end;
           else
              value = (value > arithmetic_expression);
           end;
        else if tokn='=' then do;
           call get_control_token;
           value = (value = arithmetic_expression);
           end;

        return value;
        end logical_primary;


logical_secondary: procedure byte reentrant;

        if tokn=C_NOT then do;
           call get_control_token; return not logical_primary; end;
        else
           return logical_primary;
        end logical_secondary;


logical_factor: procedure byte reentrant;
        declare value byte;

        value=logical_secondary;

        do while tokn=C_AND;
           call get_control_token; value=value and logical_secondary;
           end;

        return value;
        end logical_factor;


limited_expression: procedure byte reentrant;
        declare value byte;

        value=logical_factor;

        do while tokn=C_OR or tokn=C_XOR;
           if tokn=C_OR then do;
              call get_control_token;
              value = value or logical_factor;
              end;
           else do;
              call get_control_token;
              value = value xor logical_factor;
              end;
           end;

        return value;
        end limited_expression;


get_string_parameter: procedure (string$p);
        declare string$p pointer;
        declare (string based string$p) (81) byte,
                i integer;

        call must_match('(');

        do i=0 to argument(0);
           string(i)=argument(i);
           end;

        call get_control_token;
        call must_match(')');

        end get_string_parameter;


optional_path_name: procedure (path$p,extension$p);
        declare (path$p,extension$p) pointer;

        if tokn='(' then do;
           call get_control_token;
           call path_name_parameter(path$p,extension$p);
           call get_control_token;
           call must_match(')');
           end;

        end optional_path_name;


$SUBTITLE ("CONTROL WORD TABLES")
/***********************************************************************

                Table of Controls.

***********************************************************************/

declare max_cmd literally '71';

declare control(max_cmd+1) structure (name(12) byte, primary byte)
        initial(

        5,'PRINT      ',TRUE,   /*0*/
        7,'NOPRINT    ',TRUE,   /*1*/
        4,'LIST       ',FALSE,  /*2*/
        6,'NOLIST     ',FALSE,  /*3*/
        4,'CODE       ',FALSE,  /*4*/
        6,'NOCODE     ',FALSE,  /*5*/
        4,'XREF       ',TRUE,   /*6*/
        6,'NOXREF     ',TRUE,   /*7*/
        5,'IXREF      ',TRUE,   /*8*/
        7,'NOIXREF    ',TRUE,   /*9*/
        7,'SYMBOLS    ',TRUE,   /*10*/
        9,'NOSYMBOLS  ',TRUE,   /*11*/
        6,'PAGING     ',TRUE,   /*12*/
        8,'NOPAGING   ',TRUE,   /*13*/
       10,'PAGELENGTH ',TRUE,   /*14*/
        9,'PAGEWIDTH  ',TRUE,   /*15*/
        4,'DATE       ',TRUE,   /*16*/
        5,'TITLE      ',TRUE,   /*17*/
        8,'SUBTITLE   ',FALSE,  /*18*/
        5,'EJECT      ',FALSE,  /*19*/
       10,'LEFTMARGIN ',FALSE,  /*20*/
        9,'INTVECTOR  ',TRUE,   /*21*/
       11,'NOINTVECTOR',TRUE,   /*22*/
        8,'OPTIMIZE   ',TRUE,   /*23*/
        6,'OBJECT     ',TRUE,   /*24*/
        8,'NOOBJECT   ',TRUE,   /*25*/
        8,'OVERFLOW   ',FALSE,  /*26*/
       10,'NOOVERFLOW ',FALSE,  /*27*/
        5,'DEBUG      ',TRUE,   /*28*/
        7,'NODEBUG    ',TRUE,   /*29*/
        4,'TYPE       ',TRUE,   /*30*/
        6,'NOTYPE     ',TRUE,   /*31*/
        9,'WORKFILES  ',TRUE,   /*32*/
        7,'INCLUDE    ',FALSE,  /*33*/
        4,'SAVE       ',FALSE,  /*34*/
        7,'RESTORE    ',FALSE,  /*35*/
        3,'RAM        ',TRUE,   /*36*/
        3,'ROM        ',TRUE,   /*37*/
        5,'SMALL      ',TRUE,   /*38*/
        7,'COMPACT    ',TRUE,   /*39*/
        6,'MEDIUM     ',TRUE,   /*40*/
        5,'LARGE      ',TRUE,   /*41*/
        4,'COND       ',FALSE,  /*42*/
        6,'NOCOND     ',FALSE,  /*43*/
        3,'SET        ',FALSE,  /*44*/
        5,'RESET      ',FALSE,  /*45*/
        2,'IF         ',FALSE,  /*46*/
        6,'ELSEIF     ',FALSE,  /*47*/
        4,'ELSE       ',FALSE,  /*48*/
        5,'ENDIF      ',FALSE,  /*49*/
        6,'OPRINT     ',TRUE,   /*50*/
        8,'NOOPRINT   ',TRUE,   /*51*/
	4,'TABS       ',TRUE,   /*52*/
	6,'NOTABS     ',TRUE,   /*53*/
	4,'WARN       ',TRUE,   /*54*/
        6,'NOWARN     ',TRUE,   /*55*/
        5,'PLM80      ',TRUE,   /*56*/
        7,'GLOBALS    ',TRUE,   /*57*/
	9,'NOGLOBALS  ',TRUE,	/*58*/
	7,'PUBLICS    ',TRUE,   /*59*/
	9,'NOPUBLICS  ',TRUE,   /*60*/
	7,'OVERLAY    ',TRUE,   /*61*/
	9,'NOOVERLAY  ',TRUE,   /*62*/
	4,'ROOT       ',TRUE,   /*63*/
	6,'NOROOT     ',TRUE,   /*64*/
  	5,'ALIGN      ',TRUE,   /*65*/
	7,'NOALIGN    ',TRUE,   /*66*/
       11,'FREQUENCIES',TRUE,   /*67*/
        6,'VECTOR     ',TRUE,   /*68*/
        8,'NOVECTOR   ',TRUE,   /*69*/
	6,'ASSUME     ',TRUE,   /*70*/
        0,'           ',FALSE); /*71 -- DUMMY */

$SUBTITLE ("COMMON INTERFACE TO FORTRAN ROUTINES")
declare max_in literally '20';

common /controls/
        (leftmargin,rightmargin) integer,
        (list_flag,large_flag,non_control_line_read) byte,
        (skip_state,pagelength,pagewidth,optimize,model)
            integer,

        (print_flag,code_flag,xref_flag,ixref_flag,
         symbols_flag,paging_flag,eject_flag,intvector_flag,
         object_flag,overflow_flag,debug_flag,type_flag,rom_flag,
         cond_flag) byte,

        (print_file_string,ixref_file_string,work_file_string,
         object_file_string) (46) byte,

        (date_string,title_string,subtitle_string) (81) byte,

        in_file_string (8:max_in+1) structure (string(46) byte),

        oprint_file_string (46) byte, oprint_flag byte,
 
        tabs integer, (warn_flag,plm80_flag) byte,
	(globals_flag,publics_flag,overlay_flag,root_flag) byte,
	(globals_file_string,publics_file_string) (46) byte,
        overlay_prefix (81) byte,
 
        (align_flag,freq_flag,vector_flag) byte;

common /io/ (in,out,lst,ixi,gbl,pub) integer;

$SUBTITLE ("SAVE/RESTORE STACK")
/***********************************************************************

        Save/Restore Stack for Controls.

***********************************************************************/

declare save_level_max literally '16';

declare save_level integer initial (0);

declare CS(save_level_max) structure (list byte,
                                      code byte,
                                      overflow byte,
                                      leftmargin integer,
                                      cond byte);

declare this_switch (81) byte;

declare CR literally 'ASC$CR';


$SUBTITLE ("IF/ELSEIF/ELSE/ENDIF Stack and Procedures")
declare skip_level_max literally '20';

declare skip_state_stack (skip_level_max) integer,
        skip_level integer initial(0);

push_skip_state: procedure (new_state);
        declare new_state integer;

        skip_state_stack(skip_level)=skip_state;
        skip_state=new_state;
        skip_level=skip_level+1;
        if skip_level >= skip_level_max then
           call control_error(13);
        end push_skip_state;


pop_skip_state: procedure;
        skip_level=skip_level-1;
        skip_state=skip_state_stack(skip_level);
        end;


force_list_source: procedure external;
        end;
$SUBTITLE ("ASSUME CONTROL PROCESSOR")
/*****************************************************************/
/*                                                               */
/*		ASSUME CONTROLS.				 */
/*								 */
/*****************************************************************/
 
declare nbr_assumptions literally '15';
 
common /assumptions/ assumption_flag(nbr_assumptions) byte;
 
declare assumption (nbr_assumptions) structure (
		name(3) byte, optimize_setting(4) byte)
	data(	'SCE',f,t,t,t,	/* Short Circuit evaluation of boolean expressions */
		'CSE',f,t,t,t,	/* Common Subexpression Elimination */
		'EEQ',t,t,t,t,	/* Externals might be EQuivalenced */
		'PSE',t,t,t,t,  /* Procedures have Side Effects */
		'BRO',t,t,t,f,  /* Based References Overlay other vars */
		'BBA',f,t,t,t,  /* Basic Block Analysis */
		'CTE',t,t,t,t,	/* Compile-Time Evaluation of constant exprs */
		'MCO',f,t,t,t,	/* Machine Code Optimization */
		'CFA',f,f,t,t,	/* Control Flow Analysis */
		'SWB',f,t,t,t,  /* Subscripts are Within Bounds */
		'OSR',f,t,t,t,  /* Operator Strength Reduction */
		'SVE',f,f,f,t,  /* only Single Variables are Equivalenced */
                'S64',t,t,t,t,  /* String operations are < 64K bytes */
		'C7F',f,f,f,t,  /* shift counts are <= 07FH */
		'DBG',f,f,f,f,  /* DeBuG the compiler */
                );
 
 
process_assumptions: procedure;
    declare set_flag_sense byte;
    declare i byte;
 
    if tokn <> '(' then call control_error (2);
 
    tokn = ',';
    do while tokn = ',';
	call get_control_token;
  	if tokn <> 0 then call control_error (2);
	if CMPB(@argument,@(5,'NO'),3) = 0FFFFH then
	    do;
	    set_flag_sense = FALSE;
	    call MOVB (@argument(3),@argument(1),3);
	    end;
	else if argument(0) = 3 then
	    set_flag_sense = TRUE;
	else
	    call control_error (14);
 
	i = 0;
	do while i < nbr_assumptions and
		 CMPB(@argument(1),@assumption(i).name,3) <> 0FFFFH;
	    i = i+1;
	end;
	if i = nbr_assumptions then call control_error (14);
	assumption_flag(i) = set_flag_sense;
	call get_control_token;
    end;
    call must_match (')');
end process_assumptions;
$SUBTITLE ("FILE OPENING PROCEDURES")
open_sos_file: procedure (unit$p,file_string$p) external;
        declare (unit$p,file_string$p) pointer;
        end;


open_output_file: procedure (unit$p,file_string$p) external;
        declare (unit$p,file_string$p) pointer;
        end;


open_output_files: procedure public;
        if print_flag then
           call open_output_file(@lst,@print_file_string);
        if object_flag then
           call open_output_file(@out,@work_file_string);
        if ixref_flag then
           call open_output_file(@ixi,@ixref_file_string);
	if globals_flag then
	   call open_sos_file(@gbl,@globals_file_string);
	if publics_flag then
	   call open_output_file(@pub,@publics_file_string);
        end open_output_files;


$SUBTITLE ("CONTROL_LINE PROCEDURE")
        /*************************************
        *                                    *
        *       Control_Line procedure.      *
        *                                    *
        *************************************/

control_line: procedure public;
     declare (cmd, i, old_skip_state) integer,
             (conditional_control,first_control) byte;

     call get_control_token;
     first_control=TRUE;

control_loop:
     do forever;

        do while tokn<>0;
           if tokn=CR then return;
           call control_error(0);
           call get_control_token;
           end;

        cmd=0;
        do while cmd < max_cmd and
           not match(@argument,@control(cmd).name);
           cmd=cmd+1;
           end;

        call get_control_token;

        if control(cmd).primary and non_control_line_read then
           call control_error(8);

        conditional_control = cmd>=46 and cmd<=49;
        if conditional_control and not first_control then
           call control_error(12);

        do case skip_state;
           /* 0 - invocation line */
           ;
           /* 1 - reading at level > 0 */
           ;
           /* 2 - skipping to ENDIF */
           if not conditional_control then go to premature_exit;
           /* 3 - skipping to ENDIF/ELSE/ELSEIF-true */
           if not conditional_control then go to premature_exit;
           /* 4 - reading at level 0 */
           ;
           end;

        old_skip_state=skip_state;

command_case:
        do case cmd;

/* 0 - PRINT */         do;
                        call optional_path_name(@print_file_string,
                                                @('LIS'));
                        print_flag=TRUE;
                        end;
/* 1 - NOPRINT */       print_flag=FALSE;
/* 2 - LIST */          list_flag=TRUE;
/* 3 - NOLIST */        list_flag=FALSE;
/* 4 - CODE */          code_flag=TRUE;
/* 5 - NOCODE */        code_flag=FALSE;
/* 6 - XREF */          xref_flag=TRUE;
/* 7 - NOXREF */        xref_flag=FALSE;
/* 8 - IXREF */         do;
                        call optional_path_name(@ixref_file_string,
                                                @('IXI'));
                        ixref_flag=TRUE;
                        end;
/* 9 - NOIXREF */       ixref_flag=FALSE;
/* 10 - SYMBOLS */      symbols_flag=TRUE;
/* 11 - NOSYMBOLS */    symbols_flag=FALSE;
/* 12 - PAGING */       paging_flag=TRUE;
/* 13 - NOPAGING */     paging_flag=FALSE;
/* 14 - PAGELENGTH */   pagelength=whole_number_parameter(5,200,60);
/* 15 - PAGEWIDTH */    pagewidth=whole_number_parameter(60,132,120);
/* 16 - DATE */         call get_string_parameter(@date_string);
/* 17 - TITLE */        call get_string_parameter(@title_string);
/* 18 - SUBTITLE */     do;
                        call get_string_parameter(@subtitle_string);
                        eject_flag=TRUE;
                        end;
/* 19 - EJECT */        eject_flag=TRUE;
/* 20 - LEFTMARGIN */   leftmargin=whole_number_parameter(1,72,1);
/* 21 - INTVECTOR */    intvector_flag=TRUE;
/* 22 - NOINTVECTOR */  intvector_flag=FALSE;
/* 23 - OPTIMIZE */     do;
			optimize=whole_number_parameter(0,3,1);
			do i=0 to nbr_assumptions-1;
			    assumption_flag(i)=
				assumption(i).optimize_setting(optimize);
			end;
			end;
/* 24 - OBJECT */       do;
                        call optional_path_name(@object_file_string,
                                                @('OBJ'));
                        object_flag=TRUE;
                        end;
/* 25 - NOOBJECT */     object_flag=FALSE;
/* 26 - OVERFLOW */     overflow_flag=TRUE;
/* 27 - NOOVERFLOW */   overflow_flag=TRUE;
/* 28 - DEBUG */        debug_flag=TRUE;
/* 29 - NODEBUG */      debug_flag=FALSE;
/* 30 - TYPE */         type_flag=TRUE;
/* 31 - NOTYPE */       type_flag=FALSE;
/* 32 - WORKFILES */    do;
                        if tokn<>'(' then call control_error(2);
                        tokn=',';
                        do while tokn=',';
                           call get_control_token;
                           call path_name_parameter(@work_file_string,
                                                    @('TMP'));
                           call get_control_token;
                           end;
                        call must_match(')');
                        end;
/* 33 - INCLUDE */      do;
                        call must_match('(');
                        call path_name_parameter(@in_file_string(in+1),
                                                 @('SRC'));
                        call get_control_token;
                        call must_match(')');
                        if tokn<>CR then call control_error(10);

                        if in >= max_in then
                           call control_error(9);
                        else do;
                           in=in+1;
                           call open_sos_file(@in,@in_file_string(in));
                           end;
                        end;
/* 34 - SAVE */         do;
                        if save_level >= save_level_max then
                           call control_error(11);
                        else do;
                           CS(save_level).list=list_flag;
                           CS(save_level).code=code_flag;
                           CS(save_level).overflow=overflow_flag;
                           CS(save_level).leftmargin=leftmargin;
                           CS(save_level).cond=cond_flag;
                           save_level=save_level+1;
                           end;
                        end;
/* 35 - RESTORE */      do;
                        if save_level <= 0 then
                           call control_error(11);
                        else do;
                           save_level=save_level-1;
                           list_flag=CS(save_level).list;
                           code_flag=CS(save_level).code;
                           overflow_flag=CS(save_level).overflow;
                           leftmargin=CS(save_level).leftmargin;
                           cond_flag=CS(save_level).cond;
                           end;
                        end;
/* 36 - RAM */          rom_flag=FALSE;
/* 37 - ROM */          rom_flag=TRUE;
/* 38 - SMALL */        model=1;
/* 39 - COMPACT */      do; model=2; large_flag=TRUE; end;
/* 40 - MEDIUM */       model=3;
/* 41 - LARGE */        do; model=4; large_flag=TRUE; end;
/* 42 - COND */         cond_flag=TRUE;
/* 43 - NOCOND */       cond_flag=FALSE;
/* 44 - SET */          do;
                        if tokn<>'(' then call control_error(2);
                        tokn=',';
                        do while tokn=',';
                           call get_control_token;
                           do i=0 to argument(0);
                              this_switch(i)=argument(i);
                              end;
                           call get_control_token;
                           if tokn='=' then do;
                              call get_control_token;
                              call define_switch_value(@this_switch,
                                                 limited_expression);
                              end;
                           else
                              call define_switch_value(@this_switch,
                                                       TRUE);
                           end;
                        call must_match(')');
                        end;
/* 45 - RESET */        do;
                        if tokn<>'(' then call control_error(2);
                        tokn=',';
                        do while tokn=',';
                           call get_control_token;
                           call define_switch_value(@argument,FALSE);
                           call get_control_token;
                           end;
			call must_match(')');
                        end;
/* 46 - IF */           if_case: do case skip_state;
                        /* 0 - invocation line */
                           call control_error(12);
                        /* 1 - reading at level > 0 */
                           if limited_expression then
                              call push_skip_state(1);
                           else
                              call push_skip_state(3);
                        /* 2 - skipping to ENDIF */
                           call push_skip_state(2);
                        /* 3 - skipping to ENDIF/ELSE/ELSEIF-true */
                           call push_skip_state(2);
                        /* 4 - reading at level 0 */
                           if limited_expression then
                              call push_skip_state(1);
                           else
                              call push_skip_state(3);
                        end if_case;
/* 47 - ELSEIF */       elseif_case: do case skip_state;
                        /* 0 - invocation line */
                           call control_error(12);
                        /* 1 - reading at level > 0 */
                           skip_state=2;
                        /* 2 - skipping to ENDIF */
                           ;
                        /* 3 - skipping to ENDIF/ELSE/ELSEIF-true */
                           if limited_expression then skip_state=1;
                        /* 4 - reading at level 0 */
                           call control_error(12);
                        end elseif_case;
/* 48 - ELSE */         else_case: do case skip_state;
                        /* 0 - invocation line */
                           call control_error(12);
                        /* 1 - reading at level > 0 */
                           skip_state=2;
                        /* 2 - skipping to ENDIF */
                           ;
                        /* 3 -skipping to ENDIF/ELSE/ELSEIF-true */
                           skip_state=1;
                        /* 4 reading at level 0 */
                           call control_error(12);
                        end else_case;
/* 49 - ENDIF */        endif_case: do case skip_state;
                        /* 0 - invocation line */
                           call control_error(12);
                        /* 1 - reading at level > 0 */
                           call pop_skip_state;
                        /* 2 - skipping to ENDIF */
                           call pop_skip_state;
                        /* 3 - skipping to ENDIF/ELSE/ELSEIF-true */
                           call pop_skip_state;
                        /* 4 - reading at level 0 */
                           call control_error(12);
                        end endif_case;
/* 50 - OPRINT */       do;
                        call optional_path_name(@oprint_file_string,
                                                        @('LST'));
                        oprint_flag=TRUE;
                        end;
/* 51 - NOOPRINT */     oprint_flag=FALSE;
/* 52 - TABS */		tabs=whole_number_parameter(0,99,8);
/* 53 - NOTABS */	tabs=0;
/* 54 - WARN */		warn_flag=TRUE;
/* 55 - NOWARN */	warn_flag=FALSE;
/* 56 - PLM80 */	plm80_flag=TRUE;
/* 57 - GLOBALS */      do; globals_flag=TRUE;
			call optional_path_name(@globals_file_string,
                                                        @('GBL'));
			end;
/* 58 - NOGLOBALS */	globals_flag=FALSE;
/* 59 - PUBLICS */	do; publics_flag=TRUE;
			call optional_path_name(@publics_file_string,
                                                        @('PBL'));
			end;
/* 60 - NOPUBLICS */	publics_flag=FALSE;
/* 61 - OVERLAY */	do; overlay_flag=TRUE;
			call get_string_parameter(@overlay_prefix);
			end;
/* 62 - NOOVERLAY */	overlay_flag=FALSE;
/* 63 - ROOT */		root_flag=TRUE;
/* 64 - NOROOT */	root_flag=FALSE;
/* 65 - ALIGN */	align_flag=TRUE;
/* 66 - NOALIGN */	align_flag=FALSE;
/* 67 - FREQUENCIES */	freq_flag=TRUE;
/* 68 - VECTOR */       vector_flag=TRUE;
/* 69 - NOVECTOR */     vector_flag=FALSE;
/* 70 - ASSUME */	call process_assumptions;
/* 71 - no match */     call control_error(0);

                  end command_case;

        first_control=FALSE;

        if skip_state=2 or skip_state=3 then go to premature_exit;
        else if old_skip_state=2 or old_skip_state=3 then
                call force_list_source;

        end control_loop;
 
premature_exit:
        /* Clean up for next invocation of control line. */
	arg_length=0;  delimiter=' ';

     end control_line;


$SUBTITLE ("INVOCATION_LINE PROCEDURE")
                /************************************
                *                                   *
                *   Invocation_Line Procedure       *
                *                                   *
                ************************************/
 
declare VMS$delimiter$set (*) byte data (
        17, ',()=#!%\~+-*/&|<>');

invocation_line: procedure public;
        declare status word, i integer;
 
	call DQ$SET$DELIMITERS(@VMS$delimiter$set,@status);

        call get_control_token;

        call path_name_parameter(@in_file_string(in),@('PLM'));
        call open_sos_file(@in,@in_file_string(in));

        do i=0 to in_file_string(in).string(0);
           print_file_string(i),
           work_file_string(i),
           ixref_file_string(i),
           oprint_file_string(i),
	   globals_file_string(i),
	   publics_file_string(i),
           object_file_string(i)=in_file_string(in).string(i);
           end;

        call DQ$CHANGE$EXTENSION(@print_file_string,@('LIS'),@status);
        call DQ$CHANGE$EXTENSION(@work_file_string,@('TMP'),@status);
        call DQ$CHANGE$EXTENSION(@ixref_file_string,@('IXI'),@status);
        call DQ$CHANGE$EXTENSION(@oprint_file_string,@('LST'),@status);
        call DQ$CHANGE$EXTENSION(@object_file_string,@('OBJ'),@status);
        call DQ$CHANGE$EXTENSION(@globals_file_string,@('GBL'),@status);
        call DQ$CHANGE$EXTENSION(@publics_file_string,@('PBL'),@status);

        call control_line;

        end invocation_line;

end CONTROL_MODULE;