Trailing-Edge
-
PDP-10 Archives
-
cuspmar86binsrc_2of2_bb-fp63a-sb
-
10,7/dil/dilsrc/interf.bli
There are 5 other files named interf.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