Google
 

Trailing-Edge - PDP-10 Archives - bb-r775c-bm_tops20_ks_upd_3 - sources/interfils.bli
There are 15 other files named interfils.bli in the archive. Click here to see a list.
%TITLE 'Produce DIX interface support files'

MODULE interfils                        ! [6] Change name 

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1985.
!  ALL RIGHTS RESERVED.
!  
!  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!  COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!  THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!  ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!  AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!  SOFTWARE IS HEREBY TRANSFERRED.
!  
!  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!  NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!  EQUIPMENT CORPORATION.
!  
!  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!  ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.

!++
! .CHAPTER interfils
!
!   FACILITY: DIX
!
!   ABSTRACT: Make the interface support files.
!
!   ENVIRONMENT: Transportable program
!
!   AUTHOR: David Dyer-Bennet, Creation Date: 25-May-82
!--

(IDENT = '2(50)',                       ! \.P;\ **edit**
VERSION = '2(50)',                      ! **edit**
MAIN = mainr
%BLISS32 (                              ! [14] Correct random error found
    ,ADDRESSING_MODE (EXTERNAL = GENERAL, NONEXTERNAL = LONG_RELATIVE)	! [14] [10]
)                                       ! [14] 
) =

BEGIN

!++
! .hl 1 Description
!
!   This program makes DIX the interface support files for whatever
! system it is run on.  It will not correctly produce interface
! support files for other systems because it depends on the definition
! of a condition value provided by the current system.
!--

!++
! .hl 1 Interface Support Files
! 
!   Some text files are provided with the DIL which define names for the
! various codes used in communicating with the DIL.  In general, there
! is one file for each supported language/system combination.
! 
! .hl 2 DEC-10/20
! 
! The interface support files for the 10/20 systems are provided in a
! manner appropriate for the languages they support.
! 
! .hl 3 COB36
! For COB36, the file provided is a copy library, DIL.LIB.  The COBOL
! COPY verb can be used to retrieve the information at compilation time.
! The LIBARY system utility can be used to extract the information as a
! text file, if you want to modify it or include it directly in a source
! program.
! 
!   The library element DIL defines general codes and names applicable to
! both the DIX and the DIT routines.  To define these names in your
! programs, you should include the statement
! .I 5;COPY DIL OF DIL.
! in your working-storage section at a point where
! an 01-level item is appropriate.
! 
!   The library element DIX defines codes specific to the DIX routines.
! To define these names in your programs, you should include the
! statement 
! .I 5;COPY DIX OF DIL.
! in your working-storage section at a point where an 01-level item is
! appropriate.
! 
!   The library element DIT defines codes specific to the DIT routines.
! To define these names in your programs, you should include the
! statement 
! .I 5;COPY DIT OF DIL.
! in your working-storege section at a point where an 01-level item is
! appropriate.
! 
! .HL 3 FOR36
! For FOR36, the files provided may be included into the source program
! at compilation time using the FORTRAN INCLUDE statement.
! 
!   [14] The file DILV6.FOR defines general codes and names applicable
! to both the DIX and the DIT routines in fortran V6 format.  To define
! these names in your programs, you should include the statement
! .I 5;INCLUDE 'DILV6'
! in your program at a point where a set of PARAMETER statements would
! be legal.
! 
!   [14] The file DILV7.FOR defines general codes and names applicable
! to both the DIX and the DIT routines in fortran V7 format.  To define
! these names in your programs, you should include the statement
! .I 5;INCLUDE 'DILV7'
! in your program at a point where a set of PARAMETER statements would
! be legal.
! 
!   [14] The file DIXV6.FOR defines codes specific to the DIX routines
! in Fortran V6 format.  To define these names in your programs, you
! should include the statement
! .I 5;INCLUDE 'DIXV6'
! in your program at a point where a set of PARAMETER statements would
! be legal.
! 
!   [14] The file DIXV7.FOR defines codes specific to the DIX routines
! in Fortran V7 format.  To define these names in your programs, you
! should include the statement
! .I 5;INCLUDE 'DIXV7'
! in your program at a point where a set of PARAMETER statements would
! be legal.
! 
!   [14] Remove reference to DIT routines.
! 
! .HL 2 VAX/VMS
! 
! The interface support files for the VAX are provided as a text library
! called DIL.TLB.  The user can use language-specific features to
! extract the information from the library and include it in his
! programs at compile time.  The LIBRARY DCL command may be used to
! extract the individual modules if the user wishes to modify them or
! include them directly in a source program.
! 
! .HL 3 COB32
! For COB32, the COPY statement will do this.
! 
!   The library element DIL$COBOL defines general codes and names
! applicable to both the DIX and the DIT routines.  To define these
! names in your programs, you should include the statement
! .I 5;COPY DIL$COBOL OF DIL.
! in your working-storage section at a point where an 01-level item is
! appropriate. 
! 
!   The library element DIX$COBOL defines codes specific to the DIX
! routines.  To define these names in your programs, you should include
! the statement
! .I 5;COPY DIX$COBOL OF DIL.
! in your working-storage section at a point where an 01-level item is
! appropriate.
! 
!   The library element DIT$COBOL defines codes specific to the DIT
! routines.  To define these names in your programs, you should include
! the statement
! .I 5;COPY DIT$COBOL OF DIL.
! in your working-storege section at a point where an 01-level item is
! appropriate.
! 
! .HL 3 FOR32
! For FOR32, the INCLUDE statement will do this.
! 
!   The library element DIL$FORTRAN defines general codes and names
! applicable to both the DIX and the DIT routines.  To define these
! names in your programs, you should include the statement
! .I 5;INCLUDE 'DIL(DIL$FORTRAN)'
! in your program at a spot where a set of PARAMETER statements would be
! legal.
! 
!   The library element DIX$FORTRAN defines codes specific to the DIX
! routines.  To define these names in your programs, you should include
! the statement
! .I 5;INCLUDE 'DIL(DIX$FORTRAN)'
! in your program at a spot where a set of PARAMETER statements would be
! legal.
! 
!   The library element DIT$FORTRAN defines codes specific to the DIT
! routines.  To define these names in your programs, you should include
! the statement
! .I 5;INCLUDE 'DIL(DIT$FORTRAN)'
! in your program at a spot where a set of PARAMETER statements would be
! legal.
!--

!++
! .HL 1 Require files
!--

REQUIRE 'DIXREQ';			! \.P;\

UNDECLARE %QUOTE
    $descriptor;
%sbttl 'Edit History'                   ! [7] Add this entire subsection

!++
! .hl 1 Edit History
!--

LIBRARY 'VERSION';

! ; .autotable

!++ COPY 

new_version (1, 0)

edit (7, '23-Aug-82', 'David Dyer-Bennet')
 %( Change version and revision standards everywhere.
    Files: All. )%

EDIT (10, '22-Sep-82', 'David Dyer-Bennet')
%(  Always use long_relative addressing on VAX. )%

Edit (%o'14', '12-Oct-82', 'David Dyer-Bennet')
%(  Rename fortran interface support files, create both V6 
    and V7 versions, and make them right.
    Related to DIL edit %O'16'.
    Files: DIXV6.FOR (was DIXF36.INT), DIXV7.FOR (NEW), INTERFILS.BLI )%

Edit (%O'17', '22-Oct-82', 'David Dyer-Bennet')
%(  Make INTERFILS.BLI put in copyright info.
    Make INTERFILS generate DIXC3220.INT (20-compatible COB32 interface)
    Add name typing statements to FOR32(A).INT as generated by INTERFILS
    Files: INTERFILS.BLI
)%
Edit (%O'25', '24-Nov-82', 'David Dyer-Bennet', 'QAR 15')
%(  Change ANSI-COBOL format VMS interface files to conform to standard
    of presenting only message code for status values.
    Files: INTERFILS.BLI
)%
Edit (%O'30', '19-Jan-83', 'David Dyer-Bennet')
%(  Update copyright notices, add mark at end of edit histories.
)%
Edit (%O'35', '8-June-83', 'Charlotte L. Richardson')
%(  Declare version 1 complete.  All modules.
)%

new_version (1, 1)

new_version (2, 0)

Edit (%O'36', '11-Apr-84', 'Sandy Clemens')
%( Put all Version 2 DIX development files under edit control.  Some of
   the files listed below have major code edits, or are new modules.  Others
   have relatively minor changes, such as cleaning up a comment.
)%

Edit (%O'50', '8-Oct-84', 'Sandy Clemens')
  %( Add new format of COPYRIGHT notice.  FILES:  ALL )%

!-- .autoparagraph
! **EDIT**
mark_versions ('DIX')
!++
! .HL 1 Debugging Declarations
!--

dix$module_debug (off)

!++
! .HL 1 Macros
!--

!++
! .HL 1 Literals
!--

! ; .hl 2 Values for which_format
! ;   The mode flag controls what interface support file is being produced.
! ; The following values are currently understood:
$literal				! ; .s 1.list 1

!++ copy /strip .le;
mode_cob36 = $distinct,			! Long names, no special chars
mode_cob32 = $distinct,			! Long names, special chars
mode_cob32_20 = $distinct,              ! [%O'17'] Long names, no special chars
mode_for36V6 = $distinct,               ! [14] short names, no special chars
mode_for36v7 = $distinct,               ! [14] short names, no special chars, () around paramaters
mode_for32 = $distinct,			! Long names, special chars, () around parameters
mode_for32_ansii = $distinct,		! Short names, no special chars, () around parameters
mode_ult = $distinct;			! This must be last
!-- .end list

LITERAL
    max_mode = mode_ult - 1,
    this_sys = %BLISS36 (sys_lcg) %BLISS32 (sys_8bit);

!++
! .HL 1 Own storage
!--

OWN
    out_fil : $xpo_iob (),
    out_rec_buf : VECTOR [CH$ALLOCATION (80)],
    out_rec : $str_descriptor (class = bounded),
    systyp : VECTOR [max_mode + 1] PRESET (
	[mode_cob36] = sys_lcg,
	[mode_for36v6] = sys_lcg,       ! [14] 
        [mode_for36v7] = sys_lcg,       ! [14] 
	[mode_cob32] = sys_8bit,
        [mode_cob32_20] = sys_8bit,     ! [%O'17'] 
	[mode_for32] = sys_8bit,
	[mode_for32_ansii] = sys_8bit
	),
!++
!   These fields define what to surround the raw information with.
!--
    beg_lin : $str_descriptor (class = fixed),
    mid_lin : $str_descriptor (class = fixed),
    end_lin : $str_descriptor (class = fixed),
    comment_beg : $str_descriptor (class = fixed),
    condnam_prel : $str_descriptor (class = fixed),
    typnam_prel : $str_descriptor (class = fixed),

!++
!   These fields are used in the processing.
!--

    underscore_desc : $str_descriptor (string = '_'),
    dash_desc : $str_descriptor (string = '-'),
    null_desc : $str_descriptor (string = (0, 0));

!++
! .HL 1 External references
!--
%SBTTL 'ROUTINE STR_REPLACE'
ROUTINE str_replace (src, target, replc, dst) : NOVALUE =
    BEGIN

    MAP
	src : REF $str_descriptor (),
	target : REF $str_descriptor (),
	replc : REF $str_descriptor (),
	dst : REF $str_descriptor ();

    LOCAL
	rem : $str_descriptor ();

    $str_desc_init (descriptor = rem, string = .src);

    WHILE .rem [str$h_length] GTR 0 DO
	BEGIN				! WHILE .rem [str$h_length] GTR 0

	LOCAL
	    stat_val,
	    loc_desc : $str_descriptor (class = bounded, string = (0, 0));

	stat_val = $str_scan (string = rem, find = .target, substring = loc_desc);

	IF .stat_val EQL 0
	THEN
	    BEGIN
	    $str_append (string = rem, target = .dst);
	    EXITLOOP;
	    END;

	$str_append (string = (.loc_desc [str$h_pfxlen], CH$PLUS (.loc_desc [str$a_pointer],
		-.loc_desc [str$h_pfxlen])), target = .dst);
	$str_append (string = .replc, target = .dst);
	$str_desc_init (descriptor = rem,
	    string = (.loc_desc [str$h_maxlen] - .loc_desc [str$h_pfxlen] - .loc_desc [str$h_length], CH$PLUS
	    (.loc_desc [str$a_pointer], .loc_desc [str$h_length])));
	END;				! WHILE .rem [str$h_length] GTR 0

    END;				! ROUTINE STR_REPLACE
%SBTTL 'ROUTINE write_dt_records'
ROUTINE write_dt_records (which_format) : NOVALUE =

!++
!   Write out the data type names.
!--

    BEGIN
    $field dt_fields =
    SET
    dt$v_type = [$integer],
    dt$v_name = [$address],
    dt$v_name_lng = [$integer],
    dt$v_short_name = [$address],
    dt$v_short_name_lng = [$integer]
    TES;

    LITERAL
	dt$k_size = $field_set_size;

    dix$routine_debug (on)

    MACRO
	dix_type (class_code, type_code) =
        ((class_code AND (1^class_code_bits - 1))^type_code_bits OR
        (type_code AND (1^type_code_bits - 1))) %,

	decl_generic_item (class_name, class_code, type_name, short_name, type_code) =
        [type_code, dt$v_type] = dix_type (class_code, type_code),
        [type_code, dt$v_name] = UPLIT (type_name),
        [type_code, dt$v_name_lng] = %CHARCOUNT (type_name),
        [type_code, dt$v_short_name] = UPLIT (short_name),
        [type_code, dt$v_short_name_lng] = %CHARCOUNT (short_name),
    %,
	decl_string_item (class_code, type_name, short_name, type_code) =
        decl_generic_item ('STRING', class_code, type_name, short_name, type_code) %,
	decl_fbin_item (class_code, type_name, short_name, type_code) =
        decl_generic_item ('FBIN', class_code, type_name, short_name, type_code) %,
	decl_fp_item (class_code, type_name, short_name, type_code) =
        decl_generic_item ('FP', class_code, type_name, short_name, type_code) %,
	decl_dnum_item (class_code, type_name, short_name, type_code) =
        decl_generic_item ('DNUM', class_code, type_name, short_name, type_code) %,

	decl_pdec_item (class_code, type_name, short_name, type_code) =
        decl_generic_item ('PDEC', class_code, type_name, short_name, type_code) %;

    OWN
	string_dt_tbl : BLOCKVECTOR [dt_class_string_max + 1, dt$k_size] FIELD (dt_fields) PRESET (
           dt_class_string_def
           [0, dt$v_type] = 0           ! Macro leaves trailing comma
           ),
	fbin_dt_tbl : BLOCKVECTOR [dt_class_fbin_max + 1, dt$k_size] FIELD (dt_fields) PRESET (
            dt_class_fbin_def
            [0, dt$v_type] = 0          ! Macro leaves trailing comma
            ),
	fp_dt_tbl : BLOCKVECTOR [dt_class_fp_max + 1, dt$k_size] FIELD (dt_fields) PRESET (
           dt_class_fp_def
           [0, dt$v_type] = 0           ! Macro leaves trailing comma
           ),
        dnum_dt_tbl : BLOCKVECTOR [dt_class_dnum_max + 1, dt$k_size] FIELD (dt_fields) PRESET (
                dt_class_dnum_def
                [0, dt$v_type] = 0       ! Macro leaves trailing comma
               ),
        pdec_dt_tbl : BLOCKVECTOR [dt_class_pdec_max + 1, dt$k_size] FIELD (dt_fields) PRESET (
                dt_class_pdec_def
                [0, dt$v_type] = 0       ! Macro leaves trailing comma
               );


    MACRO
	write_dt_recs (class_name) =
        INCR ndx FROM 1 TO %NAME ('dt_class_', class_name, '_max') DO
            BEGIN
            BIND type_code = %NAME (class_name, '_dt_tbl') [.ndx, dt$v_type];
            OWN nam_desc: $str_descriptor (class = fixed),
                type_name: $str_descriptor (class = dynamic);

            $str_desc_init (descriptor = out_rec, class = bounded,
                string = (80, CH$PTR (out_rec_buf)));
            $str_desc_init (descriptor = type_name, class = dynamic,
                string = (0,0));
	    CASE .which_format FROM 1 TO max_mode OF
		SET
		[mode_for36v6, mode_for36v7, mode_for32_ansii]: ! [14] 
                    BEGIN               ! [14] 
		    $str_desc_init (descriptor = type_name, class = dynamic,
			string = (.%NAME (class_name, '_dt_tbl') [.ndx, dt$v_short_name_lng],
			CH$PTR (.%NAME (class_name, '_dt_tbl') [.ndx, dt$v_short_name])));
                    IF .which_format EQL mode_for36v7 OR        ! [%O'17'] 
                        .which_format EQL mode_for32_ansii THEN ! [%O'17'] [14] 
                        BEGIN           ! [14] 
                        ! [14] FORTRAN-77 requires INTEGER statements for each name
                        $xpo_put (iob = out_fil, string = $str_concat ( ! [14]
                           '	INTEGER ',      ! [14]
                            typnam_prel,        ! [14]
                            type_name));        ! [14]
                        END;            ! [14] 
                    END;                ! [14] 
		[mode_cob32, mode_cob32_20, mode_for32, mode_cob36]:    ! [%O'17'] 
		    BEGIN
		    dtype (1, 'Use long name:', .%name (class_name, '_dt_tbl') [.ndx, dt$v_name]);
		    $str_desc_init (descriptor = nam_desc,
			string = (.%NAME (class_name, '_dt_tbl') [.ndx, dt$v_name_lng],
			CH$PTR (.%NAME (class_name, '_dt_tbl') [.ndx, dt$v_name])));
		    IF .which_format EQL mode_cob36 OR  ! [%O'17'] 
                        .which_format EQL mode_cob32_20 THEN    ! [%O'17'] 
			str_replace (nam_desc, underscore_desc, dash_desc, type_name)
		    ELSE
			$str_copy (target = type_name, string = nam_desc);
                    ! [%O'17'] Fortran-77 requires INTEGER statements
                    IF .which_format EQL mode_for32 THEN        ! [%O'17'] 
                        BEGIN           ! [%O'17'] 
                        $xpo_put (iob = out_fil, string = $str_concat ( ! [%O'17'] 
                           '	INTEGER ',      ! [%O'17'] 
                            typnam_prel,        ! [%O'17'] 
                            type_name));        ! [%O'17'] 
                        END;            ! [%O'17'] 
		    END;
		TES;
            $str_copy (target = out_rec, string = $str_concat (
                beg_lin,
                typnam_prel,
                type_name,
                mid_lin,
                $str_ascii (.type_code),
                end_lin));
            $xpo_put (iob = out_fil, string = out_rec);
            END;
    %;

    write_dt_recs ('string')
    write_dt_recs('fbin')
    write_dt_recs('fp')
    write_dt_recs('dnum')
    write_dt_recs('pdec')

    END;
%SBTTL 'ROUTINE DUMP_CONDS'
ROUTINE dump_conds (which_format) : NOVALUE =
    BEGIN
    $field cvi_fields =
    SET
    cvi$v_value = [$integer],		! Condition value
    cvi$v_name = [$address],		! Address of UPLIT for name
    cvi$v_name_lng = [$integer],	! Length of name in characters
    cvi$v_fort_nam = [$address],	! Address of UPLIT for 6-char name
    cvi$v_fort_nam_lng = [$integer],	! Length of fortran name in characters
    cvi$v_comment = [$address],		! Address of UPLIT for comment
    cvi$v_comment_lng = [$integer]	! Length of comment in characters
    TES;

    LITERAL
	cvi$k_size = $field_set_size;

    dix$routine_debug (on)

    COMPILETIME
	message_no = 0;

    MACRO
	cond_dat (name, fort_pseud, value, comment) =
        %ASSIGN (message_no, ((value) AND sts$m_code)^(-field_position(sts$m_code)))
	dix$debug (
	    %PRINT ('Message_no: ', %NUMBER (message_no))
	)
        [%NUMBER (message_no), cvi$v_value] = (value),
        [%NUMBER (message_no), cvi$v_name] = UPLIT (%STRING(name)),
        [%NUMBER (message_no), cvi$v_name_lng] = %CHARCOUNT (%STRING (name)),
        [%NUMBER (message_no), cvi$v_fort_nam] = UPLIT (%STRING (fort_pseud)),
        [%NUMBER (message_no), cvi$v_fort_nam_lng] = %CHARCOUNT (%STRING (fort_pseud)),
        [%NUMBER (message_no), cvi$v_comment] = UPLIT (%STRING (comment)),
        [%NUMBER (message_no), cvi$v_comment_lng] = %CHARCOUNT (%STRING (comment)),
    %;

    OWN
	cond_info : BLOCKVECTOR [max_condition + 1, cvi$k_size] FIELD (cvi_fields) PRESET (
            dix$def_cons
            [0, cvi$v_value] = 0        ! dix$def_cons leaves trailing comma
            );

!++
!   Write out the stuff.
!--

    INCR ndx FROM 1 TO max_condition DO
	BEGIN

	OWN
	    short_nam : $str_descriptor (class = bounded),
	    nam_desc : $str_descriptor (class = fixed),
	    txt_desc : $str_descriptor (class = fixed);

	$str_desc_init (descriptor = txt_desc, class = fixed,
	    string = (.cond_info [.ndx, cvi$v_comment_lng], CH$PTR (.cond_info [.ndx, cvi$v_comment])));
	$str_desc_init (descriptor = out_rec, class = bounded, string = (80, CH$PTR (out_rec_buf)));
	$str_copy (string = $str_concat (beg_lin, condnam_prel), target = out_rec);
	$str_desc_init (descriptor = short_nam, class = bounded);

	CASE .which_format FROM 1 TO max_mode OF
	    SET

	    [mode_cob36, mode_for32, mode_cob32, mode_cob32_20] :       ! [%O'17'] 
		BEGIN
		$str_desc_init (descriptor = nam_desc, class = fixed,
		    string = (.cond_info [.ndx,
			cvi$v_name_lng], CH$PTR (.cond_info [.ndx, cvi$v_name])));
		$str_scan (string = nam_desc, find = '_', substring = short_nam);
		$str_desc_init (string = (.short_nam [str$h_maxlen] - .short_nam [str$h_pfxlen] - 1, CH$PLUS (
			.short_nam [str$a_pointer], 1)), descriptor = short_nam);

		IF .which_format EQL mode_cob36 OR      ! [%O'17'] 
                    .which_format EQL mode_cob32_20 THEN        ! [%O'17'] 
		    str_replace (short_nam, underscore_desc, dash_desc,
			out_rec)
		ELSE
		    $str_append (string = short_nam, target = out_rec);
                ! [%O'17'] Fortran-77 requires integer statements
                IF .which_format EQL mode_for32 THEN    ! [%O'17'] 
                    BEGIN               ! [%O'17'] 
                    $xpo_put (iob = out_fil, string = $str_concat (     ! [%O'17'] 
                        '	INTEGER ',      ! [%O'17'] 
                        condnam_prel,    ! [%O'17'] 
                        nam_desc));     ! [%O'17'] 
                    END;                ! [%O'17'] 

		END;

	    [mode_for36v6, mode_for36v7, mode_for32_ansii] :    ! [14] 
		BEGIN
		$str_desc_init (descriptor = nam_desc,
		    string = (.cond_info [.ndx, cvi$v_fort_nam_lng], CH$PTR (.cond_info [.ndx, cvi$v_fort_nam]
		    )));
                IF .which_format EQL mode_for36v7 OR    ! [%O'17'] 
                    .which_format EQL mode_for32_ansii THEN     ! [%O'17'] [14] 
                    BEGIN               ! [14] 
                    ! [14] FORTRAN-77 requires INTEGER statements for each name
                    $xpo_put (iob = out_fil, string = $str_concat (     ! [14]
                        '	INTEGER ',      ! [14]
                        typnam_prel,    ! [14]
                        nam_desc));     ! [14]
                    END;                ! [14] 
                $str_append (string = nam_desc, target = out_rec);
		END;
	    TES;

	$str_append (string = mid_lin, target = out_rec);

        IF .which_format EQL mode_cob36 OR      ! [%O'25'] 
            .which_format EQL mode_cob32_20 THEN        ! [%O'25'] 
            BEGIN                           ! [3]
            ! [3] Make condition values (as given for literals) conform to same standards as value
            ! [3] passed back for msg_id from dil$$return_kludge.
            LOCAL                           ! [3]
                temp_cond_val: condition_value,     ! [3]
                temp_cond_unique: condition_value;  ! [3]
            temp_cond_unique = 0;           ! [3]
            temp_cond_val = .cond_info [.ndx, cvi$v_value]; ! [3]
            IF .temp_cond_val [sts$v_fac_sp] THEN   ! [3]
                temp_cond_unique [sts$v_cond_id] = .temp_cond_val [sts$v_cond_id]   ! [3]
            ELSE                            ! [3]
                temp_cond_unique [sts$v_code] = .temp_cond_val [sts$v_code];        ! [3]
            $str_append (string = $str_ascii (.temp_cond_unique), target = out_rec); ! [3]
            END                             ! [3] [4]
	ELSE				! [4] Put back vax condition values
	    BEGIN			! [14] [4] These are used on FOR36 also
	    $str_append (string = $str_ascii (.cond_info [.ndx, cvi$v_value]), ! [4]
                target = out_rec);	! [4]
	    END;			! [4]
	$str_append (string = end_lin, target = out_rec);
	$xpo_put (iob = out_fil, string = out_rec);
	$str_desc_init (descriptor = out_rec, class = bounded, string = (80, CH$PTR (out_rec_buf)));
	$str_copy (string = comment_beg, target = out_rec);
	$str_append (string = txt_desc, target = out_rec);
	$xpo_put (iob = out_fil, string = out_rec);
	END;

    END;
%SBTTL 'ROUTINE ONE_MODE'
ROUTINE one_mode (which_format) : NOVALUE =
    BEGIN

    dix$routine_debug (on)             ! [14] 

!++
!   Open the output file
!--

    BEGIN

    LOCAL
	fil_nam : $str_descriptor ();

    CASE .which_format FROM 1 TO max_mode OF
	SET

	[mode_cob36] :
	    $str_desc_init (descriptor = fil_nam, string = 'DIXC36.INT');       ! [6] Change file name

	[mode_cob32] :
	    $str_desc_init (descriptor = fil_nam, string = 'DIXC32.INT');       ! [6] Change file name

        [mode_cob32_20] :               ! [%O'17'] 
            $str_desc_init (descriptor = fil_nam, string = 'DIXC3220.INT');     ! [%O'17'] 

	[mode_for36v6] :                ! [14] 
	    $str_desc_init (descriptor = fil_nam, string = 'DIXV6.FOR');        ! [14] [6] Change file name

	[mode_for36v7] :                ! [14] 
	    $str_desc_init (descriptor = fil_nam, string = 'DIXV7.FOR');        ! [14] [6] Change file name

	[mode_for32] :
	    $str_desc_init (descriptor = fil_nam, string = 'DIXF32.INT');       ! [6] Change file name

	[mode_for32_ansii] :
	    $str_desc_init (descriptor = fil_nam, string = 'DIXF32A.INT');      ! [6] Change file name
	TES;

    $xpo_iob_init (iob = out_fil);	! So that restarting works right
    $xpo_open (iob = out_fil, options = output, file_spec = fil_nam);
    END;

!++
!   Initialize the appropriate pieces of the skeleton
!--

    CASE .which_format FROM 1 TO max_mode OF
	SET

	[mode_cob36] :
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '    02  ');
	    $str_desc_init (descriptor = mid_lin, string = ' PIC S9(10) COMP VALUE ');
	    $str_desc_init (descriptor = end_lin, string = '.');
	    $str_desc_init (descriptor = comment_beg, string = '*      ');
	    $str_desc_init (descriptor = condnam_prel, string = 'DIX-C-');
	    $str_desc_init (descriptor = typnam_prel, string = 'DIX-DT-');
	    END;

	[mode_for36v6] :                ! [14] 
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '	PARAMETER ');   ! [14]
	    $str_desc_init (descriptor = mid_lin, string = ' = ');
	    $str_desc_init (descriptor = end_lin, string = (0, 0));
	    $str_desc_init (descriptor = comment_beg, string = 'C	');     ! [14]
	    $str_desc_init (descriptor = condnam_prel, string = (0, 0));
	    $str_desc_init (descriptor = typnam_prel, string = (0, 0));
	    END;

	[mode_for36v7] :                ! [14] 
	    BEGIN                       ! [14] 
	    $str_desc_init (descriptor = beg_lin, string = '	PARAMETER (');        ! [14] 
	    $str_desc_init (descriptor = mid_lin, string = ' = ');      ! [14] 
	    $str_desc_init (descriptor = end_lin, string = ')');        ! [14] 
	    $str_desc_init (descriptor = comment_beg, string = 'C	');     ! [14] 
	    $str_desc_init (descriptor = condnam_prel, string = (0, 0));        ! [14] 
	    $str_desc_init (descriptor = typnam_prel, string = (0, 0)); ! [14] 
	    END;                        ! [14] 

	[mode_cob32] :
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '    02  ');
	    $str_desc_init (descriptor = mid_lin, string = ' PIC S9(9) COMP VALUE ');
	    $str_desc_init (descriptor = end_lin, string = '.');
	    $str_desc_init (descriptor = comment_beg, string = '*      ');
	    $str_desc_init (descriptor = condnam_prel, string = 'DIX$_');
	    $str_desc_init (descriptor = typnam_prel, string = 'DIX$K_DT_');
	    END;

	[mode_cob32_20] :
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '    02  ');
	    $str_desc_init (descriptor = mid_lin, string = ' PIC S9(9) COMP VALUE ');
	    $str_desc_init (descriptor = end_lin, string = '.');
	    $str_desc_init (descriptor = comment_beg, string = '*      ');
	    $str_desc_init (descriptor = condnam_prel, string = 'DIX-C-');
	    $str_desc_init (descriptor = typnam_prel, string = 'DIX-DT-');
	    END;

	[mode_for32] :
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '        PARAMETER (');      ! [%O'17'] 
	    $str_desc_init (descriptor = mid_lin, string = ' = ');
	    $str_desc_init (descriptor = end_lin, string = ')');
	    $str_desc_init (descriptor = comment_beg, string = 'C       ');     ! [%O'17'] 
	    $str_desc_init (descriptor = condnam_prel, string = 'DIX$_');
	    $str_desc_init (descriptor = typnam_prel, string = 'DIX$K_DT_');
	    END;

	[mode_for32_ansii] :
	    BEGIN
	    $str_desc_init (descriptor = beg_lin, string = '        PARAMETER (');      ! [%O'17'] 
	    $str_desc_init (descriptor = mid_lin, string = ' = ');
	    $str_desc_init (descriptor = end_lin, string = ')');
	    $str_desc_init (descriptor = comment_beg, string = 'C       ');     ! [%O'17'] 
	    $str_desc_init (descriptor = condnam_prel, string = (0, 0));
	    $str_desc_init (descriptor = typnam_prel, string = (0, 0));
	    END;
	TES;

! [6] Remove dumping of severity and system type information.  This
! [6] is now found in DILxxx.INT, permanent files
! [14] Actually, they're called DILV6.FOR or DILV7.FOR this week

! [%O'17'] Add copyright notice to start of each file
    $xpo_put (iob = out_fil, string = $str_concat (comment_beg, ! [%O'17'] 
            'COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983  ALL RIGHTS RESERVED'));       ! [%O'30'] [%O'17'] [%O'50']

!++
!   Write the proper language's name definitions for condition values.
!--

    dump_conds (.which_format);

!++
!   Write out the data type names.  This is a separate routine because
! I blew memory limits in the compiler when I tried to include it in the
! above routine
!--

    write_dt_records (.which_format);

!++
!   Close down the file.  Whew!!
!--

    $xpo_close (iob = out_fil);

    END;
%SBTTL 'ROUTINE MAINR'
ROUTINE mainr : NOVALUE =
    BEGIN

    INCR which_format FROM 1 TO max_mode BY 1 DO

	IF .systyp [.which_format] EQL this_sys THEN one_mode (.which_format);

    END;

END					! End of module

ELUDOM