/scopy,source
COPYRT
COMMON
 CPRT     RMT 
          DATA   H*COPYRIGHT CONTROL DATA SYSTEMS INC.  1997.*
 CPRT     RMT 
          ENDX
--EOR--    
TDUEX 
ASCII 
*NOSEQ
*WIDTH 95 
MODULE tduex;
  
?? SET ( CHKALL := ON ), RIGHT := 110 ??
  
{  Program:  TDUEX  }
{            Copyright Control Data Systems Inc.  1992.  } 
{  Written:  1/84 by R. Lindsey  } 
{  Version:  Cyber 170, version 1 } 
{  Purpose:  Compile terminal definitions for the use of the terminal- }
{            independent handler VIRTERM.  This handler is used by FSE, } 
{            SCREEN, and possibly other programs.  }
{            TDU takes its input ("source") in the form of SCL-like statements} 
{            which define the characteristics of the particular terminal.  }
{            As output ("object") it produces a Virtual Terminal Table (VTT) } 
{            which is in the form of COMPASS source code.  This source is }
{            in turn fed through COMPASS which produces a relocatable version,} 
{            which is then linked to produce the absolute version that can be }
{            directly loaded by VIRTERM.  } 
{  Modules:  The TDU program is composed of four separately compiled modules: } 
{            o  TDUEX (this module) is the main program.  It calls procedures }
{               from the other modules.  This module also supplies file- and } 
{               error-handling procedures used by all the other modules. } 
{            o  TDUIN performs the input handling functions.  It reads the } 
{               TDL source file, translates it into intermediate form, and } 
{               writes that intermediate output to internal tables managed } 
{               by TDUTAB. }
{            o  TDUTAB manages the intermediate data produced by TDUIN and }
{               consumed by TDUOUT.  It hides, as much as possible, all the } 
{               details of the tables which contain this data.  This serves }
{               to isolate TDUIN and TDUOUT from changes made in each other. }
{            o  TDUOUT produces the output table from the intermediate data. }
{               It hides all details of target machine word and byte sizes, }
{               alignment, and object code format (e.g., the CYBER 170 } 
{               version produces COMPASS source code). } 
  
{ ?? PUSH ( LIST := OFF ) ??          { un-comment this list for no comm list } 
  ?? PUSH ( LIST := ON ) ??           { un-comment this line for commdeck list}
  
?? NEWTITLE := 'File I/O' ??
  
{ ***************************************** } 
{ common deck pxiotyp, for file i/o follows }
*CALL PXIOTYP 
  
{ ********************************************* } 
{ common deck lgz, for legible file i/o follows } 
*CALLALL LGZ
  
{ ************************************ }
{ common deck fz, for file i/o follows }
*CALLALL FZ 
  
?? OLDTITLE ??
?? POP ?? 
?? NEWTITLE := 'Error handling, initialization, and messages' ??
?? EJECT ?? 
  
{ ************************************************************** }
{ constants and types for procedures which are XDCL'ed in TDUEX: } 
*CALL ZTDCERR 
*CALL ZTDTFIL 
  
{ ************************ }
{ parser error conditions: }
*CALL ZTDAMT0 
*CALL ZTDCCON 
*CALL ZTDCCLC 
  
{ **************************** }
{ initialization & termination } 
*CALL ZUTPCSA 
*CALL ZOSPINI 
*CALL ZOSPEND 
  
{ ************************* } 
{ status message formatting }
*CALL ZOSPFMG 
  
?? OLDTITLE ??
  
  PROCEDURE [XREF] read_tdl_statements;
  
  PROCEDURE [XREF] initialize_tables; 
  
  PROCEDURE [XREF] write_tables; 
  
  PROCEDURE [XREF] optimize_tables; 
  
  ?? EJECT ?? 
{ ?? POP ??
  
  VAR 
     tdu_version_num: [XDCL] INTEGER := 1; { version 1 }
  
  VAR 
     error_flag: BOOLEAN := FALSE,    { an error has occurred }
  
     input_file, 
     output_file, 
     error_file: file,
     input_file_name,                 { from control statement } 
     output_file_name,
     error_file_name: ost$name_descriptor, 
  
     status: ost$status,
  
     command_name: ost$name_descriptor,
     control_statement_arguments: ARRAY [ 1 .. 3 ] OF STRING(7) 
        := [ 'TDUIN', 'TDUOUT', 'OUTPUT' ];
  
  ?? NEWTITLE := 'open_file' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] open_file (file_id: file_selector;
        input_output: input_output_selector; 
        code_set: code_set_selector);
     VAR
        f: file,
        f_name: ost$name_descriptor; 
  
     CASE file_id OF
        = input_file_sel =
           f := input_file;
           f_name := input_file_name;
        = output_file_sel =
           f := output_file;
           f_name := output_file_name;
        = error_file_sel =
           f := error_file;
           f_name := error_file_name;
     CASEND;
     CASE input_output OF
        = input_sel = 
           lg#open(f, f_name.str(1,f_name.length), old#, input#, first#);
        = output_sel = 
           lg#open(f, f_name.str(1,f_name.length), new#, output#, first#);
     CASEND;
     CASE code_set OF
        = ascii_sel = 
           ;
        = ascii64_sel = 
           lg#codeset(f, ascii64#);   { use 6-bit display code }
     CASEND;
     CASE file_id OF
        = input_file_sel =
           input_file := f;
        = output_file_sel =
           output_file := f;
        = error_file_sel =
           error_file := f;
     CASEND;
  PROCEND open_file;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'close_file' ??
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] close_file (file_id: file_selector); 
     CASE file_id OF
        = input_file_sel =
           lg#close(input_file, first#); 
        = output_file_sel =
           lg#close(output_file, first#); 
        = error_file_sel =
           lg#close(error_file, first#); 
     CASEND;
  PROCEND close_file;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'get_file' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] get_file (file_id: file_selector;
        VAR text: STRING(*); 
        VAR text_len: INTEGER;
        VAR eof_flag: BOOLEAN); 
     VAR
        structure_mark: file_mark;
  
     text := ''; 
     CASE file_id OF
        = input_file_sel =
           lg#get(input_file, text_len, text); 
           f#mark(input_file, structure_mark); 
        = output_file_sel =
           lg#get(output_file, text_len, text); 
           f#mark(output_file, structure_mark); 
        = error_file_sel =
           lg#get(error_file, text_len, text); 
           f#mark(error_file, structure_mark); 
     CASEND;
     IF ( structure_mark = eof# ) OR
        ( structure_mark = eoi# ) THEN
        eof_flag := TRUE
     ELSE 
        eof_flag := FALSE 
     IFEND
  PROCEND get_file;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'put_file' ??
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] put_file (file_id: file_selector;
        text: STRING(*));
     CASE file_id OF
        = input_file_sel =
           lg#put(input_file, text);
        = output_file_sel =
           lg#put(output_file, text);
        = error_file_sel =
           lg#put(error_file, text);
     CASEND 
  PROCEND put_file;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'report_error' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] report_error (text: STRING(*));
     VAR
        str_ndx,
        str_length: INTEGER;
  
     IF NOT error_flag THEN
        open_file(error_file_sel, output_sel, ascii_sel);
        error_flag := TRUE
     IFEND; 
     str_ndx := 1; 
     WHILE str_ndx <= STRLENGTH(text) DO
        str_length := ( STRLENGTH(text) - str_ndx ) + 1;
        IF str_length > 80 THEN
           str_length := 80 
        IFEND;
        put_file(error_file_sel, text(str_ndx, str_length));
        str_ndx := str_ndx + str_length 
     WHILEND
  PROCEND report_error;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'error_status' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] error_status (status: ost$status);
     VAR
        reentry, 
        message_complete: BOOLEAN,
        length: 0 .. osc$max_string_length,
        msg: STRING(79);
  
     report_error(' ');
     reentry := FALSE;
     REPEAT 
        osp$format_message(reentry, message_complete, length, 
           msg, status); 
        report_error(msg(1,length));
        reentry := TRUE;
     UNTIL message_complete; 
  PROCEND error_status;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'interpret_control_statement' ?? 
  ?? EJECT ?? 
  
  PROCEDURE interpret_control_statement; 
     VAR
        command_line_pointer: ^STRING(*), 
        command_line_index: clt$string_index;
  
     osp$initiate(command_name, command_line_pointer, 
        command_line_index, status);
     utp$get_control_statement_args(control_statement_arguments);
     input_file_name.typ := clc$nos170_name; 
     input_file_name.length := 7; 
     input_file_name.str := control_statement_arguments[1]; 
     output_file_name.typ := clc$nos170_name; 
     output_file_name.length := 7; 
     output_file_name.str := control_statement_arguments[2]; 
     error_file_name.typ := clc$nos170_name; 
     error_file_name.length := 7; 
     error_file_name.str := control_statement_arguments[3]
  PROCEND interpret_control_statement; 
  ?? OLDTITLE ??
  ?? EJECT ?? 
  
  PROGRAM tduex; 
     interpret_control_statement;
     initialize_tables; 
     IF NOT error_flag THEN
        read_tdl_statements; 
        IF NOT error_flag THEN 
           optimize_tables; 
           IF NOT error_flag THEN
              write_tables 
           IFEND
        IFEND 
     IFEND; 
     IF error_flag THEN
        close_file(error_file_sel);
        { osp$set_status_abnormal(tdc_prod_code, tde_error_termination,
        {    '', status) 
     IFEND; 
     osp$terminate(command_name, status) 
  PROCEND tduex; 
  
MODEND tduex;
--EOR--    
TDUIN 
ASCII 
*NOSEQ
*WIDTH 95 
MODULE tduin;
  
?? SET ( CHKALL := ON ), RIGHT := 110 ??
  
{  Module :  TDUIN  } 
{            Copyright Control Data Systems Inc.  1992.  } 
{  Written:  1/84 by R. Lindsey  } 
{  Version:  Cyber 170, version 1 } 
{  Purpose:  This module provides the input reading and parsing functions } 
{            of the TDL language on behalf of the TDU program. } 
  
{ ?? PUSH ( LIST := OFF ) ??          {use this line to suppress commdeck list}
  ?? PUSH ( LIST := ON )  ??          {use this line to list common decks }
  
?? NEWTITLE := 'SCL parsing declarations' ??
?? SKIP := 4 ??
  
{ ****************************** }
{ SCL types and routines follow: } 
*CALL ZTDPCLP 
*CALL ZUTVCTT 
  
{ ***************** } 
{ error conditions: } 
*CALL ZTDCCON 
*CALL ZTDCCLC 
  
?? OLDTITLE ??
?? NEWTITLE := 'PDT''s for TDL' ?? 
?? EJECT ?? 
  
{ ********************* } 
{ PDT's for TDL follow: }
*CALL ZTDVPDT 
  
?? OLDTITLE ??
?? NEWTITLE := 'ZTDTTAB' ??
?? EJECT ?? 
  
{ **************************** }
{ common deck ZTDTTAB follows: }
*CALL ZTDTTAB 
  
?? OLDTITLE ??
?? NEWTITLE := 'ZTDVERB' ??
?? EJECT ?? 
  
{ **************************** }
{ common deck ZTDVERB follows: }
*CALL ZTDVERB 
  
?? OLDTITLE ??
?? NEWTITLE := 'tdu XREF''s' ??
?? EJECT ?? 
  
{ ***************** } 
{ tdu file handler: }
*CALL ZTDPFIL 
  
{ ************************** }
{ tdu error handler follows: } 
*CALL ZTDPERR 
  
{ ****************************** }
{ table-handling store procedures } 
*CALLC ZTDPTBS
  
?? OLDTITLE ??
?? NEWTITLE := 'tduin variables' ??
?? EJECT ?? 
?? POP ?? 
  
  VAR 
     line_length: INTEGER, 
     line_buffer: STRING(osc$max_string_size), 
     line_number: INTEGER := 0, 
  
     source_string: STRING(osc$max_string_size), { for parser to scan } 
     source_length: clt$string_index, { valid length of source_string } 
     source_index: clt$string_index,  { current scan position in source }
     old_index: clt$string_index,     { saved scan position } 
     pdt: ^clt$parameter_descriptor_table, { the pdt for the current verb }
     pvt: ^clt$parameter_value_table,  { returned pvt from the parse }
     status: ost$status,
  
     empty_file: BOOLEAN, 
     error_return: error_type, 
     parm_rec: parameter_record, 
  
     size_ndx: INTEGER,
     junk_string: STRING(80),
     junk_len: INTEGER; 
  
  TYPE
     tdl_variable = PACKED RECORD     { my specialized version of clt$variable} 
        name: ost$name, 
        next_variable: ^tdl_variable,
        str_length: 0 .. osc$max_string_size, 
        value: ^STRING(*), 
     RECEND;
  
  VAR 
     variable_list: ^tdl_variable; 
  
  ?? OLDTITLE ??
  ?? NEWTITLE := 'read_tdl_statements' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] read_tdl_statements;
  
  ?? NEWTITLE := 'source_error' ??
  ?? SKIP := 4 ??
  
  PROCEDURE source_error (status: ost$status); 
     VAR
        length: 0 .. osc$max_string_size,
        msg: STRING(osc$max_string_size + 7); 
  
     error_status(status); 
     msg := ''; 
     STRINGREP(msg, length, line_number: 5, ': ',
        source_string(1,source_length));
     report_error(msg(1,length)); 
     msg := ''; 
     IF ( 7 + source_index ) > length THEN 
        msg(length) := '^' 
     ELSE 
        msg(7 + source_index) := '^'
     IFEND; 
     report_error(msg(1,length)); 
  PROCEND source_error;
  ?? OLDTITLE ??
  
     ?? NEWTITLE := 'add_variable_to_symbol_table' ??
     ?? EJECT ??
  
     PROCEDURE add_variable_to_symbol_table (name: ost$name_descriptor; 
           VAR variable: ^tdl_variable; VAR error_return: error_type);
  
        ALLOCATE variable;
        IF variable = NIL THEN
           error_return := no_room_error;
           osp$set_status_abnormal(tdc_prod_code, clc$table_overflow,
              name.str(1,name.length), status);
           osp$append_status_parameter( 
              ' ', osc$status_parameter_delimiter, status);
           source_error(status)
        ELSE
           error_return := no_error; 
           variable^.name := name.str(1,name.length);
           variable^.next_variable := variable_list;
           variable^.str_length := 0;
           variable^.value := NIL; 
           variable_list := variable 
        IFEND 
     PROCEND add_variable_to_symbol_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'assign_value_to_variable' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE assign_value_to_variable (value_string: STRING(*);
           value_length: 0 .. osc$max_string_size;
           VAR variable: ^tdl_variable; VAR error_return: error_type);
  
        IF variable^.value <> NIL THEN
           FREE variable^.value 
        IFEND;
        IF value_length > 0 THEN 
           ALLOCATE variable^.value : [ value_length ]
        ELSE
           ALLOCATE variable^.value : [ 1 ]
        IFEND;
        IF variable^.value = NIL THEN 
           osp$set_status_abnormal(tdc_prod_code, clc$table_overflow,
              variable^.name, status); 
           osp$append_status_parameter( 
              ' ', osc$status_parameter_delimiter, status);
           source_error(status); 
           error_return := no_room_error;
        ELSE
           error_return := no_error; 
           variable^.str_length := value_length;
           variable^.value^ := value_string(1,value_length) 
        IFEND 
     PROCEND assign_value_to_variable; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'initialize_parsing_tables' ??
     ?? EJECT ??
  
     PROCEDURE initialize_parsing_tables;
        VAR 
           var_ndx: INTEGER, 
           char_value: STRING(1), 
           name: ost$name_descriptor, 
           variable: ^tdl_variable,
           error_return: error_type; 
  
        variable_list := NIL;
        FOR var_ndx := 1 TO predefined_variable_count DO
           name.length := predefined_variables[var_ndx].length; 
           name.str := predefined_variables[var_ndx].name; 
           add_variable_to_symbol_table(name, variable, error_return); 
           IF error_return = no_error THEN
              char_value(1) := CHR(predefined_variables[var_ndx].ascii);
              assign_value_to_variable(char_value, 1, variable, error_return)
           IFEND
        FOREND
     PROCEND initialize_parsing_tables;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'open_input_file' ??
     ?? SKIP := 4 ?? 
  
     PROCEDURE open_input_file;
        open_file(input_file_sel, input_sel, ascii_sel);
        line_number := 0 
     PROCEND open_input_file;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'read_line' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE read_line (VAR eof_flag: BOOLEAN); 
           get_file(input_file_sel, line_buffer, line_length, eof_flag);
           line_number := line_number + 1
     PROCEND read_line; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'analyze_lines' ?? 
     ?? EJECT ??
  
     PROCEDURE analyze_lines; 
        VAR 
           eof_flag, 
           found: BOOLEAN,
           parm_ndx: INTEGER, 
           verb_typ: verb_type, 
           in_ordinal: ordinal_type, 
           out_ordinal: ordinal_type, 
           token: clt$token;
  
        ?? NEWTITLE := 'test_parm_given' ?? 
        ?? EJECT ?? 
  
        PROCEDURE test_parm_given (parm_name: STRING(*); VAR given: BOOLEAN); 
           clp$test_parameter(pvt, parm_name, given, status); 
           IF NOT given THEN 
              osp$set_status_abnormal(tdc_prod_code, 
                 clc$required_parameter_missing, parm_name, status); 
              osp$append_status_parameter(
                 ' ', osc$status_parameter_delimiter, status); 
              source_error(status) 
           IFEND
        PROCEND test_parm_given; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'parm_to_name' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE parm_to_name (parm_name: STRING(*); VAR result: STRING(*);
              VAR result_length: ost$string_size);
           VAR
              given: BOOLEAN, 
              value: clt$value; 
  
           test_parm_given(parm_name, given); 
           IF NOT given THEN 
              result_length := 0 
           ELSE 
              clp$get_value(pvt, parm_name, 1, 1, clc$low, value, status); 
              clp$convert_value_to_string(value, result, result_length, 
                 status); 
              IF NOT status.normal THEN 
                 source_error(status)
              IFEND 
           IFEND
        PROCEND parm_to_name; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'parm_to_integer' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE parm_to_integer (parm_name: STRING(*); VAR result: INTEGER); 
           VAR
              given: BOOLEAN, 
              temp_integer: clt$integer,
              value: clt$value; 
  
           test_parm_given(parm_name, given); 
           IF NOT given THEN 
              result := 0
           ELSE 
              clp$get_value(pvt, parm_name, 1, 1, clc$low, value, status); 
              clp$convert_value_to_integer(value, temp_integer, status);
              IF status.normal THEN 
                 result := temp_integer.int
              ELSE
                 source_error(status)
              IFEND 
           IFEND
        PROCEND parm_to_integer; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'parm_to_boolean' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE parm_to_boolean (parm_name: STRING(*); VAR result: BOOLEAN); 
           VAR
              given: BOOLEAN, 
              value: clt$value; 
  
           test_parm_given(parm_name, given); 
           IF NOT given THEN 
              result := FALSE
           ELSE 
              clp$get_value(pvt, parm_name, 1, 1, clc$low, value, status); 
              clp$convert_value_to_boolean(value, result, status); 
              IF NOT status.normal THEN 
                 source_error(status)
              IFEND 
           IFEND
        PROCEND parm_to_boolean; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'parm_to_string' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE parm_to_string (parm_name: STRING(*);
              VAR result: STRING(*); 
              VAR result_length: ost$string_size);
           { special case: this routine takes a multi-valued parameter, with } 
           {   string, integer, or variable values, and concatenates them } 
           {   into a single result string } 
  
           VAR
              given: BOOLEAN, 
              variable: ^tdl_variable, 
              set_count,
              set_ndx: 0 .. clc$max_value_sets, 
              value: clt$value; 
  
           result_length := 0; 
           test_parm_given(parm_name, given); 
           IF given THEN 
              clp$get_set_count(pvt, parm_name, set_count, status);
              IF NOT status.normal THEN 
                 source_error(status)
              ELSE
                 FOR set_ndx := 1 TO set_count DO
                    clp$get_value(pvt, parm_name, set_ndx, 1, clc$low,
                       value, status); 
                    IF NOT status.normal THEN 
                       source_error(status)
                    ELSE
                       CASE value.typ OF
                          = clc$string_value =
                             IF ( result_length + value.str_length ) >
                                   osc$max_string_size THEN 
                                osp$set_status_abnormal(tdc_prod_code, 
                                   clc$string_overflow, '', status); 
                                source_error(status) 
                             IFEND; 
                             STRINGREP(result, result_length, 
                                result(1,result_length),
                                value.str(1,value.str_length)); 
                          = clc$integer_value =
                             IF result_length >= osc$max_string_size THEN 
                                osp$set_status_abnormal(tdc_prod_code, 
                                   clc$string_overflow, '', status); 
                                source_error(status) 
                             IFEND; 
                             STRINGREP(result, result_length, 
                                result(1,result_length),
                                CHR(value.int.int)); 
                          = clc$name_value =
                             find_variable(value.name, found, variable);
                             IF found THEN 
                                IF ( result_length +
                                        variable^.str_length ) >
                                      osc$max_string_size THEN
                                   osp$set_status_abnormal( 
                                      tdc_prod_code, 
                                      clc$string_overflow, '', status);
                                   source_error(status)
                                IFEND;
                                STRINGREP(result, result_length,
                                   result(1,result_length), 
                                   variable^.value^(1,variable^.str_length)) 
                             ELSE 
                                error_table(not_found_error, 
                                   value.name.str(1,value.name.length))
                             IFEND; 
                          = clc$unknown_value =
                             result := ' ';
                             result_length := 0; 
                          = clc$boolean_value, clc$status_value, 
                            clc$variable_reference =
                             osp$set_status_abnormal(tdc_prod_code,
                                tde_invalid_type, '', status);
                             source_error(status); 
                       CASEND 
                    IFEND 
                 FOREND 
              IFEND 
           IFEND
        PROCEND parm_to_string; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'error_table' ??
        ?? EJECT ?? 
  
        PROCEDURE error_table (error_return: error_type; text: STRING(*));
  
           CASE error_return OF
              = no_room_error =
                 osp$set_status_abnormal(tdc_prod_code, tde_no_room,
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
              = duplicate_error = 
                 osp$set_status_abnormal(tdc_prod_code, tde_duplicate_verb,
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
              = duplicate_input_error =
                 osp$set_status_abnormal(tdc_prod_code, tde_duplicate_input,
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
              = superset_error = 
                 osp$set_status_abnormal(tdc_prod_code, tde_superset, 
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
              = subset_error = 
                 osp$set_status_abnormal(tdc_prod_code, tde_subset, 
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
              = not_found_error =
                 osp$set_status_abnormal(tdc_prod_code, tde_not_found,
                    text, status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
           CASEND;
           source_error(status)
        PROCEND error_table;
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'find_variable' ??
        ?? EJECT ?? 
  
        PROCEDURE find_variable (name: ost$name_descriptor; 
              VAR found: BOOLEAN; VAR variable: ^tdl_variable);
  
           found := FALSE;
           variable := variable_list;
           WHILE ( found = FALSE ) AND 
                 ( variable <> NIL ) DO 
              IF ( variable^.name = name.str(1,name.length) ) AND 
                 ( variable^.value <> NIL ) THEN
                 found := TRUE
              ELSE
                 variable := variable^.next_variable
              IFEND 
           WHILEND
        PROCEND find_variable;
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'search_verb_table' ?? 
        ?? EJECT ?? 
  
        PROCEDURE search_verb_table (str: ost$name; VAR typ: verb_type; 
              VAR in_ordinal: ordinal_type; VAR out_ordinal: ordinal_type; 
              VAR found: BOOLEAN);
           VAR
              verb_ndx: 1 .. max_verb_count + 1;
  
           found := FALSE;
           verb_ndx := 1; 
           WHILE ( verb_ndx <= max_verb_count ) AND ( NOT found ) DO
              IF verb_table[verb_ndx].name = str THEN
                 found := TRUE; 
                 typ := verb_table[verb_ndx].typ;
                 in_ordinal := verb_table[verb_ndx].in_ordinal;
                 out_ordinal := verb_table[verb_ndx].out_ordinal 
              ELSE
                 verb_ndx := verb_ndx + 1
              IFEND 
           WHILEND
        PROCEND search_verb_table; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'process_verb' ??
        ?? EJECT ?? 
  
        PROCEDURE process_verb (typ: verb_type;
              in_ordinal: ordinal_type; out_ordinal: ordinal_type; 
              name: ost$name_descriptor); 
  
           ?? NEWTITLE := 'write_parm' ?? 
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_parm (ordinal: ordinal_type; 
                 flag_ordinal: ordinal_type);
              VAR 
                 result: INTEGER,
                 variable: ^tdl_variable,
                 value: clt$value,
                 bad_name, 
                 found: BOOLEAN,
                 name_ndx, 
                 temp_string_len: ost$string_size, 
                 temp_string: STRING(osc$max_string_size); 
  
              CASE ordinal OF
                 = parm_name_ord =    { model name and length }
                    parm_to_name('VALUE', temp_string, temp_string_len); 
                    IF temp_string_len = 0 THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_name_required, '', status);
                       source_error(status)
                    ELSEIF temp_string_len > 6 THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_name_too_long, '', status); 
                       source_error(status)
                    ELSE
                       bad_name := FALSE; 
                       FOR size_ndx := 1 TO temp_string_len DO 
                          IF NOT (
                             ( ( temp_string(size_ndx) >= '0' ) AND
                               ( temp_string(size_ndx) <= '9' ) ) OR 
                             ( ( temp_string(size_ndx) >= 'A' ) AND
                               ( temp_string(size_ndx) <= 'Z' ) ) OR 
                             ( ( temp_string(size_ndx) >= 'a' ) AND 
                               ( temp_string(size_ndx) <= 'z' ) ) ) THEN
                             bad_name := TRUE 
                          IFEND 
                       FOREND;
                       IF bad_name THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_invalid_name, '', status); 
                          source_error(status) 
                       ELSE 
                          parm_rec.model_name := 
                             temp_string(1,temp_string_len); 
                          parm_rec.model_name_len := temp_string_len 
                       IFEND
                    IFEND;
                 = parm_communications_ord = 
                    clp$get_value(pvt, 'TYPE', 1, 1, clc$low, value, status);
                    IF NOT status.normal THEN 
                       source_error(status)
                    ELSE
                       IF value.typ <> clc$name_value THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_invalid_comm, '', status); 
                          source_error(status) 
                       ELSE 
                          find_variable(value.name, found, variable); 
                          IF found THEN
                             IF ( ORD(variable^.value^(1)) < 0 ) OR
                                ( ORD(variable^.value^(1)) > 
                                   communications_type_max ) THEN
                                osp$set_status_abnormal(tdc_prod_code, 
                                   tde_invalid_comm, '', status); 
                                source_error(status) 
                             ELSE 
                                parm_rec.communications :=
                                   ORD(variable^.value^(1))
                             IFEND
                          ELSE
                             osp$set_status_abnormal(tdc_prod_code,
                                tde_invalid_comm, '', status);
                             source_error(status)
                          IFEND 
                       IFEND
                    IFEND;
                 = parm_cursor_encoding_ord =
                    clp$get_value(pvt, 'TYPE', 1, 1, clc$low, value, status);
                    IF NOT status.normal THEN 
                       source_error(status)
                    ELSE
                       IF value.typ <> clc$name_value THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_invalid_cursor, '', status); 
                          source_error(status) 
                       ELSE 
                          find_variable(value.name, found, variable); 
                          IF found THEN
                             IF ( ORD(variable^.value^(1)) < 0 ) OR
                                ( ORD(variable^.value^(1)) > 
                                   cursor_encoding_max ) THEN
                                osp$set_status_abnormal(tdc_prod_code, 
                                   tde_invalid_cursor, '', status); 
                                source_error(status) 
                             ELSE 
                                parm_rec.cursor_encoding := 
                                   ORD(variable^.value^(1))
                             IFEND
                          ELSE
                             osp$set_status_abnormal(tdc_prod_code,
                                tde_invalid_cursor, '', status);
                             source_error(status)
                          IFEND 
                       IFEND
                    IFEND;
                    parm_to_integer('BIAS', result); 
                    IF ( result < LOWERVALUE(parm_rec.cursor_bias) ) OR
                       ( result > UPPERVALUE(parm_rec.cursor_bias) ) THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_bias_out_of_range, '', status);
                       source_error(status)
                    ELSE
                       parm_rec.cursor_bias := result 
                    IFEND;
                 = parm_flags_ord =   { boolean flags } 
                    parm_to_boolean('VALUE', parm_rec.flag[flag_ordinal]); 
                 = parm_size_ord =    { screen sizes }
                    size_ndx := 0;
                    WHILE ( size_ndx <= screen_size_max ) AND 
                          ( ( parm_rec.size[size_ndx].cols <> 0 ) OR
                            ( parm_rec.size[size_ndx].rows <> 0 ) ) DO
                       size_ndx := size_ndx + 1
                    WHILEND;
                    IF size_ndx > screen_size_max THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_screen_size_overflow, '', status); 
                       source_error(status)
                    ELSE
                       parm_to_integer('ROWS', junk_len); 
                       IF ( junk_len < 0 ) OR ( junk_len > size_row_max ) THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_screen_row_overflow, '', status);
                          source_error(status) 
                       ELSE 
                          parm_rec.size[size_ndx].rows := junk_len
                       IFEND; 
                       parm_to_integer('COLUMNS', junk_len);
                       IF ( junk_len < 0 ) OR ( junk_len > size_col_max ) THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_screen_col_overflow, '', status);
                          source_error(status) 
                       ELSE 
                          parm_rec.size[size_ndx].cols := junk_len
                       IFEND; 
                       test_parm_given('OUT', found); { write_out isn't picky }
                       IF found THEN 
                          write_out(size_output_ord + size_ndx) 
                       IFEND
                    IFEND;
                 = parm_cursor_behavior_ord =
                    clp$get_value(pvt, 'TYPE', 1, 1, clc$low, value, status);
                    IF NOT status.normal THEN 
                       source_error(status)
                    ELSE
                       IF value.typ <> clc$name_value THEN
                          osp$set_status_abnormal(tdc_prod_code, 
                             tde_invalid_cursor_behavior, '', status);
                          source_error(status) 
                       ELSE 
                          find_variable(value.name, found, variable); 
                          IF found THEN
                             IF ( ORD(variable^.value^(1)) < 0 ) OR
                                ( ORD(variable^.value^(1)) > 
                                   cursor_behavior_max ) THEN
                                osp$set_status_abnormal(tdc_prod_code, 
                                   tde_invalid_cursor_behavior, '', status);
                                source_error(status) 
                             ELSE 
                                parm_rec.cursor_behavior[flag_ordinal] :=
                                   ORD(variable^.value^(1))
                             IFEND
                          ELSE
                             osp$set_status_abnormal(tdc_prod_code,
                                tde_invalid_cursor_behavior, '', status); 
                             source_error(status)
                          IFEND 
                       IFEND
                    IFEND;
                 = parm_cursor_pos_column_flag_ord = { column/row first } 
                    parm_to_boolean('VALUE', parm_rec.cursor_pos_column_flag); 
                 = parm_cursor_pos_length_ord = { # chars per each x/y value } 
                    parm_to_integer('VALUE', result);
                    IF ( result < 0 ) OR
                       ( result > UPPERVALUE( 
                          parm_rec.cursor_pos_length[flag_ordinal]) ) THEN 
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_cursor_len_out_of_range, '', status); 
                       source_error(status)
                    ELSE
                       parm_rec.cursor_pos_length[flag_ordinal] := result 
                    IFEND;
                 = parm_function_key_mark_ord = { # chars of blotch leftover } 
                    parm_to_integer('VALUE', result);
                    IF ( result < 0 ) OR
                       ( result > UPPERVALUE( 
                          parm_rec.function_key_mark) ) THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_function_key_mark_range, '', status);
                       source_error(status)
                    ELSE
                       parm_rec.function_key_mark := result
                    IFEND;
              CASEND
           PROCEND write_parm; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_in' ?? 
           ?? EJECT ??
  
           PROCEDURE write_in (ordinal: ordinal_type);
              VAR 
                 in_given, 
                 inout_given, 
                 label_given: BOOLEAN, 
                 label_len: ost$string_size,
                 label_name: ost$name, 
                 string_len: ost$string_size,
                 input_string: STRING(osc$max_string_size); 
  
              clp$test_parameter(pvt, 'LABEL', label_given, status); 
              IF label_given THEN 
                 parm_to_name('LABEL', label_name, label_len); 
                 store_key_name_node(ordinal, label_len, label_name,
                    error_return); 
                 IF error_return <> no_error THEN 
                    error_table(error_return, label_name) 
                 IFEND
              IFEND;
              clp$test_parameter(pvt, 'IN', in_given, status);
              clp$test_parameter(pvt, 'INOUT', inout_given, status); 
              IF in_given AND inout_given THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_duplicate_in_inout, '', status); 
                 source_error(status)
              IFEND;
              IF in_given THEN 
                 parm_to_string('IN', input_string, string_len) 
              ELSEIF inout_given THEN 
                 parm_to_string('INOUT', input_string, string_len)
              ELSE
                 RETURN               { no major objection if unspecified }
              IFEND;
              store_input_node(ordinal, string_len, input_string,
                 error_return);
              IF error_return <> no_error THEN
                 error_table(error_return, name.str(1,name.length)) 
              IFEND 
           PROCEND write_in; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_out' ?? 
           ?? EJECT ??
  
           PROCEDURE write_out (ordinal: ordinal_type);
              VAR 
                 out_given, 
                 inout_given: BOOLEAN, 
                 string_len: ost$string_size,
                 output_string: STRING(osc$max_string_size); 
  
              clp$test_parameter(pvt, 'OUT', out_given, status); 
              clp$test_parameter(pvt, 'INOUT', inout_given, status); 
              IF out_given AND inout_given THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_duplicate_out_inout, '', status); 
                 source_error(status)
              IFEND;
              IF out_given THEN 
                 parm_to_string('OUT', output_string, string_len)
              ELSEIF inout_given THEN 
                 parm_to_string('INOUT', output_string, string_len)
              ELSE
                 RETURN               { no major objection if unspecified }
              IFEND;
              store_output_node(ordinal, string_len, output_string,
                 error_return);
              IF error_return <> no_error THEN
                 error_table(error_return, name.str(1,name.length)) 
              IFEND 
           PROCEND write_out; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_init' ?? 
           ?? EJECT ??
  
           PROCEDURE write_init (ordinal: ordinal_type);
              VAR 
                 out_given: BOOLEAN, 
                 string_len: ost$string_size,
                 output_string: STRING(osc$max_string_size); 
  
              clp$test_parameter(pvt, 'OUT', out_given, status); 
              IF out_given THEN 
                 parm_to_string('OUT', output_string, string_len); 
                 store_reset_sequence(ordinal, string_len, output_string, 
                    error_return); 
                 IF error_return <> no_error THEN 
                    error_table(error_return, name.str(1,name.length))
                 IFEND
              IFEND 
           PROCEND write_init; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_appstr' ?? 
           ?? EJECT ??
  
           PROCEDURE write_appstr; 
              VAR 
                 char_ndx: INTEGER, 
                 string_len: ost$string_size,
                 output_string: STRING(osc$max_string_size), 
                 name_len: ost$string_size,
                 name: ost$name;
  
              parm_to_name('NAME', name, name_len);
              IF (name_len < 1) OR (name_len > 7) THEN
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_appstr_name_too_long, '', status);
                 source_error(status)
              IFEND;
              FOR char_ndx := 1 to name_len DO { test for validity in C-63 }
                 IF utv$convert_ascii_to_ascii64[name(char_ndx)] = 0 THEN
                    osp$set_status_abnormal(tdc_prod_code, 
                       tde_invalid_appstr_name, name(1,name_len), status); 
                    osp$append_status_parameter(
                       ' ', osc$status_parameter_delimiter, status); 
                    source_error(status) 
                 IFEND
              FOREND; 
              parm_to_string('OUT', output_string, string_len);
              store_appstr_node(name(1,name_len), string_len, output_string, 
                 error_return);
              IF error_return <> no_error THEN
                 error_table(error_return, name(1,name_len))
              IFEND 
           PROCEND write_appstr; 
           ?? OLDTITLE ?? 
           ?? EJECT ??
  
           CASE typ OF 
              = v_parm = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^parm_pdt, pvt, status); 
                 IF status.normal THEN
                    write_parm(in_ordinal, out_ordinal) 
                 ELSE 
                    source_error(status) 
                 IFEND; 
              = v_in = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^in_pdt, pvt, status); 
                 IF status.normal THEN
                    write_in(in_ordinal)
                 ELSE 
                    source_error(status) 
                 IFEND; 
              = v_out = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^out_pdt, pvt, status); 
                 IF status.normal THEN
                    write_out(out_ordinal)
                 ELSE 
                    source_error(status) 
                 IFEND; 
              = v_inout = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^inout_pdt, pvt, status); 
                 IF status.normal THEN
                    write_in(in_ordinal); 
                    write_out(out_ordinal)
                 ELSE 
                    source_error(status) 
                 IFEND; 
              = v_init = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^init_pdt, pvt, status); 
                 IF status.normal THEN
                    write_init(out_ordinal)
                 ELSE 
                    source_error(status) 
                 IFEND; 
              = v_appstr = 
                 clp$scan_parameter_list(source_string, source_index,
                    ^appstr_pdt, pvt, status); 
                 IF status.normal THEN
                    write_appstr 
                 ELSE 
                    source_error(status) 
                 IFEND; 
           CASEND;
           clp$free_parameter_value_table(pvt) 
        PROCEND process_verb;
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'process_variable' ??
        ?? EJECT ?? 
  
        PROCEDURE process_variable (name: ost$name_descriptor);
           VAR
              found: BOOLEAN, 
              error_return: error_type,
              variable: ^tdl_variable; 
  
           ?? NEWTITLE := 'parse_variable_assignment' ??
           ?? SKIP := 4 ?? 
  
           PROCEDURE parse_variable_assignment (VAR variable: ^tdl_variable;
                 VAR error_return: error_type);
              VAR 
                 variable_reference: ^tdl_variable, 
                 token: clt$token,
                 found: BOOLEAN,
                 new_str_length,
                 value_length: INTEGER, 
                 new_str, 
                 value_string: STRING(osc$max_string_size); 
  
              old_index := source_index;
              clp$scan_token(clc$not_in_expression, source_string,
                 source_index, token, status);
              IF NOT status.normal THEN 
                 source_index := old_index; { point to offending token } 
                 source_error(status); 
                 error_return := not_found_error;
                 RETURN 
              IFEND;
              IF token.typ <> clc$assign_token THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_invalid_verb_variable, '', status); 
                 source_index := old_index; { point to offending token } 
                 source_error(status); 
                 error_return := not_found_error;
                 RETURN 
              IFEND;
              value_length := 0;
              REPEAT
                 new_str_length := 0;
                 old_index := source_index; 
                 clp$scan_token(clc$not_in_expression, source_string, 
                    source_index, token, status); 
                 IF NOT status.normal THEN
                    source_index := old_index; { point to offending token }
                    source_error(status);
                    error_return := not_found_error; 
                    RETURN
                 IFEND; 
                 IF token.typ = clc$name_token THEN 
                    find_variable(token.name, found, variable_reference);
                    IF NOT found THEN
                       error_return := not_found_error;
                       error_table(error_return, 
                          token.name.str(1,token.name.length));
                       RETURN 
                    IFEND;
                    new_str := variable_reference^.value^; 
                    new_str_length := variable_reference^.str_length
                 ELSEIF token.typ = clc$string_token THEN 
                    new_str := token.str;
                    new_str_length := token.str_length 
                 ELSEIF token.typ = clc$integer_token THEN 
                    IF ( token.int.int < 0 ) OR
                       ( token.int.int > 127 ) THEN
                       osp$set_status_abnormal(tdc_prod_code,
                          tde_invalid_character, '', status);
                       source_error(status)
                    ELSE
                       new_str(1) := CHR(token.int.int);
                       new_str_length := 1 
                    IFEND 
                 ELSEIF ( token.typ <> clc$cat_token ) AND 
                        ( token.typ <> clc$lparen_token ) AND 
                        ( token.typ <> clc$rparen_token ) AND 
                        ( token.typ <> clc$eos_token ) THEN
                    osp$set_status_abnormal(tdc_prod_code, clc$invalid,
                       token.str(1,token.str_length), status);
                    osp$append_status_parameter(
                       ' ', osc$status_parameter_delimiter, status); 
                    source_index := old_index; { point to offending token }
                    source_error(status);
                    error_return := not_found_error; 
                    RETURN
                 IFEND; 
                 IF ( value_length + new_str_length ) >
                       osc$max_string_size THEN 
                    osp$set_status_abnormal(tdc_prod_code, 
                       clc$string_overflow, '', status); 
                    source_index := old_index; { point to offending token }
                    source_error(status);
                    error_return := no_room_error; 
                    RETURN
                 IFEND; 
                 IF new_str_length > 0 THEN 
                    STRINGREP(value_string, value_length, 
                       value_string(1,value_length),
                       new_str(1,new_str_length)) 
                 IFEND
              UNTIL source_index > source_length;
              assign_value_to_variable(value_string, value_length, 
                 variable, error_return) 
           PROCEND parse_variable_assignment;
           ?? OLDTITLE ?? 
           ?? EJECT ??
  
           find_variable(name, found, variable); 
           IF found THEN 
              parse_variable_assignment(variable, error_return) 
           ELSE 
              add_variable_to_symbol_table(name, variable, error_return);
              IF error_return = no_error THEN 
                 parse_variable_assignment(variable, error_return)
              IFEND 
           IFEND
        PROCEND process_variable;
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'check_and_process_statement' ??
        ?? EJECT ?? 
  
        PROCEDURE check_and_process_statement;
              IF token.typ <> clc$name_token THEN 
                 CASE token.typ OF
                    = clc$unknown_token .. clc$string_token =
                       junk_string := token.str(1,token.str_length); 
                       junk_len := token.str_length;
                    = clc$boolean_token =
                       junk_string := '';
                       STRINGREP(junk_string, junk_len, token.bool);
                    = clc$integer_token =
                       junk_string := 'INTEGER'; 
                       junk_len := 7; 
                 CASEND;
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_expecting_verb_variable, junk_string(1,junk_len),
                    status);
                 osp$append_status_parameter( 
                    ' ', osc$status_parameter_delimiter, status);
                 source_error(status)
              ELSE
                 search_verb_table(token.name.str(1,token.name.length), 
                    verb_typ, in_ordinal, out_ordinal, found); 
                 IF found THEN 
                    process_verb(verb_typ, in_ordinal, out_ordinal,
                       token.name);
                 ELSE 
                    process_variable(token.name)
                 IFEND
              IFEND 
        PROCEND check_and_process_statement;
  
        ?? EJECT ?? 
  
        empty_file := TRUE; 
        parm_rec.model_name := ' ';
        parm_rec.model_name_len := 0; 
        parm_rec.communications := asynch_comm; 
        parm_rec.cursor_encoding := invalid_cursor;
        parm_rec.cursor_bias := 0;
        FOR parm_ndx := 0 TO parm_flag_max DO
           parm_rec.flag[parm_ndx] := FALSE
        FOREND; 
        FOR parm_ndx := 0 TO screen_size_max DO
           parm_rec.size[parm_ndx].cols := 0;
           parm_rec.size[parm_ndx].rows := 0 
        FOREND; 
        FOR parm_ndx := 0 TO cursor_behavior_max DO
           parm_rec.cursor_behavior[parm_ndx] := -1
        FOREND; 
        parm_rec.cursor_pos_column_flag := FALSE;
        FOR parm_ndx := 0 TO 1 DO 
           parm_rec.cursor_pos_length[parm_ndx] := 0
        FOREND; 
  
        read_line(eof_flag); 
        WHILE NOT eof_flag DO
           source_string := line_buffer; 
           source_length := line_length; 
           source_index := 1; 
           WHILE source_index <= source_length DO { pre-scan for continuations} 
              REPEAT
                 old_index := source_index; 
                 clp$scan_token(clc$not_in_expression, source_string, 
                    source_index, token, status); 
                 IF NOT status.normal THEN
                    source_index := old_index; { point to offending token }
                    source_error(status);
                    source_index := source_length + 1 { stop scanning now }
                 IFEND
              UNTIL ( source_index > source_length ) OR
                    ( token.typ = clc$ellipsis_token ); 
              IF status.normal AND
                 ( token.typ = clc$ellipsis_token ) THEN
                 read_line(eof_flag);
                 IF ( old_index + line_length ) > osc$max_string_size THEN
                    osp$set_status_abnormal(tdc_prod_code, 
                       tde_continuation_overflow, '', status); 
                    source_error(status) 
                 ELSE 
                    STRINGREP(source_string, source_length, 
                       source_string(1,old_index-1),
                       line_buffer(1,line_length)); 
                    source_index := old_index 
                 IFEND
              IFEND 
           WHILEND; 
           source_index := 1; 
           clp$scan_token(clc$not_in_expression, source_string, 
              source_index, token, status); 
           IF status.normal AND       { error reported during pre-scan }
              ( source_index <= source_length ) THEN 
              empty_file := FALSE;    { found something } 
              check_and_process_statement 
           IFEND; 
           read_line(eof_flag);
        WHILEND;
  
        store_parameters(parm_rec)
     PROCEND analyze_lines; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'global_edits' ?? 
     ?? EJECT ??
  
     PROCEDURE global_edits; 
        VAR 
           behavior_ndx: 0 .. cursor_behavior_max; 
  
        IF empty_file THEN 
           osp$set_status_abnormal(tdc_prod_code, tde_empty_file,
              '', status);
           error_status(status)
        ELSE
           IF parm_rec.model_name_len = 0 THEN 
              osp$set_status_abnormal(tdc_prod_code, 
                 clc$required_parameter_missing, 
                 verb_table[parm_name_verb].name, status); 
              osp$append_status_parameter(
                 ' ', osc$status_parameter_delimiter, status); 
              error_status(status) 
           IFEND; 
           IF parm_rec.cursor_encoding = invalid_cursor THEN
              osp$set_status_abnormal(tdc_prod_code, 
                 clc$required_parameter_missing, 
                 verb_table[parm_cursor_encoding_verb].name, status);
              osp$append_status_parameter(
                 ' ', osc$status_parameter_delimiter, status); 
              error_status(status) 
           IFEND; 
           IF parm_rec.cursor_encoding = binary_cursor THEN
              junk_len := 0; 
              size_ndx := 0; 
              WHILE ( size_ndx <= screen_size_max ) AND 
                    ( parm_rec.size[size_ndx].cols <> 0 ) AND 
                    ( parm_rec.size[size_ndx].rows <> 0 ) DO
                 IF junk_len < parm_rec.size[size_ndx].cols THEN 
                    junk_len := parm_rec.size[size_ndx].cols 
                 IFEND; 
                 size_ndx := size_ndx + 1 
              WHILEND;
              IF junk_len + parm_rec.cursor_bias > binary_col_max THEN
                 osp$set_status_abnormal(tdc_prod_code,
                    clc$value_out_of_range, 
                    verb_table[parm_set_size_verb].name, status); 
                 osp$append_status_parameter( ' ',
                    osc$status_parameter_delimiter, status); 
                 error_status(status)
              IFEND 
           IFEND; 
           FOR behavior_ndx := 0 TO cursor_behavior_max DO 
              IF parm_rec.cursor_behavior[behavior_ndx] < 0 THEN
                 IF behavior_ndx < cursor_behavior_div THEN 
                   osp$set_status_abnormal(tdc_prod_code,
                      clc$required_parameter_missing,
                      verb_table[parm_cursor_behavior_verb + behavior_ndx].name,
                      status);
                   osp$append_status_parameter( 
                      ' ', osc$status_parameter_delimiter, status);
                   error_status(status)
                 IFEND
              IFEND 
  
           FOREND 
        IFEND 
     PROCEND global_edits; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'close_input_file' ??
     ?? EJECT ??
  
     PROCEDURE close_input_file;
        close_file(input_file_sel);
     PROCEND close_input_file;
     ?? OLDTITLE ?? 
     ?? EJECT ??
  
     initialize_parsing_tables;
     open_input_file;
     analyze_lines; 
     global_edits; 
     close_input_file;
  
  PROCEND read_tdl_statements; 
  ?? OLDTITLE ??
  
MODEND tduin;
--EOR--    
TDUOUT
ASCII 
*NOSEQ
*WIDTH 95 
MODULE tduout;
  
?? SET ( CHKALL := ON ), RIGHT := 110 ??
  
{  Module :  TDUOUT } 
{            Copyright Control Data Systems Inc.  1992.  } 
{  Written:  1/84 by R. Lindsey  } 
{  Version:  Cyber 170, version 1 } 
{  Purpose:  This is the output portion of the TDU program.  }
  
  ?? PUSH ( LIST := OFF ) ??          { uncomment this line to suppress list }
{ ?? PUSH ( LIST := ON ) ??           { uncomment this line to list }
  
?? NEWTITLE := 'Utilities' ??
  
{ integer to string conversion, ascii to ascii-64 conversion } 
*CALLC ZUTPI2S
*CALL ZUTVCTT 
  
?? OLDTITLE ??
?? NEWTITLE := 'ZTDTTAB' ??
?? SKIP := 4 ??
  
{ **************************** }
{ common deck ZTDTTAB follows: }
*CALL ZTDTTAB 
  
?? OLDTITLE ??
?? NEWTITLE := 'tdu XREF''s, etc.' ?? 
?? EJECT ?? 
  
{ ***************** } 
{ tdu file handler: }
*CALL ZTDPFIL 
  
{ ********************** }
{ error handling routine }
*CALL ZTDPERR 
  
{ ****************************** }
{ table-handling dump procedures } 
*CALLC ZTDPTBD
  
  ?? EJECT ?? 
  ?? POP ?? 
  
  CONST 
     target_wordsize = 60,            { word size of target machine (170) }
     target_char_size = 7;            { bit size of each character }
  
  VAR 
     tdu_version_num: [XREF] INTEGER,  { from main program } 
  
     word_number: INTEGER := -1,      { pre-decremented word counter } 
     bits_left_in_word: INTEGER := 0, { bits remaining in word, start empty }
  
     stringrep_len: INTEGER,          { used by all STRINGREP calls }
  
     parm_record: parameter_record,   { terminal non-I/O parameters }
     in_node: ^input_node,            { input table item } 
     status: ost$status,
  
     outrec: PACKED RECORD            { output buffer }
        CASE line_type: (whole_line, opcode_line, comment_line) OF 
           = whole_line =             { for output--write the whole line } 
              line_buffer: STRING(72), 
           = opcode_line =            { for 'regular' opcode/param lines }
              filler1: STRING(1),     { CHAR won't work here } 
              label: STRING(9),       { column 2 }
              opcode: STRING(7),      { column 11 }
              parameters: STRING(20), { column 18, need lots of room here }
              comment: STRING(35),    { column 38, non-standard, oh well } 
           = comment_line =           { for full-line comments }
              comment_indicator: STRING(6), { col. 1 '*' + filler } 
              comment_text: STRING(66), { column 7, not to line up w/opcode } 
        CASEND, 
     RECEND;
  
  {  Subtable labels table }
  
  CONST 
     subtable_count = 5,              { number of subtables defined }
     subtable_input = 1, 
     subtable_names = 2, 
     subtable_init = 3, 
     subtable_appstr = 4, 
     subtable_end = 5; 
  
  VAR 
     subtable_index: INTEGER, 
     subtable_list: [STATIC] PACKED ARRAY [1..subtable_count] OF PACKED RECORD
        label: STRING(8),             { the label itself }
        label_len: 0 .. 8,            { significant length of label }
     RECEND 
        := [  ['INPUT', 5],
              ['NAMES', 5], 
              ['INIT', 4],
              ['APPSTR', 6],
              ['ENDTABL', 7] ]; 
  
  ?? NEWTITLE := 'write_tables' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] write_tables;      { this is called to write entire table } 
  
     ?? NEWTITLE := 'write_line' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE write_line; 
        put_file(output_file_sel, outrec.line_buffer);
     PROCEND write_line; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_opcode_line' ??
     ?? SKIP := 4 ?? 
  
     PROCEDURE write_opcode_line;
        outrec.line_type := whole_line; 
        write_line;
        outrec.line_type := opcode_line; 
        outrec.label := '';           { never want to save a label } 
     PROCEND write_opcode_line;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_comment' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE write_comment; 
        outrec.comment_indicator := '*'; 
        outrec.line_type := whole_line; 
        write_line;
        outrec.line_buffer := '';     { always return a blank line } 
        outrec.line_type := comment_line; 
     PROCEND write_comment; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_vfd' ?? 
     ?? EJECT ??
  
     PROCEDURE write_vfd(bit_length, field_value: INTEGER; commnt: STRING(*)); 
        VAR 
           temp_string, 
           bit_length_string,
           field_value_string: STRING(4),
           bit_l_s_length, 
           field_v_s_length: ost$string_length; { subrange for string size }
  
        outrec.opcode := 'VFD';
        utp$convert_integer_to_string(bit_length_string, bit_l_s_length, 
           bit_length, 10);
        utp$convert_integer_to_string(field_value_string, field_v_s_length, 
           field_value, 10);
{       IF field_value = (-0) THEN 
{          STRINGREP(temp_string, field_v_s_length, 
{             '-', field_value_string(1,field_v_s_length)); 
{          field_value_string := temp_string
{       IFEND; 
        outrec.parameters := ''; 
        STRINGREP(outrec.parameters, stringrep_len, 
           bit_length_string(1,bit_l_s_length), 
           '/': 1, 
           field_value_string(1,field_v_s_length));
        outrec.comment := commnt; 
        write_opcode_line; 
        outrec.comment := ''; 
        bits_left_in_word := bits_left_in_word - bit_length;
     PROCEND write_vfd; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'start_word_output' ??
     ?? EJECT ??
  
     PROCEDURE start_word_output;
        VAR 
           integer_string: STRING(6), 
           i_s_length: ost$string_length; { subrange of integer, str-len } 
  
        IF bits_left_in_word < target_wordsize THEN { only if not already word} 
           word_number := word_number + 1; 
           bits_left_in_word := target_wordsize; 
           outrec.line_type := comment_line;
           outrec.comment_text := ''; 
           utp$convert_integer_to_string(integer_string, i_s_length,
              word_number, 8);        { STRINGREP can't do octal (!) } 
           STRINGREP(outrec.comment_text, stringrep_len, 'WORD ': 5,
              integer_string: i_s_length);
           write_comment; 
        IFEND;
     PROCEND start_word_output;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_ordinals' ?? 
     ?? EJECT ??
  
     PROCEDURE write_ordinals (dump_procedure: dump_procedure_type);
        VAR 
           ordinal_ndx: INTEGER, 
           length: INTEGER,
           chars: ^STRING(*),
           total_characters, 
           total_ordinals: INTEGER, 
           node_returned: BOOLEAN, 
           bit_count, 
           word_count, 
           remainder,
           remainder_chars, 
           filler_bits, 
           char_offset: INTEGER, 
           integer_string: STRING(6), 
           i_s_length: ost$string_length, { subrange of integer, str-len } 
           comment: STRING(30); 
  
        dump_procedure^(0, length, chars, total_ordinals, total_characters,
           node_returned);
        bit_count := ( ( total_ordinals + 2 ) * 12 ); 
        word_count := bit_count DIV 60; 
        remainder := 60 - ( bit_count MOD 60 ); 
        char_offset := ( word_count * 8 ) + 8 - ( remainder DIV 7 ); 
        ordinal_ndx := 0;
        REPEAT
           dump_procedure^(ordinal_ndx, length, chars, 
              total_ordinals, total_characters, node_returned); 
           IF node_returned THEN
              IF bits_left_in_word < 12 THEN
                 start_word_output 
              IFEND;
              outrec.line_type := opcode_line; 
              comment := '';
              utp$convert_integer_to_string(integer_string, i_s_length, 
                    ordinal_ndx, 10); { ordinal in string format } 
              STRINGREP(comment, stringrep_len,
                    'ORDINAL ': 8, integer_string: i_s_length);
              write_vfd(12, char_offset, comment); 
              char_offset := char_offset + length; 
              ordinal_ndx := ordinal_ndx + 1 
           IFEND
        UNTIL NOT node_returned;
        IF bits_left_in_word < 12 THEN
           start_word_output 
        IFEND;
        outrec.line_type := opcode_line; 
        write_vfd(12, char_offset, 'END OF ORDINALS');
        IF bits_left_in_word > 0 THEN 
           remainder_chars := remainder DIV 7;
           filler_bits := remainder - ( remainder_chars * 7 );
           write_vfd(filler_bits, 0, 'FILLER')
        IFEND 
     PROCEND write_ordinals; 
  
     ?? OLDTITLE ?? 
     ?? NEWTITLE := 'write_char_sequences' ??
     ?? EJECT ??
  
     PROCEDURE write_char_sequences (dump_procedure: dump_procedure_type); 
        VAR 
           ordinal_ndx: INTEGER, 
           length: INTEGER,
           chars: ^STRING(*),
           total_characters, 
           total_ordinals: INTEGER, 
           node_returned: BOOLEAN, 
           integer_string: STRING(6), 
           i_s_length: ost$string_length, { subrange of integer, str-len } 
           char_ndx: INTEGER, 
           comment: STRING(30); 
  
        ordinal_ndx := 0;
        REPEAT
           dump_procedure^(ordinal_ndx, length, chars, 
              total_ordinals, total_characters, node_returned); 
           IF node_returned THEN
              IF bits_left_in_word = target_wordsize THEN { first word only }
                 write_vfd(4, 0, 'FILLER'); 
              IFEND;
              comment := '';
              utp$convert_integer_to_string(integer_string, i_s_length, 
                 ordinal_ndx, 10);    { ordinal in string format } 
              STRINGREP(comment, stringrep_len,
                 'ORDINAL ': 8, integer_string: i_s_length); 
              outrec.line_type := opcode_line; 
              FOR char_ndx := 1 TO length DO
                 IF bits_left_in_word < target_char_size THEN 
                    start_word_output; 
                    outrec.line_type := opcode_line; 
                    write_vfd(4, 0, 'FILLER') 
                 IFEND; 
                 write_vfd(target_char_size,
                    ORD(chars^(char_ndx)), comment);
                 comment := ''
              FOREND; 
              ordinal_ndx := ordinal_ndx + 1 
           IFEND
        UNTIL NOT node_returned;
        IF ( bits_left_in_word > 0 ) AND
           ( bits_left_in_word < target_wordsize ) THEN 
           outrec.line_type := opcode_line;
           write_vfd(bits_left_in_word, 0, 'FILLER')
        IFEND 
     PROCEND write_char_sequences;
  
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_tab_protect_parms' ?? 
     ?? EJECT ??
  
     PROCEDURE write_tab_protect_parms; 
        VAR 
           resv_ndx: INTEGER, 
           loop_ndx: INTEGER, 
           parm_ndx: INTEGER; 
        loop_ndx := (cursor_behavior_div + 1); 
  
        FOR parm_ndx := loop_ndx TO cursor_behavior_max DO
           IF (ORD(parm_record.cursor_behavior[parm_ndx]) = -1) THEN 
             write_vfd(4, 0, 'CURSOR BEHAVIOR');
           ELSE 
             write_vfd(4, ORD(parm_record.cursor_behavior[parm_ndx]),
                'CURSOR BEHAVIOR'); 
           IFEND; 
        FOREND; 
  
        resv_ndx := 4 * ((cursor_behavior_max - cursor_behavior_div)- 1); 
        write_vfd(resv_ndx, 0, 'RESERVED');
  
     PROCEND write_tab_protect_parms; 
  
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_header' ?? 
     ?? EJECT ??
  
     PROCEDURE write_header; 
        VAR 
           junk_name: STRING(7), 
           junk_len: INTEGER; 
  
        dump_parameters(parm_record); 
        junk_name := ' ';             { concatenate 'Z' to start of name } 
        STRINGREP(junk_name, junk_len, 'Z', { to ensure a valid NOS name } 
           parm_record.model_name(1,parm_record.model_name_len));
        parm_record.model_name := junk_name;
        parm_record.model_name_len := junk_len; 
  
        outrec.line_type := opcode_line; 
        outrec.label := ''; 
        outrec.comment := ''; 
        outrec.opcode := 'IDENT';
        outrec.parameters := parm_record.model_name;
        write_opcode_line; 
        outrec.opcode := 'LCC';
        outrec.parameters := 'GROUP(VIRTERM)'; 
        write_opcode_line; 
        outrec.parameters := ''; 
        STRINGREP(outrec.parameters,stringrep_len, 'CAPSULE(':8, 
           parm_record.model_name(1,parm_record.model_name_len), 
           ')':1 );
        write_opcode_line; 
        outrec.opcode := 'ENTRY';
        outrec.parameters := parm_record.model_name;
        write_opcode_line; 
        start_word_output; 
        outrec.line_type := opcode_line; 
        outrec.label := parm_record.model_name;
        outrec.opcode := 'BSS';
        outrec.parameters := '0';
        write_opcode_line; 
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'HEADER';
        write_comment;
        write_comment;
        outrec.line_type := opcode_line; 
        outrec.opcode := 'VFD';
        outrec.parameters := ''; 
        STRINGREP(outrec.parameters, stringrep_len, 
           '42/0L': 5, 
           parm_record.model_name(2,6)); { without leading 'Z' } 
        write_opcode_line; 
        bits_left_in_word := bits_left_in_word - 42; 
        write_vfd(18, tdu_version_num, 'VERSION NUMBER') 
     PROCEND write_header; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_sub_table_pointers' ?? 
     ?? EJECT ??
  
     PROCEDURE write_sub_table_pointers; 
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'SUB-TABLE POINTERS';
        write_comment;
        write_comment;                { comment_text was automatically blanked} 
        start_word_output; 
        FOR subtable_index := 1 TO subtable_count DO 
           IF bits_left_in_word < 12 THEN 
              start_word_output; 
           IFEND; 
           outrec.line_type := opcode_line;
           outrec.opcode := 'VFD'; 
           outrec.parameters := '';
           STRINGREP(outrec.parameters, stringrep_len,
              '12/',
              subtable_list[subtable_index].label: 
                 subtable_list[subtable_index].label_len,
              '-',
              parm_record.model_name(1,parm_record.model_name_len)); 
           write_opcode_line;
           bits_left_in_word := bits_left_in_word - 12;
        FOREND; 
        outrec.line_type := opcode_line; 
        IF bits_left_in_word > 0 THEN { make explicit filler }
           write_vfd(bits_left_in_word, 0, 'RESERVED'); 
        IFEND;
        start_word_output; 
        outrec.line_type := opcode_line; 
     {  write_vfd(target_wordsize, 0, 'RESERVED') } 
        write_tab_protect_parms;
     PROCEND write_sub_table_pointers; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_parameters' ?? 
     ?? EJECT ??
  
     PROCEDURE write_parameters; 
        VAR 
           parm_ndx: INTEGER; 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'PARAMETERS';
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        write_vfd(6, parm_record.cursor_encoding, 
           'CURSOR ADDRESSING TYPE'); 
        write_vfd(8, parm_record.cursor_bias, 'CURSOR ADDRESSING BIAS');
  
      { FOR parm_ndx := 0 TO cursor_behavior_max DO }
        FOR parm_ndx := 0 TO cursor_behavior_div DO
           write_vfd(4, ORD(parm_record.cursor_behavior[parm_ndx]),
              'CURSOR BEHAVIOR'); 
        FOREND; 
  
        write_vfd(1, ORD(parm_record.cursor_pos_column_flag),
           'COLUMNS BEFORE ROWS FLAG'); 
        FOR parm_ndx := 0 TO 1 DO 
           write_vfd(3, parm_record.cursor_pos_length[parm_ndx],
              'NUMBER OF DIGITS IN CURSOR POSITION'); 
        FOREND; 
        write_vfd(bits_left_in_word, 0, 'RESERVED');
  
        start_word_output; 
        outrec.line_type := opcode_line; 
        FOR parm_ndx := 0 TO parm_flag_max DO
           write_vfd(1, ORD(parm_record.flag[parm_ndx]), 'FLAG');
        FOREND; 
        write_vfd(3, parm_record.function_key_mark, 'FUNCTION KEY MARK') 
     PROCEND write_parameters; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_size_table' ??
     ?? EJECT ??
  
     PROCEDURE write_size_table;
        VAR 
           size_ndx: INTEGER; 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'SCREEN SIZES';
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        FOR size_ndx := 0 TO 3 DO 
           write_vfd(8, parm_record.size[size_ndx].cols, 'X SIZE (COLUMNS)');
           write_vfd(7, parm_record.size[size_ndx].rows, 'Y SIZE (ROWS)')
        FOREND
     PROCEND write_size_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_subtable_start' ??
     ?? EJECT ??
  
     PROCEDURE write_subtable_start;
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'START OF SUB-TABLES'; 
        write_comment;
        write_comment 
     PROCEND write_subtable_start;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_output_table' ??
     ?? EJECT ??
  
     PROCEDURE write_output_table;
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'OUTPUT SUB-TABLE';
        write_comment;
        outrec.comment_text := '    OFFSETS BY ORDINAL';
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        write_ordinals(^dump_output_node);
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := '    OUTPUT CHARACTER SEQUENCES';
        write_comment;
        write_comment;
        outrec.line_type := opcode_line; 
        write_char_sequences(^dump_output_node)
     PROCEND write_output_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_input_table' ??
     ?? EJECT ??
  
     PROCEDURE write_input_table;
        VAR 
           table_size: INTEGER, 
           node_returned: BOOLEAN; 
  
        ?? NEWTITLE := 'write_input_item' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE write_input_item (in_node: ^input_node); 
  
           ?? NEWTITLE := 'write_char' ?? 
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_char(char_value: INTEGER; comment: STRING(*));
  
              outrec.line_type := opcode_line; 
              IF bits_left_in_word = target_wordsize THEN { first word only }
                 write_vfd(4, 0, 'FILLER'); 
              IFEND;
              IF bits_left_in_word < target_char_size THEN
                 start_word_output;
                 outrec.line_type := opcode_line;
                 write_vfd(4, 0, 'FILLER'); 
              IFEND;
              write_vfd(target_char_size, char_value, comment); 
           PROCEND write_char; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_action' ?? 
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_action (action: input_action);
              VAR 
                 comment: STRING(30), 
                 integer_string: STRING(6), 
                 i_s_length: ost$string_length; { subrange of integer }
  
              IF action.ordinal = no_ordinal THEN { offset to next item } 
                 comment := ''; 
                 utp$convert_integer_to_string(integer_string, i_s_length,
                    action.next_offset, 10); { offset in string format }
                 STRINGREP(comment, stringrep_len, 
                    'OFFSET ': 8, integer_string: i_s_length); 
                 write_char(action.next_offset DIV 128, comment); { high_order}
                 write_char(action.next_offset MOD 128, ''); { low-order}
              ELSE                    { ordinal }
                 comment := ''; 
                 utp$convert_integer_to_string(integer_string, i_s_length,
                    action.ordinal, 10); { ordinal in string format } 
                 STRINGREP(comment, stringrep_len, 
                    'ORDINAL ': 8, integer_string: i_s_length);
                 write_char((16383-action.ordinal) DIV 128, comment);
                 write_char((16383-action.ordinal) MOD 128, ''); { low-order }
              IFEND;
           PROCEND write_action; 
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_fail_node' ??
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_fail_node (in_node: ^input_node);
              write_char(0, '*****  FAIL  *****'); 
           PROCEND write_fail_node;
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_list_node' ??
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_list_node (in_node: ^input_node);
              VAR 
                 char_ndx: INTEGER; 
  
              write_char(1, '*****  LIST  *****'); 
              write_char(in_node^.list_character_count, 'LIST COUNT');
              FOR char_ndx := 1 to in_node^.list_character_count DO
                 write_char(ORD(in_node^.list_pointer^[char_ndx].character),
                    '');
                 write_action(in_node^.list_pointer^[char_ndx].action);
              FOREND; 
           PROCEND write_list_node;
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_range_node' ??
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_range_node (in_node: ^input_node);
              VAR 
                 char_ndx: INTEGER; 
  
              write_char(2, '*****  RANGE  *****');
              write_char(ORD(in_node^.range_lower_bound), 'LOWER BOUND');
              write_char(ORD(in_node^.range_upper_bound), 'UPPER BOUND');
              FOR char_ndx := ORD(in_node^.range_lower_bound) TO
                              ORD(in_node^.range_upper_bound) DO
                 write_action(in_node^.range_pointer^[char_ndx]); 
              FOREND; 
           PROCEND write_range_node;
           ?? OLDTITLE ?? 
  
           ?? NEWTITLE := 'write_sar_node' ??
           ?? SKIP := 4 ?? 
  
           PROCEDURE write_sar_node (in_node: ^input_node);
  
              write_char(3, '*****  SINGLE-ACTION RANGE  *****');
              write_char(ORD(in_node^.sar_lower_bound), 'LOWER BOUND');
              write_char(ORD(in_node^.sar_upper_bound), 'UPPER BOUND');
              write_action(in_node^.sar_action); 
           PROCEND write_sar_node;
           ?? OLDTITLE ?? 
  
           ?? EJECT ??
  
           CASE in_node^.opcode OF 
              = fail =
                 write_fail_node(in_node); 
              = list =
                 write_list_node(in_node); 
              = range =
                 write_range_node(in_node); 
              = single_action_range =
                 write_sar_node(in_node); 
           CASEND;
        PROCEND write_input_item; 
        ?? OLDTITLE ??
  
        ?? EJECT ?? 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'INPUT SUB-TABLE'; 
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        outrec.label := subtable_list[subtable_input].label;
        outrec.opcode := 'BSS';
        outrec.parameters := '0';
        outrec.comment := ''; 
        write_opcode_line; 
        reset_input_table(table_size);
        dump_input_node(^write_input_item); { pass my procedure to dumper }
        IF ( bits_left_in_word > 0 ) AND
           ( bits_left_in_word < target_wordsize ) THEN 
           outrec.line_type := opcode_line;
           write_vfd(bits_left_in_word, 0, 'FILLER'); 
        IFEND;
     PROCEND write_input_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_key_name_table' ?? 
     ?? EJECT ??
  
     PROCEDURE write_key_name_table; 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'KEY-NAME SUB-TABLE';
        write_comment;
        outrec.comment_text := '     ORDINALS BY KEY';
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        outrec.label := subtable_list[subtable_names].label;
        outrec.opcode := 'BSS';
        outrec.parameters := '0';
        outrec.comment := ''; 
        write_opcode_line; 
        write_ordinals(^dump_key_name_node); 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := '     KEY NAMES';
        write_comment;
        write_comment;
        outrec.line_type := opcode_line; 
        write_char_sequences(^dump_key_name_node) 
     PROCEND write_key_name_table; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_initialization_table' ??
     ?? EJECT ??
  
     PROCEDURE write_initialization_table;
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'INITIALIZATION SUB-TABLE';
        write_comment;
        outrec.comment_text := '     LINE/SCREEN ORDINALS'; 
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        outrec.label := subtable_list[subtable_init].label;
        outrec.opcode := 'BSS';
        outrec.parameters := '0';
        outrec.comment := ''; 
        write_opcode_line; 
        write_ordinals(^dump_reset_sequence);
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := '     INITIALIZATION SEQUENCES'; 
        write_comment;
        write_comment;
        outrec.line_type := opcode_line; 
        write_char_sequences(^dump_reset_sequence)
     PROCEND write_initialization_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_appstr_table' ??
     ?? EJECT ??
  
     PROCEDURE write_appstr_table;
        VAR 
           length: INTEGER,
           chars: ^STRING(*),
           total_sequences, 
           total_characters: INTEGER, 
           node_returned: BOOLEAN, 
           name: STRING(7);
  
        ?? NEWTITLE := 'write_appstr_names' ?? 
        ?? SKIP := 4 ??
  
        PROCEDURE write_appstr_names; 
           VAR
              char_ndx: INTEGER,
              comment: STRING(30);
  
           start_word_output;
           outrec.line_type := opcode_line;
           comment := name(1,7);
           FOR char_ndx := 1 TO 7 DO
              write_vfd(6,
                 utv$convert_ascii_to_ascii64[name(char_ndx)], comment);
              comment := '' 
           FOREND;
           write_vfd(18, length, '')
        PROCEND write_appstr_names; 
        ?? OLDTITLE ??
  
        ?? NEWTITLE := 'write_appstr_sequences' ?? 
        ?? EJECT ?? 
  
        PROCEDURE write_appstr_sequences; 
           VAR
              char_ndx: INTEGER,
              comment: STRING(30);
  
           outrec.line_type := opcode_line;
           FOR char_ndx := 1 TO length DO 
              IF bits_left_in_word < target_char_size THEN
                 start_word_output;
                 outrec.line_type := opcode_line;
                 write_vfd(4, 0, 'FILLER')
              IFEND;
              write_vfd(target_char_size, 
                 ORD(chars^(char_ndx)), ''); 
           FOREND;
           IF bits_left_in_word > 0 THEN
              outrec.line_type := opcode_line; 
              write_vfd(bits_left_in_word, 0, 'FILLER') 
           IFEND
        PROCEND write_appstr_sequences; 
        ?? OLDTITLE ??
        ?? EJECT ?? 
  
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'APPLICATION STRING SUB-TABLE';
        write_comment;
        write_comment;
        start_word_output; 
        outrec.line_type := opcode_line; 
        outrec.label := subtable_list[subtable_appstr].label;
        outrec.opcode := 'BSS';
        outrec.parameters := '0';
        outrec.comment := ''; 
        write_opcode_line; 
  
        reset_appstr_table; 
        REPEAT
           dump_appstr_node(name, length, chars, 
              total_sequences, total_characters, node_returned); 
           IF node_returned THEN
              write_appstr_names; 
              write_appstr_sequences
           IFEND
        UNTIL NOT node_returned;
        start_word_output; 
        outrec.line_type := opcode_line; 
        write_vfd(target_wordsize, 0, 'END OF NAMES') 
     PROCEND write_appstr_table;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'write_trailer' ?? 
     ?? EJECT ??
  
     PROCEDURE write_trailer; 
        outrec.line_type := comment_line; 
        outrec.comment_text := '';
        write_comment;
        outrec.comment_text := 'END OF TABLE';
        write_comment;
        write_comment;
        outrec.line_type := opcode_line; 
        outrec.label := subtable_list[subtable_end].label;
        outrec.opcode := 'END';
        outrec.parameters := ''; 
        write_opcode_line; 
     PROCEND write_trailer; 
     ?? OLDTITLE ?? 
     ?? EJECT ??
  
     open_file(output_file_sel, output_sel, ascii64_sel); 
     outrec.line_type := whole_line;
     outrec.line_buffer := ''; 
  
     write_header; 
     write_sub_table_pointers; 
     write_parameters; 
     write_size_table;
     write_subtable_start;
  
     write_output_table;
     write_input_table;
     write_key_name_table; 
     write_appstr_table;
     write_initialization_table;
     write_trailer; 
  
     close_file(output_file_sel)
  PROCEND write_tables;
  ?? OLDTITLE ??
  
MODEND tduout;
--EOR--    
TDUTAB
ASCII 
*NOSEQ
*WIDTH 95 
MODULE tdutab;
  
?? SET ( CHKALL := ON ), RIGHT := 110 ??
  
{  Module :  TDUTAB } 
{            Copyright Control Data Systems Inc.  1992.  } 
{  Written:  1/84 by R. Lindsey  } 
{  Version:  Cyber 170/180, version 1 } 
{  Purpose:  This module encapsulates the internal tables of the TDU program. }
{            It provides functions to add elements to the tables, to optimize } 
{            them, and to return the elements for output.  } 
{            This module has no I/O.  } 
  
  ?? PUSH ( LIST := OFF ) ??          {use this line to suppress commdeck list} 
{ ?? PUSH ( LIST := ON )  ??          {use this line to list common decks } 
?? SKIP := 4 ??
  
?? NEWTITLE := 'ZTDTTAB' ??
{ **************************** }
{ common deck ZTDTTAB follows: }
*CALL ZTDTTAB 
  
?? OLDTITLE ??
  
{ ************************** }
{ tdu error handler follows: } 
*CALL ZTDPERR 
*CALL ZTDCCON 
  
{ ************************* } 
{ tdu verb-table constants: } 
*CALL ZTDCVRB 
  
?? EJECT ?? 
?? POP ?? 
  
  VAR 
     parm_record: parameter_record,   { all parameters stored here } 
     input_list: ^input_node := NIL, { head of input list } 
     input_offset: INTEGER, 
     output_table: ARRAY [ 0 .. output_last_ordinal ] OF string_node,
     key_name_table: ARRAY [ 0 .. key_name_last_ordinal ] OF string_node,
     init_table: ARRAY [ 0 .. init_last_ordinal ] OF string_node,
     appstr_table, 
     appstr_next_node_dumped, 
     appstr_latest_new_node: ^appstr_node, 
     output_total_characters,
     key_name_total_characters, 
     init_total_characters,
     appstr_total_sequences,
     appstr_total_characters: INTEGER,
     status: ost$status;
  
  ?? NEWTITLE := 'store_ord_char_node' ??
  ?? EJECT ?? 
  
  PROCEDURE store_ord_char_node (ordinal: ordinal_type;
        sequence_length: INTEGER;
        char_sequence: STRING(*);
        VAR table: ARRAY [ * ] OF string_node;
        VAR total_characters: INTEGER;
        VAR error_return: error_type); 
  
     error_return := no_error; 
     IF table[ordinal].length > 0 THEN
        error_return := duplicate_error 
     ELSEIF sequence_length > 0 THEN
        ALLOCATE table[ordinal].chars : [ sequence_length ];
        IF table[ordinal].chars = NIL THEN 
           error_return := no_room_error;
        ELSE
           table[ordinal].length := sequence_length; 
           table[ordinal].chars^ := char_sequence(1,sequence_length);
           total_characters := total_characters + sequence_length
        IFEND 
     IFEND
  PROCEND store_ord_char_node;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'concatenate_sequences' ?? 
  ?? EJECT ?? 
  
  PROCEDURE concatenate_sequences (new_seq: STRING(*);
        new_seq_length: INTEGER;
        VAR table_node: string_node; 
        VAR total_characters: INTEGER; 
        VAR error_return: error_type);
     VAR
        allocation_len,
        stringrep_len: INTEGER, 
        old_node: string_node; 
  
     error_return := no_error;
     old_node := table_node;
     IF old_node.length = 0 THEN 
        allocation_len := new_seq_length 
     ELSE 
        allocation_len := old_node.length + new_seq_length
     IFEND; 
     table_node.length := allocation_len; 
     IF allocation_len > 0 THEN    { can't allocate 0 }
        ALLOCATE table_node.chars : [ allocation_len ];
        IF table_node.chars = NIL THEN
           error_return := no_room_error; 
        ELSE
           IF old_node.length = 0 THEN 
              table_node.chars^ := new_seq(1,new_seq_length) 
           ELSE 
              STRINGREP(table_node.chars^, stringrep_len,
                 old_node.chars^(1,old_node.length),
                 new_seq(1,new_seq_length));
              FREE old_node.chars 
           IFEND; 
           total_characters := total_characters + new_seq_length
        IFEND 
     IFEND
  PROCEND concatenate_sequences;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'initialize_tables' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] initialize_tables; 
     VAR
        table_ndx: INTEGER;
  
     ALLOCATE input_list : [ fail ];  { ignore no-room error, caught later }
     IF input_list <> NIL THEN 
        input_list^.next_node := NIL;
        input_list^.offset := 0; 
        input_list^.node_visited := FALSE 
     IFEND; 
     FOR table_ndx := 1 TO output_last_ordinal DO 
        output_table[table_ndx].length := 0;
        output_table[table_ndx].chars := NIL 
     FOREND;
     output_total_characters := 0;
     FOR table_ndx := 1 TO key_name_last_ordinal DO
        key_name_table[table_ndx].length := 0; 
        key_name_table[table_ndx].chars := NIL
     FOREND;
     key_name_total_characters := 0; 
     FOR table_ndx := 1 TO init_last_ordinal DO 
        init_table[table_ndx].length := 0;
        init_table[table_ndx].chars := NIL 
     FOREND;
     init_total_characters := 0;
     appstr_table := NIL; 
     appstr_latest_new_node := NIL; 
     appstr_next_node_dumped := NIL; 
     appstr_total_sequences := 0;
     appstr_total_characters := 0 
  PROCEND initialize_tables;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_parameters' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_parameters (parm: parameter_record);
     parm_record := parm;             { save it in my local space }
  PROCEND store_parameters;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_parameters' ??
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] dump_parameters (VAR parm: parameter_record);
     parm := parm_record;             { give caller my copy }
  PROCEND dump_parameters;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_output_node' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_output_node (ordinal: ordinal_type;
        sequence_length: INTEGER;
        char_sequence: STRING(*);
        VAR error_return: error_type); 
  
     IF ( ordinal < 0 ) OR 
        ( ordinal > output_last_ordinal ) THEN
        error_return := no_room_error
     ELSE 
        concatenate_sequences(char_sequence, sequence_length, 
           output_table[ordinal], output_total_characters, 
           error_return) 
     IFEND
  PROCEND store_output_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_output_node' ?? 
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] dump_output_node (ordinal: ordinal_type;
        VAR length: INTEGER; 
        VAR chars: ^STRING(*); 
        VAR total_ordinals: INTEGER;
        VAR total_characters: INTEGER;
        VAR node_returned: BOOLEAN); 
  
     node_returned := FALSE; 
     IF ( ordinal >= 0 ) AND 
        ( ordinal <= output_last_ordinal ) THEN 
        node_returned := TRUE; 
        total_ordinals := output_last_ordinal; 
        total_characters := output_total_characters; 
        length := output_table[ordinal].length;
        chars := output_table[ordinal].chars 
     IFEND
  PROCEND dump_output_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_key_name_node' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_key_name_node (ordinal: ordinal_type; 
        sequence_length: INTEGER;
        char_sequence: STRING(*);
        VAR error_return: error_type); 
  
     IF ( ordinal < 0 ) OR 
        ( ordinal > key_name_last_ordinal ) THEN 
        error_return := no_room_error
     ELSE 
        store_ord_char_node(ordinal, sequence_length, char_sequence, 
           key_name_table, key_name_total_characters, error_return)
     IFEND
  PROCEND store_key_name_node;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_key_name_node' ??
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] dump_key_name_node(ordinal: ordinal_type;
        VAR length: INTEGER; 
        VAR chars: ^STRING(*); 
        VAR total_ordinals: INTEGER;
        VAR total_characters: INTEGER;
        VAR node_returned: BOOLEAN); 
  
     node_returned := FALSE; 
     IF ( ordinal >= 0 ) AND 
        ( ordinal <= key_name_last_ordinal ) THEN
        node_returned := TRUE; 
        total_ordinals := key_name_last_ordinal;
        total_characters := key_name_total_characters;
        length := key_name_table[ordinal].length; 
        chars := key_name_table[ordinal].chars
     IFEND
  PROCEND dump_key_name_node;
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_reset_sequence' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_reset_sequence (ordinal: ordinal_type;
        char_seq_length: INTEGER; 
        char_seq: STRING(*);
        VAR error_return: error_type); 
  
     IF ( ordinal < 0 ) OR 
        ( ordinal > init_last_ordinal ) THEN
        error_return := no_room_error
     ELSE 
        concatenate_sequences(char_seq, char_seq_length,
           init_table[ordinal], init_total_characters, 
           error_return);
     IFEND
  PROCEND store_reset_sequence; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_reset_sequence' ?? 
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] dump_reset_sequence(ordinal: ordinal_type; 
        VAR length: INTEGER; 
        VAR chars: ^STRING(*); 
        VAR total_ordinals: INTEGER;
        VAR total_characters: INTEGER;
        VAR node_returned: BOOLEAN); 
  
     node_returned := FALSE; 
     IF ( ordinal >= 0 ) AND 
        ( ordinal <= init_last_ordinal ) THEN 
        node_returned := TRUE; 
        total_ordinals := init_last_ordinal; 
        total_characters := init_total_characters; 
        length := init_table[ordinal].length;
        chars := init_table[ordinal].chars 
     IFEND
  PROCEND dump_reset_sequence; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_appstr_node' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_appstr_node (name: STRING(*);
        sequence_length: INTEGER;
        char_sequence: STRING(*);
        VAR error_return: error_type); 
     VAR
        new_node: ^appstr_node;
  
     error_return := no_error; 
     ALLOCATE new_node;
     IF new_node = NIL THEN
        error_return := no_room_error
     ELSE 
        IF appstr_table = NIL THEN 
           appstr_table := new_node
        ELSE
           appstr_latest_new_node^.next_node := new_node
        IFEND;
        appstr_latest_new_node := new_node;
        new_node^.next_node := NIL;
        new_node^.name := name;
        new_node^.value.length := sequence_length;
        appstr_total_sequences := appstr_total_sequences + 1;
        IF sequence_length > 0 THEN 
           ALLOCATE new_node^.value.chars : [ sequence_length ]; 
           IF new_node^.value.chars = NIL THEN
              error_return := no_room_error
           ELSE 
              new_node^.value.chars^ := char_sequence(1,sequence_length); 
              appstr_total_characters :=
                 appstr_total_characters + sequence_length 
           IFEND
        IFEND 
     IFEND
  PROCEND store_appstr_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'reset_appstr_table' ?? 
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] reset_appstr_table;
     appstr_next_node_dumped := appstr_table
  PROCEND reset_appstr_table; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_appstr_node' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] dump_appstr_node (VAR name: STRING(*);
        VAR length: INTEGER; 
        VAR chars: ^STRING(*); 
        VAR total_sequences: INTEGER;
        VAR total_characters: INTEGER;
        VAR node_returned: BOOLEAN); 
  
     IF ( appstr_table = NIL ) OR
        ( appstr_next_node_dumped = NIL ) THEN
        node_returned := FALSE 
     ELSE 
        node_returned := TRUE; 
        name := appstr_next_node_dumped^.name;
        length := appstr_next_node_dumped^.value.length; 
        chars := appstr_next_node_dumped^.value.chars; 
        appstr_next_node_dumped := appstr_next_node_dumped^.next_node;
        total_sequences := appstr_total_sequences; 
        total_characters := appstr_total_characters
     IFEND
  PROCEND dump_appstr_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'store_input_node' ?? 
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] store_input_node (ordinal: ordinal_type;
        sequence_length: INTEGER;
        char_sequence: STRING(*);
        VAR error_return: error_type); 
  
     { Input character recognition sequences are stored in a tree of linked }
     {   lists.  Each character of a particular sequence occupies a node in }
     {   a different level of the tree.  Thus, when matching a sequence in }
     {   the tree, one would start at the first level (pointed to by   }
     {   input_list), and search the linked list which constitutes that level } 
     {   (using search_level).  If the character is found, the process repeats}
     {   with the next character in the sequence, and the search is of the }
     {   level pointed to by the node which was found.  } 
     { Each level consists of a linked list of 'list' nodes, where each node } 
     {   corresponds to a single-element list in the final output format.  } 
     {   These list nodes are later combined where possible into ranges and }
     {   single-action ranges by the optimize_tables procedure.  }
     {   The last node in each level's linked list is always a 'fail' node. }
  
     VAR
        new_node,
        pred_node,                    { predecessor to current node } 
        succ_node,                    { successor to current node } 
        prev_level,                   { previous level which points to current} 
        curr_level: ^input_node,      { start of the level to search } 
        node_found: BOOLEAN,
        char_ndx: INTEGER;
  
     ?? NEWTITLE := 'search_level' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE search_level (ch: CHAR; curr_level: ^input_node; 
           VAR pred_node: ^input_node; VAR succ_node: ^input_node;
           VAR node_found: BOOLEAN);
        { This procedure searches a particular level of the input char tree, }
        {   looking for a node which contains the given character.  If it } 
        {   doesn't find one, it returns pointers set up to insert a new node }
        {   for that character in its proper order. } 
  
        node_found := FALSE;
        pred_node := NIL;
        succ_node := curr_level;
        WHILE ( succ_node^.opcode <> fail ) AND
              ( node_found = FALSE ) AND 
              ( succ_node^.list_pointer^[1].character <= ch ) DO
           IF succ_node^.list_pointer^[1].character = ch THEN 
              node_found := TRUE
           ELSE 
              pred_node := succ_node;
              succ_node := pred_node^.next_node 
           IFEND
        WHILEND 
     PROCEND search_level; 
     ?? OLDTITLE ?? 
     ?? EJECT ??
  
     error_return := no_error; 
     curr_level := input_list; 
     FOR char_ndx := 1 TO sequence_length DO
        search_level(char_sequence(char_ndx), curr_level,
           pred_node, succ_node, node_found);
        IF node_found THEN 
           IF succ_node^.list_pointer^[1].action.ordinal > no_ordinal THEN 
              IF char_ndx <> sequence_length THEN
                 error_return := superset_error; 
                 RETURN 
              IFEND;
              error_return := duplicate_input_error; 
              RETURN
           IFEND; 
           IF char_ndx = sequence_length THEN
              error_return := subset_error;
              RETURN
           IFEND; 
           prev_level := succ_node; 
           curr_level :=      { point to next level in sequence } 
              succ_node^.list_pointer^[1].action.next_level 
        ELSE                          { no match found, build a new node } 
           ALLOCATE new_node : [ list ]; { create a list node }
           IF pred_node = NIL THEN    { never got past first node }
              IF char_ndx = 1 THEN    { first level only } 
                 new_node^.next_node := input_list; 
                 input_list := new_node
              ELSE                    { beyond first level }
                 new_node^.next_node :=
                    prev_level^.list_pointer^[1].action.next_level;
                 prev_level^.list_pointer^[1].action.next_level := new_node
              IFEND 
           ELSE                       { new node is in midst of existing level}
              new_node^.next_node := pred_node^.next_node;
              pred_node^.next_node := new_node;
           IFEND; 
           new_node^.offset := 0;
           new_node^.node_visited := FALSE; 
           new_node^.list_character_count := 1; { one element in list }
           ALLOCATE new_node^.list_pointer : [ 1..1 ]; { the list itself } 
           new_node^.list_pointer^[1].character := char_sequence(char_ndx);
           new_node^.list_pointer^[1].action.next_offset := 0; 
           IF char_ndx = sequence_length THEN
              new_node^.list_pointer^[1].action.ordinal := ordinal;
              new_node^.list_pointer^[1].action.next_level := NIL 
           ELSE 
              new_node^.list_pointer^[1].action.ordinal := no_ordinal; 
              ALLOCATE
                 new_node^.list_pointer^[1].action.next_level : [ fail ]; 
              new_node^.list_pointer^[1].action.next_level^.next_node := NIL;
              new_node^.list_pointer^[1].action.next_level^.offset := 0; 
              new_node^.list_pointer^[1].action.next_level^.
                 node_visited := FALSE; 
              prev_level := new_node;
              curr_level := 
                 new_node^.list_pointer^[1].action.next_level
           IFEND
        IFEND 
     FOREND 
  PROCEND store_input_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'dump_input_node' ?? 
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] dump_input_node ( 
        before_procedure: ^PROCEDURE(in_nd: ^input_node) ); 
  
     traverse_input_tree(input_list, before_procedure, NIL)
  PROCEND dump_input_node; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'reset_input_table' ?? 
  ?? SKIP := 4 ??
  
  PROCEDURE [XDCL] reset_input_table (VAR character_count: INTEGER);
  
     PROCEDURE reset_node_flags(in_node: ^input_node); 
        in_node^.node_visited := FALSE;
        calculate_input_offsets(in_node) 
     PROCEND reset_node_flags;
  
     input_offset := 0; 
     dump_input_node(^reset_node_flags);
     character_count := input_offset
  PROCEND reset_input_table; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'traverse_input_tree' ?? 
  ?? EJECT ?? 
  
  PROCEDURE traverse_input_tree (  { recursively process tree, calling proc}
        in_node: ^input_node;
        before_procedure: ^PROCEDURE(in_nd: ^input_node); 
        after_procedure: ^PROCEDURE(in_nd: ^input_node) ); 
  
     VAR
        action_ndx: INTEGER;
  
     IF in_node <> NIL THEN 
        IF before_procedure <> NIL THEN
           before_procedure^(in_node) { do whatever my caller requests }
        IFEND;
        CASE in_node^.opcode OF
           = fail = 
              ; 
           = list = 
              traverse_input_tree(in_node^.next_node, { same level first }
                 before_procedure, after_procedure); 
              FOR action_ndx := 1 TO in_node^.list_character_count DO
                 traverse_input_tree(    { now the next level } 
                    in_node^.list_pointer^[action_ndx]. 
                       action.next_level,
                    before_procedure, after_procedure) 
              FOREND; 
           = range = 
              traverse_input_tree(in_node^.next_node, 
                 before_procedure, after_procedure); 
              FOR action_ndx := ORD(in_node^.range_lower_bound) TO
                                ORD(in_node^.range_upper_bound) DO
                 traverse_input_tree(
                    in_node^.range_pointer^[action_ndx].next_level, 
                    before_procedure, after_procedure) 
              FOREND; 
           = single_action_range = 
              traverse_input_tree(in_node^.next_node, 
                 before_procedure, after_procedure); 
              traverse_input_tree( 
                 in_node^.sar_action.next_level, 
                 before_procedure, after_procedure); 
        CASEND; 
        IF after_procedure <> NIL THEN
           after_procedure^(in_node)  { do whatever desired after traversal } 
        IFEND 
     IFEND
  PROCEND traverse_input_tree; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'calculate_input_offsets' ?? 
  ?? EJECT ?? 
  
  PROCEDURE calculate_input_offsets (in_node: ^input_node); 
  
     in_node^.offset := input_offset;
     CASE in_node^.opcode OF 
        = fail =
           input_offset := input_offset + 1; 
        = list =
           input_offset := input_offset + 2 +
              ( in_node^.list_character_count * 3 ); 
        = range =
           input_offset := input_offset + 3 + (
              ( ( ORD(in_node^.range_upper_bound) - 
                  ORD(in_node^.range_lower_bound) ) + 1 ) * 2 );
        = single_action_range =
           input_offset := input_offset + 5; 
     CASEND 
  PROCEND calculate_input_offsets; 
  ?? OLDTITLE ??
  
  ?? NEWTITLE := 'optimize_tables' ??
  ?? EJECT ?? 
  
  PROCEDURE [XDCL] optimize_tables; 
     VAR
        next_ordinal: ordinal_type,
        node_returned: BOOLEAN,
        error_return: error_type;
  
     ?? NEWTITLE := 'create_ranges' ?? 
     ?? SKIP := 4 ?? 
  
     PROCEDURE create_ranges (in_node: ^input_node); 
        VAR 
           action_ndx: INTEGER; 
  
        IF in_node <> NIL THEN
           CASE in_node^.opcode OF 
              = fail =
                 ;
              = list =
                 FOR action_ndx := 1 TO in_node^.list_character_count DO 
                    IF in_node^.list_pointer^[action_ndx].action.next_level <> 
                       NIL THEN 
                       create_range_level(
                          in_node^.list_pointer^[action_ndx].action.next_level)
                    IFEND 
                 FOREND;
              = range =
                 FOR action_ndx := ORD(in_node^.range_lower_bound) TO 
                                   ORD(in_node^.range_upper_bound) DO 
                    IF in_node^.range_pointer^[action_ndx].next_level <> NIL
                       THEN 
                       create_range_level(
                          in_node^.range_pointer^[action_ndx].next_level) 
                    IFEND 
                 FOREND;
              = single_action_range =
                 IF in_node^.sar_action.next_level <> NIL THEN 
                    create_range_level(in_node^.sar_action.next_level) 
                 IFEND
           CASEND 
        IFEND 
     PROCEND create_ranges; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'create_range_level' ??
     ?? EJECT ??
  
     PROCEDURE create_range_level (VAR curr_level: ^input_node);
        { This procedure scans across a given level of the input tree, }
        {   attempting to reduce consecutive lists of characters to ranges. } 
        { It ASSUMES it is being called as the FIRST phase of input table } 
        {   optimization, so that each level consists of single-item lists }
        {   ONLY, and that the lists are in ASCENDING ORDER. }
  
        VAR 
           new_node, 
           pred_node, 
           succ_node, 
           low_node, 
           low_node_pred,
           new_low_node: ^input_node,
           low,
           high: CHAR, 
           range_ndx: INTEGER; 
  
        IF curr_level^.opcode = list THEN { just in case of empty table } 
           low := curr_level^.list_pointer^[1].character 
        IFEND;
        high := low;
        low_node := curr_level;
        succ_node := curr_level;
        pred_node := NIL;
        WHILE ( succ_node <> NIL ) AND
              ( error_return = no_error ) DO
           IF ( succ_node^.opcode <> fail ) AND
              ( succ_node^.list_pointer^[1].character = SUCC(high) ) THEN 
              high := succ_node^.list_pointer^[1].character { extend range }
           ELSEIF low = high THEN     { 'orphan' list--reset search ptrs }
              IF succ_node^.opcode = list THEN 
                 low := succ_node^.list_pointer^[1].character;
                 high := low; 
                 low_node := succ_node; 
                 low_node_pred := pred_node 
              IFEND 
           ELSE                       { at least 2 consecutive nodes found }
              ALLOCATE new_node : [ range ]; 
              IF new_node = NIL THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_optimize_table_full, '', status); 
                 error_status(status); 
                 error_return := no_room_error;
                 RETURN 
              IFEND;
              new_node^.next_node := succ_node; { new range in same spot}
              new_node^.offset := 0; 
              new_node^.node_visited := FALSE;
              IF low_node = curr_level THEN { new node is first on level}
                 curr_level := new_node { return pointer to my caller } 
              ELSE
                 low_node_pred^.next_node := new_node 
              IFEND;
              new_node^.range_lower_bound := low;
              new_node^.range_upper_bound := high;
              ALLOCATE new_node^.range_pointer : [ ORD(low)..ORD(high) ]; 
              IF new_node^.range_pointer = NIL THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_optimize_table_full, '', status); 
                 error_status(status); 
                 error_return := no_room_error;
                 RETURN 
              IFEND;
              FOR range_ndx := ORD(low) TO ORD(high) DO 
                 new_node^.range_pointer^[range_ndx] := 
                    low_node^.list_pointer^[1].action;
                 new_low_node := low_node^.next_node;
                 FREE low_node^.list_pointer;
                 FREE low_node;
                 low_node := new_low_node 
              FOREND; 
              IF succ_node^.opcode = list THEN 
                 low := succ_node^.list_pointer^[1].character;
                 high := low; 
                 low_node := succ_node; 
                 low_node_pred := new_node 
              IFEND 
           IFEND; 
           pred_node := succ_node; 
           IF succ_node^.opcode = fail THEN
              succ_node := NIL 
           ELSE 
              succ_node := pred_node^.next_node 
           IFEND
        WHILEND 
     PROCEND create_range_level;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'insert_remaining_chars' ??
     ?? EJECT ??
  
     PROCEDURE insert_remaining_chars;
        { This procedure processes the first level of the input tree only, }
        {   adding all characters that are not yet represented there.  This }
        {   is necessary because we can make no assumptions about which } 
        {   characters the application program wants to see.  We will pass }
        {   everything to the app, and let it decide what to do. }
        { At the time this procedure is called, it ASSUMES that the first }
        {   level consists ONLY of ranges and lists, and that everything }
        {   is still in ASCENDING ORDER. } 
  
        VAR 
           pred_node, 
           succ_node: ^input_node, 
           first_needed: 0 .. 129;
  
        ?? NEWTITLE := 'maybe_insert_chars' ?? 
        ?? EJECT ?? 
  
        PROCEDURE maybe_insert_chars (next_used: 0 .. 128; 
              succ_node: ^input_node;
              VAR pred_node: ^input_node;
              VAR first_needed: 0 .. 129);
  
           VAR
              new_node: ^input_node;
  
           IF next_used > first_needed THEN
              ALLOCATE new_node : [ single_action_range ]; 
              IF new_node = NIL THEN 
                 osp$set_status_abnormal(tdc_prod_code,
                    tde_optimize_table_full, '', status); 
                 error_status(status); 
                 error_return := no_room_error;
              ELSE
                 new_node^.next_node := succ_node; 
                 new_node^.offset := 0;
                 new_node^.node_visited := FALSE; 
                 IF pred_node = NIL THEN
                    input_list := new_node 
                 ELSE 
                    pred_node^.next_node := new_node 
                 IFEND; 
                 pred_node := new_node; 
                 new_node^.sar_lower_bound := CHR(first_needed); 
                 new_node^.sar_upper_bound := CHR(next_used - 1); 
                 new_node^.sar_action.ordinal := overstrike_ordinal;
                 new_node^.sar_action.next_offset := 0; 
                 new_node^.sar_action.next_level := NIL
              IFEND 
           IFEND; 
           first_needed := next_used + 1
        PROCEND maybe_insert_chars; 
        ?? OLDTITLE ??
  
        succ_node := input_list;
        pred_node := NIL;
        first_needed := 0;
        WHILE first_needed < 128 DO
           CASE succ_node^.opcode OF 
              = fail =
                 maybe_insert_chars(128, succ_node, pred_node, first_needed);
              = list =
                 maybe_insert_chars(
                    ORD(succ_node^.list_pointer^[1].character), 
                    succ_node, pred_node, first_needed); 
                 first_needed := 1 + ORD(succ_node^.list_pointer^
                    [succ_node^.list_character_count].character); 
              = range =
                 maybe_insert_chars(ORD(succ_node^.range_lower_bound),
                    succ_node, pred_node, first_needed); 
                 first_needed := 1 + ORD(succ_node^.range_upper_bound); 
           CASEND;
           pred_node := succ_node; 
           succ_node := pred_node^.next_node
        WHILEND 
     PROCEND insert_remaining_chars;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'combine_lists' ?? 
     ?? EJECT ??
  
     PROCEDURE combine_lists (in_node: ^input_node); 
        { This procedure processes all levels of the input tree, combining } 
        {   multiple list nodes at each level into a single list node. } 
        { It is called recursively by traverse_input_tree. } 
  
        VAR 
           action_ndx: INTEGER; 
  
        IF in_node <> NIL THEN
           CASE in_node^.opcode OF 
              = fail =
                 ;
              = list =
                 FOR action_ndx := 1 TO in_node^.list_character_count DO 
                    IF in_node^.list_pointer^[action_ndx].action.next_level <> 
                       NIL THEN 
                       combine_list_level(
                          in_node^.list_pointer^[action_ndx].action.next_level)
                    IFEND 
                 FOREND;
              = range =
                 FOR action_ndx := ORD(in_node^.range_lower_bound) TO 
                                   ORD(in_node^.range_upper_bound) DO 
                    IF in_node^.range_pointer^[action_ndx].next_level <> NIL
                       THEN 
                       combine_list_level(
                          in_node^.range_pointer^[action_ndx].next_level) 
                    IFEND 
                 FOREND;
              = single_action_range =
                 IF in_node^.sar_action.next_level <> NIL THEN 
                    combine_list_level(in_node^.sar_action.next_level) 
                 IFEND
           CASEND 
        IFEND 
     PROCEND combine_lists; 
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'combine_list_level' ??
     ?? EJECT ??
  
     PROCEDURE combine_list_level (VAR curr_level: ^input_node);
        { This procedure scans across a given level of the input tree, }
        {   combining all separate lists found at that level into a single }
        {   list.  It doesn't really care at what phase of the optimization }
        {   it is being called. }
  
        VAR 
           new_node, 
           pred_node, 
           succ_node: ^input_node, 
           list_count, 
           new_ndx, 
           old_ndx: INTEGER; 
  
        succ_node := curr_level;
        pred_node := NIL;
        list_count := 0;
        WHILE succ_node^.opcode <> fail DO 
           IF succ_node^.opcode = list THEN
              list_count := list_count + succ_node^.list_character_count
           IFEND; 
           pred_node := succ_node; 
           succ_node := succ_node^.next_node
        WHILEND;
        IF list_count > 0 THEN        { at least one list on this level } 
           ALLOCATE new_node : [ list ];
           IF new_node = NIL THEN
              error_return := no_room_error; 
              osp$set_status_abnormal(tdc_prod_code, tde_optimize_table_full,
                 '', status); 
              error_status(status);
              RETURN
           IFEND; 
           new_node^.offset := 0;
           new_node^.node_visited := FALSE; 
           new_node^.list_character_count := list_count;
           ALLOCATE new_node^.list_pointer : [ 1 .. list_count ];
           IF new_node^.list_pointer = NIL THEN
              error_return := no_room_error; 
              osp$set_status_abnormal(tdc_prod_code, 
                 tde_optimize_table_full, '', status);
              error_status(status);
              RETURN
           IFEND; 
           succ_node := curr_level; 
           pred_node := NIL; 
           new_ndx := 0; 
           WHILE ( succ_node <> NIL ) AND 
                 ( error_return = no_error ) DO 
              CASE succ_node^.opcode OF
                 = list =                { old node, move pieces to new node }
                    FOR old_ndx := 1 TO succ_node^.list_character_count DO
                       new_ndx := new_ndx + 1; 
                       new_node^.list_pointer^[new_ndx].character :=
                          succ_node^.list_pointer^[old_ndx].character;
                       new_node^.list_pointer^[new_ndx].action :=
                          succ_node^.list_pointer^[old_ndx].action 
                    FOREND; 
                    FREE succ_node^.list_pointer; 
                    IF succ_node = curr_level THEN { old list is first on lvl } 
                       curr_level := succ_node^.next_node; { link around it }
                       FREE succ_node;
                       succ_node := curr_level
                    ELSE
                       pred_node^.next_node := succ_node^.next_node; 
                       FREE succ_node;
                       succ_node := pred_node^.next_node
                    IFEND;
                 = range, single_action_range = 
                    pred_node := succ_node;
                    succ_node := pred_node^.next_node;
                 = fail =             { at end, insert new node here }
                    new_node^.next_node := succ_node; { new list at end }
                    IF succ_node = curr_level THEN { new node is first on lvl } 
                       curr_level := new_node { return pointer to my caller } 
                    ELSE
                       pred_node^.next_node := new_node
                    IFEND;
                    succ_node := NIL;
              CASEND; 
           WHILEND
        IFEND 
     PROCEND combine_list_level;
     ?? OLDTITLE ?? 
  
     ?? NEWTITLE := 'assign_input_offsets' ??
     ?? SKIP := 2 ?? 
  
     PROCEDURE assign_input_offsets (in_node: ^input_node);
        VAR 
           action_ndx: INTEGER; 
  
        CASE in_node^.opcode OF
           = fail = 
              ; 
           = list = 
              FOR action_ndx := 1 TO in_node^.list_character_count DO
                 IF in_node^.list_pointer^[action_ndx].action.ordinal =
                       no_ordinal THEN 
                    in_node^.list_pointer^[action_ndx].action.next_offset := 
                       in_node^.list_pointer^[action_ndx].action.next_level^
                          .offset 
                 IFEND
              FOREND; 
           = range = 
              FOR action_ndx := ORD(in_node^.range_lower_bound) TO
                                ORD(in_node^.range_upper_bound) DO
                 IF in_node^.range_pointer^[action_ndx].ordinal=no_ordinal THEN
                    in_node^.range_pointer^[action_ndx].next_offset :=
                       in_node^.range_pointer^[action_ndx].next_level^.offset
                 IFEND
              FOREND; 
           = single_action_range = 
              IF in_node^.sar_action.ordinal = no_ordinal THEN
                 in_node^.sar_action.next_offset :=
                    in_node^.sar_action.next_level^.offset
              IFEND 
        CASEND
     PROCEND assign_input_offsets;
     ?? OLDTITLE ?? 
  
     ?? EJECT ??
  
     error_return := no_error; 
     appstr_latest_new_node := appstr_table; 
  
     traverse_input_tree(input_list, NIL, ^create_ranges); 
     create_range_level(input_list);  { root level wasn't handled recursively }
     IF error_return = no_error THEN
        insert_remaining_chars;       { adds all chars not already in first lv}
        IF error_return = no_error THEN 
           traverse_input_tree(input_list, NIL, ^combine_lists); 
           combine_list_level(input_list); { root level wasn't handled }
           IF error_return = no_error THEN
              input_offset := 0;      { assign object table offset addresses }
              dump_input_node(^calculate_input_offsets); 
              dump_input_node(^assign_input_offsets)
           IFEND
        IFEND 
     IFEND
  PROCEND optimize_tables;
  ?? OLDTITLE ??
  
MODEND tdutab;
--EOR--    
TDU 
ASCII 
*NOSEQ
*WIDTH 132
.PROC,TDU*I"Terminal Definition Utility", 
 I'Terminal definition file (TDUIN)'=(*F,*N=TDUIN),
 L'Error listing file (OUTPUT)'=(*F,*N=OUTPUT),
 LIB'Library file (TERMLIB)'=(*F,*N=TERMLIB), 
 REC'Record name to process'=(*S6/AD,*,*N=),
 RW'Rewind definition file?'=(*K=YES,YES,Y,NO,N=NO,*N=YES).
.HELP.
TDU - Terminal Definition Utility.
  
The TDU procedure compiles into capsule format a user- 
defined terminal definition file, inserting the new 
capsule into a local user library.
.HELP,I.
The name of the user-defined terminal definition file 
( default is TDUIN ).
.HELP,L.
The name of the listing file ( default is list ).
.HELP,LIB.
The name of the library ( default is TERMLIB ).
.HELP,REC.
The name of the record to process from the terminal
definition file.  If * is specified, all records
will be processed (default:  process one terminal 
definition record regardless of the record name ). 
.HELP,RW. 
NO to prevent terminal definition and listing files 
from being rewound before and after processing. 
YES to have both files rewound before and after 
processing ( default is YES ). 
.ENDHELP. 
.IFE(.NOT.FILE(I,AS),NOINPUT) 
  REVERT,ABORT.  NO INPUT FILE I. 
.ENDIF(NOINPUT) 
.IF($RW$.NE.$NO$,REWIND)
  .IF($L$.NE.$OUTPUT$.AND.$L$.NE.$0$)REWIND,L.
  REWIND,I. 
.ENDIF(REWIND)
RENAME,ZZZZZTI=I. 
REWIND,ZZZZZTA,LIB. 
.IF(CSET.EQ.NORMAL)CSET,ASCII.
.IF($REC$.NE.$$.AND.$REC$.NE.$*$,MULTI) 
  GTR,ZZZZZTI,I.REC 
.ELSE(MULTI)
  COPYBR,ZZZZZTI,I. 
  .IF($REC$.EQ.$*$,MULTI) 
    WHILE(.NOT.(FILE(ZZZZZTI,EOF).OR.FILE(ZZZZZTI,EOI)),NEXTREC)
.ENDIF(MULTI) 
RETURN,ZZZZZTB,ZZZZZTC,ZZZZZTL. 
TDUEX,I,ZZZZZTC,ZZZZZTL.
IF(FILE(ZZZZZTC,AS),TDUERR) 
  .IF($L$.NE.$0$)IF(FILE(ZZZZZTL,AS))COPYBR,ZZZZZTL,L.
  COMPASS,#I=ZZZZZTC,#L=0,B=ZZZZZTB,A.
  LDSET,ERR=ALL.
  LOAD,ZZZZZTB. 
  NOGO,ZZZZZTA. 
  .IF($REC$.EQ.$*$,MULTI) 
    COPYBR,ZZZZZTI,I. 
    ENDW(NEXTREC) 
  .ENDIF(MULTI) 
  .IF(FILE(LIB,AS),REPLACE) 
    ULIB,R,ZZZZZTA,LIB. 
  .ELSE(REPLACE)
    ULIB,C,ZZZZZTA,LIB. 
  .ENDIF(REPLACE) 
  REWIND,LIB. 
  RENAME,I=ZZZZZTI. 
  .IF($RW$.NE.$NO$,REWIND)
    REWIND,I. 
    .IF($L$.NE.$OUTPUT$.AND.$L$.NE.$0$)REWIND,L.
  .ENDIF(REWIND)
  .IF(CSET.EQ.NORMAL)CSET,NORMAL. 
  RETURN,ZZZZZTA,ZZZZZTB,ZZZZZTC,ZZZZZTL. 
  REVERT.  I --> LIB. 
  EXIT. 
ENDIF(TDUERR) 
RENAME,I=ZZZZZTI. 
.IF($L$.NE.$0$)IF(FILE(ZZZZZTL,AS))COPYBR,ZZZZZTL,L.
.IF($RW$.NE.$NO$,REWIND)
  REWIND,I. 
  .IF($L$.NE.$OUTPUT$.AND.$L$.NE.$0$)REWIND,L.
.ENDIF(REWIND)
.IF(CSET.EQ.NORMAL)CSET,NORMAL. 
RETURN,ZZZZZTA,ZZZZZTB,ZZZZZTC,ZZZZZTL. 
REVERT,ABORT.  COMPILATION FAILED.
*WEOR 
--EOR--    
--EOF--    
/
